Site icon R-bloggers

Some rediscovered R scripts from spring cleaning

BioStatMatt

[This article was first published on BioStatMatt » R, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

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>
<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"

To leave a comment for the author, please follow the link and comment on their blog: BioStatMatt » R.
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.