R/writeSpss.R

In sachseka/eatPrep: Prepare Data for IRT Analyses

################## TO DO ########
# Definition von Missings fuer SPSS

#-----------------------------------------------------------------------------------------
autoQuote <- function (x){
paste("\"", x, "\"", sep = "")}

writeSpss <- function (dat, values, subunits, units, filedat = "mydata.txt", filesps = "readmydata.sps",
  missing.rule = list ( mvi = 0 , mnr = 0 , mci = NA , mbd = NA , mir = 0 , mbi = 0 ),
  path = getwd(), sep = "\t", dec = ",", verbose = FALSE) {

  lapply(list(dat, values, subunits, units), checkmate::assert_data_frame)
  lapply(c(filedat, filesps, sep, dec), checkmate::assert_character, len = 1)
  checkmate::assert_list(missing.rule, names = "unique")
  checkmate::assert_character(path, len = 1, null.ok = TRUE)
  checkmate::assert_logical(verbose, len = 1)

  funVersion <- "writeSpss: "

  varinfo <- makeInputCheckData (values, subunits, units)

  # reduce varinfo
  varinfo <- varinfo [ match(colnames(dat), names(varinfo)) ]

  if (!inherits(dat, "data.frame")) {
    stop (paste(funVersion, "dat must be a data.frame.", sep = ""))
  }

  if (!is.null(path)) {
    filedat <- file.path(path, filedat)
    filesps <- file.path(path, filesps)
  }

  # treat missings
  dat <- collapseMissings(dat, missing.rule, items=colnames(dat))

  zkdWriteForeignSPSS(dat, varinfo, datafile = filedat, codefile = filesps,
           missing.rule = list ( mvi = 0 , mnr = 0 , mci = NA , mbd = NA , mir = 0 , mbi = 0 ),
           varnames = colnames(dat), sep = sep, dec = dec, verbose = verbose)
  if (verbose) {
    cat(paste(funVersion, "Data values written to ", filedat, "\n", sep = ""))
    cat(paste(funVersion, "Syntax file written to ", filesps, "\n", sep = ""))
  }
}

#-----------------------------------------------------------------------------------------

zkdWriteForeignSPSS <- function(dat, varinfo, datafile, codefile,
  missing.rule = list ( mvi = 0 , mnr = 0 , mci = NA , mbd = NA , mir = 0 , mbi = 0 ),
  varnames = NULL, dec = ",", sep = "\t", verbose = FALSE) {

  funVersion <- "writeSpss: "

  # make vars numeric (if possible)
  dat <- data.frame(asNumericIfPossible(dat, force.string = FALSE))
  eol <- paste(sep, "\n", sep = "")

  # write dataset
  write.table(dat, file = datafile, row.names = FALSE,
      col.names = FALSE, sep = sep, dec = dec, quote = FALSE,
      na = "", eol = eol)

  # get varlabels from varinfo
  varlabels <- lapply(varinfo, "[[", "label" )
  varlabels <- varlabels [ match(varnames, names(varlabels)) ]
  if ( any( sapply(varlabels, is.null)) ) {
		ind <- which ( sapply(varlabels, is.null ) )
		if (verbose) cat (paste(funVersion, "Found no variable labels for variable(s) ", paste( varnames[ind], collapse = ", "), ".\n", sep = ""))
		varlabels [ ind ] <- ""
		names (varlabels)  [ ind ]  <- varnames [ ind ]
	}

  varlabels <- gsub("\n", " ", varlabels)

  # make SPSS variable format statements
  varnames <- gsub("[^[:alnum:]_\\$@#]", "\\.", varnames)
  dl.varnames <- varnames

  chv <- sapply(dat, is.character)

  # hier eventuell statt 'is.numeric' 'is.real' ?
  num <- which(sapply(dat, is.numeric))
  lengths <- sapply(dat , function(ll) { if(is.numeric(ll)) {
                                      max(nchar(round(na.omit(abs(ll)), digits=0)))
                                    } else {
                                      max(nchar(ll))
                                    }
                                  })

  # checken, ob Dezimalstellen vorhanden - wenn ja, dann Format auf Fx.2 -> 2 Dezimalstellen werden angezeigt
  decimals <- sapply(dat , function(ll) { if(is.numeric(ll)) {
                                       max(nchar(na.omit(abs(ll))))
                                    } else {
                                      max(nchar(ll))
                                    }
                                  })
  varsWithDecimals <-  names(which(lengths != decimals))


  if (any(lengths > 255L))
    stop("Cannot handle character variables longer than 255\n")

  if (any(chv)) {
    lengths <- paste("(", ifelse(chv, "A", "F"), lengths, ")", sep = "")
  }  else {
    lengths <- paste ( "(F", lengths, ")", sep = "")
  }

  if (! is.null(varsWithDecimals)){
    lengths[which(dl.varnames %in% varsWithDecimals)] <- gsub(")", ".2)", lengths[which(dl.varnames %in% varsWithDecimals)], fixed = TRUE)
  }
  dl.varnames <- paste(dl.varnames, lengths)

  # write codefile
  if (sep == "\t")
      freefield <- " free (TAB)\n"
  if (sep != "\t")
      freefield <- cat(" free (\"", sep, "\")\n", sep = "")
  cat("DATA LIST FILE=", autoQuote(datafile), freefield,
      file = codefile)
  cat(" /", dl.varnames, ".\n\n", file = codefile, append = TRUE,
      fill = 60, labels = " ")
  cat("VARIABLE LABELS\n", file = codefile, append = TRUE)
  cat(" ", paste(varnames, autoQuote(varlabels), "\n"), ".\n",
      file = codefile, append = TRUE)

  # get value labels from varinfo
  valuesToWrite <- lapply(lapply(varinfo, "[[", "values"), names)
  valuesToWrite <- lapply ( valuesToWrite, function (ll) { setdiff(ll, names(missing.rule))})
  valuesToWrite <- valuesToWrite [ match(varnames, names(valuesToWrite)) ]

  if (any(sapply(valuesToWrite, length) > 0) ) {

    variablesToLabel <- which(sapply(valuesToWrite, length) > 0)
    variablesToLabel <- names(valuesToWrite)[variablesToLabel]

    cat("\nVALUE LABELS\n", file = codefile, append = TRUE)

    for (v in variablesToLabel) {
      cat(" /", v, "\n", file = codefile, append = TRUE)
      valueLabels <- sapply ( varinfo[[v]]$values, "[[", "label")
      valueLabels <- valueLabels[ which(! names(valueLabels) %in% names(missing.rule)) ]
      valueLabels <- gsub("\n", " ", valueLabels)
      if (any(nchar(valueLabels) > 120L)) {
        cat(paste(funVersion, "Value labels for variable", v , "longer than 120 characters. Only the first 120 characters will be used.\n"))
        valueLabels <- substring(valueLabels, 1, 120)
        }
      cat(paste("  ", names(valueLabels),
      autoQuote(valueLabels),"\n",  sep = " "), file = codefile,
      append = TRUE)
    }
    cat(" .\n", file = codefile, append = TRUE)
  }
  cat("\nEXECUTE.\n", file = codefile, append = TRUE)

}