[R-gregmisc-users] SF.net SVN: r-gregmisc: [1203] trunk/SASxport/R
Brought to you by:
warnes
Menu
▾
▴
[R-gregmisc-users] SF.net SVN: r-gregmisc: [1203] trunk/SASxport/R
|
From: <wa...@us...> - 2007-11-01 06:14:30
|
Revision: 1203
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1203&view=rev
Author: warnes
Date: 2007-10-31 23:14:22 -0700 (Wed, 31 Oct 2007)
Log Message:
-----------
- Use of the attribute named 'format' caused problems with chron
objects. Consequently, the format information is now stored in the
'SASformat' attribute. For consistency, the input format information
is now stored in the 'SASiformat' attribute.
- The functions for extracting and setting the format and iformat
information have been renamed to 'SASformat' and 'SASiformat', etc.
- In order to properly handle SAS format information, we now use a
locally modified version of foreign::lookup.xport and
foreign::read.xport.
- Various typo corrections
- Creation of a new function fstr() to generate sas format name strings
using name, length, and digits information.
- Addion of a toSAS method for chron() objects
Modified Paths:
--------------
trunk/SASxport/R/lookup.xport.R
trunk/SASxport/R/make.formats.R
trunk/SASxport/R/read.xport.R
trunk/SASxport/R/toSAS.R
trunk/SASxport/R/write.xport.R
Added Paths:
-----------
trunk/SASxport/R/SASformat.R
trunk/SASxport/R/SASiformat.R
trunk/SASxport/R/fstr.R
Removed Paths:
-------------
trunk/SASxport/R/formats.R
trunk/SASxport/R/iformat.R
Copied: trunk/SASxport/R/SASformat.R (from rev 1196, trunk/SASxport/R/formats.R)
===================================================================
--- trunk/SASxport/R/SASformat.R (rev 0)
+++ trunk/SASxport/R/SASformat.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -0,0 +1,36 @@
+SASformat <- function(x, default)
+ UseMethod("SASformat")
+
+SASformat.default <- function(x, default=NULL)
+{
+ lab <- attr(x,"SASformat")
+ if(is.null(lab))
+ default
+ else
+ lab
+}
+
+SASformat.data.frame <- function(x, default=NULL)
+{
+ sapply( x, SASformat)
+}
+
+"SASformat<-" <- function(x, value)
+ UseMethod("SASformat<-")
+
+"SASformat<-.default" <- function(x, value)
+{
+ attr(x,'SASformat') <- value
+ x
+}
+
+
+"SASformat<-.data.frame" <- function(x, value)
+{
+ if( ncol(x) != length(value) )
+ stop("vector of formats must match number of data frame columns")
+
+ for(i in 1:ncol(x))
+ attr(x[[i]],'SASformat') <- value[i]
+ x
+}
Copied: trunk/SASxport/R/SASiformat.R (from rev 1196, trunk/SASxport/R/iformat.R)
===================================================================
--- trunk/SASxport/R/SASiformat.R (rev 0)
+++ trunk/SASxport/R/SASiformat.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -0,0 +1,20 @@
+SASiformat <- function(x, default)
+ UseMethod("SASiformat")
+
+SASiformat.default <- function(x, default=NULL)
+{
+ lab <- attr(x,"SASiformat")
+ if(is.null(lab))
+ default
+ else
+ lab
+}
+
+"SASiformat<-" <- function(x, value)
+ UseMethod("SASiformat<-")
+
+"SASiformat<-.default" <- function(x, value)
+{
+ attr(x,'SASiformat') <- value
+ x
+}
Deleted: trunk/SASxport/R/formats.R
===================================================================
--- trunk/SASxport/R/formats.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/formats.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -1,20 +0,0 @@
-formats <- function(x, default)
- UseMethod("formats")
-
-formats.default <- function(x, default=NULL)
-{
- lab <- attr(x,"format")
- if(is.null(lab))
- default
- else
- lab
-}
-
-"formats<-" <- function(x, value)
- UseMethod("formats<-")
-
-"formats<-.default" <- function(x, value)
-{
- attr(x,'format') <- value
- x
-}
Added: trunk/SASxport/R/fstr.R
===================================================================
--- trunk/SASxport/R/fstr.R (rev 0)
+++ trunk/SASxport/R/fstr.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -0,0 +1,17 @@
+fstr <- function(name, length, digits)
+ {
+ invalid <- function(x) is.null(x) | ( length(x)<1 ) | ( nchar(x) < 1 ) | x==0
+ inner <- function(i)
+ {
+ if( invalid(name[i]) )
+ return("")
+ if( invalid( length[i] ) )
+ return(name[i])
+ if( invalid(digits[i]) )
+ return( paste(name[i], length[i], '.', sep='' ) )
+ else
+ return( paste(name[i], length[i], '.', digits[i], sep='' ) )
+ }
+ sapply( 1:length(name), inner)
+
+ }
Deleted: trunk/SASxport/R/iformat.R
===================================================================
--- trunk/SASxport/R/iformat.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/iformat.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -1,20 +0,0 @@
-iformat <- function(x, default)
- UseMethod("iformat")
-
-iformat.default <- function(x, default=NULL)
-{
- lab <- attr(x,"iformat")
- if(is.null(lab))
- default
- else
- lab
-}
-
-"iformat<-" <- function(x, value)
- UseMethod("iformat<-")
-
-"iformat<-.default" <- function(x, value)
-{
- attr(x,'iformat') <- value
- x
-}
Modified: trunk/SASxport/R/lookup.xport.R
===================================================================
--- trunk/SASxport/R/lookup.xport.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/lookup.xport.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -11,7 +11,7 @@
file <- tf
}
- ret <- foreign:::lookup.xport(file)
+ ret <- lookup.xport.inner(file)
attr(ret, "call") <- match.call()
attr(ret, "file") <- fname
class(ret) <- c("lookup.xport", "list")
@@ -30,7 +30,13 @@
subFun <- function(XX)
{
df <- object[[XX]]
- ret <- as.data.frame(df[c("name","type","format","width","label")])
+ ret <- as.data.frame(df[c(
+ "name", "type",
+ "format", "flength", "fdigits",
+ "iformat", "iflength", "ifdigits",
+ "label"
+ )
+ ])
cbind(dataset=XX, ret, nobs=df$length)
}
Modified: trunk/SASxport/R/make.formats.R
===================================================================
--- trunk/SASxport/R/make.formats.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/make.formats.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -1,9 +1,9 @@
## Take a list of data frames and process factor objects:
##
## For each factor object
-## 1) generate SAS format infromation
+## 1) generate SAS format information
## 2) add the "factor" attribute to these factors with the name of the generated SAS format
-## 3) add this SAS format information to the FORMATS datafram, creating it if necessary.
+## 3) add this SAS format information to the FORMATS dataframe, creating it if necessary.
##
## Then return a new list of dataframe containing
## 1) The (potentially modified) data frames
@@ -34,7 +34,7 @@
for(varName in colnames(df))
{
var <- df[[varName]]
- if(is.factor(var) && is.null(formats(var)) )
+ if(is.factor(var) && is.null(SASformat(var)) )
{
# We need unique format names, but SAS restricts
# format names alpha characters. To create a unique
@@ -50,7 +50,7 @@
make.format.factor(var, formatName )
)
- formats(var) <- formatName
+ SASformat(var) <- formatName
df[[varName]] <- var
}
}
Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/read.xport.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -46,16 +46,15 @@
stop("The specified file does not start with a SAS xport file header!")
scat("Extracting data file information...")
- dsinfo <- foreign:::lookup.xport(file)
+ dsinfo <- lookup.xport.inner(file)
if(length(keep))
whichds <- toupper(keep)
else
-
whichds <- setdiff(names(dsinfo), c(toupper(drop),'_CONTENTS_','_contents_'))
scat("Reading the data file...")
- ds <- foreign:::read.xport(file)
+ ds <- read.xport.inner(file)
if(any(duplicated(names(dsinfo)))) # only true if file contains has more than one data set
{
@@ -128,10 +127,17 @@
nam <- names.tolower(makeNames(names(w), allow=name.chars))
names(w) <- nam
dinfo <- dsinfo[[k]]
+
fmt <- sub('^\\$','',dinfo$format)
+ formats <- fstr( fmt, dinfo$flength, dinfo$fdigits)
+
+ ifmt <- sub('^\\$','',dinfo$iformat)
+ iformats <- fstr( ifmt, dinfo$iflength, dinfo$ifdigits)
+
lab <- dinfo$label
+
ndinfo <- names.tolower(makeNames(dinfo$name, allow=name.chars))
- names(lab) <- names(fmt) <- ndinfo
+ names(lab) <- names(fmt) <- names(formats) <- names(iformats) <- ndinfo
for(i in 1:length(w)) {
changed <- FALSE
x <- w[[i]]
@@ -141,7 +147,7 @@
f <- finfo[[fi]]
if(length(f)) { ## may be NULL because had a range in format
x <- factor(x, f$value, f$label)
- attr(x, 'format') <- fi
+ attr(x, 'SASformat') <- fi
changed <- TRUE
}
}
@@ -181,13 +187,18 @@
changed <- TRUE
}
- fmt <- fmt[nam[i]];
- if( !is.null(fmt) && length(fmt)>0 && !is.na(fmt) && fmt > '') {
- names(fmt) <- NULL
- formats(x) <- fmt
- changed <- TRUE
- }
-
+ if( formats[nam[i]] > "" )
+ {
+ SASformat(x) <- formats[[nam[i]]]
+ changed <- TRUE
+ }
+
+ if( iformats[nam[i]] > "" )
+ {
+ SASformat(x) <- formats[[nam[i]]]
+ changed <- TRUE
+ }
+
if(changed)
w[[i]] <- x
}
@@ -199,10 +210,13 @@
scat("Done")
- if(include.formats)
+ if( include.formats )
{
nds <- nds+1
- res$"FORMATS" <- ds[[fds]]
+ if( length(fds)>0 )
+ res$"FORMATS" <- ds[[fds]]
+ else
+ res$FORMATS <- empty.format.table()
}
Modified: trunk/SASxport/R/toSAS.R
===================================================================
--- trunk/SASxport/R/toSAS.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/toSAS.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -1,42 +1,42 @@
toSAS <- function(x, format, format.info=NULL)
UseMethod("toSAS")
-toSAS.numeric <- function(x, format=formats(x), format.info=NULL)
+toSAS.numeric <- function(x, format=SASformat(x), format.info=NULL)
{
retval <- as.numeric(x)
- attr(retval, "format")=format
+ attr(retval, "SASformat")=format
retval
}
-toSAS.logical <- function(x, format=formats(x), format.info=NULL)
+toSAS.logical <- function(x, format=SASformat(x), format.info=NULL)
{
retval <- as.character(x)
- attr(retval, "format")=format
+ attr(retval, "SASformat")=format
retval
}
-toSAS.character <- function(x, format=formats(x), format.info=NULL)
+toSAS.character <- function(x, format=SASformat(x), format.info=NULL)
{
retval <- as.character(x)
- attr(retval, "format")=format
+ attr(retval, "SASformat")=format
retval
}
-toSAS.factor <- function(x, format=formats(x), format.info=NULL)
+toSAS.factor <- function(x, format=SASformat(x), format.info=NULL)
{
finfo <- process.formats(format.info)
if( (length(format>0)) && (format %in% names(finfo)) )
{
- labels <- finfo[[formats(x)]]$label
- values <- finfo[[formats(x)]]$value
+ labels <- finfo[[SASformat(x)]]$label
+ values <- finfo[[SASformat(x)]]$value
retval <- values[match( x, labels)]
}
else
{
retval <- as.character(x)
}
- attr(retval, "format")=format
+ attr(retval, "SASformat")=format
retval
}
@@ -44,7 +44,7 @@
{
sasBaseSeconds <- as.numeric(ISOdatetime(1960,1,1,0,0,0))
retval <- unclass(as.POSIXct(x)) - sasBaseSeconds # sasBaseSeconds is negative
- attr(retval,"format") <- format
+ attr(retval,"SASformat") <- format
retval
}
@@ -52,14 +52,15 @@
{
sasBase <- as.Date(strptime("01/01/1960", "%m/%d/%Y", tz="GMT")) # days
retval <- as.numeric( as.Date(x) - sasBase)
- attr(retval, "format") <- format
+ attr(retval, "SASformat") <- format
retval
}
-toSAS.default <- function(x, format=formats(x), format.info=NULL)
+toSAS.default <- function(x, format=SASformat(x), format.info=NULL)
{
retval <- as.character(x)
- attr(retval, "format")=format
+ attr(retval, "SASformat") <- format
retval
}
+toSAS.chron <- toSAS.POSIXt
Modified: trunk/SASxport/R/write.xport.R
===================================================================
--- trunk/SASxport/R/write.xport.R 2007-11-01 06:01:50 UTC (rev 1202)
+++ trunk/SASxport/R/write.xport.R 2007-11-01 06:14:22 UTC (rev 1203)
@@ -204,8 +204,8 @@
# get attribute information before any transformations!"
varLabel <- attr(var, "label")
- varFormat <- attr(var, "format")
- varIFormat <- attr(var, "iformat")
+ varFormat <- attr(var, "SASformat")
+ varIFormat <- attr(var, "SASiformat")
# Convert R object to SAS object
df[[i]] <- var <- toSAS(var, format.info=formats)
@@ -233,15 +233,15 @@
out(
xport.namestr(
var=var,
- varName=i,
- varNum=varIndex,
- varPos=lenIndex,
- varLength=varLen,
- varLabel=varLabel,
- fName = formatInfo$name,
+ varName = i,
+ varNum = varIndex,
+ varPos = lenIndex,
+ varLength = varLen,
+ varLabel = varLabel,
+ fName = formatInfo$name,
fLength = formatInfo$len,
fDigits = formatInfo$digits,
- iName = iFormatInfo$name,
+ iName = iFormatInfo$name,
iLength = iFormatInfo$len,
iDigits = iFormatInfo$digits,
)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
