[R-gregmisc-users] SF.net SVN: r-gregmisc: [1131] trunk/SASxport/R

[<wa...@us...>]

Revision: 1131
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1131&view=rev
Author:   warnes
Date:     2007-08-09 16:28:27 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
More changes, esp to lookup.xport() and friends

Modified Paths:
--------------
    trunk/SASxport/R/AFirst.lib.s
    trunk/SASxport/R/lookup.xport.R
    trunk/SASxport/R/read.xport.R
    trunk/SASxport/R/write.xport.R

Added Paths:
-----------
    trunk/SASxport/R/all.is.numeric.R
    trunk/SASxport/R/in.opererator.R

Modified: trunk/SASxport/R/AFirst.lib.s
===================================================================
--- trunk/SASxport/R/AFirst.lib.s	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/AFirst.lib.s	2007-08-09 23:28:27 UTC (rev 1131)
@@ -17,3 +17,9 @@
   existsFunction <- function(...) exists(..., mode='function')
 }
 
+if(.R.) {  
+  ## create some function definitions just to avoid R CMD CHECK warnings
+  timeDate <- function(...) stop("Not Implemented")
+  dates <- function(...) stop("Not Implemented")
+}
+

Added: trunk/SASxport/R/all.is.numeric.R
===================================================================
--- trunk/SASxport/R/all.is.numeric.R	                        (rev 0)
+++ trunk/SASxport/R/all.is.numeric.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -0,0 +1,22 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
+all.is.numeric <- function(x, what=c('test','vector'), extras=c('.','NA'))
+{
+  what <- match.arg(what)
+  old <- options(warn=-1)
+  on.exit(options(old))
+  ##.Options$warn <- -1  6Aug00
+  x <- sub('[[:space:]]+$', '', x)
+  x <- sub('^[[:space:]]+', '', x)
+  xs <- x[x %nin% c('',extras)]
+  isnum <- !any(is.na(as.numeric(xs)))
+  if(what=='test')
+    isnum
+  else if(isnum)
+    as.numeric(x)
+  else x
+}

Added: trunk/SASxport/R/in.opererator.R
===================================================================
--- trunk/SASxport/R/in.opererator.R	                        (rev 0)
+++ trunk/SASxport/R/in.opererator.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -0,0 +1,7 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
+"%nin%" <- function(a, b) ! (a %in% b)

Modified: trunk/SASxport/R/lookup.xport.R
===================================================================
--- trunk/SASxport/R/lookup.xport.R	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/lookup.xport.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -1,2 +1,62 @@
 ## Simply make this accessible here as a convenience to the user
-lookup.xport <- foreign:::lookup.xport
+lookup.xport <- function(file)
+  {
+    fname <- file
+
+    if(length(grep('http://', file))>0 || length(grep('ftp://', file))>0 )
+      {
+        scat("Downloading file...")        
+        tf <- tempfile()
+        download.file(file, tf, mode='wb', quiet=TRUE)
+        file <- tf
+      }
+
+    ret <- foreign:::lookup.xport(file)
+    attr(ret, "call") <- match.call()
+    attr(ret, "file") <- fname
+    class(ret) <- c("lookup.xport", "list")
+    ret
+  }
+
+print.lookup.xport <- function(x, ...)
+  {
+    Sinfo <- summary(x, ...)
+    print(Sinfo)
+  }
+
+
+summary.lookup.xport <- function(object, ...)
+  {
+    subFun <- function(XX)
+      {
+        df <- object[[XX]]
+        ret <- as.data.frame(df[c("name","type","format","width","label")])
+        cbind(dataset=XX, ret, nobs=df$length)
+      }
+    
+    dFrames <- lapply( names(object), subFun )
+    singleFrame <- do.call("rbind", dFrames)
+    rownames(singleFrame) <- paste(singleFrame$dataset, singleFrame$name, sep=".")
+
+    attr(singleFrame, "call") <- attr(object, "call")
+    attr(singleFrame, "file") <- attr(object, "file")    
+    class(singleFrame) <- c("summary.lookup.xport","data.frame")
+    
+    singleFrame
+  }
+
+print.summary.lookup.xport <- function(x, ...)
+{
+  cat("\n")
+  cat("SAS xport file\n")
+  cat("--------------\n");
+  cat("Filename: `", attr(x,"file"), "'\n", sep="")
+  cat("\n")
+  for(dSetName in levels(x$dataset))
+    {
+      cat("Variables in data set `", dSetName, "':\n", sep="")
+      print(as.data.frame(x)[x$dataset==dSetName,], row.names=FALSE)
+      cat("\n")
+    }
+}
+

Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/read.xport.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -21,12 +21,6 @@
     sastimeform     <- toupper(c("hhmm","hour","mmss","time"))
     sasdatetimeform <- toupper(c("datetime","tod"))
 
-    if(length(grep('http://', file))) {
-      tf <- tempfile()
-      download.file(file, tf, mode='wb', quiet=TRUE)
-      file <- tf
-    }
-
     if(verbose)
       {
         oldOptionsDebug <- options("DEBUG")
@@ -34,6 +28,14 @@
         on.exit(options(DEBUG=oldOptionsDebug))
       }
 
+    if(length(grep('http://', file))>0 || length(grep('ftp://', file))>0 )
+      {
+        scat("Downloading file...")        
+        tf <- tempfile()
+        download.file(file, tf, mode='wb', quiet=TRUE)
+        file <- tf
+      }
+
     scat("Extracting data file information...")
     dsinfo <- foreign:::lookup.xport(file)
 

Modified: trunk/SASxport/R/write.xport.R
===================================================================
--- trunk/SASxport/R/write.xport.R	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/write.xport.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -51,10 +51,10 @@
     scat("Done")
 
     if(file==stdout())
-      out <- function(what)
+      out <- function(...)
         {
-          cat("ASCII: ", rawToDisplay(what), "")
-          cat("HEX:   ", what, "")
+          cat("ASCII: ", rawToDisplay(...), "")
+          cat("HEX:   ", ..., "")
         }
     else
       out <- function(...) writeBin( ..., raw(), con=file)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.