1spss.portable.file <- function(
2    file,
3    varlab.file=NULL,
4    codes.file=NULL,
5    missval.file=NULL,
6    count.cases=TRUE,
7    to.lower=getOption("spss.por.to.lower",FALSE),
8    iconv=TRUE,
9    encoded=getOption("spss.por.encoding","cp1252")
10    ){
11    file <- path.expand(file)
12    check.file(file,error=TRUE)
13    ptr <- porStream(file)
14
15    data.spec <- parseHeaderPorStream(ptr)
16    types <- data.spec$types
17    variables <- vector(length(types),mode="list")
18    variables[types==0] <- list(new("double.item"))
19    variables[types>0] <- list(new("character.item"))
20
21    varprintfmt <- lapply(data.spec$dictionary,"[[",i="printformat")
22    varprintfmt <- sapply(varprintfmt,"[",i=1)
23    vardatetime <- varprintfmt %in% c(20,22:24,26:30,38,39)
24    variables[vardatetime] <- list(new("datetime.item",
25                                       tzone="GMT",
26                                       origin="1582-10-14"))
27
28    names(variables) <- names(types)
29
30    varlabs <- lapply(data.spec$dictionary,"[[",i="label")
31    varlabs <- unlist(varlabs)
32    if(length(varlabs))
33        varlabs <- varlabs[nzchar(varlabs)]
34
35    vallabs <- data.spec$value.labels
36    vallabs.vars <- lapply(vallabs,"[[",i="vars")
37    vallab.tmp <- lapply(seq_along(vallabs),function(i){
38                        ans <- list()
39                        ans[vallabs.vars[[i]]] <- list(vallabs[[i]]$value.labels)
40                        ans
41                      })
42    vallabs <- unlist(vallab.tmp,recursive=FALSE)
43
44    missings <- lapply(data.spec$dictionary,"[[",i="missing")
45
46    if(length(varlab.file) && check.file(varlab.file,error=TRUE)){
47      message("using ",varlab.file)
48      varlabs <- spss.parse.variable.labels(varlab.file,
49                                            iconv=iconv,
50                                            encoded=encoded)
51      }
52    if(length(codes.file) && check.file(codes.file,error=TRUE)){
53      message("using ",codes.file)
54      vallabs <- spss.parse.value.labels(codes.file,
55                                         iconv=iconv,
56                                         encoded=encoded)
57      }
58    if(length(missval.file) && check.file(missval.file,error=TRUE)){
59      message("using ",missval.file)
60      missings <- spss.parse.missing.values(missval.file)
61      }
62
63    if(length(varlabs))
64      variables[names(varlabs)] <- mapply("description<-",variables[names(varlabs)],varlabs)
65    if(length(vallabs))
66      suppressWarnings(variables[names(vallabs)] <- mapply("labels<-",variables[names(vallabs)],vallabs))
67    if(length(missings))
68      variables[names(missings)] <- mapply("missing.values<-",variables[names(missings)],missings)
69
70    if(count.cases){
71        ncases <- .Call("countCasesPorStream",ptr,types)
72        seekPorStream(ptr,data.spec$start.data)
73    } else
74        ncases <- NA
75    attr(ptr,"ncases") <- ncases
76
77    if(to.lower){
78      names(variables) <- tolower(names(variables))
79    }
80
81    if(iconv)
82        variables <- lapply(variables,Iconv,from=encoded,to="")
83    else
84        encoded = ""
85
86    warn_if_duplicate_labels(variables)
87
88    document <- data.spec$document
89    data.spec$document <- NULL
90
91    new("spss.portable.importer",
92      variables,
93      ptr=ptr,
94      varlab.file=varlab.file,
95      codes.file=codes.file,
96      missval.file=missval.file,
97      document=document,
98      data.spec=data.spec,
99      encoded=encoded
100      )
101}
102setMethod("initialize","spss.portable.importer",function(.Object,
103                                                         variables,
104                                                         ptr,
105                                                         varlab.file=character(),
106                                                         codes.file=character(),
107                                                         missval.file=character(),
108                                                         document=character(),
109                                                         data.spec,
110                                                         encoded
111                                                         ){
112     .Object@.Data <- variables
113     .Object@ptr <- ptr
114     .Object@varlab.file <- as.character(varlab.file)
115     .Object@codes.file <- as.character(codes.file)
116     .Object@missval.file <- as.character(missval.file)
117     .Object@document <- as.character(document)
118     .Object@data.spec <- data.spec
119     .Object@encoded <- encoded
120     .Object
121})
122
123setMethod("getNobs","spss.portable.importer",function(x){
124  ncases <- attr(x@ptr,"ncases")
125  if(!length(ncases)) {
126    seekPorStream(x@ptr,x@data.spec$start.data)
127    attr(x@ptr,"ncases") <- ncases <- .Call("countCasesPorStream",x@ptr,x@data.spec$types)
128    seekPorStream(x@ptr,x@data.spec$start.data)
129  }
130  ncases
131})
132
133setMethod("seekData","spss.portable.importer",function(x)
134  seekPorStream(x@ptr,x@data.spec$start.data)
135)
136
137setMethod("readData","spss.portable.importer",
138  function(x,n)
139    iconv_list(.Call("readDataPorStream",
140           x@ptr,
141           what=x,
142           nlines=n,
143           types=x@data.spec$types),
144      encoded=x@encoded))
145
146setMethod("readSlice","spss.portable.importer",
147  function(x,rows,cols)
148    iconv_list(.Call("readSlicePorStream",x@ptr,
149           what=x,
150           j=cols,i=rows,
151           types=x@data.spec$types),
152      encoded=x@encoded))
153
154setMethod("readChunk","spss.portable.importer",
155  function(x,nrows,cols)
156    iconv_list(.Call("readChunkPorStream",x@ptr,
157           what=x,
158           vars=cols,n=nrows,
159           types=x@data.spec$types),
160      encoded=x@encoded))
161
162setMethod("show","spss.portable.importer",
163  function(object){
164    file.name <- attr(object@ptr,"file.name")
165    nobs <- nrow(object)
166    nvar <- ncol(object)
167    varlab.file <- object@varlab.file
168    codes.file <- object@codes.file
169    missval.file <- object@missval.file
170    cat("\nSPSS portable file",sQuote(file.name),"\n\twith ")
171    cat(nvar,"variables and ")
172    cat(nobs,"observations\n")
173    if(length(varlab.file)) cat("\twith variable labels from file",sQuote(varlab.file),"\n")
174    if(length(codes.file)) cat("\twith value labels from file",sQuote(codes.file),"\n")
175    if(length(missval.file)) cat("\twith missing value definitions from file",sQuote(missval.file),"\n")
176})
177
178subset.spss.portable.importer <- subset.importer
179