Writesas

NAMESPACE

@@ -4,6 +4,7 @@ export(convert_to_date)
 export(convert_to_datetime)
 export(convert_to_time)
 export(read.sas)
+export(write.sas)
 import(Rcpp)
 importFrom(stringi,stri_encode)
 importFrom(utils,download.file)

R/RcppExports.R

@@ -16,3 +16,18 @@ readsas <- function(filePath, debug, selectrows_, selectcols_, empty_to_na, temp
     .Call(`_readsas_readsas`, filePath, debug, selectrows_, selectcols_, empty_to_na, tempstr)
 }
 
+#' Writes the binary SAS file
+#'
+#' @param filePath The full systempath to the sas7bdat file you want to export.
+#' @param dat an R-Object of class data.frame.
+#' @param compress the file
+#' @param debug print debug information
+#' @param bit32 write smaller 32 bit file
+#' @param headersize,pagesize size parameters 512 / 1024 times x
+#' @param dateval timestamp
+#' @keywords internal
+#' @noRd
+writesas <- function(filePath, dat, compress, debug, bit32, headersize, pagesize, dateval, encoding32) {
+    invisible(.Call(`_readsas_writesas`, filePath, dat, compress, debug, bit32, headersize, pagesize, dateval, encoding32))
+}
+

R/readsas.R

