Add R list-column support for FITS vector columns

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: Rfits
 Type: Package
 Title: FITS Readers and Writers
-Version: 1.15.2
-Date: 2026-04-10
+Version: 1.16.0
+Date: 2026-06-15
 Authors@R: c(
     person(given='Aaron', family='Robotham', email='aaron.robotham@uwa.edu.au',
         role=c('aut', 'cre'), comment=c(ORCID='0000-0003-0429-3579')),

R/RcppExports.R

@@ -33,6 +33,10 @@ Cfits_write_col <- function(filename, data, nrow, colref = 1L, ext = 2L, typecod
     invisible(.Call(`_Rfits_Cfits_write_col`, filename, data, nrow, colref, ext, typecode))
 }
 
+Cfits_write_col_vector <- function(filename, data, nrow, vec_len, colref = 1L, ext = 2L, typecode = 1L) {
+    invisible(.Call(`_Rfits_Cfits_write_col_vector`, filename, data, nrow, vec_len, colref, ext, typecode))
+}
+
 Cfits_read_key <- function(filename, keyname, typecode, ext = 1L) {
     .Call(`_Rfits_Cfits_read_key`, filename, keyname, typecode, ext)
 }

R/Rfits_header.R

@@ -123,24 +123,24 @@ Rfits_write_key=function(filename='temp.fits', keyname, keyvalue, keycomment="",
   assertIntegerish(ext, len=1)
 
   typecode=0
-  if(is.integer(keyvalue)){typecode=31}
-  if(is.integer64(keyvalue)){typecode=81}
-  if(typecode==0 & is.numeric(keyvalue)){
+  if(is.integer(keyvalue)){typecode = 31}
+  if(is.integer64(keyvalue)){typecode = 81}
+  if(typecode == 0 & is.numeric(keyvalue)){
     if(keyvalue %% 1 == 0){
       if(keyvalue < 2^31){
         keyvalue=as.integer(keyvalue)
-        typecode=31
+        typecode = 31
       }else{
         keyvalue=as.integer64(keyvalue)
-        typecode=81
+        typecode = 81
       }
     }else{
-      typecode=82
+      typecode = 82
     }
   }
   if(is.logical(keyvalue)){
-    typecode=14
-    keyvalue=as.integer(keyvalue)
+    typecode = 14
+    keyvalue = as.integer(keyvalue)
   }
 
   if(nchar(keyname) > 8){

R/Rfits_table.R

@@ -94,14 +94,29 @@ Rfits_read_table=function(filename='temp.fits', ext=2, data.table=TRUE, cols=NUL
     if(is.null(output[count][[1]])){
       output[[count]] = NA
     }
+    if(is.character(output[[count]])){
+      if(all(output[[count]] %in% c('T', 'F', ' '))){
+        is_TRUE = (output[[count]] == 'T')
+        is_NA = (output[[count]] == ' ')
+        output[[count]] = is_TRUE
+        output[[count]][is_NA] = NA
+      }
+    }
     count = count + 1
   }
 
-  if(data.table){
-    data.table::setDT(output)
-  }else{
-    output = as.data.frame(output)
-  }
+    # Wrap list-columns with I() for proper data.table handling
+    for(j in seq_along(output)){
+      if(is.list(output[[j]]) && !is.data.frame(output[[j]])){
+        output[[j]] = I(output[[j]])
+      }
+    }
+
+    if(data.table){
+      data.table::setDT(output)
+    }else{
+      output = as.data.frame(output)
+    }
 
   colnames(output) = colnames
 
@@ -185,13 +200,23 @@ Rfits_write_table=function(table, filename='temp.fits', ext=2, extname='Main', t
   check.integer64 = sapply(table,is.integer64)
   check.double = sapply(table,is.numeric) & (! check.int) & (! check.integer64)
   check.char = sapply(table,is.character)
+  check.list = sapply(table,is.list)
 
-  if(any(check.logical)){
-    for(i in which(check.logical)){
-      table[,i] = as.integer(table[,i])
-    }
+  # For list columns, override other checks
+  if(any(check.list)){
+    check.logical[check.list] = FALSE
+    check.int[check.list] = FALSE
+    check.integer64[check.list] = FALSE
+    check.double[check.list] = FALSE
+    check.char[check.list] = FALSE
   }
 
+  # if(any(check.logical)){
+  #   for(i in which(check.logical)){
+  #     table[,i] = as.integer(table[,i])
+  #   }
+  # }
+
   if(inherits(table, 'Rfits_table') & tforms[1]=='get'){
     TFORMsel = grep('TFORM', attributes(table)$keynames)
     if(length(TFORMsel)>0){
@@ -211,11 +236,11 @@ Rfits_write_table=function(table, filename='temp.fits', ext=2, extname='Main', t
 
     if(tforms[1] == 'auto'){
       tforms=character(ncol)
-      tforms[check.logical]="I9"
-      tforms[check.int]="I9"
-      tforms[check.integer64]='I20'
-      tforms[check.double]="D18.10"
-      tforms[check.char]=paste('A', sapply(table[,check.char,drop=FALSE],function(x) max(nchar(x))+1), sep='')
+      tforms[check.logical] = "A1"
+      tforms[check.int] = "I9"
+      tforms[check.integer64] = 'I20'
+      tforms[check.double] = "D18.10"
+      tforms[check.char] = paste('A', sapply(table[,check.char,drop=FALSE],function(x) max(nchar(x))+1), sep='')
     }
     if(length(grep('I|D|A',tforms)) != ncol){
       stop(cat('Unrecognised column data type in column', paste(which(!1:ncol %in% grep('I|D|A',tforms))),sep='\n'))
@@ -224,25 +249,73 @@ Rfits_write_table=function(table, filename='temp.fits', ext=2, extname='Main', t
     table_type = 2
 
     if(tforms[1] == 'auto'){
-      tforms=character(ncol)
-      tforms[check.logical]="1J"
-      tforms[check.int]="1J" # will become typecode = TINT = 31
-      tforms[check.integer64]='1K' # will become typecode = TLONGLONG = 81
-      tforms[check.double]="1D" # will become typecode = TDOUBLE = 82
-      tforms[check.char]=paste(sapply(table[,check.char,drop=FALSE],function(x) max(nchar(x))+1), 'A', sep='') # will become typecode = TSTRING = 16
+      tforms = character(ncol)
+      tforms[check.logical] = "1L"#logical flag
+      tforms[check.int] = "1J" # will become typecode = TINT = 31
+      tforms[check.integer64] = '1K' # will become typecode = TLONGLONG = 81
+      tforms[check.double] = "1D" # will become typecode = TDOUBLE = 82
+      tforms[check.char] = paste(sapply(table[,check.char,drop=FALSE],function(x) max(nchar(x))+1), 'A', sep='') # will become typecode = TSTRING = 16
+      # Vector (list) columns: determine repeat count and element type
+      if(any(check.list)){
+        for(i in which(check.list)){
+          lens = sapply(table[[i]], length)
+          if(length(unique(lens)) != 1){
+            stop("Vector column '", ttypes[i], "' has inconsistent vector lengths across rows")
+          }
+          vec_len = lens[1]
+          if(vec_len == 0){
+            stop("Vector column '", ttypes[i], "' has zero-length vectors (vec_len must be > 0)")
+          }
+          first_elem = table[[i]][[1]]
+          if(is.logical(first_elem)){
+            tforms[i] = paste0(vec_len, "L")
+          }else if(is.integer(first_elem)){
+            tforms[i] = paste0(vec_len, "J")
+          }else if(is.integer64(first_elem)){
+            tforms[i] = paste0(vec_len, "K")
+          }else if(is.double(first_elem)){
+            tforms[i] = paste0(vec_len, "D")
+          }else{
+            stop("Vector column '", ttypes[i], "' has unsupported element type: only logical, integer, integer64, and double are supported")
+          }
+        }
+      }
     }
 
-    if(length(grep('1B|1K|1J|1D|1E|1I|A',tforms)) != ncol){
-      stop(cat('Unrecognised column data type in column', paste(which(!1:ncol %in% grep('1B|1K|1J|1D|1E|1I|A',tforms))),sep='\n'))
+    invalid = which(!(1:ncol %in% grep('1B|1K|1J|1D|1E|1I|A|[0-9]+[JKDEIL]', tforms)))
+    if(length(invalid) > 0){
+      stop('Unrecognised column data type in column(s): ', paste(invalid, collapse=', '))
     }
   }
 
   typecode = rep(0, ncol)
-  typecode[check.logical]=31
-  typecode[check.int]=31
-  typecode[check.integer64]=81
-  typecode[check.double]=82
-  typecode[check.char]=16
+  if(table_type == 1){
+    typecode[check.logical] = 16 #needs to be a CHAR for ASCII logicals
+  }else{
+    typecode[check.logical] = 14
+  }
+  typecode[check.int] = 31
+  typecode[check.integer64] = 81
+  typecode[check.double] = 82
+  typecode[check.char] = 16
+  # Set typecodes for list (vector) columns based on element type
+  if(any(check.list)){
+    if(table_type == 1){stop('ASCII tables cannot have vector columns!')}
+    for(i in which(check.list)){
+      first_elem = table[[i]][[1]]
+      if(is.logical(first_elem)){
+        typecode[i] = 14 # TLOGICAL
+      }else if(is.integer(first_elem)){
+        typecode[i] = 31 # TINT
+      }else if(is.integer64(first_elem)){
+        typecode[i] = 81 # TLONGLONG
+      }else if(is.double(first_elem)){
+        typecode[i] = 82 # TDOUBLE
+      }else{
+        stop("Vector column '", ttypes[i], "' has unsupported element type: only logical, integer, integer64, and double are supported")
+      }
+    }
+  }
 
   assertCharacter(ttypes, len=ncol)
   assertCharacter(tforms, len=ncol)
@@ -278,16 +351,40 @@ Rfits_write_table=function(table, filename='temp.fits', ext=2, extname='Main', t
     if(verbose){
       message("Writing column: ",ttypes[i],", which is ",i," of ", ncol)
     }
-    if(anyNA(table[[i]])){
-      table[[i]][is.na(table[[i]])] = NA_replace
-    }
-    if(anyNaN(table[[i]])){
-      table[[i]][is.nan(table[[i]])] = NaN_replace
-    }
-    if(anyInfinite(table[[i]])){
-      table[[i]][is.infinite(table[[i]])] = Inf_replace
+    if(check.list[i]){
+      # Write vector (list) column
+      # Validate uniform vector length regardless of tforms mode
+      lens = sapply(table[[i]], length)
+      if(length(unique(lens)) != 1){
+        stop("Vector column '", ttypes[i], "' has inconsistent vector lengths across rows")
+      }
+      vec_len = lens[1]
+      Cfits_write_col_vector(filename=filename, data=table[[i]], nrow=nrow, vec_len=vec_len, colref=i, ext=ext, typecode=typecode[i])
+    }else{
+      if(is.logical(table[[i]])){
+        if(table_type == 1){
+          # ASCII: encode logical as 'T'/'F'/' ' character strings
+          sel_TRUE = which(table[[i]])
+          sel_FALSE = which(!table[[i]])
+          table[[i]] = rep(' ', length(table[[i]]))
+          table[[i]][sel_TRUE] = 'T'
+          table[[i]][sel_FALSE] = 'F'
+        }
+        # Binary: TLOGICAL with null masking is handled in Cfits_write_col
+      }else{
+        # Apply NA/NaN/Inf replacement for all numeric columns regardless of table type
+        if(anyNA(table[[i]])){
+          table[[i]][is.na(table[[i]])] = NA_replace
+        }
+        if(anyNaN(table[[i]])){
+          table[[i]][is.nan(table[[i]])] = NaN_replace
+        }
+        if(anyInfinite(table[[i]])){
+          table[[i]][is.infinite(table[[i]])] = Inf_replace
+        }
+      }
+      Cfits_write_col(filename=filename, data=table[[i]], nrow=nrow, colref=i, ext=ext, typecode=typecode[i])
     }
-    Cfits_write_col(filename=filename, data=table[[i]], nrow=nrow, colref=i, ext=ext, typecode=typecode[i])
   }
 }
 

man/Rfits_table.Rd

@@ -97,6 +97,8 @@ Integer scalar; value to replace Inf (since FITS does not support Inf). If numer
 }
 \details{
 R FITS table readers and writers that uses CFITSIO to do the interfacing with files. Requires \code{bit64} package for integer64 (i.e. long long) to be work. If \option{header}=TRUE is set then the output inherits an extra class of 'Rfits_table' (it keeps its 'data.frame' and 'data.table' classes as relevant though).
+
+Vector columns are supported in reading and writing via the R \code{\link{AsIs}} class, and they appear as a multi-element list of vectors for further interrogation (see Examples). This format is also how Parquet files support vector columns in Arrow.
 }
 \note{
 \code{Rfits_read_table} will apply TSCALn and TZEROn scaling, since this is applied at the CFITSIO level, so the column values will be VALn = (RAWn x TSCALn) + TZEROn, where VALn is what is seen in the R \code{data.frame} or \code{data.table} and RAWn is what you would find if inspecting the binary values stored on disk. The \code{Rfits_write_table} will only scale if you pass the TSCALn and TZEROn key values into the \option{tadd} argument (see Examples).
@@ -146,6 +148,22 @@ file_table_temp = tempfile()
 Rfits_write_table(temp_table, file_table_temp, tadd=list(TSCAL6=2, TZERO6=10))
 temp_table2 = Rfits_read_table(file_table_temp)
 sum(temp_table[,..cols_check] - temp_table2[,..cols_check])
+
+#Using vector columns:
+file_vec_table = tempfile()
+tb_vec = data.frame(
+  id = 1:3,
+  vals_dbl = I(list(c(1.1, 2.2, 3.3), c(4.4, 5.5, 6.6), c(7.7, 8.8, 9.9))),
+  vals_int = I(list(1:4, 5:8, 9:12))
+)
+Rfits_write_table(tb_vec, file_vec_table)
+tb_vec_read = Rfits_read_table(file_vec_table)
+tb_vec_read$vals_int[[1]] #will be a vector 1:4
+#To collapse into a matrix, this is the most efficient method:
+mat_col = do.call(rbind, tb_vec_read$vals_dbl)
+mat_col
+#And we can turn it back into the form needed to write out via asplit:
+asplit(mat_col,1)
 }
 % Add one or more standard keywords, see file 'KEYWORDS' in the
 % R documentation directory.

src/RcppExports.cpp

@@ -119,6 +119,22 @@ BEGIN_RCPP
     return R_NilValue;
 END_RCPP
 }
+// Cfits_write_col_vector
+void Cfits_write_col_vector(Rcpp::String filename, Rcpp::List data, long nrow, long vec_len, int colref, int ext, int typecode);
+RcppExport SEXP _Rfits_Cfits_write_col_vector(SEXP filenameSEXP, SEXP dataSEXP, SEXP nrowSEXP, SEXP vec_lenSEXP, SEXP colrefSEXP, SEXP extSEXP, SEXP typecodeSEXP) {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< Rcpp::String >::type filename(filenameSEXP);
+    Rcpp::traits::input_parameter< Rcpp::List >::type data(dataSEXP);
+    Rcpp::traits::input_parameter< long >::type nrow(nrowSEXP);
+    Rcpp::traits::input_parameter< long >::type vec_len(vec_lenSEXP);
+    Rcpp::traits::input_parameter< int >::type colref(colrefSEXP);
+    Rcpp::traits::input_parameter< int >::type ext(extSEXP);
+    Rcpp::traits::input_parameter< int >::type typecode(typecodeSEXP);
+    Cfits_write_col_vector(filename, data, nrow, vec_len, colref, ext, typecode);
+    return R_NilValue;
+END_RCPP
+}
 // Cfits_read_key
 SEXP Cfits_read_key(Rcpp::String filename, Rcpp::String keyname, int typecode, int ext);
 RcppExport SEXP _Rfits_Cfits_read_key(SEXP filenameSEXP, SEXP keynameSEXP, SEXP typecodeSEXP, SEXP extSEXP) {
@@ -419,6 +435,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"_Rfits_Cfits_read_colname", (DL_FUNC) &_Rfits_Cfits_read_colname, 3},
     {"_Rfits_Cfits_create_bintable", (DL_FUNC) &_Rfits_Cfits_create_bintable, 10},
     {"_Rfits_Cfits_write_col", (DL_FUNC) &_Rfits_Cfits_write_col, 6},
+    {"_Rfits_Cfits_write_col_vector", (DL_FUNC) &_Rfits_Cfits_write_col_vector, 7},
     {"_Rfits_Cfits_read_key", (DL_FUNC) &_Rfits_Cfits_read_key, 4},
     {"_Rfits_Cfits_update_key", (DL_FUNC) &_Rfits_Cfits_update_key, 6},
     {"_Rfits_Cfits_write_history", (DL_FUNC) &_Rfits_Cfits_write_history, 3},