[R-gregmisc-users] SF.net SVN: r-gregmisc:[1659] trunk/SASxport
Brought to you by:
warnes
Menu
▾
▴
[R-gregmisc-users] SF.net SVN: r-gregmisc:[1659] trunk/SASxport
|
From: <wa...@us...> - 2013-05-12 00:55:27
|
Revision: 1659
http://sourceforge.net/p/r-gregmisc/code/1659
Author: warnes
Date: 2013-05-12 00:55:24 +0000 (Sun, 12 May 2013)
Log Message:
-----------
Complete work to handle dataframe label and type
Modified Paths:
--------------
trunk/SASxport/NAMESPACE
trunk/SASxport/R/SAStype.R
trunk/SASxport/R/read.xport.R
trunk/SASxport/src/SASxport.c
trunk/SASxport/tests/dfAttributes.R
Modified: trunk/SASxport/NAMESPACE
===================================================================
--- trunk/SASxport/NAMESPACE 2013-05-11 23:41:36 UTC (rev 1658)
+++ trunk/SASxport/NAMESPACE 2013-05-12 00:55:24 UTC (rev 1659)
@@ -35,12 +35,12 @@
S3method(label, default)
S3method(SASformat, default)
S3method(SASiformat, default)
-S3method(SAStype, data.frame)
+S3method(SAStype, default)
S3method("label<-", default)
S3method("SASformat<-", default)
S3method("SASiformat<-", default)
-S3method("SAStype<-", data.frame)
+S3method("SAStype<-", default)
S3method(print, lookup.xport)
S3method(summary, lookup.xport)
Modified: trunk/SASxport/R/SAStype.R
===================================================================
--- trunk/SASxport/R/SAStype.R 2013-05-11 23:41:36 UTC (rev 1658)
+++ trunk/SASxport/R/SAStype.R 2013-05-12 00:55:24 UTC (rev 1659)
@@ -1,7 +1,7 @@
SAStype <- function(x, default)
UseMethod("SAStype")
-SAStype.data.frame <- function(x, default=NULL)
+SAStype.default <- function(x, default=NULL)
{
lab <- attr(x,"SAStype")
if(is.null(lab))
@@ -13,7 +13,7 @@
"SAStype<-" <- function(x, value)
UseMethod("SAStype<-")
-"SAStype<-.data.frame" <- function(x, value)
+"SAStype<-.default" <- function(x, value)
{
attr(x,'SAStype') <- value
x
Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R 2013-05-11 23:41:36 UTC (rev 1658)
+++ trunk/SASxport/R/read.xport.R 2013-05-12 00:55:24 UTC (rev 1659)
@@ -48,6 +48,9 @@
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
@@ -123,6 +126,9 @@
next
}
+ label(w) <- dsLabels[k]
+ SAStype(w) <- dsTypes[k]
+
nam <- names.tolower(makeNames(names(w), allow=name.chars))
names(w) <- nam
dinfo <- dsinfo[[k]]
Modified: trunk/SASxport/src/SASxport.c
===================================================================
--- trunk/SASxport/src/SASxport.c 2013-05-11 23:41:36 UTC (rev 1658)
+++ trunk/SASxport/src/SASxport.c 2013-05-12 00:55:24 UTC (rev 1659)
@@ -22,6 +22,7 @@
*/
#include <stdio.h>
+#include <ctype.h>
#include <string.h>
#include <R.h>
#include <Rinternals.h>
@@ -266,25 +267,21 @@
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 label, and trim trailing blanks */
+ strncpy(dslabel, mem_head->sas_dslabel, 40);
+ for(int i=40-1; i>0; i--)
+ if( isspace(dslabel[i]) )
+ dslabel[i] = '\0';
+ else
+ break;
/* 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';
+ strncpy(dstype, mem_head->sas_dstype, 8);
+ for(int i=8-1; i>0; i--)
+ if( isspace(dstype[i]) )
+ dstype[i] = '\0';
+ else
+ break;
Free(mem_head);
@@ -595,9 +592,14 @@
PROTECT(varInfo = allocVector(VECSXP, VAR_INFO_LENGTH));
setAttrib(varInfo, R_NamesSymbol, varInfoNames);
- PROTECT(dfLabel = mkChar(dslabel));
- PROTECT(dfType = mkChar(dstype) );
+ dslabel[40] = '\n';
+ PROTECT(dfLabel = allocVector(STRSXP, 1));
+ SET_STRING_ELT(dfLabel, 0, mkChar(dslabel));
setAttrib(varInfo, install("label" ), dfLabel);
+
+ dstype[8] = '\n';
+ PROTECT(dfType = allocVector(STRSXP, 1));
+ SET_STRING_ELT(dfType, 0, mkChar(dstype));
setAttrib(varInfo, install("SAStype"), dfType );
SET_XPORT_VAR_TYPE(varInfo, allocVector(STRSXP, memLength));
Modified: trunk/SASxport/tests/dfAttributes.R
===================================================================
--- trunk/SASxport/tests/dfAttributes.R 2013-05-11 23:41:36 UTC (rev 1658)
+++ trunk/SASxport/tests/dfAttributes.R 2013-05-12 00:55:24 UTC (rev 1659)
@@ -4,7 +4,7 @@
abc.out <- data.frame( x=c(1, 2, NA, NA ), y=c('a', 'B', NA, '*' ) )
## add a data set label (not used by R)
-label(abc.out) <- "data set"
+label(abc.out) <- "xxxx data set xxxxx"
SAStype(abc.out) <- "normal"
## add a format specifier (not used by R)
@@ -15,7 +15,7 @@
# create a SAS XPORT file from our local data frame
write.xport(abc.out,
- file="xxx2.xpt",
+ file="dfAttributes.xpt",
cDate=strptime("28JUL07:21:08:06 ", format="%d%b%y:%H:%M:%S"),
osType="SunOS",
sasVer="9.1",
@@ -23,16 +23,16 @@
)
# read the SAS data back in
-abc.in <- read.xport("xxx2.xpt", names.tolower=FALSE)
+abc.in <- read.xport("dfAttributes.xpt", names.tolower=FALSE)
## Test that the files are otherwise identical
-label(abc.out, "missing!")
-label(abc.in , "missing!")
+label(abc.out, "MISSING!")
+label(abc.in , "MISSING!")
-SAStype(abc.out, "missing!")
-SAStype(abc.in , "missing!")
+SAStype(abc.out, "MISSING!")
+SAStype(abc.in , "MISSING!")
-stopifnot( label(abc.out)==label(abc.in, "missing!") )
-stopifnot( SAStype(abc.out)==SAStype(abc.in, "missing!") )
+stopifnot( label (abc.out, "MISSING!")==label (abc.in, "MISSING!") )
+stopifnot( SAStype(abc.out, "MISSING!")==SAStype(abc.in, "MISSING!") )
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
