The R Project SVN
R-packages
(root)/trunk/foreign/R/spss.R – Rev 7551
Rev 7366 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
### This file is part of the 'foreign' package for R.###### Read SPSS system data files###### Copyright 2000-2002 Saikat DebRoy <saikat$stat.wisc.edu>### Douglas M. Bates <bates$stat.wisc.edu>,### Thomas Lumley### Copyright 2007-2017 R Core Development Team### Patched 2013-01-02 following PR#15073 by Peggy Overcashier### This file is part of the `foreign' package for R and related languages.### It is made available under the terms of the GNU General Public### License, version 2, or at your option, any later version,### incorporated herein by reference.###### This program is distributed in the hope that it will be### useful, but WITHOUT ANY WARRANTY; without even the implied### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR### PURPOSE. See the GNU General Public License for more### details.###### You should have received a copy of the GNU General Public### License along with this program; if not, a copy is available at### http://www.r-project.org/Licenses/read.spss <- function(file, use.value.labels = TRUE, to.data.frame = FALSE,max.value.labels = Inf, trim.factor.names = FALSE,trim_values = TRUE, reencode = NA,use.missings = to.data.frame, sub = ".",add.undeclared.levels = c("sort", "append", "no"),duplicated.value.labels = c("append", "condense"),duplicated.value.labels.infix = "_duplicated_", ...){add.undeclared.levels <- match.arg(add.undeclared.levels)duplicated.value.labels <- match.arg(duplicated.value.labels)trim <- function(strings, trim=TRUE)if (trim && is.character(strings)) sub(" +$", "", strings) else strings## mappings taken from win-iconvknownCP <- c("UCS-2LE" = 1200, "UCS-2BE" = 1201,"macroman" = 10000, " UCS-4LE" = 12000, "UCS-4BE" = 12001,"koi8-r" = 20866, "koi8-u" = 21866,"latin1" = 28591, "latin2" = 28592, "latin3" = 28593,## latin-9 seems most portable, but only on Windows## R >= 2.10.0. libiconv doesn't know latin9."latin4" = 28594, "latin-9" = 28605,"ISO-2022-JP" = 50221, "euc-jp" = 51932,"UTF-8" = 65001,"ASCII" = 20127,## pages known to glibc and libiconv"CP1250" = 1250,"CP1251" = 1251,"CP1252" = 1252,"CP1253" = 1253,"CP1254" = 1254,"CP1255" = 1255,"CP1256" = 1256,"CP1257" = 1257,"CP1258" = 1258,"CP874" = 874,"CP936" = 936)if(length(grep("^(http|ftp|https)://", file))) {tmp <- tempfile()download.file(file, tmp, quiet = TRUE, mode = "wb")file <- tmpon.exit(unlink(file))}rval <- .Call(do_read_SPSS, file)codepage <- attr(rval, "codepage")if(is.null(codepage)) codepage <- 2 # .por filesif(!capabilities("iconv")) reencode <- FALSEif(!identical(reencode, FALSE)) {cp <- "unknown"if(is.character(reencode)) {cp <- reencodereencode <- TRUE} else if(codepage == 20127) {reencode <- FALSE # ASCII} else if(m <- match(codepage, knownCP, 0L)) {cp <- names(knownCP)[m]} else if (codepage < 200) {## small numbers are not codepages, and real codepages are largeattr(rval, "codepage") <- NULLreencode <- FALSE} else cp <- paste("CP", codepage, sep="")if(is.na(reencode)){l10ni <- l10n_info()## Do not reencode from UTF-8 in a UTF-8 locale and## not from latin1 in a latin1 localereencode <- (l10ni[["UTF-8"]] && (codepage != 65001)) ||(l10ni[["Latin-1"]] && (codepage != 28591))}if(reencode) {message(gettextf("re-encoding from %s", cp), domain = NA)names(rval) <- iconv(names(rval), cp, "", sub=sub)vl <- attr(rval, "variable.labels")nm <- names(vl)vl <- iconv(vl, cp, "", sub=sub)names(vl) <- iconv(nm, cp, "", sub=sub)attr(rval, "variable.labels") <- vlfor(i in seq_along(rval)) {xi <- rval[[i]]if(is.character(xi)) rval[[i]] <- iconv(xi, cp, "", sub=sub)}}}miss <- attr(rval, "missings")vl <- attr(rval,"label.table")if(!is.null(miss)) {if(reencode) {nm <- names(miss)names(miss) <- iconv(nm, cp, "", sub=sub)for(i in seq_along(miss))if(is.character(miss[[i]]$value))miss[[i]]$value <- iconv(miss[[i]]$value, cp, "", sub=sub)attr(rval, "missings") <- miss}if(use.missings)for(v in names(rval)) {tp <- miss[[v]]$typexi <- rval[[v]]z <- miss[[v]]$value## Convert data (xi) to NA for values that either match a## specified discrete missing value code or fall within## the specified missing value range, if applicable.#### Added Oct. 2012: Retain value labels (vl[[v]]) only for## codes that haven't been converted to NA in the data.if(tp %in% "none") nextif(tp %in% c("one", "two", "three")) {other <- miss[[v]]$value## FIXME: do we need to worry about padding for string vals?xi[ xi %in% other ] <- NAvl[[v]] <- vl[[v]][ !(vl[[v]] %in% other) ]} else if(tp == "low" || tp == "low+1") {xi[ xi <= z[1L] ] <- NAvl[[v]] <- vl[[v]][ as.numeric(vl[[v]]) > z[1L] ]if(tp == "low+1"){xi[ xi == z[2L] ] <- NAvl[[v]] <- vl[[v]][ as.numeric(vl[[v]]) != z[2L] ]}} else if(tp == "high" || tp == "high+1") {xi[ xi >= z[1L] ] <- NAvl[[v]] <- vl[[v]][ as.numeric(vl[[v]]) < z[1L] ]if(tp == "high+1"){xi[ xi == z[2L] ] <- NAvl[[v]] <- vl[[v]][ as.numeric(vl[[v]]) != z[2L] ]}} else if(tp == "range" || tp == "range+1") {xi[ xi >= z[1L] & xi <= z[2L] ] <- NAvl[[v]] <- vl[[v]][ as.numeric(vl[[v]]) < z[1L] | as.numeric(vl[[v]]) > z[2L] ]if(tp == "range+1"){xi[ xi == z[3L] ] <- NAvl[[v]] <- vl[[v]][ as.numeric(vl[[v]]) != z[3L] ]}} elsewarning(gettextf("missingness type %s is not handled", tp),domain = NA)rval[[v]] <- xi}} else use.missings <- FALSEif(reencode) names(vl) <- iconv(names(vl), cp, "", sub=sub)has.vl <- which(!vapply(vl, is.null, NA))for(v in has.vl) {nm <- names(vl)[[v]]vlv <- vl[[v]]nlabels <- length(vlv)if(reencode && nlabels) {nm2 <- names(vlv)vl[[v]] <- vlv <- iconv(vlv, cp, "", sub=sub)names(vl[[v]]) <- names(vlv) <- iconv(nm2, cp, "", sub=sub)}newlevels <- rev(trim(vlv, trim_values))newrval <- trim(rval[[nm]], trim_values)uniquevalues <- na.omit(unique(newrval))nvalues <- length(uniquevalues)## We may have nlabels == nvalues but they do not always match,## e.g. in case 2 labels are duplicated, hence be careful:if (use.value.labels && (add.undeclared.levels != "no" || all(uniquevalues %in% c(newlevels, ""))) &&(!is.finite(max.value.labels) || nvalues <= max.value.labels)) {newlabels <- rev(trim(names(vlv), trim.factor.names))if(add.undeclared.levels != "no" && !all(uniquevalues %in% c(newlevels, ""))){addlabels <- addlevels <- sort(uniquevalues[!(uniquevalues %in% c(newlevels, ""))])newlevels <- c(newlevels, addlevels)newlabels <- c(newlabels, addlabels)if(add.undeclared.levels == "sort"){o <- order(newlevels)newlevels <- newlevels[o]newlabels <- newlabels[o]}warning("Undeclared level(s) ", paste(addlevels, collapse = ", "), " added in variable: ", nm)}dupnewlabels <- duplicated(newlabels)## duplicated factor labels are no longer possible for R >= 3.4.0,## hence adding two ways around## - append: appends infix plus original level (that is unique)## - condense: removes additional levels with identical labels and## condenses to the first of all duplicated levelsif(any(dupnewlabels)) {warning("Duplicated levels in factor ", nm, ": ",paste(newlabels[dupnewlabels], collapse=", "))if(duplicated.value.labels == "append"){newlabels[dupnewlabels] <-paste(newlabels[dupnewlabels], newlevels[dupnewlabels],sep = duplicated.value.labels.infix)}if(duplicated.value.labels == "condense"){for(d in unique(newlabels[dupnewlabels])){dups <- newlabels %in% dnewrval[newrval %in% newlevels[dups]] <- newlevels[dups][1]}newlabels <- newlabels[!dupnewlabels]newlevels <- newlevels[!dupnewlabels]}}rval[[nm]] <- factor(newrval,levels = newlevels,labels = newlabels)} elseattr(rval[[nm]], "value.labels") <- vl[[v]]}if(reencode) attr(rval, "label.table") <- vlif (to.data.frame) {varlab <- attr(rval, "variable.labels")rval <- as.data.frame(rval, ...)attr(rval, "variable.labels") <- varlabif(codepage > 500) attr(rval, "codepage") <- codepage}rval}