[R-gregmisc-users] SF.net SVN: r-gregmisc: [1110] trunk/SASxport
Brought to you by:
warnes
Menu
▾
▴
[R-gregmisc-users] SF.net SVN: r-gregmisc: [1110] trunk/SASxport
|
From: <wa...@us...> - 2007-08-03 00:35:41
|
Revision: 1110
http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1110&view=rev
Author: warnes
Date: 2007-08-02 17:35:39 -0700 (Thu, 02 Aug 2007)
Log Message:
-----------
More modifications. Should now work for most R data types
Modified Paths:
--------------
trunk/SASxport/NAMESPACE
trunk/SASxport/R/write.xport.R
trunk/SASxport/R/xport.character.R
trunk/SASxport/R/xport.file.header.R
trunk/SASxport/R/xport.member.header.R
trunk/SASxport/R/xport.namestr.R
trunk/SASxport/src/SASxport.so
trunk/SASxport/src/writeSAS.c
Added Paths:
-----------
trunk/SASxport/R/fromSASDate.R
trunk/SASxport/R/parseFormat.R
trunk/SASxport/R/toSAS.R
trunk/SASxport/man/toSAS.Rd
Modified: trunk/SASxport/NAMESPACE
===================================================================
--- trunk/SASxport/NAMESPACE 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/NAMESPACE 2007-08-03 00:35:39 UTC (rev 1110)
@@ -1,5 +1,14 @@
export(
- write.xport
+ write.xport,
+ toSAS
)
+S3method(toSAS,numeric)
+S3method(toSAS,logical)
+S3method(toSAS,character)
+S3method(toSAS,factor)
+S3method(toSAS,POSIXt)
+S3method(toSAS,Date)
+S3method(toSAS,default)
+
useDynLib(SASxport)
Added: trunk/SASxport/R/fromSASDate.R
===================================================================
--- trunk/SASxport/R/fromSASDate.R (rev 0)
+++ trunk/SASxport/R/fromSASDate.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -0,0 +1,15 @@
+fromSASDate <- function( sDate )
+ {
+ sasBase <- as.Date(strptime("01/01/1960 0:00:00", "%m/%d/%Y %H:%M:%S", tz="GMT")) # days
+ sasBase + sDate
+ }
+
+
+fromSASDateTime <- function( sDateTime )
+ {
+ sasBaseSeconds <- as.numeric(ISOdatetime(1960,1,1,0,0,0) - 0)
+ retval <- sDateTime + sasBaseSeconds
+ class(retval) <- c("POSIXt","POSIXct")
+ retval
+ }
+
Added: trunk/SASxport/R/parseFormat.R
===================================================================
--- trunk/SASxport/R/parseFormat.R (rev 0)
+++ trunk/SASxport/R/parseFormat.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -0,0 +1,41 @@
+## Convert SAS format specification string into format name, length, and digits
+parseFormat <- function(format)
+ {
+ retval <- list("name"="", "len"=0, "digits"=0)
+
+
+ if( !is.null(format) && (length(format)==1) && (format > "") )
+ {
+ index <- regexpr("[0-9]+", format)
+ if(index==-1)
+ {
+ retval$name <- format
+ retval$len <- 0
+ retval$digits <- 0
+ }
+ else
+ {
+ retval$name <- substr(format,0,index-1)[1]
+
+ lenStr <- substr(format,index, nchar(format))
+
+ index <- regexpr("\\.", lenStr)
+ if(index==-1)
+ {
+ retval$len <- as.numeric(lenStr)
+ retval$digits <- 0
+ }
+ else
+ {
+ retval$len <- as.numeric(substr(lenStr, 0, index-1))
+ retval$digits <- as.numeric(substr(lenStr, index+1, nchar(lenStr)))
+ }
+ }
+
+ if(is.na(retval$len)) retval$len <- 0
+ if(is.na(retval$digits)) retval$digits <- 0
+
+ }
+
+ return(retval)
+ }
Added: trunk/SASxport/R/toSAS.R
===================================================================
--- trunk/SASxport/R/toSAS.R (rev 0)
+++ trunk/SASxport/R/toSAS.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -0,0 +1,55 @@
+toSAS <- function(x, format)
+ UseMethod("toSAS")
+
+toSAS.numeric <- function(x, format="")
+ {
+ retval <- as.numeric(x)
+ attr(retval, "format")=format
+ retval
+ }
+
+toSAS.logical <- function(x, format="")
+ {
+ retval <- as.character(x)
+ attr(retval, "format")=format
+ retval
+ }
+
+
+toSAS.character <- function(x, format="")
+ {
+ retval <- as.character(x)
+ attr(retval, "format")=format
+ retval
+ }
+
+toSAS.factor <- function(x, format="")
+ {
+ retval <- as.character(x)
+ attr(retval, "format")=format
+ retval
+ }
+
+toSAS.POSIXt <- function( x, format="DATETIME16." )
+ {
+ sasBaseSeconds <- as.numeric(ISOdatetime(1960,1,1,0,0,0))
+ retval <- unclass(as.POSIXct(x)) - sasBaseSeconds # sasBaseSeconds is negative
+ attr(retval,"format") <- format
+ retval
+ }
+
+toSAS.Date <- function(x, format="DATE9." )
+ {
+ sasBase <- as.Date(strptime("01/01/1960", "%m/%d/%Y", tz="GMT")) # days
+ retval <- as.numeric( as.Date(x) - sasBase)
+ attr(retval, "format") <- format
+ retval
+ }
+
+toSAS.default <- function(x, format="")
+ {
+ retval <- as.character(x)
+ attr(retval, "format")=format
+ retval
+ }
+
Modified: trunk/SASxport/R/write.xport.R
===================================================================
--- trunk/SASxport/R/write.xport.R 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/R/write.xport.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -88,9 +88,14 @@
scat("", i , "...")
var <- df[[i]]
- # Convert factors to character strings
- if(is.factor(var)) df[[i]] <- var <- as.character(var)
+ # get attribute information before any transformations!"
+ varLabel <- attr(var, "label")
+ varFormat <- attr(var, "format")
+ varIFormat <- attr(var, "iformat")
+ # Convert R object to SAS object
+ df[[i]] <- var <- toSAS(var)
+
# compute variable length
if(is.character(var))
varLen <- max(8, max( nchar(var) ) )
@@ -100,12 +105,33 @@
# fill in variable offset and length information
offsetTable[i, "len"] <- varLen
offsetTable[i, "offset"] <- lenIndex
+
+
+
+ # parse format and iformat
+ formatInfo <- parseFormat( varFormat)
+ iFormatInfo <- parseFormat( varIFormat)
+
+
+
# write the entry
- out( xport.namestr(
- var=var, varName=i, varNum=varIndex, varPos=lenIndex,
- varLength=varLen
- ) )
+ out(
+ xport.namestr(
+ var=var,
+ varName=i,
+ varNum=varIndex,
+ varPos=lenIndex,
+ varLength=varLen,
+ varLabel=varLabel,
+ fName = formatInfo$name,
+ fLength = formatInfo$len,
+ fDigits = formatInfo$digits,
+ iName = iFormatInfo$name,
+ iLength = iFormatInfo$len,
+ iDigits = iFormatInfo$digits,
+ )
+ )
# increment our counters
lenIndex <- lenIndex + varLen
@@ -115,7 +141,8 @@
scat("Done.")
# Space-fill to 80 character record end
- fillSize <- spaceUsed %% 80
+ fillSize <- 80 - (spaceUsed %% 80)
+ if(fillSize==80) fillSize <- 0
out( xport.fill( TRUE, fillSize ) )
scat("Write header for data block ...")
@@ -123,7 +150,6 @@
scat("Done")
scat("Write data ... ");
- counter <- 1
spaceUsed <- 0
for(i in 1:nrow(df) )
for(j in 1:ncol(df) )
@@ -140,9 +166,11 @@
spaceUsed <- spaceUsed + valLen
}
- fillSize <- spaceUsed %% 80
- out( xport.fill(FALSE, fillSize ) )
+ fillSize <- 80 - (spaceUsed %% 80)
+ if(fillSize==80) fillSize <- 0
+ out( xport.fill(TRUE, fillSize ) )
+
scat("Done.")
}
Modified: trunk/SASxport/R/xport.character.R
===================================================================
--- trunk/SASxport/R/xport.character.R 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/R/xport.character.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -1,6 +1,8 @@
xport.character <- function( value, width )
{
if(length(value)!=1) stop("Only a single character value is permitted.")
+
+ if(is.na(value)) value <- ""
.C("fill_character_field",
value = as.character(value),
Modified: trunk/SASxport/R/xport.file.header.R
===================================================================
--- trunk/SASxport/R/xport.file.header.R 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/R/xport.file.header.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -2,10 +2,10 @@
function( cDate=Sys.time(), mDate=cDate, sasVer="7.00", osType="Unknown" )
{
.C("fill_file_header",
- cDate = xport.dateFMT(cDate), # creation date
- mDate = xport.dateFMT(mDate), # modification date
+ cDate = xport.dateFMT(cDate), # Creation date
+ mDate = xport.dateFMT(mDate), # Modification date
sasVer = toupper(as.character(sasVer)), # SAS version number
- osType = toupper(as.character(osType)), # operating system
+ osType = as.character(osType), # Operating System (can include lowercase)
PACKAGE="SASxport"
)
Modified: trunk/SASxport/R/xport.member.header.R
===================================================================
--- trunk/SASxport/R/xport.member.header.R 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/R/xport.member.header.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -4,7 +4,7 @@
.C("fill_member_header",
dfName = toupper(as.character(dfName)), # Name of data set
sasVer = toupper(as.character(sasVer)), # SAS version number
- osType = toupper(as.character(osType)), # Operating System
+ osType = as.character(osType), # Operating System (can include lowercase)
cDate = xport.dateFMT(cDate), # Creation date
mDate = xport.dateFMT(mDate), # modification date
PACKAGE="SASxport"
Modified: trunk/SASxport/R/xport.namestr.R
===================================================================
--- trunk/SASxport/R/xport.namestr.R 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/R/xport.namestr.R 2007-08-03 00:35:39 UTC (rev 1110)
@@ -33,13 +33,8 @@
else
varLength <- 8
-# if(missing(varLabel) || is.null(varLabel) )
-# {
-# varLabel <- attr(var, "label")
-# if(is.null(varLabel))
-# varLabel <- varName
-# }
- varLabel=""
+ if( missing(varLabel) || is.null(varLabel) )
+ varLabel <- ""
just <- match.arg(just)
if(just=="left")
Added: trunk/SASxport/man/toSAS.Rd
===================================================================
--- trunk/SASxport/man/toSAS.Rd (rev 0)
+++ trunk/SASxport/man/toSAS.Rd 2007-08-03 00:35:39 UTC (rev 1110)
@@ -0,0 +1,90 @@
+\name{toSAS.default}
+alias{toSAS}
+alias{toSAS.numeric}
+alias{toSAS.logical}
+alias{toSAS.character}
+alias{toSAS.factor}
+alias{toSAS.POSIXt}
+alias{toSAS.Date}
+alias{toSAS.default}
+\title{Convert R data object for storage in SAS xport file}
+\description{
+ The \code{toSAS} methods control how R objects and data types are
+ represented when stored into a SAS xport format file using
+ \code{write.xport}.
+}
+\usage{
+toSAS(x, format)
+\method{toSAS}{default}(x, format="")
+\method{toSAS}{numeric}(x, format="")
+\method{toSAS}{logical}(x, format="")
+\method{toSAS}{character}(x, format="")
+\method{toSAS}{factor}(x, format="")
+\method{toSAS}{POSIXt}( x, format="DATETIME16." )
+\method{toSAS}{Date}(x, format="DATE9." )
+}
+\arguments{
+ \item{x}{ Object to be converted }
+ \item{format}{SAS format name}
+}
+\details{
+ To add support for a new object type, create an appropriate
+ \code{toSAS} method. This method must convert the object data to
+ either an object of type "numeric" or type "character", and should add
+ an attribute named "format" to the object providing an appropriate SAS
+ format string or "" (indicating the default SAS format).
+}
+\value{
+ A vector of type "character" or of type "numeric", with an attribute
+ named "lable" containing the SAS format specification.
+}
+\author{ Gregory R. Warnes \email{gr...@ra...} }
+\seealso{
+ \code{\link{write.xport}},
+ \code{\link{read.xport}},
+ \code{\link{lookup.xport}}
+}
+\examples{
+
+####
+## See how an R date object will be stored in a SAS xport file:
+####
+
+dateObj <- ISOdate(2007,08,01,10,14,37)
+dateObj
+
+sasObj <- toSAS(dateObj)
+str(sasObj)
+
+####
+## Create a new R object class based on factor to hold color names
+####
+colorFactor <- function(x) # constructor
+ {
+ retval <- factor(x, levels=c("Red","Green","Blue") )
+ class(retval) <- c("colorFactor","factor")
+ retval
+ }
+
+## create one and look at it
+cf <- colorFactor( c("Red","Red","Blue",NA) )
+
+
+## See how it will be represented in a SAS xport file
+toSAS(cf)
+class(toSAS(cf))
+
+## Create a new conversion function to store as a RGB hex value
+toSAS.colorFactor <- function(x, format="")
+{
+ retval <- ifelse(x=="Red", "#FF0000", ifelse(x=="Green", "#00FF00", "#0000FF") )
+ attr(retval, "format") <- format
+ retval
+}
+
+## see it in action
+toSAS(cf)
+
+}
+\keyword{manip}
+\keyword{IO}
Modified: trunk/SASxport/src/SASxport.so
===================================================================
(Binary files differ)
Modified: trunk/SASxport/src/writeSAS.c
===================================================================
--- trunk/SASxport/src/writeSAS.c 2007-08-03 00:35:07 UTC (rev 1109)
+++ trunk/SASxport/src/writeSAS.c 2007-08-03 00:35:39 UTC (rev 1110)
@@ -328,7 +328,6 @@
static char numeric_NA[8] = {0x2e,0x00,0x00,0x00,0x00,0x00,0x00,0x00};
memcpy(raw_buffer, numeric_NA, 8);
- REVERSE(raw_buffer, 8);
raw_buffer_used = 8;
return;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
