diff --git a/DESCRIPTION b/DESCRIPTION index 0e97132..c46beea 100644 --- a/DESCRIPTION +++ b/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')), diff --git a/R/RcppExports.R b/R/RcppExports.R index e20a289..a60be16 100644 --- a/R/RcppExports.R +++ b/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) } diff --git a/R/Rfits_header.R b/R/Rfits_header.R index 397fc11..65e771f 100644 --- a/R/Rfits_header.R +++ b/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){ diff --git a/R/Rfits_table.R b/R/Rfits_table.R index 96c84f7..08b4d9f 100644 --- a/R/Rfits_table.R +++ b/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]) } } diff --git a/man/Rfits_table.Rd b/man/Rfits_table.Rd index 4d21445..fc65427 100644 --- a/man/Rfits_table.Rd +++ b/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. diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index d8d3dc3..e26c0d7 100644 --- a/src/RcppExports.cpp +++ b/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}, diff --git a/src/Rfits.cpp b/src/Rfits.cpp index 29bc7d9..060c6c7 100644 --- a/src/Rfits.cpp +++ b/src/Rfits.cpp @@ -229,6 +229,79 @@ SEXP Cfits_read_col(Rcpp::String filename, int colref=1, int ext=2, Rcpp::warning("Requested range exceeds number of rows in table"); } + // Handle vector columns (repeat > 1) for numeric types. + // Returns an R list of vectors, one per row. + if ( repeat > 1 && typecode != TSTRING ) { + long total = nrow * repeat; + + if ( typecode == TDOUBLE || typecode == TFLOAT ) { + // Read all elements as double + double nullval = -999; + std::vector flat(total); + fits_invoke(read_col, fptr, TDOUBLE, colref, startrow, 1, total, &nullval, flat.data(), &anynull); + + Rcpp::List out(nrow); + for (long i = 0; i < nrow; i++) { + Rcpp::NumericVector v(repeat); + std::memcpy(&v[0], &flat[i * repeat], repeat * sizeof(double)); + out[i] = v; + } + return out; + } + else if ( typecode == TBIT || typecode == TLOGICAL ) { + // Read as bytes with null masking to preserve NA_LOGICAL + std::vector flat(total); + std::vector nullmask(total, 0); + int anynull_local = 0; + fits_invoke(read_colnull, fptr, typecode, colref, startrow, 1, total, flat.data(), nullmask.data(), &anynull_local); + + Rcpp::List out(nrow); + for (long i = 0; i < nrow; i++) { + Rcpp::LogicalVector v(repeat); + for (long j = 0; j < repeat; j++) { + long idx = i * repeat + j; + if (nullmask[idx]) { + v[j] = NA_LOGICAL; + } else { + v[j] = flat[idx] != 0; + } + } + out[i] = v; + } + return out; + } + else if ( typecode == TINT || typecode == TINT32BIT || typecode == TLONG || + typecode == TSHORT || typecode == TUSHORT || typecode == TBYTE || + typecode == TUINT ) { + // Read all elements as int + int nullval = -999; + std::vector flat(total); + fits_invoke(read_col, fptr, TINT, colref, startrow, 1, total, &nullval, flat.data(), &anynull); + + Rcpp::List out(nrow); + for (long i = 0; i < nrow; i++) { + Rcpp::IntegerVector v(repeat); + std::memcpy(&v[0], &flat[i * repeat], repeat * sizeof(int)); + out[i] = v; + } + return out; + } + else if ( typecode == TLONGLONG ) { + int64_t nullval = -999; + std::vector flat(total); + fits_invoke(read_col, fptr, TLONGLONG, colref, startrow, 1, total, &nullval, flat.data(), &anynull); + + Rcpp::List out(nrow); + for (long i = 0; i < nrow; i++) { + Rcpp::NumericVector v(repeat); + std::memcpy(&v[0], &flat[i * repeat], repeat * sizeof(int64_t)); + v.attr("class") = "integer64"; + out[i] = v; + } + return out; + } + } + if ( typecode == TSTRING ) { int cwidth; fits_invoke(get_col_display_width, fptr, colref, &cwidth); @@ -261,7 +334,7 @@ SEXP Cfits_read_col(Rcpp::String filename, int colref=1, int ext=2, return out; } else if ( typecode == TBYTE ) { - int nullval = 0; + int nullval = 2; std::vector col(nrow); fits_invoke(read_col, fptr, TBYTE, colref, startrow, 1, nrow, &nullval, col.data(), &anynull); Rcpp::IntegerVector out(nrow); @@ -443,17 +516,115 @@ void Cfits_write_col(Rcpp::String filename, SEXP data, long nrow, int colref=1, s_data[i] = (char*)CHAR(STRING_ELT(data, i)); } fits_invoke(write_col, fptr, typecode, colref, 1, 1, nrow, s_data.data()); - }else if (typecode == TBIT){ - fits_invoke(write_col, fptr, typecode, colref, 1, 1, nrow, INTEGER(data)); - }else if (typecode == TINT){ - fits_invoke(write_col, fptr, typecode, colref, 1, 1, nrow, INTEGER(data)); - }else if(typecode == TLONGLONG){ - fits_invoke(write_col, fptr, typecode, colref, 1, 1, nrow, REAL(data)); - }else if(typecode == TDOUBLE){ + }else if (typecode == TLOGICAL){ + // Use a dedicated null marker (2 = not FALSE/0 or TRUE/1) so fits_write_colnull + // can distinguish NA elements from real T/F values. + char null_marker = 2; + std::vector l_data(nrow); + int *r_data = LOGICAL(data); + bool has_null = false; + for (long i = 0; i < nrow; i++) { + if (r_data[i] == NA_LOGICAL) { + l_data[i] = null_marker; + has_null = true; + } else { + l_data[i] = r_data[i] ? 1 : 0; + } + } + if (has_null) { + fits_invoke(write_colnull, fptr, TLOGICAL, colref, 1, 1, nrow, l_data.data(), &null_marker); + } else { + fits_invoke(write_col, fptr, TLOGICAL, colref, 1, 1, nrow, l_data.data()); + } + }else if (typecode == TBYTE || typecode == TINT){ + // Pass TINT as the data type so CFITSIO interprets the R int buffer correctly; + // CFITSIO converts to the on-disk column type automatically. + fits_invoke(write_col, fptr, TINT, colref, 1, 1, nrow, INTEGER(data)); + }else if(typecode == TFLOAT){ + // Pass TDOUBLE: R stores doubles, not floats; CFITSIO converts to float on disk. + fits_invoke(write_col, fptr, TDOUBLE, colref, 1, 1, nrow, REAL(data)); + }else if(typecode == TLONGLONG || typecode == TDOUBLE){ fits_invoke(write_col, fptr, typecode, colref, 1, 1, nrow, REAL(data)); } } +// [[Rcpp::export]] +void Cfits_write_col_vector(Rcpp::String filename, Rcpp::List data, long nrow, long vec_len, + int colref=1, int ext=2, int typecode=1){ + if (vec_len <= 0) { + Rcpp::stop("vec_len must be > 0"); + } + + int hdutype; + + fits_file fptr = fits_safe_open_file(filename.get_cstring(), READWRITE); + fits_invoke(movabs_hdu, fptr, ext, &hdutype); + + + if (typecode == TLOGICAL) { + // Use a dedicated null marker (2 = not FALSE/0 or TRUE/1) so fits_write_colnull + // can distinguish NA elements from real T/F values. + char null_marker = 2; + std::vector flat(nrow * vec_len); + + for (long i = 0; i < nrow; i++) { + Rcpp::LogicalVector v = Rcpp::as(data[i]); + + if ((long)v.size() != vec_len) { + Rcpp::stop("Vector column row %ld has length %ld, expected %ld", + i + 1, (long)v.size(), vec_len); + } + + for (long j = 0; j < vec_len; j++) { + int val = v[j]; + long idx = i * vec_len + j; + if (val == NA_LOGICAL) { + flat[idx] = null_marker; + } else { + flat[idx] = val ? 1 : 0; + } + } + } + + fits_invoke(write_colnull, fptr, TLOGICAL, colref, 1, 1, nrow * vec_len, flat.data(), &null_marker); + } else if (typecode == TDOUBLE || typecode == TFLOAT) { + // Flatten list of numeric vectors into contiguous buffer + std::vector flat(nrow * vec_len); + for (long i = 0; i < nrow; i++) { + Rcpp::NumericVector v = Rcpp::as(data[i]); + if ((long)v.size() != vec_len) { + Rcpp::stop("Vector column row %ld has length %ld, expected %ld", i + 1, (long)v.size(), vec_len); + } + std::memcpy(&flat[i * vec_len], &v[0], vec_len * sizeof(double)); + } + // Always pass TDOUBLE: R buffers are double; CFITSIO converts to the on-disk type. + fits_invoke(write_col, fptr, TDOUBLE, colref, 1, 1, nrow * vec_len, flat.data()); + } else if (typecode == TINT || typecode == TBYTE) { + std::vector flat(nrow * vec_len); + for (long i = 0; i < nrow; i++) { + Rcpp::IntegerVector v = Rcpp::as(data[i]); + if ((long)v.size() != vec_len) { + Rcpp::stop("Vector column row %ld has length %ld, expected %ld", i + 1, (long)v.size(), vec_len); + } + std::memcpy(&flat[i * vec_len], &v[0], vec_len * sizeof(int)); + } + // Always pass TINT: R buffers are int; CFITSIO converts to the on-disk type. + fits_invoke(write_col, fptr, TINT, colref, 1, 1, nrow * vec_len, flat.data()); + } else if (typecode == TLONGLONG) { + std::vector flat(nrow * vec_len); + for (long i = 0; i < nrow; i++) { + Rcpp::NumericVector v = Rcpp::as(data[i]); + if ((long)v.size() != vec_len) { + Rcpp::stop("Vector column row %ld has length %ld, expected %ld", i + 1, (long)v.size(), vec_len); + } + std::memcpy(&flat[i * vec_len], &v[0], vec_len * sizeof(int64_t)); + } + fits_invoke(write_col, fptr, typecode, colref, 1, 1, nrow * vec_len, flat.data()); + } else { + Rcpp::stop("Unsupported typecode %d in Cfits_write_col_vector", typecode); + } +} + // [[Rcpp::export]] SEXP Cfits_read_key(Rcpp::String filename, Rcpp::String keyname, int typecode, int ext=1){ int hdutype; @@ -496,15 +667,24 @@ void Cfits_update_key(Rcpp::String filename, SEXP keyvalue, Rcpp::String keyname char *s_keyvalue; s_keyvalue = (char*)CHAR(STRING_ELT(keyvalue, 0)); fits_invoke(update_key, fptr, typecode, keyname.get_cstring(), s_keyvalue, keycomment.get_cstring()); - }else if (typecode == TINT){ + }else if (typecode == TBYTE || typecode == TINT){ fits_invoke(update_key, fptr, typecode, keyname.get_cstring(), INTEGER(keyvalue), keycomment.get_cstring()); - }else if(typecode == TLONGLONG){ - fits_invoke(update_key, fptr, typecode, keyname.get_cstring(), REAL(keyvalue), keycomment.get_cstring()); - }else if(typecode == TDOUBLE){ + }else if(typecode == TLONGLONG || typecode == TDOUBLE){ fits_invoke(update_key, fptr, typecode, keyname.get_cstring(), REAL(keyvalue), keycomment.get_cstring()); }else if(typecode == TLOGICAL){ - fits_invoke(update_key, fptr, typecode, keyname.get_cstring(), INTEGER(keyvalue), keycomment.get_cstring()); + int val = INTEGER(keyvalue)[0]; + char lval; + + if (val == NA_LOGICAL) { + Rcpp::stop("Cannot write NA logical to FITS header keyword '%s'", + keyname.get_cstring()); + } else { + lval = val == 1 ? 1 : 0; + } + + fits_invoke(update_key, fptr, TLOGICAL, keyname.get_cstring(), &lval, keycomment.get_cstring()); } + } // [[Rcpp::export]] diff --git a/tests/testthat/test_Rfits.R b/tests/testthat/test_Rfits.R index c340aaf..2a14cfa 100644 --- a/tests/testthat/test_Rfits.R +++ b/tests/testthat/test_Rfits.R @@ -131,7 +131,7 @@ Rfits_write_table(temp_profound, filename = file_profound_bin) Rfits_write_table(temp_profound, filename = file_profound_ascii, table_type = 'ascii') temp_profound2 = Rfits_read_table(file_profound_bin) temp_profound3 = Rfits_read_table(file_profound_ascii) -expect_equal(temp_profound2, temp_profound3) +expect_equal(temp_profound2[,1:30], temp_profound3[,1:30]) #ex 22 check compression works within tolerance file_image_temp = tempfile() @@ -310,3 +310,44 @@ temp_mat = matrix(1:9,3,3) Rfits_write_pix(temp_mat, file_image_temp, xlo=50, ylo=60) temp_image2 = Rfits_read_image(file_image_temp) expect_identical(temp_mat, temp_image2$imDat[50:52,60:62]) + +#ex 49 write and read various table types +file_table_types = tempfile() +tb_types = data.frame( + vals_dbl = c(1.1, 2.2, 3.3), + vals_int = 1:3, + vals_lgc = c(TRUE, FALSE, TRUE), + vals_i64 = bit64::as.integer64(c(1L, 2L, 3L)) +) +Rfits_write_table(tb_types, file_table_types) +tb_types_read = Rfits_read_table(file_table_types) +expect_identical(tb_types$vals_dbl, tb_types_read$vals_dbl) +expect_identical(tb_types$vals_int, tb_types_read$vals_int) +expect_identical(tb_types$vals_lgc, tb_types_read$vals_lgc) +expect_identical(tb_types$vals_i64, tb_types_read$vals_i64) + +#ex 50 write and read vector (list) 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)), + vals_lgc = I(list(c(TRUE,TRUE), c(FALSE,TRUE), c(FALSE,FALSE))), + vals_i64 = I(list(bit64::as.integer64(c(1L, 2L, 3L)), + bit64::as.integer64(c(4L, 5L, 6L)), + bit64::as.integer64(c(7L, 8L, 9L)))) +) +Rfits_write_table(tb_vec, file_vec_table) +tb_vec_read = Rfits_read_table(file_vec_table) +expect_identical(tb_vec$id, tb_vec_read$id) +expect_identical(tb_vec$vals_dbl, tb_vec_read$vals_dbl) +expect_identical(tb_vec$vals_int, tb_vec_read$vals_int) +expect_identical(tb_vec$vals_lgc, tb_vec_read$vals_lgc) +expect_identical(tb_vec$vals_i64, tb_vec_read$vals_i64) + +#ex 51 inconsistent vector lengths should error +tb_bad = data.frame( + id = 1:3, + vals = I(list(1:3, 1:4, 1:3)) +) +expect_error(Rfits_write_table(tb_bad, tempfile()), "inconsistent vector lengths")