Nothing
##' Make HTML Table from R 'table-like' Object
##'
##' Function for making HTML tables from an \R 'table-like' object; ie, a
##' \code{data.frame} or a \code{matrix}. It simply parses the item as an HTML table.
##'
##' The row.spans and col.spans argument can be specified as a matrix to
##' set the row or column span of a certain cell to be >1, if desired.
##' See \code{\link{pxt}} for an example implementation.
##' It will also handle 'boxes', e.g. cells with both rowspan and colspan > 1.
##'
##' Note that the default behavior is to \code{'clean'} numeric input; this prints
##' numeric values with a maximum of four digits; ie, through the \code{"\%.4G"} format
##' specifier. Alternatively,
##' you can use a format specifier (as used in \code{sprintf}) to ensure numbers
##' are formatted and displayed as desired.
##'
##' @param x the \code{data.frame} / \code{matrix} you want to convert to an HTML table.
##' @param attr attributes to be passed to the \code{<table>} tag, as raw HTML.
##' @param row.spans a matrix specifying desired row.spans, for largers cells.
##' @param col.spans a matrix specifying desired column spans, for larger cells.
##' @param use.row.names if you submit an object with row names, use those names in
##' construction of the table.
##' @param use.col.names if you submit an object with column names, use those names in
##' construction of the table.
##' @param clean boolean. if \code{TRUE}, we print all numeric values with 4 digits.
##' Alternatively, we can pass a format specifier as used by \code{\link{sprintf}}.
##' @param replace.periods replace periods with spaces?
##' @export
##' @examples
##' dat <- data.frame( apple=c(1.2150125, 2, 3), banana=c("a", "b", "c") )
##' makeHTMLTable( dat )
makeHTMLTable <- function( x,
attr,
row.spans=0,
col.spans=0,
use.row.names=FALSE,
use.col.names=FALSE,
clean=TRUE,
replace.periods=TRUE
) {
if (missing(attr))
attr <- 'class="table table-collapsed table-hover table-striped"'
if( length(x) == 0 ) {
warning( paste(x, "is of length zero") )
x <- ""
}
x <- as.data.frame(x, stringsAsFactors=FALSE, optional=TRUE )
if( use.row.names == FALSE ) {
rownames(x) <- NULL
}
if( use.col.names == FALSE ) {
colnames(x) <- paste(sep="", "x_", 1:ncol(x) )
}
## We round any numeric entries so that they aren't printed with
## an excessive number of decimal places.
if( clean == TRUE || length( grep("^\\%", clean ) ) > 0 ) {
if( clean == TRUE ) {
clean <- "%.4G"
}
my_rownames <- rownames(x)
x <- as.data.frame( lapply( x, function(xx) {
if( class(xx) %in% c("numeric", "integer") ) {
return( sprintf( clean, xx ) )
} else {
return( xx )
}
}), stringsAsFactors=FALSE, optional=TRUE )
rownames(x) <- my_rownames
}
if( use.row.names == TRUE ) {
x <- cbind( rownames(x), x )
}
if( use.col.names == TRUE ) {
x <- factor_to_char( x )
if( replace.periods ) {
colnames(x) <- gsub( "\\.", " ", colnames(x) )
}
x <- rbind( colnames(x), x )
if( use.row.names == TRUE ) {
x[1,1] <- ""
}
## Printing the basic table
if( row.spans == 0 && col.spans == 0 ) {
}
out <- paste( sep="", "<table ", attr, ">" )
out <- paste( sep="", out, "<thead><tr>" )
for (j in 1:ncol(x)) {
out <- paste( sep="", out, "<th>", x[1, j], "</td>" )
}
out <- paste( sep="", out, "</thead></tr>" )
out <- paste( sep="", out, "<tbody>")
for( i in 2:nrow(x) ) {
out <- paste( sep="", out, "<tr>" )
for( j in 1:ncol(x) ) {
out <- paste( sep="", out, "<td>", x[i,j], "</td>" )
}
out <- paste( sep="", out, "</tr>" )
}
out <- paste( sep="", out, "</tbody></table>" )
cat(out, "\n")
} else {
## Handling tables with specialized row, col spans.
## First, verify that we're receiving acceptable matrices.
if( !identical( row.spans, 0 ) ) {
if( length( unique( apply( row.spans, 1, sum ) ) ) != 1 ) {
stop("ERROR: Invalid row.spans matrix specified.")
}
} else {
row.spans <- matrix(1, ncol=ncol(x), nrow=nrow(x) )
}
if( !identical( col.spans, 0 ) ) {
if( length( unique( apply( col.spans, 2, sum ) ) ) != 1 ) {
stop("ERROR: Invalid col.spans matrix specified.")
}
} else {
col.spans <- matrix(1, ncol=ncol(x), nrow=nrow(x) )
}
## Pre-process the table: if we see a number greater in a particular
## cell for both tables (implying 2x2 or greater cell block), then we set
## numbers in the lower-right cells to zero.
for( i in 1:nrow(row.spans) ) {
for( j in 1:ncol(row.spans) ) {
if( row.spans[i,j] > 1 && col.spans[i,j] > 1 ) {
cell_width <- row.spans[i,j]
cell_height <- col.spans[i,j]
row.spans[ i:(i+cell_width-1), j:(j+cell_height-1) ] <- 0
col.spans[ i:(i+cell_width-1), j:(j+cell_height-1) ] <- 0
row.spans[i,j] <- cell_width
col.spans[i,j] <- cell_height
}
}
}
out <- paste( sep="", "<table ", attr, ">" )
for( i in 1:nrow(x) ) {
out <- paste( sep="", out, "<tr>" )
for( j in 1:ncol(x) ) {
cRowSpan <- row.spans[i,j]
cColSpan <- col.spans[i,j]
openTag <- "<td "
## only generate a td if both the elements in row, colspan are non-zero
cond1 <- cRowSpan != 0 && cColSpan != 0
if( cond1 ) {
if( cRowSpan > 1 ) {
openTag <- paste( sep="", openTag, "colspan=", cRowSpan, " " )
}
if( cColSpan > 1 ) {
openTag <- paste( sep="", openTag, "rowspan=", cColSpan, " " )
}
openTag <- paste( sep="", openTag, ">" )
out <- paste( sep="", out, openTag, x[i,j], "</td>" )
}
}
out <- paste( sep="", out, "</tr>" )
}
out <- paste( sep="", out, "</table>" )
cat(out, "\n")
}
}
##' Make 1D HTML Table
##'
##' This tabling function is intended for the output of \code{kTable}, as
##' generated when only one 'data' argument is passed.
##' @export
##' @param x a \code{data.frame}, typically output of \code{kTable}.
##' @param class class to be passed to HTML table; used for CSS styling.
##' @param id id to be passed to HTML table; used for CSS styling.
##' @param ... optional arguments passed to \code{\link{makeHTMLTable}}.
##' @seealso \code{\link{kTable}}, \code{\link{makeHTMLTable}}
##' @examples
##' y <- factor( rbinom( 100, 2, 0.2 ) )
##' p1t( kTable( y ) )
p1t <- function( x,
class='table table-condensed table-striped table-hover',
id=NULL,
... ) {
warning("Deprecated: use knitr::kable instead.")
myAttr <- NULL
if( !is.null(class) ) myAttr <- paste( sep="", myAttr, "class='", class, "' ")
if( !is.null(id) ) myAttr <- paste( sep="", myAttr, "id='", id, "'")
makeHTMLTable( x,
attr=myAttr,
clean=FALSE,
...
)
}
##' Make 2x2 HTML Contingency Table
##'
##' Function for outputting cross-tabulated tables as marked-up HTML.
##' CSS styling can be used to make these tables look especially nice.
##' @param x a 2x2 table; typically something returned from \code{kTable(x,y)}
##' @param class class to be passed to HTML table; used for CSS styling.
##' @param id id to be passed to HTML table; used for CSS styling.
##' @param ... optional arguments passed to \code{\link{makeHTMLTable}}.
##' @export
##' @seealso \code{\link{kTable}}
##' @examples
##' x <- rbinom( 100, 2, 0.2 )
##' y <- rbinom( 100, 2, 0.2 )
##' pxt( kTable(x, y) )
pxt <- function( x,
class='twoDtable',
id=NULL,
...) {
myAttr <- NULL
if( !is.null(class) ) myAttr <- paste( sep="", myAttr, "class='", class, "' ")
if( !is.null(id) ) myAttr <- paste( sep="", myAttr, "id='", id, "'")
my_row_span <- matrix(1, nrow=nrow(x)-1, ncol=ncol(x))
my_row_span <- rbind( c( 2, 0, ncol(x)-3, rep(0, ncol(x)-4), 1), my_row_span )
my_col_span <- matrix(1, nrow=nrow(x), ncol=ncol(x)-1)
my_col_span <- cbind( c( 2, 0, nrow(x)-3, rep(0, nrow(x)-4), 1 ), my_col_span )
makeHTMLTable( x,
attr=myAttr,
row.spans=my_row_span,
col.spans=my_col_span,
clean=FALSE,
...
)
}
##' HTML - Source an Image
##'
##' Convenience function for \code{cat}-ing out HTML markup for an image as
##' \code{<img src="..." />}.
##' @param x path to an image you want to source
##' @param width width (in pixels) of the image
##' @param height height (in pixels) of the image
##' @seealso \code{\link{hImg}}
kImg <- function(x, width=480, height=480) {
## If we have a period as the first character, remove it.
if( re_exists(x, "^\\./") ) {
x <- gsub( "^\\./", "", x )
}
cat( paste( sep="", '<img class="center" src="', x, '" width=', width, ' height=', height, ' />') )
}
##' HTML - Source an SVG file
##'
##' Convenience function for \code{cat}-ing out HTML markup for an SVG image, using
##' \code{<embed>}.
##' @param file path to the SVG file you want to embed
##' @param width width (in pixels) of the SVG file (or, more accurately, canvas in which that file is displayed)
##' @param height height (in pixels) of the SVG file (or, more accurately, canvas in which that file is displayed)
##' @param class class passed to the \code{<embed>} tag
kSvg <- function(file=NULL, width=4, height=4, class=NULL) {
stopifnot( !is.null(file) )
## If we have a period as the first character, remove it.
if( re_exists(file, "^\\.") ) {
x <- gsub( "^\\.", getwd(), file )
}
tag <- paste( sep="", '<embed src="', file, '" width=', width, ' height=', height)
if( !is.null(class) ) {
tag <- paste( sep="", tag, " class='", class, "'" )
}
cat( "<div align='center'>\n")
cat( paste( sep="", tag, ' type="image/svg+xml" />\n') )
cat("</div>\n")
}
##' Print Plot to File and Return HTML
##'
##' A convenience function that prints a plot to file, and then returns HTML
##' to embed that image in the page.
##'
##' The \code{dim} attribute is passed on to \code{par( mfrow='dim' )}; ie, it is used if
##' you are calling a plot function that writes more than one plot.
##'
##' The \code{png} device is used.
##'
##' @param my_plot a plot object, or code that generates a plot
##' @param file file location to output image to
##' @param width width (in pixels) of the plot
##' @param height height (in pixels) of the plot
##' @param dpi the number of dots per inch used. Default is high to ensure plots are crisp on all displays
##' @param dim passed to \code{par( mfrow )}; used if making multiple base-R plots
##' @param scale the scale factor to use when scaling plots for web display.
##' @param device the device to use for the plot call.
##' @param ... optional arguments passed to \code{\link{png}}
##' @export
##' @examples
##' library(lattice)
##' ## generate an xyplot, write it to file, and return HTML
##' ## code that sources the generated image
##' dat <- data.frame( x = rnorm(100), y = rnorm(100) )
##' hImg( file = "plot_output.png",
##' xyplot( y ~ x, dat )
##' )
hImg <- function( my_plot,
file,
width=400,
height=300,
dpi=300,
dim=NULL,
scale=100,
device="png",
... ) {
device <- match.fun(device)
device( file,
width=width/scale,
height=height/scale,
res=dpi,
units="in",
... )
if( !is.null(dim) ) {
if( length(dim) != 2 ) stop("must specifiy 2-length dimension")
par( mfrow=dim )
}
print( my_plot )
invisible( dev.off() )
kImg( file, width=width, height=height )
}
##' Print SVG to File and Return HTML
##'
##' A convenience function that prints a plot to file, and then returns HTML
##' to embed that image in the page. Used for SVG images.
##'
##' @param my_plot a plot object, or code that generates a plot
##' @param file location to output file
##' @param width width (in pixels) of the plot
##' @param height height (in pixels) of the plot
##' @param scale the scale used to scale the plot from inches to pixels, for display in a web browser
##' @param dim passed to \code{par( mfrow )}; used if making multiple base-R plots
##' @param ... passed to \code{svg}
##' @export
##' @examples
##' library(lattice)
##' ## generate an xyplot, write it to file, and return HTML code that
##' ## sources the generated image
##' dat <- data.frame( x = rnorm(100), y = rnorm(100) )
##' hSvg( file = "plot_output.svg",
##' xyplot( y ~ x, dat )
##' )
##'
hSvg <- function( my_plot, file, width=400, height=300, dim=NULL, scale=100, ... ) {
svg( file, width=width/scale, height=height/scale, ... )
if( !is.null(dim) ) {
if( length(dim) != 2 ) stop("must specifiy 2-length dimension")
par( mfrow=dim )
}
if( any( class( my_plot ) %in% c("trellis", "ggplot") ) ) {
print( my_plot )
} else {
my_plot
}
invisible( dev.off() )
kSvg( file, width=width, height=height )
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.