[R-gregmisc-users] SF.net SVN: r-gregmisc:[1803] trunk/SASxport
Brought to you by:
warnes
Menu
▾
▴
[R-gregmisc-users] SF.net SVN: r-gregmisc:[1803] trunk/SASxport
|
From: <wa...@us...> - 2014-04-10 02:02:29
|
Revision: 1803
http://sourceforge.net/p/r-gregmisc/code/1803
Author: warnes
Date: 2014-04-10 02:02:25 +0000 (Thu, 10 Apr 2014)
Log Message:
-----------
Remove definitions of labels in favor of those coming from Hmisc. Modify read.xport and write.xport to use appropriate arguments for label method for data.frames.
Modified Paths:
--------------
trunk/SASxport/R/read.xport.R
trunk/SASxport/R/write.xport.R
Removed Paths:
-------------
trunk/SASxport/R/label.R
trunk/SASxport/man/label.Rd
Deleted: trunk/SASxport/R/label.R
===================================================================
--- trunk/SASxport/R/label.R 2014-04-09 23:52:17 UTC (rev 1802)
+++ trunk/SASxport/R/label.R 2014-04-10 02:02:25 UTC (rev 1803)
@@ -1,20 +0,0 @@
-label <- function(x, default)
- UseMethod("label")
-
-label.default <- function(x, default=NULL)
-{
- lab <- attr(x,"label")
- if(is.null(lab))
- default
- else
- lab
-}
-
-"label<-" <- function(x, value)
- UseMethod("label<-")
-
-"label<-.default" <- function(x, value)
-{
- attr(x,'label') <- value
- x
-}
Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R 2014-04-09 23:52:17 UTC (rev 1802)
+++ trunk/SASxport/R/read.xport.R 2014-04-10 02:02:25 UTC (rev 1803)
@@ -1,5 +1,5 @@
##
-## Code originally from Frank Harrell's 'Hmisc' library:
+## 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
##
@@ -32,7 +32,7 @@
if(length(grep('http://', file))>0 || length(grep('ftp://', file))>0 )
{
- scat("Downloading file...")
+ scat("Downloading file...")
tf <- tempfile()
download.file(file, tf, mode='wb', quiet=TRUE)
file <- tf
@@ -44,13 +44,13 @@
file.header <- substr(file.header, start=1, stop=nchar(xport.file.header) )
if( !identical(xport.file.header, file.header) )
stop("The specified file does not start with a SAS xport file header!")
-
+
scat("Extracting data file information...")
dsinfo <- lookup.xport.inner(file)
dsLabels <- sapply(dsinfo, label)
dsTypes <- sapply(dsinfo, SAStype)
-
+
if(length(keep))
whichds <- toupper(keep)
else
@@ -65,7 +65,7 @@
names(ds) <- make.unique(names(ds))
}
-
+
if( (length(keep)>0 || length(drop)>0) )
ds <- ds[whichds]
@@ -82,7 +82,7 @@
fds <- fds[1]
}
}
-
+
finfo <- NULL
if(length(formats) || length(fds)) {
if(length(formats))
@@ -108,7 +108,7 @@
names(res) <- gsub('_','.',dsn)
- possiblyConvertChar <- (is.logical(as.is) && !as.is) ||
+ possiblyConvertChar <- (is.logical(as.is) && !as.is) ||
(is.numeric(as.is) && as.is > 0)
j <- 0
for(k in which.regular) {
@@ -120,9 +120,9 @@
else ds[[k]]
scat('.')
-
- label(w) <- dsLabels[k]
- names(label(w)) <- NULL
+
+ label(w, self=TRUE) <- dsLabels[k]
+ names(label(w, self=TRUE)) <- NULL
SAStype(w) <- dsTypes[k]
names(SAStype(w)) <- NULL
@@ -137,7 +137,7 @@
iformats <- fstr( ifmt, dinfo$iflength, dinfo$ifdigits)
lab <- dinfo$label
-
+
ndinfo <- names.tolower(makeNames(dinfo$name, allow=name.chars))
names(lab) <- names(fmt) <- names(formats) <- names(iformats) <- ndinfo
if(length(w)>0)
@@ -176,13 +176,13 @@
}
}
} else if(possiblyConvertChar && is.character(x)) {
- if((is.logical(as.is) && !as.is) ||
+ if((is.logical(as.is) && !as.is) ||
(is.numeric(as.is) && length(unique(x)) < as.is*length(x))) {
x <- factor(x, exclude='')
changed <- TRUE
}
}
-
+
lz <- lab[nam[i]]
if(!is.null(lz) && length(lz)>0 && !is.na(lz) && lz != '') {
names(lz) <- NULL
@@ -195,13 +195,13 @@
SASformat(x) <- formats[[nam[i]]]
changed <- TRUE
}
-
+
if(nam[i] %in% names(iformats) && iformats[nam[i]] > "" )
{
SASformat(x) <- formats[[nam[i]]]
changed <- TRUE
}
-
+
if(changed)
w[[i]] <- x
}
@@ -216,7 +216,7 @@
if( include.formats )
{
nds <- nds+1
- if( length(fds)>0 )
+ if( length(fds)>0 )
res$"FORMATS" <- ds[[fds]]
else
res$FORMATS <- empty.format.table()
Modified: trunk/SASxport/R/write.xport.R
===================================================================
--- trunk/SASxport/R/write.xport.R 2014-04-09 23:52:17 UTC (rev 1802)
+++ trunk/SASxport/R/write.xport.R 2014-04-10 02:02:25 UTC (rev 1803)
@@ -1,13 +1,13 @@
write.xport <- function(...,
list=base::list(),
- file = stop("'file' must be specified"),
+ file = stop("'file' must be specified"),
verbose=FALSE,
sasVer="7.00",
osType,
cDate=Sys.time(),
formats=NULL,
autogen.formats=TRUE
- )
+ )
{
## Handle verbose option ##
@@ -31,10 +31,10 @@
dotNames <- names(dotList)
if(is.null(dotNames)) dotNames <- rep("", length(dotList))
- if(length(dotList)>0)
+ if(length(dotList)>0)
{
## Get data frame names from ... in function call, but don't
- ## clobber any explicitly provided names
+ ## clobber any explicitly provided names
mc <- match.call()
mc$file <- NULL
mc$verbose <- NULL
@@ -45,8 +45,8 @@
mc$autogen.formats <- NULL
mc[[1]] <- NULL
# note we *do not* mask off format argument so it will get
- # magically included if present.
-
+ # magically included if present.
+
mc <- as.character(mc)
badNames <- which(is.na(dotNames) | dotNames<="")
@@ -59,7 +59,7 @@
listNames <- rep("", length(list))
dfList <- c(dotList, list)
dfNames <- c(dotNames, listNames)
-
+
## check for and handle <NA> or empty names ##
badNames <- which(is.na(dfNames) | dfNames<="")
if(length(badNames)>0)
@@ -79,7 +79,7 @@
if(length(not.df)==1)
stop(paste("'", dfNames[not.df], "'"),
" is not a data.frame object.")
- else
+ else
stop(paste("'", dfNames[not.df], "'", sep="", collapse=", "),
" are not data.frame objects.")
##
@@ -111,8 +111,8 @@
#######
scat("opening file ...")
- if (is.character(file))
- if (file == "")
+ if (is.character(file))
+ if (file == "")
file <- stdout()
else {
file <- file(description=file, open="wb")
@@ -132,10 +132,10 @@
scat("Write file header ...")
out( xport.file.header( cDate=cDate, sasVer=sasVer, osType=osType ) )
scat("Done.")
-
+
for(i in dfNames)
{
-
+
df <- dfList[[i]]
if(is.null(colnames(df)))
@@ -149,17 +149,17 @@
dfList[[i]] <- df
}
-
+
colnames(dfList[[i]]) <- colnames(df) <- varNames <- makeSASNames(colnames(df))
-
+
offsetTable <- data.frame("name"=varNames,
"len"=rep(NA, length(varNames)),
"offset"=rep(NA, length(varNames)) )
rownames(offsetTable) <- offsetTable[,"name"]
- dfLabel <- label(df, default="" )
+ dfLabel <- label(df, default="", self=TRUE )
dfType <- SAStype(df, default="")
-
+
scat("Write data frame header ...")
out( xport.member.header(dfName=i, cDate=cDate, sasVer=sasVer, osType=osType,
dfLabel=dfLabel, dfType=dfType) )
@@ -168,7 +168,7 @@
scat("Write variable information block header ...")
out( xport.namestr.header( nvar=ncol(df) ) )
scat("Done.")
-
+
scat("Write entries for variable information block ...")
lenIndex <- 0
varIndex <- 1
@@ -197,14 +197,14 @@
offsetTable[i, "offset"] <- lenIndex
-
+
# parse format and iformat
formatInfo <- parseFormat(varFormat)
iFormatInfo <- parseFormat(varIFormat)
-
-
-
+
+
+
# write the entry
out(
xport.namestr(
@@ -213,7 +213,7 @@
varNum = varIndex,
varPos = lenIndex,
varLength = varLen,
- varLabel = varLabel,
+ varLabel = varLabel,
fName = formatInfo$name,
fLength = formatInfo$len,
fDigits = formatInfo$digits,
@@ -232,8 +232,8 @@
# Space-fill to 80 character record end
fillSize <- 80 - (spaceUsed %% 80)
- if(fillSize==80) fillSize <- 0
- out( xport.fill( TRUE, fillSize ) )
+ if(fillSize==80) fillSize <- 0
+ out( xport.fill( TRUE, fillSize ) )
scat("Write header for data block ...")
out( xport.obs.header() )
@@ -248,7 +248,7 @@
{
val <- df[i,j]
valLen <- offsetTable[j,"len"]
-
+
scat("i=", i, " j=", j, " value=", val, " len=", valLen, "");
if(is.character( val ))
{
@@ -260,18 +260,18 @@
spaceUsed <- spaceUsed + valLen
}
}
-
+
fillSize <- 80 - (spaceUsed %% 80)
if(fillSize==80) fillSize <- 0
out( xport.fill(TRUE, fillSize ) )
-
+
scat("Done.")
}
scat("Closing file ...")
- if (is.character(file))
+ if (is.character(file))
if (file != "")
- {
+ {
close(file)
on.exit()
}
Deleted: trunk/SASxport/man/label.Rd
===================================================================
--- trunk/SASxport/man/label.Rd 2014-04-09 23:52:17 UTC (rev 1802)
+++ trunk/SASxport/man/label.Rd 2014-04-10 02:02:25 UTC (rev 1803)
@@ -1,107 +0,0 @@
-\name{label}
-
-\alias{label}
-\alias{label.default}
-\alias{label<-}
-\alias{label<-.default}
-
-\alias{SASformat}
-\alias{SASformat.default}
-\alias{SASformat<-}
-\alias{SASformat<-.default}
-
-\alias{SASiformat}
-\alias{SASiformat.default}
-\alias{SASiformat<-}
-\alias{SASiformat<-.default}
-
-\alias{SAStype}
-\alias{SAStype.default}
-\alias{SAStype<-}
-\alias{SAStype<-.default}
-
-\title{
-Set or Retreive the 'label', 'SASformat', 'SASiformat', or 'SAStype'
-attribute of a vector or (components of) a data frame
-}
-\description{
- Sets or retrieves the \code{"label"}, \code{"SASformat"},
- \code{"SASiformat"}, or \code{SAStype} attribute of an object.
-
- More comprehensive support for object labels, and SASformat, are
- available in Frank Harrell's \code{Hmisc} package.
-
- Note that \code{SAStype} enforces the SAS 8-character naming convention.
-}
-\usage{
-label(x, default)
-label(x) <- value
-
-SASformat(x, default)
-SASformat(x) <- value
-
-SASiformat(x, default)
-SASiformat(x) <- value
-
-SAStype(x, default)
-SAStype(x) <- value
-}
-\arguments{
-\item{x}{any object}
-\item{value}{new value for the \code{"label"}, \code{"SASformat"},
- \code{"SASiformat"}, or \code{SAStype} attribute of an object.}
-\item{default}{value to return when no appropriate attribute is
- found. The usual return value is NULL.}
-}
-\value{
- the contents of the \code{"label"}, \code{"SASformat"},
- \code{"SASiformat"}, \code{"SAStype"} attribute of x, if any;
- otherwise, the value provided by \code{default}.
-}
-\author{
- Gregory R. Warnes \email{gr...@wa...} based on code from the
- \code{Hmisc} library by Frank E. Harrell, Jr. ]
-}
-%\seealso{
-%}
-\examples{
-
-## Examples for vectors
-
-fail.time <- c(10,20)
-
-# set attributes
-label(fail.time) <- 'Failure Time'
-SASformat(fail.time) <- 'Numeric2'
-SASiformat(fail.time) <- 'Numeric2'
-
-# display individual attributes
-label(fail.time)
-SASformat(fail.time)
-SASiformat(fail.time)
-
-# display all attributes
-attributes(fail.time)
-
-## SAStype only applies to data frames
-df <- data.frame( fail.time, day=c("Mon","Tue") )
-label(df) <- "Data frame object"
-SAStype(df) <- "USER"
-
-label(df)
-SAStype(df)
-
-## Example showing specification of default return value
-a <- 70
-label(a, default="no label")
-
-\dontrun{
-# Hmisc packages functions label attributes for annotating tables and plots:
-library(Hmisc)
-label(fail.time)
-describe(fail.time)
-}
-}
-\keyword{utilities}
-\keyword{interface}
-
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
