* Resolves r-gregmisc#22.

* Don't assign empty ("" or " ") labels to datasets * Use auto-detected SAS attributes unless user has specified them. * `testDates.R` now does an explicit compare to detect regressions like r-gregmisc#22.
elimillera · Dec 30, 2020 · c578e6e · c578e6e
1 parent 302972d
commit c578e6e
Show file tree

Hide file tree

Showing 4 changed files with 57 additions and 15 deletions.
diff --git a/R/read.xport.R b/R/read.xport.R
@@ -53,8 +53,8 @@ read.xport <- function(file,
     scat("Extracting data file information...")
     dsinfo <- lookup.xport.inner(file)
 
-    dsLabels <- sapply(dsinfo, label)
-    dsTypes  <- sapply(dsinfo, SAStype)
+    dsLabels <- trimws(sapply(dsinfo, label))
+    dsTypes  <- trimws(sapply(dsinfo, SAStype))
 
     if(length(keep))
       whichds <- toupper(keep)
@@ -77,7 +77,7 @@ read.xport <- function(file,
     scat("Processing contents...")
     ## PROC FORMAT CNTLOUT= dataset present?
     fds <- NULL
-    if(!length(formats)) {
+    if(length(formats)==0) {
       fds <- sapply(dsinfo, function(x)
                     all(c('FMTNAME','START','END','MIN','MAX','FUZZ')
                         %in% x$name))
@@ -126,15 +126,22 @@ read.xport <- function(file,
 
       scat('.')
 
-      label(w, self=TRUE)   <- dsLabels[k]
-      names(label(w, self=TRUE)) <- NULL
-      SAStype(w) <- dsTypes[k]
-      names(SAStype(w)) <- NULL
+      if (nchar(dsLabels[k]) != 0)
+      {
+        label(w, self=TRUE)   <- dsLabels[k]
+        names(label(w, self=TRUE)) <- NULL
+      }
 
       nam      <- names.tolower(makeNames(names(w), allow=name.chars))
       names(w) <- nam
-      dinfo    <- dsinfo[[k]]
 
+      if(nchar(dsTypes[k]) != 0)
+      {
+        SAStype(w) <- dsTypes[k]
+        names(SAStype(w)) <- NULL
+      }
+
+      dinfo    <- dsinfo[[k]]
       fmt <- dinfo$format
       formats  <- fstr( fmt, dinfo$flength, dinfo$fdigits)
 

diff --git a/R/write.xport.R b/R/write.xport.R
@@ -180,7 +180,7 @@ write.xport <- function(...,
             scat("", i , "...")
             var <- df[[i]]
 
-            # get attribute information before any transformations!"
+            # Stash user-specified attribute information
             varLabel <- attr(var, "label")
             varFormat <- attr(var, "SASformat")
             varIFormat <- attr(var, "SASiformat")
@@ -189,6 +189,24 @@ write.xport <- function(...,
             # Convert R object to SAS object
             df[[i]] <- var <- toSAS(var, format.info=formats)
 
+            # Enforce user-specified attribute information
+            postVarLabel <- attr(var, "label")
+            postVarFormat <- attr(var, "SASformat")
+            postVarIFormat <- attr(var, "SASiformat")
+            postVarLength <- attr(var, "SASlength")
+
+            if(length(varLabel)==0)
+              varLabel <- postVarLabel
+
+            if(length(varFormat)==0)
+              varFormat <- postVarFormat
+
+            if(length(varIFormat)==0)
+              varIFormat <- postVarIFormat
+
+            if(length(varLength)==0)
+              varLength <- postVarLength
+
             # compute variable length
             if(is.character(var)){
               # If variable is character, use varLength if available.

diff --git a/R/xport.R b/R/xport.R
@@ -21,7 +21,9 @@
 ### License along with this program; if not, a copy is available at
 ### http://www.r-project.org/Licenses/
 
-lookup.xport.inner <- function(file) .Call('xport_info', file, PACKAGE = "SASxport")
+lookup.xport.inner <- function(file) {
+  .Call('xport_info', file, PACKAGE = "SASxport")
+}
 
 read.xport.inner <- function(file, stringsAsFactors=FALSE)
 {

diff --git a/tests/testDates.R b/tests/testDates.R
@@ -8,19 +8,34 @@ times <- c("23:03:20", "22:29:56", "01:03:30", "18:21:03", "16:56:26")
 
 
 temp <- data.frame(
-  x=c(1, 2, 3, 4, 5 ),
+  x=c(1L, 2L, 3L, 4L, 5L), # integer
+  z=c(1.1, 2.2, 3.3, 4.4, 5.5), # real
   y=c('a', 'B', 'c', 'd', 'e' ),
-  dates=strptime(dates, "%m/%d/%y"),
-  datetimes=strptime( paste(dates,times), "%m/%d/%y %H:%M:%S"),
-  stringsAsFactors = TRUE
+  date=as.Date(dates, format="%m/%d/%y"),
+  datetime=strptime( paste(dates,times), "%m/%d/%y %H:%M:%S"),
+  stringsAsFactors = FALSE
 )
 
 print(temp)
 
 write.xport( DATETIME=temp, file="datetime.xpt")
-temp2 <- read.xport(file="datetime.xpt", names.tolower=FALSE)
+temp2 <- read.xport(file="datetime.xpt",
+                    names.tolower=TRUE,
+                    verbose = TRUE)
 
 print(temp2)
 
+# Strip off SASformats added by read.xport so comparison won't fail
+for(col in colnames(temp2))
+  SASformat(temp2[[col]]) <- NULL
 
 identical(temp, temp2)
+
+# Test for issue #19: toSAS() - The number of seconds since
+# 1960-01-01:00:00:00 GMT is greater than it is supposed to be
+
+zeroDate <- ISOdate(1960, 01, 01, 00, 00, 00, tz="GMT")
+zeroSAS <- toSAS(zeroDate, format="DATETIME19.")
+
+stopifnot(zeroSAS==0)
+