[R-gregmisc-users] SF.net SVN: r-gregmisc:[1658] trunk/SASxport
Brought to you by:
warnes
Menu
▾
▴
[R-gregmisc-users] SF.net SVN: r-gregmisc:[1658] trunk/SASxport
|
From: <wa...@us...> - 2013-05-11 23:41:38
|
Revision: 1658
http://sourceforge.net/p/r-gregmisc/code/1658
Author: warnes
Date: 2013-05-11 23:41:36 +0000 (Sat, 11 May 2013)
Log Message:
-----------
Add support for dataset labels and types
Modified Paths:
--------------
trunk/SASxport/NAMESPACE
trunk/SASxport/R/write.xport.R
trunk/SASxport/R/xport.member.header.R
trunk/SASxport/man/label.Rd
trunk/SASxport/src/SASxport.c
trunk/SASxport/src/SASxport.h
trunk/SASxport/src/init.c
trunk/SASxport/src/writeSAS.c
trunk/SASxport/src/writeSAS.h
Added Paths:
-----------
trunk/SASxport/R/SAStype.R
Modified: trunk/SASxport/NAMESPACE
===================================================================
--- trunk/SASxport/NAMESPACE 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/NAMESPACE 2013-05-11 23:41:36 UTC (rev 1658)
@@ -17,9 +17,12 @@
"SASformat<-",
"SASiformat",
- "SASiformat<-"
- )
+ "SASiformat<-",
+ "SAStype",
+ "SAStype<-"
+)
+
S3method(toSAS, numeric)
S3method(toSAS, logical)
S3method(toSAS, character)
@@ -32,10 +35,12 @@
S3method(label, default)
S3method(SASformat, default)
S3method(SASiformat, default)
+S3method(SAStype, data.frame)
S3method("label<-", default)
S3method("SASformat<-", default)
S3method("SASiformat<-", default)
+S3method("SAStype<-", data.frame)
S3method(print, lookup.xport)
S3method(summary, lookup.xport)
Added: trunk/SASxport/R/SAStype.R
===================================================================
--- trunk/SASxport/R/SAStype.R (rev 0)
+++ trunk/SASxport/R/SAStype.R 2013-05-11 23:41:36 UTC (rev 1658)
@@ -0,0 +1,20 @@
+SAStype <- function(x, default)
+ UseMethod("SAStype")
+
+SAStype.data.frame <- function(x, default=NULL)
+{
+ lab <- attr(x,"SAStype")
+ if(is.null(lab))
+ default
+ else
+ lab
+}
+
+"SAStype<-" <- function(x, value)
+ UseMethod("SAStype<-")
+
+"SAStype<-.data.frame" <- function(x, value)
+{
+ attr(x,'SAStype') <- value
+ x
+}
Modified: trunk/SASxport/R/write.xport.R
===================================================================
--- trunk/SASxport/R/write.xport.R 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/R/write.xport.R 2013-05-11 23:41:36 UTC (rev 1658)
@@ -155,8 +155,12 @@
offsetTable <- data.frame("name"=varNames, "len"=NA, "offset"=NA )
rownames(offsetTable) <- offsetTable[,"name"]
+ dfLabel <- label(df, default="" )
+ dfType <- SAStype(df, default="")
+
scat("Write data frame header ...")
- out( xport.member.header(dfName=i, cDate=cDate, sasVer=sasVer, osType=osType ) )
+ out( xport.member.header(dfName=i, cDate=cDate, sasVer=sasVer, osType=osType,
+ dfLabel=dfLabel, dfType=dfType) )
scat("Done.")
scat("Write variable information block header ...")
Modified: trunk/SASxport/R/xport.member.header.R
===================================================================
--- trunk/SASxport/R/xport.member.header.R 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/R/xport.member.header.R 2013-05-11 23:41:36 UTC (rev 1658)
@@ -1,12 +1,15 @@
`xport.member.header` <-
-function( dfName, cDate=Sys.time(), mDate=cDate, sasVer="7.00", osType="Unknown" )
+function(dfName, cDate=Sys.time(), mDate=cDate, sasVer="7.00", osType="Unknown",
+ dfLabel="", dfType="" )
{
.C("fill_member_header",
dfName = toupper(as.character(dfName)), # Name of data set
sasVer = toupper(as.character(sasVer)), # SAS version number
osType = as.character(osType), # Operating System (can include lowercase)
- cDate = xport.dateFMT(cDate), # Creation date
- mDate = xport.dateFMT(mDate), # modification date
+ cDate = xport.dateFMT(cDate), # Creation date
+ mDate = xport.dateFMT(mDate), # modification date
+ dfLabel= as.character(dfLabel), # Data set label
+ dfType = as.character(dfType), # Data set type
PACKAGE="SASxport"
)
Modified: trunk/SASxport/man/label.Rd
===================================================================
--- trunk/SASxport/man/label.Rd 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/man/label.Rd 2013-05-11 23:41:36 UTC (rev 1658)
@@ -15,13 +15,18 @@
\alias{SASiformat<-}
\alias{SASiformat<-.default}
+\alias{SAStype}
+\alias{SAStype.default}
+\alias{SAStype<-}
+\alias{SAStype<-.default}
\title{
-Set or Retreive the 'label', 'SASformat', or 'SASiformat' Attribute of a Vector
+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"}, or
- \code{"SASiformat"} attribute of an object.
+ 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.
@@ -36,18 +41,20 @@
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"}, or
- \code{"SASiformat"} attribute of an 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"}, or
- \code{"SASiformat"} attribute of x, if any; otherwise, the value provided
- by \code{default}.
+ 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
@@ -57,6 +64,8 @@
%}
\examples{
+## Examples for vectors
+
fail.time <- c(10,20)
# set attributes
@@ -72,20 +81,24 @@
# display all attributes
attributes(fail.time)
-# Example showing specification of default return value
+## 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{
-# for a nice display
+# Hmisc packages functions label attributes for annotating tables and plots:
library(Hmisc)
+label(fail.time)
describe(fail.time)
-
-f <- cph(Surv(fail.time, event) ~ xx)
-plot(xx,xx2,xlab=label(xx),"s",sep=""))
}
-
}
\keyword{utilities}
\keyword{interface}
Modified: trunk/SASxport/src/SASxport.c
===================================================================
--- trunk/SASxport/src/SASxport.c 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/src/SASxport.c 2013-05-11 23:41:36 UTC (rev 1658)
@@ -194,9 +194,12 @@
n = GET_RECORD(record, fp, 80);
if(n != 80)
return 0;
+ record[80] = '\0';
memcpy(member->sas_mod, record, 16);
- if((strrchr(record+16, ' ') - record) != 79)
- return 0;
+
+ memcpy(member->sas_dslabel, record+32, 40);
+ memcpy(member->sas_dstype, record+72, 8);
+
return 1;
}
@@ -230,7 +233,7 @@
}
static int
-init_mem_info(FILE *fp, char *name)
+init_mem_info(FILE *fp, char *name, char *dslabel, char *dstype)
{
int length, n;
char record[81];
@@ -253,6 +256,7 @@
record[58] = '\0';
sscanf(record+54, "%d", &length);
+ /* Extract data set name */
tmp = strchr(mem_head->sas_dsname, ' ');
n = tmp - mem_head->sas_dsname;
if(n > 0) {
@@ -262,6 +266,26 @@
name[n] = '\0';
} else name[0] = '\0';
+ /* Extract data set label */
+ tmp = strchr(mem_head->sas_dslabel, ' ');
+ n = tmp - mem_head->sas_dslabel;
+ if(n > 0) {
+ if (n > 40)
+ n = 40;
+ strncpy(dslabel, mem_head->sas_dslabel, n);
+ dslabel[n] = '\0';
+ } else dslabel[0] = '\0';
+
+ /* Extract data set type */
+ tmp = strchr(mem_head->sas_dstype, ' ');
+ n = tmp - mem_head->sas_dstype;
+ if(n > 0) {
+ if (n > 40)
+ n = 40;
+ strncpy(dstype, mem_head->sas_dstype, n);
+ dstype[n] = '\0';
+ } else dstype[0] = '\0';
+
Free(mem_head);
return length;
@@ -542,8 +566,11 @@
FILE *fp;
int i, namestrLength, memLength, ansLength;
char dsname[9];
+ char dslabel[41];
+ char dstype[9];
SEXP ans, ansNames, varInfoNames, varInfo;
SEXP char_numeric, char_character;
+ SEXP dfLabel, dfType;
PROTECT(varInfoNames = allocVector(STRSXP, VAR_INFO_LENGTH));
for(i = 0; i < VAR_INFO_LENGTH; i++)
@@ -561,13 +588,18 @@
ansLength = 0;
PROTECT(ans = allocVector(VECSXP, 0));
- PROTECT(ansNames = allocVector(STRSXP, 0));
+ PROTECT(ansNames = allocVector(STRSXP, 0));
- while(namestrLength > 0 && (memLength = init_mem_info(fp, dsname)) > 0) {
+ while(namestrLength > 0 && (memLength = init_mem_info(fp, dsname, dslabel, dstype)) > 0) {
PROTECT(varInfo = allocVector(VECSXP, VAR_INFO_LENGTH));
setAttrib(varInfo, R_NamesSymbol, varInfoNames);
+ PROTECT(dfLabel = mkChar(dslabel));
+ PROTECT(dfType = mkChar(dstype) );
+ setAttrib(varInfo, install("label" ), dfLabel);
+ setAttrib(varInfo, install("SAStype"), dfType );
+
SET_XPORT_VAR_TYPE(varInfo, allocVector(STRSXP, memLength));
SET_XPORT_VAR_WIDTH(varInfo, allocVector(INTSXP, memLength));
SET_XPORT_VAR_INDEX(varInfo, allocVector(INTSXP, memLength));
@@ -611,7 +643,8 @@
char_character);
}
PROTECT(ans = lengthgets(ans, ansLength+1));
- PROTECT(ansNames = lengthgets(ansNames, ansLength+1));
+ PROTECT(ansNames = lengthgets(ansNames, ansLength+1));
+
/* PROTECT(newAns = allocVector(VECSXP, ansLength+1)); */
/* PROTECT(newAnsNames = allocVector(STRSXP, ansLength+1)); */
@@ -622,15 +655,16 @@
/* ans = newAns; */
/* ansNames = newAnsNames; */
- SET_STRING_ELT(ansNames, ansLength, mkChar(dsname));
+ SET_STRING_ELT(ansNames , ansLength, mkChar(dsname ));
SET_VECTOR_ELT(ans, ansLength, varInfo);
ansLength++;
- UNPROTECT(5);
+ UNPROTECT(7);
PROTECT(ans);
PROTECT(ansNames);
}
+
setAttrib(ans, R_NamesSymbol, ansNames);
UNPROTECT(5);
fclose(fp);
Modified: trunk/SASxport/src/SASxport.h
===================================================================
--- trunk/SASxport/src/SASxport.h 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/src/SASxport.h 2013-05-11 23:41:36 UTC (rev 1658)
@@ -50,6 +50,9 @@
char sas_osname[8];
char sas_create[16];
char sas_mod[16];
+ char sas_dslabel[40];
+ char sas_dstype[8];
+
};
struct SAS_XPORT_namestr {
Modified: trunk/SASxport/src/init.c
===================================================================
--- trunk/SASxport/src/init.c 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/src/init.c 2013-05-11 23:41:36 UTC (rev 1658)
@@ -31,7 +31,8 @@
#define ARGTYPE static R_NativePrimitiveArgType
ARGTYPE fill_file_header_args[] = { STRSXP, STRSXP, STRSXP, STRSXP };
-ARGTYPE fill_member_header_args[] = { STRSXP, STRSXP, STRSXP, STRSXP, STRSXP };
+ARGTYPE fill_member_header_args[] = { STRSXP, STRSXP, STRSXP, STRSXP, STRSXP, STRSXP,
+ STRSXP };
ARGTYPE fill_namestr_args[] = { INTSXP, INTSXP, INTSXP, STRSXP, STRSXP,
STRSXP, INTSXP, INTSXP, INTSXP, STRSXP,
INTSXP, INTSXP, INTSXP };
@@ -43,7 +44,7 @@
#define CDEF(name, narg, argVec) { #name, (DL_FUNC) &name, narg, argVec }
static const R_CMethodDef CEntries[] = {
CDEF(fill_file_header, 4, fill_file_header_args ),
- CDEF(fill_member_header, 5, fill_member_header_args ),
+ CDEF(fill_member_header, 7, fill_member_header_args ),
CDEF(fill_namestr, 13, fill_namestr_args ),
CDEF(fill_namestr_header, 1, fill_namestr_header_args ),
CDEF(fill_obs_header, 0, 0 ),
Modified: trunk/SASxport/src/writeSAS.c
===================================================================
--- trunk/SASxport/src/writeSAS.c 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/src/writeSAS.c 2013-05-11 23:41:36 UTC (rev 1658)
@@ -149,11 +149,13 @@
void fill_member_header(
- char **dfName, /* Name of data set */
- char **sasVer, /* SAS version number*/
- char **osType, /* Operating System */
- char **cDate, /* Creation date */
- char **mDate /* Modification date */
+ char **dfName, /* Name of data set */
+ char **sasVer, /* SAS version number */
+ char **osType, /* Operating System */
+ char **cDate, /* Creation date */
+ char **mDate, /* Modification date */
+ char **dfLabel, /* Label of data set */
+ char **dfType /* Type of data set */
)
{
struct MEMBER_HEADER member_header;
@@ -175,8 +177,11 @@
/* Line 4 */
blankCopy( member_header.sas_modified,16, mDate[0] );
- blankFill( member_header.blanks2, 64);
+ blankFill( member_header.padding, 16);
+ blankCopy( member_header.dslabel, 40, dfLabel[0] );
+ blankCopy( member_header.dstype, 8, dfType[0] );
+
/* Copy over for return */
memcpy( raw_buffer, &member_header, sizeof(member_header) );
Modified: trunk/SASxport/src/writeSAS.h
===================================================================
--- trunk/SASxport/src/writeSAS.h 2013-05-11 23:32:35 UTC (rev 1657)
+++ trunk/SASxport/src/writeSAS.h 2013-05-11 23:41:36 UTC (rev 1658)
@@ -103,7 +103,10 @@
/* Line 4 */
char sas_modified[16];
- char blanks2[64];
+ //char blanks2[64];
+ char padding[16];
+ char dslabel[40];
+ char dstype[8];
};
@@ -155,7 +158,7 @@
void fill_file_header(char **cDate, char **mDate, char **sasVer, char **osType);
void fill_member_header(char **dfName, char **sasVer, char **osType, char **cDate,
- char **mDate);
+ char **mDate, char **dfLabel, char **dfType);
void fill_namestr(int *isChar, int *nlng, int *nvar0, char **nname, char **nlabel,
char **nform, int *nfl, int *nfd, int *nfj, char **niform,
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
