write.spss.R

write.spss <-
  function(data, datafile, codefile, varlabels=NULL) {
    # EXAMPLE DATA (see: http://stackoverflow.com/q/10181730/1270695)
    #
    # If you do not want to alter your original file, as in the example above, 
    # and if you are connected to the internet while you are using this function, 
    # you can try this self-contained function:
    #
    # df <- data.frame(id = c(1:6), 
    #                  p.code = c(1, 5, 4, NA, 0, 5),  
    #                  p.label = c('Optometrists', 'Nurses', 
    #                              'Financial analysts', '<NA>', 
    #                              '0', 'Nurses'), 
    #                  foo = LETTERS[1:6])
    # Add some variable labels using label from the Hmisc package
    # require(Hmisc)
    # label(df) <- "Sweet sweet data"
    # label(df$id) <- "id !@#$%^" 
    # label(df$p.label) <- "Profession with human readable information"
    # label(df$p.code) <- "Profession code"
    # label(df$foo) <- "Variable label for variable x.var"
    #
    # USAGE
    # write.Hmisc.SPSS(df, datafile="df.sav", codefile="df.sps")
    #
    # Original "write.SPSS" function taken from:
    # https://stat.ethz.ch/pipermail/r-help/2006-January/085941.html
    
    a = do.call(list, data)
    tempout = vector("list", length(a))
    
    for (i in 1:length(a)) {
      tempout[[i]] = Hmisc:::label(a[[i]])
    }
    b = unlist(tempout)
    label.temp = structure(c(b), .Names = names(data))
    attributes(data)$variable.labels = label.temp
    
    # source("http://dl.dropbox.com/u/2556524/R%20Functions/writeSPSS.R")
    write.SPSS <- function (df, datafile, codefile, varlabels = NULL) {
      
      if (!is.null(varlabels) & length(df) != length(varlabels))
        stop("lengths of data and varlabels are different")
      
      ## we want ASCII quotes, not UTF-8 quotes here
      adQuote <- function(x) paste("\"", x, "\"", sep = "")
      
      dfn <- lapply(df, function(x) if (is.factor(x))
        as.numeric(x)
        else x)
      
      write.table(dfn, file = datafile, row.names = FALSE, col.names = FALSE,
                  sep = ",", quote = FALSE, na = "",eol = ",\n",
                  fileEncoding = "UTF-8")
      
      
      if(is.null(varlabels)) {
        if(is.null(attributes(df)$variable.labels)) varlabels <- names(df) 
        else varlabels <- attributes(df)$variable.labels      
      }
      
      
      if (is.null(names(df))) varnames <- varlabels
      else varnames <- names(df)
      
      varnames_original <- varnames
      
      varnames <- abbreviate(names(df), 15L)
      if (any(sapply(varnames, nchar) > 15L))
        stop("I cannot abbreviate the variable names to 15 or fewer letters")
      if (any(varnames != varnames_original))
        warning("some variable names were abbreviated")
      
      varnames <- gsub("[^[:alnum:]_\\$@#]", "\\.", varnames)
      
      dl.varnames <- names(df)
      if (any(chv <- sapply(df,is.character))) {
        lengths <- sapply(df[chv],function(v) max(nchar(v)))
        if(any(lengths > 255L))
          stop("Cannot handle character variables longer than 255")
        lengths <- paste0("(A", lengths, ")")
        # corrected by PR#15583
        star <- ifelse(c(TRUE, diff(which(chv) > 1L))," *", " ")
        dl.varnames[chv] <- paste(star, dl.varnames[chv], lengths)
      }
      
      
      cat("DATA LIST FILE=", adQuote(datafile), " free (\",\")\n",
          file = codefile)
      cat("/",  dl.varnames, " .\n\n", file = codefile, append = TRUE)
      cat("VARIABLE LABELS\n", file = codefile, append = TRUE)
      cat(paste(varnames, adQuote(varlabels),"\n"), ".\n",
          file = codefile, append = TRUE)
      
      
      factors <- sapply(df, is.factor)
      
      if (any(factors)) {
        cat("\nVALUE LABELS\n", file = codefile, append = TRUE)
        for (v in which(factors)) {
          cat("/\n", file = codefile, append = TRUE)
          cat(varnames[v], " \n", file = codefile, append = TRUE)
          levs <- levels(df[[v]])
          cat(paste(1:length(levs), adQuote(levs), "\n", sep = " "),
              file = codefile, append = TRUE)
        }
        cat(".\n", file = codefile, append = TRUE)
      }
      cat("\nEXECUTE.\n", file = codefile, append = TRUE) 
      
    }
    
    write.SPSS(data, datafile, codefile, varlabels)
  }