Some rediscovered R scripts from spring cleaning

May 1, 2011

(This article was first published on BioStatMatt » R, and kindly contributed to R-bloggers)

Gompertz Model Visualization

# Gomperz growth function
gomp <- function(x, a, b, k)
    a*exp(-b*exp(-k*x))
 
# Normal model with Gompertz mean function
likelihood <- function(weight, age, sigma, a, b, k) {
    mu <- gomp(age, a, b, k)
    dnorm(weight, mu, sigma)
}
 
# Visualize the model
visualize <- function(phi=40, theta=-35) {
    weight <- seq(0, 250, length.out=100)
    age    <- seq(0, 50, length.out=100)
    dens   <- outer(weight, age, likelihood, sigma=20,
        a=170, b=2, k=0.21)
    persp(weight, age, dens, phi=phi, theta=theta,
        xlab="weight", ylab="age", zlab="density")
}

Web Presentation for Data Frames

I know there is some functionality for this in the Hmisc and R2HTML packages. Can you get alternating row colors with the functions in these packages?

	Murder	Assault	UrbanPop	Rape
Alabama	13.2	236	58	21.2
Alaska	10	263	48	44.5
Arizona	8.1	294	80	31
Arkansas	8.8	190	50	19.5
California	9	276	91	40.6
Colorado	7.9	204	78	38.7

 
# Try:
# data(USArrests)
# webpage(head(USArrests))
 
webpage <- function(object, ...) UseMethod("webpage")
HEADER <- "
<!DOCTYPE html>
<html><head>
<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />
<style type=\"text/css\">
table   {
    border: 0px;
    padding: 0px;
}
tr.even { background: #E2EBF0; text-align: right; }
tr.odd  { background: #FFFFFF; text-align: right; }
tr.name { background: #1F2D49; color: white; text-align: center; }
td.name { background: #1F2D49; color: white; text-align: left; }
</style></head><body>
"
FOOTER <- "
</body></html>
"
 
webpage.data.frame <- function(object, header=HEADER, footer=FOOTER, ...) {
    esc <- function (text) {
        text <- gsub("&", "&amp;", text)
        text <- gsub("\"", "&quot;", text)
        text <- gsub("'", "&apos;", text)
        text <- gsub(">", "&gt;", text)
        gsub("<", "&lt;", text)
    }
    row_count <- nrow(object)
    col_count <- ncol(object)
    row_names <- gsub(" ", "&nbsp;", row.names(object))
    col_names <- gsub(" ", "&nbsp;", names(object))
    cat(header, "<table><tr class=\"name\"><td class=\"name\"></td><td>",
         paste(esc(col_names), collapse="</td><td>"), "</td></tr>", sep="")
    evenodd <- "even"
    for(i in 1:row_count) {
        cat("<tr class=\"",evenodd,"\"><td class=\"name\">", esc(row_names[i]),
            "<td>", paste(esc(format(object[i,], ...)), collapse = "</td><td>"),
            "</td></tr>", sep="")
        evenodd <- ifelse(evenodd=="even", "odd", "even")
    }
    cat("</table>",footer)
}

Compress and Upload Files

I was surprised to find little information regarding compressed file uploads in the PHP / JavaScript literature. The function below serves this purpose (but may not be fault tolerant). It would be cool to use this function in conjunction with a local HTTP server (running in R) to provide a web interface to compress and upload files to remote servers. This function assumes that the remote server has a mechanism to receive the data. I've included a server-side CGI shell script below that simply writes the (compressed) data to disk. Alternatively, one could set up a server-side R script, using rApache to simultaneously receive, decompress, and store the data.

# This function compresses a file using 'xz -9' compression 
# and uploads the file to a server using the HTTP POST method.
# 'packpost' is shorthand for 'compress and upload'. The receiving
# server should be set up to receive this upload using a server-side
# scripting mechanism.
packpost <- function(file, host="localhost", port="80",
    location="/", quiet = FALSE, query = URLencode(file)) {
 
    if(!is.character(file) || length(file) != 1)
        stop("'file' must be a character vector of length 1")
    if(!is.character(host) || length(host) != 1)
        stop("'host' must be a character vector of length 1")
    if(!is.character(port) || length(port) != 1)
        stop("'port' must be a character vector of length 1")
    if(!is.character(location) || length(location) != 1)
        stop("'location' must be a character vector of length 1")
    if(!is.logical(quiet) || length(quiet) != 1)
        stop("'quiet' must be a logical vector of length 1")
    if(!is.character(query) || length(query) != 1)
        stop("'query' must be a character vector of length 1")
 
    # pack
    cfile <- tempfile()
    fcon  <- file(file, open="rb")
    ccon  <- xzfile(cfile, open="wb", compression=9)
    if(!quiet)
        cat("packpost: compressing", file, "->", cfile, "\n")
    while(length(buff <- readBin(fcon, "raw", 1024)) > 0)
        writeBin(buff, ccon)
    close(fcon)
    close(ccon)
    if(!quiet)
        cat("packpost: compression ratio:", 
            file.info(file)$size / file.info(cfile)$size, "\n") 
 
    # post 
    if(!quiet)
        cat("packpost: uploading", cfile, "\n")
    location <- paste(URLencode(location), "?", URLencode(query), sep="")
    header <- paste("POST ", location, " HTTP/1.1\r\n",
                    "Host: ", paste(host, port, sep=":"), "\r\n",
                    "Content-Length: ", file.info(cfile)$size, "\r\n",
                    "Content-Type: application/x-xz\r\n\r\n", sep="")
 
    ccon <- file(cfile, open="rb")
    scon <- socketConnection(host, port, open="w+b", blocking=TRUE)
    cat(header, file=scon)
    while(length(buff <- readBin(ccon, "raw", 1024)) > 0)
        writeBin(buff, scon)
    response <- readLines(scon, n=1)
    close(scon)
    close(ccon)
    if(!quiet)
        cat("packpost: removing", cfile, "\n")
    unlink(cfile)
    return(response)
}

#!/bin/bash
# This script would be located in a CGI directory on a remote host.
# Note that this script alone may not be safe. In particular, The web
# server should be configured to limit the upload size / prevent malicious
# uploads.
DATAFILE="upload-`date +%Y-%b-%d-%H%M-%N`"
 
# Append '.xz' when the data are xz compressed
if [ "application/x-xz" = "${CONTENT_TYPE}" ]; then
    DATAFILE="${DATAFILE}.xz"
fi
 
# POST data come from STDIN
cat > ${DATAFILE}
 
# Return control to CGI handler
echo -e "\r\n"