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();
 }