@@ -284,3 +284,15 @@ convert_to_datetime <- function(x) {
 convert_to_time <- function(x) {
   format(convert_to_datetime(x), format = "%H:%M:%S")
 }
+
+
+as_date <- function(x) {
+  as.vector(
+    julian(x, as.Date("1960-1-1", tz = "UTC"))
+  )
+}
+
+as_datetime <- function(x) {
+  # From SAS blog: Number of seconds between 01JAN1960 and 01JAN1970: 315619200
+  as.numeric(x) + 315619200
+}

R/writesas.R

@@ -0,0 +1,111 @@
+#' write.sas
+#'
+#'@author Jan Marvin Garbuszus \email{jan.garbuszus@@ruhr-uni-bochum.de}
+#'
+#'@param dat data frame to save
+#'@param filepath path to save file to
+#'@param compress option to compress file
+#'@param debug print debug information
+#'@param bit32 write 32bit file
+#'@param varlabels optional variable labels
+#'@param size optional header/pagesize
+#'@param encoding encoding 62 = windows, 20 = utf
+#'
+#'@useDynLib readsas, .registration=TRUE
+#'
+#'@export
+write.sas <- function(dat, filepath, compress = 0, debug = FALSE, bit32 = FALSE,
+                      varlabels, size, encoding = 20) {
+
+  filepath <- path.expand(filepath)
+
+  if (missing(varlabels)) {
+    varlabels <- rep("", ncol(dat))
+  }
+
+  if (missing(size)) {
+
+    hsize <- 65536
+    psize <- 65536
+
+    if (bit32) {
+      hsize <- 1024
+      psize <- 8192
+    }
+
+    size <- c(hsize, psize)
+  } else if (length(size) != 2) {
+    size <- c(size[1], size[1])
+  }
+
+  if (!inherits(dat, "data.frame")) {
+    dat <- as.data.frame(dat)
+  }
+
+  # convert from factor
+  ff <- sapply(dat, is.factor)
+  dat[ff] <- lapply(dat[ff], as.character)
+
+  vartypes <- sapply(dat, is.character) + 1
+  colwidth <- sapply(dat, function(x) max(nchar(x)))
+  colwidth[vartypes == 1] <- 8
+
+  labels <- "testlab"
+
+  vartypen <- sapply(dat, is.numeric)
+
+  formats <- NA
+  formats[vartypen] <- "BEST"
+  formats[!vartypen] <- ""
+
+  width <- 0
+  width[vartypen] <- 32 # fix for now
+  width[!vartypen] <- 0 # colwidth[!vartypen]
+
+  decim <- sapply(dat, is.integer)
+  decim[!vartypen] <- TRUE
+
+  is.Date <- function(x) inherits(x, "Date")
+  is.POSIX <- function(x) inherits(x, "POSIXt")
+
+  vartypen <- sapply(dat, is.Date)
+  dat[vartypen] <- lapply(dat[vartypen], as_date)
+  formats[vartypen] <- "DATE"
+  width[vartypen] <- 9
+
+  vartypen <- sapply(dat, is.POSIX)
+  dat[vartypen] <- lapply(dat[vartypen], as_datetime)
+  formats[vartypen] <- "DATETIME"
+  width[vartypen] <- 22
+  decim[vartypen] <- 3
+
+  if (debug) {
+    message("vartypes")
+    print(vartypes)
+    message("colwidth")
+    print(colwidth)
+    message("formats")
+    print(formats)
+    message("width")
+    print(width)
+    message("decim")
+    print(decim)
+    message("labels")
+    print(labels)
+  }
+
+  # for numerics
+  # formats <- rep("BEST", ncol(dat))
+
+  attr(dat, "vartypes")  <- as.integer(vartypes)
+  attr(dat, "colwidth")  <- as.integer(colwidth)
+  attr(dat, "formats")   <- formats
+  attr(dat, "width")     <- width
+  attr(dat, "decim")     <- decim
+  attr(dat, "labels")    <- labels
+  attr(dat, "varlabels") <- varlabels
+
+  writesas(filepath, dat, compress = 0, debug = debug, bit32 = bit32,
+           headersize = size[1], pagesize = size[2],
+           dateval = as_datetime(Sys.time()), encoding32 = encoding)
+}

src/RcppExports.cpp

@@ -26,9 +26,28 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// writesas
+void writesas(const char * filePath, Rcpp::DataFrame dat, uint8_t compress, bool debug, bool bit32, int32_t headersize, int32_t pagesize, double dateval, int32_t encoding32);
+RcppExport SEXP _readsas_writesas(SEXP filePathSEXP, SEXP datSEXP, SEXP compressSEXP, SEXP debugSEXP, SEXP bit32SEXP, SEXP headersizeSEXP, SEXP pagesizeSEXP, SEXP datevalSEXP, SEXP encoding32SEXP) {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< const char * >::type filePath(filePathSEXP);
+    Rcpp::traits::input_parameter< Rcpp::DataFrame >::type dat(datSEXP);
+    Rcpp::traits::input_parameter< uint8_t >::type compress(compressSEXP);
+    Rcpp::traits::input_parameter< bool >::type debug(debugSEXP);
+    Rcpp::traits::input_parameter< bool >::type bit32(bit32SEXP);
+    Rcpp::traits::input_parameter< int32_t >::type headersize(headersizeSEXP);
+    Rcpp::traits::input_parameter< int32_t >::type pagesize(pagesizeSEXP);
+    Rcpp::traits::input_parameter< double >::type dateval(datevalSEXP);
+    Rcpp::traits::input_parameter< int32_t >::type encoding32(encoding32SEXP);
+    writesas(filePath, dat, compress, debug, bit32, headersize, pagesize, dateval, encoding32);
+    return R_NilValue;
+END_RCPP
+}
 
 static const R_CallMethodDef CallEntries[] = {
     {"_readsas_readsas", (DL_FUNC) &_readsas_readsas, 6},
+    {"_readsas_writesas", (DL_FUNC) &_readsas_writesas, 9},
     {NULL, NULL, 0}
 };
 

src/readsas.cpp

@@ -49,6 +49,7 @@ Rcpp::List readsas(const char * filePath,
                    const bool empty_to_na,
                    std::string tempstr)
 {
+
   std::ifstream sas(filePath, std::ios::in | std::ios::binary | std::ios::ate);
   auto sas_size = sas.tellg();
   if (sas) {
@@ -503,11 +504,24 @@ Rcpp::List readsas(const char * filePath,
 
       pageseqnum[pg] = pageseqnum32;
 
+      if (debug) {
+        Rcout << "pageseqnum: " << pageseqnum32 << std::endl;
+        Rcout << unk1 << " " << unk2 << " " << PAGE_DELETED_POINTER_LENGTH << std::endl;
+      }
+
       PAGE_TYPE       = readbin(PAGE_TYPE, sas, swapit);
       BLOCK_COUNT     = readbin(BLOCK_COUNT, sas, swapit);
       SUBHEADER_COUNT = readbin(SUBHEADER_COUNT, sas, swapit);
       unk16           = readbin(unk16, sas, swapit);
 
+      if(debug) {
+        Rcout << "PAGE_TYPE: " << PAGE_TYPE <<
+          " - BLOCK_COUNT: "  << BLOCK_COUNT <<
+            " - SUBHEADER_COUNT: " << SUBHEADER_COUNT << std::endl;
+      }
+
+      // Rcout << sas.tellg() << std::endl;
+
       page_type.push_back(PAGE_TYPE);
 
       rowsperpage[pg] = BLOCK_COUNT - SUBHEADER_COUNT;
@@ -709,8 +723,11 @@ Rcpp::List readsas(const char * filePath,
                 unk64 = readbin(unk64, sas, swapit);
                 if (debug) Rcout << unk64 << std::endl;
                 pgsize = readbin(pgsize, sas, swapit);
+                if (debug) Rcout << "pgsize " << pgsize << std::endl;
                 unk64 = readbin(unk64, sas, swapit);
                 rcmix =  readbin(rcmix, sas, swapit);
+                if (debug)
+                  Rcout << "rcmix " << rcmix << std::endl;
 
                 /* next two indicate the end of the initial header ? */
                 unk64 = readbin(unk64, sas, swapit);
@@ -756,6 +773,7 @@ Rcpp::List readsas(const char * filePath,
                 unk16 = readbin(unk16, sas, swapit); // padding
 
                 pgc = readbin(pgc, sas, swapit);
+                if (debug) Rcout << "pgc: " << pgc << std::endl;
 
                 unk16 = readbin(unk16, sas, swapit); // val ?
                 unk16 = readbin(unk16, sas, swapit); // padding
@@ -926,7 +944,8 @@ Rcpp::List readsas(const char * filePath,
                 unk32 = readbin(unk32, sas, swapit);
                 if (debug) Rcout << unk32 << std::endl;
                 rcmix =  readbin((int32_t)rcmix, sas, swapit);
-                if (debug) Rcout << "rcmix " << rcmix << std::endl;
+                if (debug)
+                  Rcout << "rcmix " << rcmix << std::endl;
                 uunk32 = readbin(uunk32, sas, swapit);
                 if (debug) Rcout << uunk32 << std::endl;
                 uunk32 = readbin(uunk32, sas, swapit);

src/sas.h

@@ -8,6 +8,36 @@
 
 #include "swap_endian.h"
 
+// #define NA_DOUBLE 00 00 00 00 00 FE FF FF
+
+template <typename T>
+inline void writebin(T t, std::fstream& sas, bool swapit)
+{
+  if (swapit==1){
+    T t_s = swap_endian(t);
+    sas.write((char*)&t_s, sizeof(t_s));
+  } else {
+    sas.write((char*)&t, sizeof(t));
+  }
+}
+
+
+inline void write_case_i(uint32_t f1, uint32_t f2, bool ENDIANNES, bool bit32, bool swapit, std::fstream& sas) {
+
+  // with ENDIANNES == 0 aka big endian
+  // f2 is written first. So this requires an additional swap
+  if (ENDIANNES == 0) {
+    writebin(f2, sas, swapit);
+    if (bit32 == 0)
+      writebin(f1, sas, swapit);
+  } else if (ENDIANNES == 1) {
+    writebin(f1, sas, swapit);
+    if (bit32 == 0)
+      writebin(f2, sas, swapit);
+  }
+
+}
+
 inline void writestr(std::string val_s, int32_t len, std::fstream& sas)
 {
 
@@ -62,6 +92,7 @@ T readbin( T t , std::istream& sas, bool swapit)
     return(swap_endian(t));
 }
 
+inline
 double readbinlen(double d, std::istream& sas, bool swapit, int len)
 {
 
@@ -489,7 +520,7 @@ inline std::string SASEncoding(uint8_t encval) {
   return enc;
 }
 
-std::vector<int64_t> vec_order(const std::vector<int64_t> &v) {
+inline std::vector<int64_t> vec_order(const std::vector<int64_t> &v) {
   std::vector<int64_t> idx(v.size());
   iota(idx.begin(), idx.end(), 0);
   stable_sort(idx.begin(), idx.end(),
@@ -499,7 +530,7 @@ std::vector<int64_t> vec_order(const std::vector<int64_t> &v) {
 }
 
 // order only the valid options
-std::vector<int64_t> order_(std::vector<int64_t> v) {
+inline std::vector<int64_t> order_(std::vector<int64_t> v) {
   // if (std::count(v.begin(), v.end(), -1)) {
   //   std::vector<int64_t> idx(v.size());
   //   iota(idx.begin(), idx.end(), -1);
@@ -526,7 +557,7 @@ std::vector<int64_t> order_(std::vector<int64_t> v) {
   // }
 }
 
-bool any_keepr(Rcpp::IntegerVector rvec, uint64_t idx) {
+inline bool any_keepr(Rcpp::IntegerVector rvec, uint64_t idx) {
   return std::find(rvec.begin(), rvec.end(), idx) != rvec.end();
 }