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)
# 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

13.2 236 58 21.2

10 263 48 44.5

8.1 294 80 31

8.8 190 50 19.5

9 276 91 40.6

7.9 204 78 38.7
# Try:
# data(USArrests)
# webpage(head(USArrests))
webpage <- function(object, ...) UseMethod("webpage")
<!DOCTYPE html>
<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; } { background: #1F2D49; color: white; text-align: center; } { background: #1F2D49; color: white; text-align: left; }
" <- 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")

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)
        cat("packpost: compressing", file, "->", cfile, "\n")
    while(length(buff <- readBin(fcon, "raw", 1024)) > 0)
        writeBin(buff, ccon)
        cat("packpost: compression ratio:", 
  $size /$size, "\n") 
    # post 
        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: ",$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)
        cat("packpost: removing", cfile, "\n")
# 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
# 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. offers daily e-mail updates about R news and tutorials on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...

If you got this far, why not subscribe for updates from the site? Choose your flavor: e-mail, twitter, RSS, or facebook...

Tags: , , , , ,

Comments are closed.


Mango solutions

RStudio homepage

Zero Inflated Models and Generalized Linear Mixed Models with R

Dommino data lab

Quantide: statistical consulting and training



CRC R books series

Six Sigma Online Training

Contact us if you wish to help support R-bloggers, and place your banner here.

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)