[Rd] (PR#13423) bug report: writeForeignSAS in package "foreign"

[Prof Brian Ripley]

And did you want to report a bug?

On Fri, 2 Jan 2009, ken_kleinman at hms.harvard.edu wrote:

> function (df, datafile, codefile, dataname = "rdata", validvarname = c("V7",
>    "V6"))
> {
>    factors <- sapply(df, is.factor)
>    strings <- sapply(df, is.character)
>    dates <- sapply(df, FUN = function(x) inherits(x, "Date") ||
>        inherits(x, "dates") || inherits(x, "date"))
>    xdates <- sapply(df, FUN = function(x) inherits(x, "dates") ||
>        inherits(x, "date"))
>    datetimes <- sapply(df, FUN = function(x) inherits(x, "POSIXt"))
>    varlabels <- names(df)
>    varnames <- make.SAS.names(names(df), validvarname = validvarname)
>    if (any(varnames != varlabels))
>        message("Some variable names were abbreviated or otherwise altered.")
>    dfn <- df
>    if (any(factors))
>        dfn[factors] <- lapply(dfn[factors], as.numeric)write
>    if (any(datetimes))
>        dfn[datetimes] <- lapply(dfn[datetimes], function(x) format(x,
>            "%d%b%Y %H:%M:%S"))
>    if (any(xdates))
>        dfn[xdates] <- lapply(dfn[xdates], function(x) as.Date(as.POSIXct(x)))
>    write.table(dfn, file = datafile, row = FALSE, col = FALSE,
>        sep = ",", quote = TRUE, na = "")
>    lrecl <- max(sapply(readLines(datafile), nchar)) + 4L
>    cat("* Written by R;\n", file = codefile)
>    cat("* ", deparse(sys.call(-2L))[1L], ";\n\n", file = codefile,
>        append = TRUE)
>    if (any(factors)) {
>        cat("PROC FORMAT;\n", file = codefile, append = TRUE)
>        fmtnames <- make.SAS.formats(varnames[factors])
>        fmt.values <- lapply(df[, factors, drop = FALSE], levels)
>        names(fmt.values) <- fmtnames
>        for (f in fmtnames) {
>            cat("value", f, "\n", file = codefile, append = TRUE)
>            values <- fmt.values[[f]]
>            for (i in 1L:length(values)) {
>                cat("    ", i, "=", adQuote(values[i]), "\n",
>                  file = codefile, append = TRUE)
>            }
>            cat(";\n\n", file = codefile, append = TRUE)
>        }
>    }
>    cat("DATA ", dataname, ";\n", file = codefile, append = TRUE)
>    if (any(strings)) {
>        cat("LENGTH", file = codefile, append = TRUE)
>        lengths <- sapply(df[, strings, drop = FALSE], FUN =
> function(x) max(nchar(x)))
>        names(lengths) <- varnames[strings]
>        for (v in varnames[strings]) cat("\n", v, "$", lengths[v],
>            file = codefile, append = TRUE)
>        cat("\n;\n\n", file = codefile, append = TRUE)
>    }
>    if (any(dates)) {
>        cat("INFORMAT", file = codefile, append = TRUE)
>        for (v in varnames[dates]) cat("\n", v, file = codefile,
>            append = TRUE)
>        cat("\n YYMMDD10.\n;\n\n", file = codefile, append = TRUE)
>    }
>    if (any(datetimes)) {
>        cat("INFORMAT", file = codefile, append = TRUE)
>        for (v in varnames[datetimes]) cat("\n", v, file = codefile,
>            append = TRUE)
>        cat("\n DATETIME18.\n;\n\n", file = codefile, append = TRUE)
>    }
>    cat("INFILE ", adQuote(datafile), "\n     DSD", "\n     LRECL=",
>        lrecl, ";\n", file = codefile, append = TRUE)
>    cat("INPUT", file = codefile, append = TRUE)
>    for (v in 1L:ncol(df)) cat("\n", varnames[v], file = codefile,
>        append = TRUE)
>    if (strings[v])
>        cat(" $ ", file = codefile, append = TRUE)
>    cat("\n;\n", file = codefile, append = TRUE)
>    for (v in 1L:ncol(df)) if (varnames[v] != names(varnames)[v])
>        cat("LABEL ", varnames[v], "=", adQuote(varlabels[v]),
>            ";\n", file = codefile, append = TRUE)
>    if (any(factors))
>        for (f in 1L:length(fmtnames)) cat("FORMAT", names(fmtnames)[f],
>            paste(fmtnames[f], ".", sep = ""), ";\n", file = codefile,
>            append = TRUE)
>    if (any(dates))
>        for (v in varnames[dates]) cat("FORMAT", v, "yymmdd10.;\n",
>            file = codefile, append = TRUE)
>    if (any(datetimes))
>        for (v in varnames[datetimes]) cat("FORMAT", v, "datetime18.;\n",
>            file = codefile, append = TRUE)
>    cat("RUN;\n", file = codefile, append = TRUE)
> }
>
> -- 
> ___________________________
> Ken Kleinman, ScD
> Associate Professor, Department of Ambulatory Care and Prevention
> Harvard Medical School and Harvard Pilgrim Health Care
> 133 Brookline Ave., 6th Floor
> Boston, MA 02215
> p: 617 509 9935
> f: 617 859 8112
> https://dacppages.pbwiki.com/Ken%20Kleinman
>
>
> "The only useful function of a statistician is to make predictions,
> and thus to provide a basis for action." - W.E. Deming
>
> "Cleesh Inbox"  - Me
>
> This email is only for the intended recipient and may contain
> information that is privileged, confidential or exempt from disclosure
> under applicable Federal or State law. Any review, retransmission,
> dissemination or other use of  protected health information by other
> than the intended recipient is prohibited. If you received this email
> in error, please contact the sender and delete the material.
>
> ______________________________________________
> R-devel at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
>

-- 
Brian D. Ripley,                  ripley at stats.ox.ac.uk
Professor of Applied Statistics,  http://www.stats.ox.ac.uk/~ripley/
University of Oxford,             Tel:  +44 1865 272861 (self)
1 South Parks Road,                     +44 1865 272866 (PA)
Oxford OX1 3TG, UK                Fax:  +44 1865 272595