Nothing
R/HTMLcore.R
In R2HTML: HTML exportation for R objects
Defines functions
HTML2clip
Documented in
HTML2clip
# $Id: HTMLcore.R 47 2008-05-23 17:29:31Z mentus $
# R2HTML - Library of exportation to HTML for R
# Copyright (C) 2002-2004 - Eric Lecoutre
# R2HTML Package
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#----------------------------------------------------------------------------------------------------#
#
# Contact:
#
# Eric Lecoutre
# <lecoutre@stat.ucl.ac.be>
#
# Institut de statistique
# Voie du Roman Pays, 20
# 1348 Louvain-la-Neuve
# BELGIQUE
#
#----------------------------------------------------------------------------------------------------#
"HTML"<- function(x,...) {
UseMethod("HTML")
}
#----------------------------------------------------------------------------------------------------#
"HTML.default"<-
function(x, file=get(".HTML.file"),append=TRUE,...)
{
HTML(paste(capture.output(x),collapse="\n<br>\n"),file=file,append=append,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.atomic"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("\n<p class='atomic'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.complex"<- function(x, file=get(".HTML.file"), append=TRUE,...){
cat(paste("\n<p><font class='complexRe'>",Re(x),"</font>",ifelse(sign(Im(x))<0,"-","+"),"<font class='complexIm'>",Im(x),"</font><font class='complexI'>i</font>","</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.numeric"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
if(!is.null(names(x))) {
HTML(as.table(x),file=file,append=append,...)
}
else {
cat(paste("\n<p class='numeric'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
}
#----------------------------------------------------------------------------------------------------#
"HTML.integer"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("\n<p class='integer'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.logical"<- function(x, file=get(".HTML.file"), append=TRUE,...){
cat(paste("\n<p class='logical'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.character"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("\n<p class='character'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.call"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("<font class='call'>",deparse(x),"</font>",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.function"<-function(x,file=get(".HTML.file"),append=TRUE,...){
cat(paste("\n<br>\n<xmp class=function>",
paste(capture.output(x),collapse="\n"),"\n</xmp><br>\n",sep=""),
file=file,append=append,sep="\n<br>\n")
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.environment"<-function(x,file=get(".HTML.file"),append=TRUE,...){
cat(paste("\n<br>environment: <font class='environment'>",attributes(x)$name,"</font><br>\n",sep=""),
file=file,append=append)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.formula"<-function(x,file=get(".HTML.file"),append=TRUE,...) {
HTML(paste("<font class='formula'>",deparse(unclass(x)),"</font>",collapse=""),file=file,append=append,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.array"<- function(x, file=get(".HTML.file"),append=TRUE, ...)
{
odometer <- function(current, radix)
{
if(any(c(current, radix) < 0))
stop("arguments must be non-negative")
lc <- length(current)
if(length(radix) != lc)
radix <- rep(radix, length = lc)
radix <- radix - 1
for(i in 1:lc) {
if((ii <- current[i]) < radix[i]) {
current[i] <- ii + 1
return(current)
}
else current[i] <- 0
}
current
}
d <- dim(x)
ndim <- length(d)
dn <- dimnames(x)
if(ndim == 1)
HTML.matrix(matrix(x, 1, dimnames = list("", if(is.null(
dn)) paste("[", 1:d[1], "]", sep = "") else dn[[1]])),
file = file, append=append,...)
else if(ndim == 2)
HTML.matrix(x, Border = 0, file = file, append=append,...)
else {
if(length(dn) < ndim)
dn <- vector("list", ndim)
for(i in 3:ndim)
if(length(dn[[i]]) < d[i]) dn[[i]] <- paste(1:d[i])
xm <- array(x[1], d[1:2])
dimnames(xm) <- dn[1:2]
d <- d[ - (1:2)]
nm <- length(xm)
which <- 1:nm
dn <- dn[ - (1:2)]
ndim <- ndim - 2
counter <- rep(0, length(d))
for(i in 1:(length(x)/nm)) {
cat("<br>, , ", file = file, append = TRUE)
for(j in 1:ndim)
cat(dn[[j]][counter[j] + 1], if(j < ndim) ", "
else "<br>", sep = "", file = file, append
= TRUE)
xm[1:nm] <- x[which]
HTML.matrix(xm, Border = 0, file = file, append=TRUE,...)
counter <- odometer(counter, d)
which <- which + nm
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.by"<- function (x, file=get(".HTML.file"),vsep="\n<hr size=1 width=100%>\n",append=TRUE,...)
{
HTML("\n",file=file,append=append,...)
d <- dim(x)
dn <- dimnames(x)
dnn <- names(dn)
if (missing(vsep))
vsep <- "\n<hr size=1 width=100%>\n"
lapply(seq(along = x), function(i, x, vsep, ...) {
if (i != 1 && !is.null(vsep))
HTML(vsep, file=file,append=TRUE)
ii <- i - 1
for (j in seq(along = dn)) {
iii <- ii%%d[j] + 1
ii <- ii%/%d[j]
HTML(paste(dnn[j], ": ", dn[[j]][iii], "\n<br>", sep = ""),file=file,append=TRUE,...)
}
HTML(x[[i]], file=file,append=TRUE)
}, x, vsep, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.family" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
HTML(paste("\n<br><b>Family</b>:<font class='family'>", x$family, "\n</font><br>",sep=""),file=get(".HTML.file",pos=1),append=append,...)
HTML(paste("\n<b>Link function</b>:<font class='link'>", x$link, "\n</font><br>\n<br>",sep=""),file=get(".HTML.file",pos=1),append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.terms" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML.default(paste("<font class='terms'>",unclass(x),"</font>",sep=""),file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.factor" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
HTML("\n\n<font class='factor'>",file=file,append=append,...)
if (length(x) <= 0)
HTML("factor(0)\n<br>\n",file=file,append=TRUE,...)
else HTML(as.character(x), file=file,append=TRUE, ...)
HTML("</font>\n",file=file,append=TRUE,...)
HTMLbr(file=file,append=TRUE,...)
HTML(paste("Levels:<font class='factorlevels'> ", paste(levels(x), collapse = " "), "</font>\n<br>",sep=""),file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.density" <- function (x,file=get(".HTML.file"), digits=4,append=TRUE,...)
{
HTML(paste("\n<br><b>Call</b>:<font class='call'>\n ", deparse(x$call), "</font><br><br>\n\n<b>Data</b><font class='dataname'>: ", x$data.name,
"</font> (", x$n, " obs.);", " <b>Bandwidth</b> 'bw' = ", round(x$bw, digits), "\n<br>\n<br>", sep = ""),append=append,file=file)
HTML(summary(as.data.frame(x[c("x", "y")])),append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.infl" <- function (x, file=get(".HTML.file"),digits = max(3, getOption("digits") - 4),append=TRUE,...)
{
HTML(paste("\n<br>Influence measures of\n<br> <font class='call'> ", deparse(x$call), ":</font>\n<br>\n<br>",sep=""),file=file,append=append,...)
is.star <- apply(x$is.inf, 1, any, na.rm = TRUE)
HTML(data.frame(round(x$infmat,digits), inf = ifelse(is.star, "*", " ")),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.lm"<-function(x,file=get(".HTML.file"),digits= max(3, getOption("digits") - 3),append=TRUE,...)
{
HTMLli(paste("Call: <font class='call'>",deparse(x$call),"</font>",sep=""),file=file,append=append,...)
HTMLli("Coefficients<br>",file=file,append=TRUE,...)
HTML(round(x$coeff,3),file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.lm.null" <- function (x, file=get(".HTML.file"),digits = max(3, getOption("digits") - 3),append=TRUE,...)
{
HTMLli(paste("Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>", sep = ""),file=file,append=append,...)
HTMLli("No coefficients<br>\n",append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ftable" <- function (x, file=get(".HTML.file"),digits = getOption("digits"),append=TRUE,...)
{
if (!inherits(x, "ftable"))
stop("x must be an `ftable'")
ox <- x
makeLabels <- function(lst) {
lens <- sapply(lst, length)
cplensU <- c(1, cumprod(lens))
cplensD <- rev(c(1, cumprod(rev(lens))))
y <- NULL
for (i in rev(seq(along = lst))) {
ind <- 1 + seq(from = 0, to = lens[i] - 1) * cplensD[i +
1]
tmp <- character(length = cplensD[i])
tmp[ind] <- lst[[i]]
y <- cbind(rep(tmp, times = cplensU[i]), y)
}
y
}
makeNames <- function(x) {
nmx <- names(x)
if (is.null(nmx)) nmx <- rep("", length = length(x))
nmx
}
xrv <- attr(x, "row.vars")
xcv <- attr(x, "col.vars")
LABS <- cbind(rbind(matrix("", nrow = length(xcv), ncol = length(xrv)), makeNames(xrv), makeLabels(xrv)), c(makeNames(xcv),rep("", times = nrow(x) + 1)))
DATA <- rbind(t(makeLabels(xcv)), rep("", times = ncol(x)), format(unclass(x), digits = digits))
x <- cbind(apply(LABS, 2, format, justify = "left"), apply(DATA, 2, format, justify = "right"))
HTML(x,file=file,append=append,...)
invisible(ox)
}
#----------------------------------------------------------------------------------------------------#
"HTML.POSIXlt" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<P class='POSIXlt'>",format(x, usetz = TRUE),"</p>",sep=""), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.POSIXct" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<P class='POSIXct'>",format(x, usetz = TRUE),"</p>",sep=""), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.octmode" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<P class='octmode'>",format(x),"</p>",sep=""), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.rle" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
HTML("<b><center>Run Length Encoding</center></b>\n<br>\n",file=file,append=append,...)
tab<-rbind(x$length,x$values)
tab<-cbind(c("Length","Values"),tab)
HTML(tab,file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.logLik" <- function (x, file=get(".HTML.file"),digits = getOption("digits"),append=TRUE,...) HTML(paste("<p>`log Lik.' ", format(c(x), digits = digits), " (df=", format(attr(x, "df")), ")\n</p>", sep = ""),file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.xtabs" <- function (x,file=get(".HTML.file"),append=TRUE,...)
{
ox <- x
attr(x, "call") <- NULL
HTML.table(x,file=file, append=append,...)
invisible(ox)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.lm"<-function (x, file=get(".HTML.file"),digits = max(3, getOption("digits") - 3), symbolic.cor = p > 4, signif.stars = getOption("show.signif.stars"),append=TRUE,...)
{
HTML("\n",file=file,append=append)
HTMLli(paste("Call:<font class='call'> ",deparse(x$call),"</font>","\n", sep = "", collapse = ""),file=file,append=TRUE)
resid <- x$residuals
df <- x$df
rdf <- df[2]
HTMLli(paste(if (!is.null(x$w) && diff(range(x$w))) "Weighted "," Residuals<br>\n"),file=file,append=TRUE)
if (rdf > 5) {
nam <- c("Min", "1Q", "Median", "3Q", "Max")
rq <- if (length(dim(resid)) == 2)
structure(apply(t(resid), 1, quantile), dimnames = list(nam, dimnames(resid)[[2]]))
else structure(quantile(resid), names = nam)
HTML(rq, file=file,append=TRUE,...)
}
else if (rdf > 0) {
HTML(resid,file=file,append=TRUE,...)
}
else {
HTML(paste("ALL", df[1], "residuals are 0: no residual degrees of freedom!<br>\n",sep=""),file=file,append=TRUE,...)
}
if (nsingular <- df[3] - df[1])
HTMLli(paste("Coefficients (",nsingular, "not defined because of singularities)<br>\n",sep=""),file=file,append=TRUE)
else HTMLli("Coefficients\n",file=file,append=TRUE)
HTML.coefmat(x$coef, digits = digits, signif.stars = signif.stars, file=file,append=TRUE,...)
HTMLli(paste("Residuals standard error: ",round(x$sigma,digits)," on ",rdf," degrees of freedom\n",sep=""),file=file,append=TRUE)
if (!is.null(x$fstatistic)) {
HTMLli(paste("Multiple R-Squared:<b>",round(x$r.squared,digits),"</b>",sep=""),file=file,append=TRUE)
HTMLli(paste("Adjusted R-Squared:<b>",round(x$adj.r.squared,digits),"</b>",sep=""),file=file,append=TRUE)
HTMLli(paste("F-statistics: <b>", round(x$fstatistic[1],digits), "</b> on ",x$fstatistic[2], " and ", x$fstatistic[3], " DF. P-value:<b>",round(1-pf(x$fstatistic[1],x$fstatistic[2],x$fstatistic[3]),digits),"</b>." ,sep=""),file=file,append=TRUE)
}
correl <- x$correlation
if (!is.null(correl)) {
p <- NCOL(correl)
if (p > 1) {
HTMLli("Correlation of Coefficients:\n",file=file,append=TRUE,...)
if (symbolic.cor)
HTML(symnum(correl)[-1, -p],file=file,append=TRUE,...)
else {
correl[!lower.tri(correl)] <- NA
HTML(correl[-1, -p, drop = FALSE],file=file,append=TRUE,...)
}
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.coefmat"<- function (x, digits = max(3, getOption("digits") - 2), signif.stars = getOption("show.signif.stars"),
dig.tst = max(1, min(5, digits - 1)), cs.ind = 1:k, tst.ind = k +
1, zap.ind = integer(0), P.values = NULL, has.Pvalue = nc >=
4 && substr(colnames(x)[nc], 1, 3) == "Pr(", na.print = "",file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (is.null(d <- dim(x)) || length(d) != 2)
stop("1st arg. 'x' must be coefficient matrix/d.f./...")
nc <- d[2]
if (is.null(P.values)) {
scp <- getOption("show.coef.Pvalues")
if (!is.logical(scp) || is.na(scp)) {
warning("option `show.coef.Pvalues' is invalid: assuming TRUE")
scp <- TRUE
}
P.values <- has.Pvalue && scp
}
else if (P.values && !has.Pvalue)
stop("'P.values is TRUE, but has.Pvalue not!")
if (has.Pvalue && !P.values) {
d <- dim(xm <- data.matrix(x[, -nc, drop = FALSE]))
nc <- nc - 1
has.Pvalue <- FALSE
}
else xm <- data.matrix(x)
k <- nc - has.Pvalue - (if (missing(tst.ind))
1
else length(tst.ind))
if (!missing(cs.ind) && length(cs.ind) > k)
stop("wrong k / cs.ind")
Cf <- array("", dim = d, dimnames = dimnames(xm))
ok <- !(ina <- is.na(xm))
if (length(cs.ind) > 0) {
acs <- abs(coef.se <- xm[, cs.ind, drop = FALSE])
digmin <- 1 + floor(log10(range(acs[acs != 0], na.rm = TRUE)))
Cf[, cs.ind] <- format(round(coef.se, max(1, digits -
digmin)), digits = digits)
}
if (length(tst.ind) > 0)
Cf[, tst.ind] <- format(round(xm[, tst.ind], digits = dig.tst),
digits = digits)
if (length(zap.ind) > 0)
Cf[, zap.ind] <- format(zapsmall(xm[, zap.ind], digits = digits),
digits = digits)
if (any(r.ind <- !((1:nc) %in% c(cs.ind, tst.ind, zap.ind,
if (has.Pvalue) nc))))
Cf[, r.ind] <- format(xm[, r.ind], digits = digits)
okP <- if (has.Pvalue)
ok[, -nc]
else ok
x0 <- (xm[okP] == 0) != (as.numeric(Cf[okP]) == 0)
if (length(not.both.0 <- which(x0 & !is.na(x0)))) {
Cf[okP][not.both.0] <- format(xm[okP][not.both.0], digits = max(1,
digits - 1))
}
if (any(ina))
Cf[ina] <- na.print
if (P.values) {
if (!is.logical(signif.stars) || is.na(signif.stars)) {
warning("option `show.signif.stars' is invalid: assuming TRUE")
signif.stars <- TRUE
}
pv <- xm[, nc]
if (any(okP <- ok[, nc])) {
Cf[okP, nc] <- format.pval(pv[okP], digits = dig.tst)
signif.stars <- signif.stars && any(pv[okP] < 0.1)
if (signif.stars) {
Signif <- symnum(pv, corr = FALSE, na = FALSE,
cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
symbols = c("***", "**", "*", ".", " "))
Cf <- cbind(Cf, formatC(Signif))
}
}
else signif.stars <- FALSE
}
else signif.stars <- FALSE
HTML.matrix(Cf, file=file, ...)
if (signif.stars) HTML(paste("\n<p>--- Signif. codes: ", attr(Signif, "legend"), "</p>\n",sep=""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.table"<- function(x, file=get(".HTML.file"),append=TRUE,digits=4,...)
{
cat("\n",file=file,append=append)
if (!is.null(digits) && is.numeric(x)) x <- round(x,digits) # PhG, because summary(iris) returns a table, but it is not numeric!
if (is.null(dim(x))) HTML(t(as.matrix(x)),file=file,append=TRUE,digits=NULL,...)
else HTML(unclass(x),file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.listof" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
nn <- names(x)
ll <- length(x)
if (length(nn) != ll)
nn <- paste("Component ", seq(ll))
for (i in seq(length = ll)) {
HTMLli(paste(nn[i],":\n<br>",sep=""),file=file)
HTML(x[[i]], file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ts" <- function (x, calendar=NULL, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
x.orig <- x
x <- as.ts(x)
fr.x <- frequency(x)
if (missing(calendar))
calendar <- any(fr.x == c(4, 12))
if (!calendar)
header <- function(x) {
if ((fr.x <- frequency(x)) != 1)
HTML(paste("\n<br><b>Time series</b>:\n<br><li>Start=",deparse(start(x)),"\n<br><li>End=",deparse(end(x)),"\n<br><li>Frequency=",deparse(fr.x),"\n<br>",sep=""),file=file)
else
HTML(paste("\n<br><b>Time series</b>:\n<br><li>Start=",format(tsp(x)[1]),"\n<br><li>End=",format(tsp(x)[2]),"\n<br><li>Frequency=",deparse(fr.x),"\n<br>",sep=""),file=file)
}
if (NCOL(x) == 1) {
if (calendar) {
if (fr.x > 1) {
dn2 <- if (fr.x == 12)
month.abb
else if (fr.x == 4) {
c("Qtr1", "Qtr2", "Qtr3", "Qtr4")
}
else paste("p", 1:fr.x, sep = "")
if (NROW(x) <= fr.x && start(x)[1] == end(x)[1]) {
dn1 <- start(x)[1]
dn2 <- dn2[1 + (start(x)[2] - 2 + seq(along = x))%%fr.x]
x <- matrix(format(x, ...), nrow = 1, byrow = TRUE,
dimnames = list(dn1, dn2))
}
else {
start.pad <- start(x)[2] - 1
end.pad <- fr.x - end(x)[2]
dn1 <- start(x)[1]:end(x)[1]
x <- matrix(c(rep("", start.pad), format(x,
...), rep("", end.pad)), ncol = fr.x, byrow = TRUE,
dimnames = list(dn1, dn2))
}
}
else {
tx <- time(x)
attributes(x) <- NULL
names(x) <- tx
}
}
else {
header(x)
attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL
}
}
else {
if (calendar && fr.x > 1) {
tm <- time(x)
t2 <- 1 + round(fr.x * ((tm + 0.001)%%1))
p1 <- format(floor(tm))
rownames(x) <- if (fr.x == 12)
paste(month.abb[t2], p1, sep = " ")
else paste(p1, if (fr.x == 4)
c("Q1", "Q2", "Q3", "Q4")[t2]
else format(t2), sep = " ")
}
else {
if (!calendar)
header(x)
rownames(x) <- format(time(x))
}
attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL
}
NextMethod("HTML", x, file=file, ...)
invisible(x.orig)
}
#----------------------------------------------------------------------------------------------------#
"HTML.list" <- function(x,file=get(".HTML.file"),first=TRUE,append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (first) {HTML("<hr class='hr'>",file=file,append=TRUE,sep="\n")}
for (i in 1:length(x)) {
cat("<ul>",file=file,append=TRUE,sep="\n")
cat("</center><li>",file=file,append=TRUE,sep="\n")
HTML(x[[i]],file=file,first=FALSE,...)
cat("</ul>",file=file,append=TRUE,sep="\n")
}
cat("\n<br><hr class='hr'>",file=file,append=TRUE,sep="\n")
}
#----------------------------------------------------------------------------------------------------#
"HTML.pairlist" <- function(x,file=get(".HTML.file"),first=TRUE,append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (first) {HTML("<hr class='hr'>",file=file,append=TRUE,sep="\n")}
for (i in 1:length(x)) {
cat("<ul>",file=file,append=TRUE,sep="\n")
cat("</center><li>",file=file,append=TRUE,sep="\n")
HTML(x[[i]],file=file,first=FALSE,...)
cat("</ul>",file=file,append=TRUE,sep="\n")
}
cat("\n<br><hr class='hr'>",file=file,append=TRUE,sep="\n")
}
#----------------------------------------------------------------------------------------------------#
# row.names option contributed by
# Tobias Verbeke on 2006-05-27
#
# Fixed bug of invalid HTML output when using
# row.names = FALSE, as patch contributed
# by Michael Irskens on 2006-11-04
#
"HTML.data.frame" <- function(
x, file=get(".HTML.file"),
Border = 1, innerBorder = 0,
classfirstline = "firstline",
classfirstcolumn = "firstcolumn",
classcellinside = "cellinside",
append = TRUE,
align = "center",
caption = "",
captionalign = "bottom",
classcaption = "captiondataframe",
classtable = "dataframe",
digits = getOption("R2HTML.format.digits"),
nsmall = getOption("R2HTML.format.nsmall"),
big.mark = getOption("R2HTML.format.big.mark"),
big.interval = getOption("R2HTML.format.big.interval"),
decimal.mark = getOption("R2HTML.format.decimal.mark"),
sortableDF = getOption("R2HTML.sortableDF"),
row.names = TRUE,
...)
{
cat("\n", file = file, append = append)
# Handle sortableDF argument
if (is.null(sortableDF)) sortableDF = FALSE
if (sortableDF)
cat(paste(c("\n<style>", ".tablesort {",
"cursor: pointer ;",
" behavior:url(tablesort.htc);",
" -moz-binding: url(moz-behaviors.xml#tablesort.htc);",
"}",
"</style>\n"),
collapse="\n"),
file = file, append = TRUE)
# if (!is.null(digits)) x[] = lapply(x, FUN = function(vec) if (is.numeric(vec)) round(vec, digits) else vec)
txt <- paste("\n<p align=",align,">")
txtcaption <- ifelse(is.null(caption),
"",
paste("\n<caption align=", captionalign,
" class=", classcaption, ">",
caption,
"</caption>\n", sep=""))
if (!is.null(Border))
txt <- paste(txt, "\n<table cellspacing=0 border=", Border, ">",
txtcaption,"<tr><td>",
"\n\t<table border=", innerBorder, " class=",classtable,">",
sep = "")
else txt <- paste(txt, "\n<table border=", innerBorder,
" class=",classtable," cellspacing=0>",
txtcaption, sep = "")
txt <- paste(txt,"\t<tbody>",sep="\n")
VecDebut <- c(
if(row.names)
paste("\n\t\t<th>",
if(sortableDF) '<b class="tablesort">',
sep = "", collapse = ""),
rep(paste("\n\t\t<th>",
if(sortableDF) '<b class="tablesort">',
sep = "", collapse = ""), ncol(x) - 1)
)
VecMilieu <- c(
if(row.names) " ",
as.character(dimnames(x)[[2]])
)
VecFin <- c(
if(row.names)
paste(if(sortableDF) '</b>', "", "</th>", collapse = ""),
rep(
paste(if(sortableDF) '</b>',"", "</th>", collapse = ""), ncol(x) - 1
),
"</th>"
)
txt <- paste(txt, "\n\t<tr class=", classfirstline, ">",
paste(VecDebut, VecMilieu, VecFin, sep = "", collapse = ""),
"\n\t</tr>"
)
x.formatted <- format(x, digits = digits, nsmall = nsmall,
big.mark = big.mark, big.interval = big.interval,
decimal.mark = decimal.mark)
x.formatted <- as.matrix(x.formatted)
x.formatted[is.na(x.formatted)] <- " "
x.formatted[is.nan(x.formatted)] <- " "
for(i in 1:dim(x)[1]) {
if(i == 1) {
VecDebut <- c(if(row.names)
paste("\n<td class=", classfirstcolumn, ">",
sep = ""),
paste("\n<td class=", classcellinside, ">", sep = ""),
rep(paste("\n<td class=", classcellinside, ">",
sep = ""),
dim(x)[2] - 1)
)
VecMilieu <- c(if(row.names)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,])
)
VecFin <- c(if(row.names) "\n</td>",
rep("\n</td>", dim(x)[2] - 1),
"\n</td></tr>\n"
)
}
else {
VecDebut <- c(if(row.names)
paste("\n<td class=", classfirstcolumn, ">",
sep = ""),
paste(rep(paste("\n<td class=", classcellinside, ">",
sep = ""),
dim(x)[2])
)
)
VecMilieu <- c(if(row.names)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,]))
VecFin <- c(if(row.names) "\n</td>",
rep("\n</td>", dim(x)[2] - 1),
"\n</td></tr>\n")
}
txt <- paste(txt, "\n<tr>",
paste(VecDebut, VecMilieu, VecFin, sep = "", collapse = ""))
}
txt <- paste(txt, "\n\t</tbody>\n</table>\n",
if (!is.null(Border)) "</td></table>\n","<br>")
cat(txt, "\n", file = file, sep = "", append = TRUE)
}
#----------------------------------------------------------------------------------------------------#
"HTML.matrix" <- function(x, file=get(".HTML.file"), Border = 1, innerBorder = 0, classfirstline = "firstline", classfirstcolumn = "firstcolumn", classcellinside = "cellinside", append=TRUE,align="center",caption="",captionalign="bottom",classcaption="captiondataframe",classtable="dataframe",digits=getOption("R2HTML.format.digits"),nsmall = getOption("R2HTML.format.nsmall"), big.mark = getOption("R2HTML.format.big.mark"), big.interval = getOption("R2HTML.format.big.interval"), decimal.mark = getOption("R2HTML.format.decimal.mark"),...)
{
cat("\n", file=file,append=append)
# if (is.numeric(x) & !is.null(digits)) x<-round(x,digits=digits)
txt <- paste("\n<p align=",align,">")
txtcaption <- ifelse(is.null(caption),"",paste("<caption align=",captionalign," class=",classcaption,">",caption,"</caption>\n",sep=""))
if (!is.null(Border)) txt <- paste(txt, "\n<table cellspacing=0 border=",Border,">",txtcaption,"<tr><td>","\n\t<table border=", innerBorder, " class=",classtable,">", sep = "")
else txt <- paste(txt, "\n\t<table border=", innerBorder, " class=", classtable," cellspacing=0>", txtcaption, sep = "")
txt <- paste(txt,"\t<tbody>",sep="\n")
if(is.null(dimnames(x)[[2]]) == FALSE) {
VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste(
"<th>", sep = ""),
rep(paste("<th>", sep = ""), dim(
x)[2] - 1))
VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "",
as.character(dimnames(x)[[2]]))
VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</th>", rep(
"</th>", dim(x)[2] - 1), "</th>")
txt <- paste(txt,"<tr class=",classfirstline,">", paste(VecDebut, VecMilieu, VecFin, sep = "",collapse = ""),"</tr>\n")
}
x.formatted <- format(x, digits=digits, nsmall=nsmall, big.mark=big.mark, big.interval=big.interval, decimal.mark=decimal.mark)
x.formatted <- as.matrix(x.formatted)
x.formatted[is.na(x.formatted)] <- " "
x.formatted[is.nan(x.formatted)] <- " "
for(i in 1:dim(x)[1]) {
if(i == 1) {
VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste(
"\n<tr><td class=", classfirstcolumn, ">", sep = ""),
paste("\n<td class=", classcellinside, ">", sep = ""),
rep(paste("\n<td class=", classcellinside, ">", sep =
""), dim(x)[2] - 1))
VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,]))
VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</td>",
rep("</td>", dim(x)[2] - 1), "</td></tr>\n")
}
else {
VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste(
"\n<tr><td class=", classfirstcolumn, ">", sep = ""),
paste(rep(paste("\n<td class=", classcellinside, ">", sep
= ""), dim(x)[2])))
VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,]))
VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</td>",
rep("</td>", dim(x)[2] - 1), "</td></tr>\n")
}
txt <- paste(txt, paste(VecDebut, VecMilieu, VecFin, sep = "",collapse = ""))
}
txt <- paste(txt, "\n\t</tbody>\n</table>\n",if (!is.null(Border)) "</td></table>\n","<br>")
cat(txt, "\n", file = file, sep = "", append=TRUE)
}
#----------------------------------------------------------------------------------------------------#
"HTML.structure"<-
function(x, a = attributes(x), prefix = "", file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
n <- length(dim(x))
nn <- names(a)
ate <- character(0)
if(n > 0) {
if(n == 2)
HTML.matrix(x, file = file,append=TRUE, ...)
else HTML.array(x, file = file,append=TRUE, ...)
ate <- c("dim", "dimnames")
if(n == 1)
ate <- c(ate, "names")
}
else if(!is.atomic(x)) {
HTML(as.vector(x), file = file,append=TRUE, ...)
ate <- "names"
}
else if(length(tsp(x))) {
HTML.ts(x, file = file,append=TRUE, ...)
ate <- "tsp"
}
else if(length(names(x))) {
HTML.matrix(matrix(x, 1, dimnames = list("", names(x))),
file = file,append=TRUE, ...)
ate <- "names"
}
else HTML(as.vector(x), file = file,append=TRUE, ...)
ii <- !match(nn, ate, nomatch = FALSE)
nn <- nn[ii]
a <- a[ii]
for(i in seq(nn)) {
this <- paste("attr(", prefix, ", \"", nn[i], "\")", sep = "")
HTML(this, file=file,append=TRUE)
HTML(a[[i]], file = file, append=TRUE, ...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.connection" <- function(x,file=get(".HTML.file"),append=TRUE,...) HTML(paste("<font class='connection'>",unlist(summary(x)),"</font>",sep=""),file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.socket" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
if (length(port <- as.integer(x$socket)) != 1)
stop("invalid `socket' argument")
HTML(paste("Socket connection #", x$socket, "to", x$host, "on port",
x$port, "\n<br>",sep=""),file=file,append=append,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.htest" <- function (x, digits = 4, quote = TRUE, prefix = "",file=get(".HTML.file"),append=TRUE, ...)
{
HTML("\n", file=file,append=append)
HTML(as.title(paste(" ",x$method,sep="")),file=file,append=TRUE,...)
HTMLli(paste("\n data:<font class=dataname>",x$data.name,"</font>\n",sep=""),file=file,append=TRUE,...)
out <- character()
if (!is.null(x$statistic))
out <- c(out, paste(names(x$statistic), "=<b>", format(round(x$statistic,4)),"</b>"))
if (!is.null(x$parameter))
out <- c(out, paste(names(x$parameter), "=<b>", format(round(x$parameter,3)),"</b>"))
if (!is.null(x$p.value))
out <- c(out, paste("p-value =<font class='pvalue'>", format.pval(x$p.value,digits = digits),"</font>"))
HTMLli(paste(out,collapse=" , "),file=file,append=TRUE,...)
if (!is.null(x$alternative)) {
HTMLli("alternative hypothesis: ",file=file)
if (!is.null(x$null.value)) {
if (length(x$null.value) == 1) {
alt.char <- switch(x$alternative, two.sided = "not equal to",
less = "less than", greater = "greater than")
HTML(paste("true", names(x$null.value), "is", alt.char,
x$null.value, "\n"),file=file,append=TRUE,...)
}
else {
HTMLli(paste(x$alternative, "\nnull values:\n<br>"),file=file,append=TRUE,...)
HTML(x$null.value, file=file,append=TRUE,...)
}
}
else HTML(paste(x$alternative, "\n<br>"),file=file,append=TRUE,...)
}
if (!is.null(x$conf.int)) {
HTMLli(paste("<b>",format(100 * attr(x$conf.int, "conf.level")), "</b> percent confidence interval:\n",
"<b>[", paste(format(c(x$conf.int[1], x$conf.int[2])),sep="",collapse=" ;"),"]</b>",sep=""),file=file,append=TRUE,...)
}
if (!is.null(x$estimate)) {
HTMLli("sample estimates:\n",file=file,...)
HTML(t(as.matrix(x$estimate)),file=file,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.aov" <- function (x, intercept = FALSE, tol = .Machine$double.eps^0.5, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:\n<br><font class='call'>", deparse(cl)),"</font>",file=file)
asgn <- x$assign[x$qr$pivot[1:x$rank]]
effects <- x$effects
if (!is.null(effects))
effects <- as.matrix(effects)[seq(along = asgn), , drop = FALSE]
rdf <- x$df.resid
uasgn <- unique(asgn)
nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))[1 + uasgn]
nterms <- length(uasgn)
nresp <- NCOL(effects)
df <- numeric(nterms)
ss <- matrix(NA, nterms, nresp)
if (nterms) {
for (i in seq(nterms)) {
ai <- asgn == uasgn[i]
df[i] <- sum(ai)
ef <- effects[ai, , drop = FALSE]
ss[i, ] <- if (sum(ai) > 1)
colSums(ef^2)
else ef^2 }
keep <- df > 0
if (!intercept && uasgn[1] == 0)
keep[1] <- FALSE
nmeffect <- nmeffect[keep]
df <- df[keep]
ss <- ss[keep, , drop = FALSE]
nterms <- length(df) }
HTMLli("Terms:\n<br>",file=file)
if (nterms == 0) {
if (rdf > 0) {
ss <- colSums(as.matrix(x$residuals)^2)
ssp <- sapply(ss, format)
if (!is.matrix(ssp))
ssp <- t(ssp)
tmp <- as.matrix(c(ssp, format(rdf)))
if (length(ss) > 1) {
rn <- colnames(x$fitted)
if (is.null(rn))
rn <- paste("resp", 1:length(ss))
}
else rn <- "Sum of Squares"
dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), "Residuals")
HTML(as.data.frame(tmp), file=file,..)
HTMLli(paste("Residual standard error:", paste(sapply(sqrt(ss/rdf),format),collapse=" "), "\n"),file=file)
}
else HTML.matrix(matrix(0, 2, 1, dimnames = list(c("Sum of Squares","Deg. of Freedom"), "<empty>")),file=file)
}
else {
if (rdf > 0) {
resid <- as.matrix(x$residuals)
nterms <- nterms + 1
df <- c(df, rdf)
ss <- rbind(ss, colSums(resid^2))
nmeffect <- c(nmeffect, "Residuals") }
ssp <- apply(zapsmall(ss), 2, format)
tmp <- t(cbind(ssp, format(df)))
if (ncol(effects) > 1) {
rn <- colnames(x$coef)
if (is.null(rn))
rn <- paste("resp", seq(ncol(effects))) }
else rn <- "Sum of Squares"
dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), nmeffect)
HTML(as.data.frame(tmp), file=file)
rank <- x$rank
int <- attr(x$terms, "intercept")
nobs <- NROW(x$residuals) - !(is.null(int) || int == 0)
if (rdf > 0) {
rs <- sqrt(colSums(as.matrix(x$residuals)^2)/rdf)
HTMLli(paste("Residual standard error:", paste(sapply(rs,format),collapse=" "), "\n"),file=file) }
coef <- as.matrix(x$coef)[, 1]
R <- x$qr$qr
R <- R[1:min(dim(R)), , drop = FALSE]
R[lower.tri(R)] <- 0
if (rank < (nc <- length(coef))) {
HTMLli(paste(nc - rank, "out of", nc, "effects not estimable\n"),file=file)
R <- R[, 1:rank, drop = FALSE] }
d2 <- sum(abs(diag(R)))
diag(R) <- 0
if (sum(abs(R))/d2 > tol)
HTMLli("Estimated effects may be unbalanced\n",file=file)
else HTMLli("Estimated effects are balanced\n",file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.anova" <- function (x, digits = max(getOption("digits") - 2, 3), signif.stars = getOption("show.signif.stars"),file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (!is.null(heading <- attr(x, "heading")))
HTML(paste("<p><b>",heading, "</b></p>"),file=file)
nc <- (d <- dim(x))[2]
if (is.null(cn <- colnames(x)))
stop("anova object must have colnames(.)!")
ncn <- nchar(cn)
has.P <- substr(cn[nc], 1, 3) == "Pr("
zap.i <- 1:(if (has.P) nc - 1 else nc)
i <- which(substr(cn, 2, 7) == " value")
i <- c(i, which(!is.na(match(cn, c("FALSE", "Cp", "Chisq")))))
if (length(i))
zap.i <- zap.i[!(zap.i %in% i)]
tst.i <- i
if (length(i <- which(substr(cn, ncn - 1, ncn) == "Df")))
zap.i <- zap.i[!(zap.i %in% i)]
HTML.coefmat(x, digits = digits, signif.stars = signif.stars,
has.Pvalue = has.P, P.values = has.P, cs.ind = NULL,
zap.ind = zap.i, tst.ind = tst.i, na.print = "", file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.glm" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "", file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
HTMLli(paste("Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>\n<br>"),file=file)
HTMLli("Coefficients",file=file)
if (is.character(co <- x$contrasts))
HTML(paste(" [contrasts: ", apply(cbind(names(co), co), 1,
paste, collapse = "="), "]"),file=file)
HTMLbr(file=file)
HTML(format(x$coefficients, digits = digits),file=file)
HTMLli(paste("\nDegrees of Freedom:<b>", x$df.null, "</b>Total (i.e. Null);<b> ",
x$df.residual, "</b> Residual\n"),file=file)
HTMLli(paste("Null Deviance:<b> ", format(signif(x$null.deviance,
digits)), "</b> Residual Deviance:<b>", format(signif(x$deviance,
digits)), " </b> AIC:<b> ", format(signif(x$aic, digits)), "</b>\n<br>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tables.aov" <- function (x, digits = 4, file=get(".HTML.file"),...)
{
HTML("<center>",file=file)
tables.aov <- x$tables
n.aov <- x$n
se.aov <- if (se <- !is.na(match("se", names(x))))
x$se
type <- attr(x, "type")
switch(type, effects = HTML("<p class=partitle>Tables of effects\n</p>",file=file), means = HTML("<P CLASS=partitle>Tables of means\n</p>",file=file),
residuals = if (length(tables.aov) > 1)
HTML("<p class=partitle>Table of residuals from each stratum\n</p>",file=file))
if (!is.na(ii <- match("Grand mean", names(tables.aov)))) {
HTML("<p>Grand mean\n</p>",file=file)
gmtable <- tables.aov[[ii]]
HTML.mtable(gmtable, digits = digits, file=file)
}
for (i in names(tables.aov)) {
if (i == "Grand mean")
next
table <- tables.aov[[i]]
HTML(paste("\n<p>", i, "\n</p>"),file=file)
if (!is.list(n.aov))
HTML.mtable(table, digits = digits,file=file,append=TRUE, ...)
else {
n <- n.aov[[i]]
if (length(dim(table)) < 2) {
table <- rbind(table, n)
rownames(table) <- c("", "rep")
HTML(table, digits = digits, file=file)
}
else {
ctable <- array(c(table, n), dim = c(dim(table),
2))
dim.t <- dim(ctable)
d <- length(dim.t)
ctable <- aperm(ctable, c(1, d, 2:(d - 1)))
dim(ctable) <- c(dim.t[1] * dim.t[d], dim.t[-c(1,
d)])
dimnames(ctable) <- c(list(format(c(rownames(table),
rep("rep", dim.t[1])))), dimnames(table)[-1])
ctable <- eval(parse(text = paste("ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))",
paste(rep(", ", d - 2), collapse = " "), "]")))
names(dimnames(ctable)) <- names(dimnames(table))
class(ctable) <- "mtable"
HTML.mtable(ctable, digits = digits,file=file, append=TRUE,...)
}
}
}
if (se) {
if (type == "residuals")
rn <- "df"
else rn <- "replic."
switch(attr(se.aov, "type"), effects = HTML("\n<p class=partitle>Standard errors of effects\n</p>",file=file),
means = HTML("\n<p class=partitle>Standard errors for differences of means\n</p>",file=file),
residuals = HTML("\n<p class=partitle>Standard errors of residuals\n</p>",file=file))
if (length(unlist(se.aov)) == length(se.aov)) {
n.aov <- n.aov[!is.na(n.aov)]
se.aov <- unlist(se.aov)
cn <- names(se.aov)
se.aov <- rbind(format(se.aov, digits = digits),
format(n.aov))
dimnames(se.aov) <- list(c(" ", rn), cn)
HTML.matrix(se.aov,file=file)
}
else for (i in names(se.aov)) {
se <- se.aov[[i]]
if (length(se) == 1) {
se <- rbind(se, n.aov[i])
dimnames(se) <- list(c(i, rn), "")
HTML(se, file=file)
}
else {
dimnames(se)[[1]] <- ""
HTML(paste("\n<p>", i, "\n</p>"),file=file)
HTML("When comparing means with same levels of:\n<br>",file=file)
HTML(se, file=file, ...)
HTML(paste("replic.", n.aov[i], "\n<br>"),file=file)
}
}
}
HTML("</center>",file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.mtable" <- function (x, digits = getOption("digits"),file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
xxx <- x
xx <- attr(x, "Notes")
nn <- names(dimnames(x))
a.ind <- match(names(a <- attributes(x)), c("dim", "dimnames",
"names"))
a <- a[!is.na(a.ind)]
class(x) <- attributes(x) <- NULL
attributes(x) <- a
if (length(x) == 1 && is.null(names(x)) && is.null(dimnames(x)))
names(x) <- rep("", length(x))
if (length(dim(x)) && is.numeric(x)) {
xna <- is.na(x)
x <- format(zapsmall(x, digits))
x[xna] <- " "
}
HTML(x, file=file, ...)
if (length(xx)) {
HTML("\n<br>Notes:\n<br>",file=file)
HTML(xx,file=file)
}
invisible(xxx)
}
#----------------------------------------------------------------------------------------------------#
"HTML.integrate" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
if (x$message == "OK")
HTML(paste("<p>",format(x$value, digits = digits), " with absolute error < ",
format(x$abs.error, digits = 2), "\n</p>", sep = ""),file=file)
else HTML(paste("<p>failed with message `", x$message, "'\n</p>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.lm.null" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
HTMLli(paste("<br><p>Call:<font class=call> ", paste(deparse(x$call), sep = "\n<br>", collapse = "\n<br>"), "</font></p>" ),file=file)
resid <- x$residuals
df <- x$df
rdf <- df[2]
if (rdf > 5) {
HTMLli("Residuals:\n<br>",file=file)
if (length(dim(resid)) == 2) {
rq <- apply(t(resid), 1, quantile)
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q",
"Max"), dimnames(resid)[[2]])
}
else {
rq <- quantile(resid)
names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
}
HTML(round(rq, digits) ,file=file)
}
else if (rdf > 0) {
HTMLli("Residuals:\n<br>",file=file)
HTML(round(resid, digits ), file=file)
}
else HTMLli("\n<br>No Coefficients:\n<br>",file=file)
HTMLli(paste("\n<br>Residual standard error:<b> ", format(signif(x$sigma,
digits)), "on <b> ", rdf, " </b>degrees of freedom\n<br><br>",sep=""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.glm" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "",
symbolic.cor = p > 4, signif.stars = getOption("show.signif.stars"), file=get(".HTML.file"),append=TRUE,
...)
{
cat("\n", file=file,append=append,...)
HTMLli(paste("\n<p>Call: <font class=call>",paste(deparse(x$call),collapse=" "),"</font>"),file=file)
HTML("<p>Deviance Residuals: \n</p>",file=file)
if (x$df.residual > 5) {
x$deviance.resid <- quantile(x$deviance.resid, na.rm = TRUE)
names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q",
"Max")
}
HTML(t(round(x$deviance.resid,digits)) , file=file)
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML.coefmat(x$coef, signif.stars = signif.stars, file=file)
HTML(paste("\n<p>(Dispersion parameter for ", x$family$family, " family taken to be ",
format(x$dispersion), ")\n</p>\n"),file=file)
HTML(paste("<li>Null deviance:<b>", round(x$null.deviance,digits), "</b> on <b>", x[c("df.null")],"</b> degrees of freedom."),file=file)
HTML(paste("<li>Residual deviance:<b>", round(x$deviance,digits), "</b> on <b>", x[c("df.residual")],"</b> degrees of freedom."),file=file)
HTML(paste("<p>AIC:<b> ", format(x$aic, digits = max(4, digits + 1)), "</b>\n</p>\n<p>Number of Fisher Scoring iterations: <b>", x$iter, "</b>\n</p>", sep = ""),file=file)
correl <- x$correlation
if (!is.null(correl)) {
p <- NCOL(correl)
if (p > 1) {
HTML("\n<p>Correlation of Coefficients:\n</p>")
if (symbolic.cor)
HTML(symnum(correl)[-1, -p],file=file)
else {
correl[!lower.tri(correl)] <- NA
HTML(correl[-1, -p, drop = FALSE], file=file)
}
}
}
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.hsearch" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
fields <- paste(x$fields, collapse = " or ")
db <- x$matches
if (NROW(db) > 0) {
HTML(paste("<p>Help files with ", fields, " matching `",
x$pattern, "',\n", "type `help(FOO, package = PKG)' to inspect ",
"entry `FOO(PKG) TITLE':", "\n</p>", sep = ""), file=file)
dbnam <- paste(db[, "name"], "(", db[, "Package"], ")",sep = "")
dbtit <- paste(db[, "title"], sep = "")
HTML(cbind(dbnam, dbtit), file=file)
}
else HTML(paste("<p>No help files found with ", fields, " matching `", x$pattern, "'\n</p>", sep = ""),file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.aov" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
NextMethod("HTML")
}
"HTML.aovlist" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
cl <- attr(x, "call")
if (!is.null(cl)) {
cat("\nCall:\n<font class=call>",file=file,append=TRUE,...)
dput(cl,file=file)
cat("\n</font>",file=file,append=TRUE,...)
}
if (!is.null(attr(x, "weights")))
cat("Note: The results below are on the weighted scale\n",file=file,append=TRUE,...)
nx <- names(x)
if (nx[1] == "(Intercept)") {
mn <- x[[1]]$coef
if (is.matrix(mn)) {
cat("\nGrand Means:\n",file=file,append=TRUE,...)
cat(format(mn[1, ]), file=file,append=TRUE,...)
}
else cat("\nGrand Mean:", format(mn[1]), "\n",file=file,append=TRUE,...)
nx <- nx[-1]
}
for (ii in seq(along = nx)) {
i <- nx[ii]
cat("\nStratum ", ii, ": ", i, "\n", sep = "",file=file,append=TRUE,...)
xi <- x[[i]]
cat(xi,file=file,append=TRUE, ...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.SavedPlots" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n",file=file,append=append,...)
if (x[[1]] != 31416) {
HTML("<p>object is not of class `SavedPlots'</p>\n<br>",file=file)
return()
}
HTML("<p>Saved Plots from R version 1.4.0 or later</p>\n<br>\n<br>",file=file,append=TRUE,...)
HTML(" Contains", x[[2]], "out of a maximum", x[[3]], "plots\n",file=file,append=TRUE,...)
lens <- sapply(x[[5]], length)[1:x[[2]]]
cat(" #plot calls are", paste(lens, collapse = ", "), "\n",file=file,append=TRUE,...)
cat(" Current position is plot", 1 + x[[4]], "\n",file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ordered" <- function (x, quote = FALSE,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (length(x) <= 0)
HTML("\n<p>ordered(0)\n</p>",file=file,append=TRUE,...)
else HTML(as.character(x), file,file, append=TRUE,...)
HTML(paste("\n<p>Levels<font class=factorlevels>: ", paste(levels(x), collapse = " < "), "</font>\n</p>"),file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.difftime" <- function (x, digits = getOption("digits"),file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
if (length(x) > 1)
HTML(paste("<p>Time differences of ", paste(format(unclass(x),
digits = digits), collapse = ", "), " ", attr(x,
"units"), "\n</p>", sep = ""),file=file,append=TRUE,...)
else HTML(paste("<p>Time difference of ", format(unclass(x), digits = digits),
" ", attr(x, "units"), "\n", sep = ""),file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.dummy.coef" <- function (x, file=get(".HTML.file"),append=TRUE,title="",...)
{
cat("\n",file=file,append=append,...)
terms <- names(x)
n <- length(x)
nm <- max(sapply(x, length))
ans <- matrix("", 2 * n, nm)
rn <- rep("", 2 * n)
line <- 0
for (j in seq(n)) {
this <- x[[j]]
n1 <- length(this)
if (n1 > 1) {
line <- line + 2
ans[line - 1, 1:n1] <- names(this)
ans[line, 1:n1] <- format(this, ...)
rn[line - 1] <- paste(terms[j], ": ", sep = "")
}
else {
line <- line + 1
ans[line, 1:n1] <- format(this, ...)
rn[line] <- paste(terms[j], ": ", sep = "")
}
}
rownames(ans) <- rn
colnames(ans) <- rep("", nm)
HTML(paste("\n<p>",if (title=="")
"Full coefficients are"
else title, "\n</p>"),file=file,append=TRUE,...)
HTML.matrix(ans[1:line, , drop = FALSE],file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.dummy.coef.list" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
for (strata in names(x)) HTML.dummy.coef(x[[strata]], file=file, title = paste("\n<p> Error:", strata,"</p>"),append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.glm.null" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "",
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste(" Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>\n"),file=file)
HTMLli("No coefficients\n<br>")
HTMLli(paste("Degrees of Freedom:<b>", length(x$residuals), "</b> Total; <b>",
x$df.residual, " </b>Residual\n<br>"),file=file)
HTMLli(paste("Null Deviance:<b>", format(signif(x$null.deviance, digits)),
"</b>\n<br>"),file=file)
HTMLli(paste("Residual Deviance: <b>", format(signif(x$deviance, digits)),
" </b><br>\n"),file=file)
HTMLli(paste("AIC:<b>", format(signif(x$aic, digits)), "</b><br>\n"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.MethodsFunction"<- function (x,file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
info=attr(x,"info")
if (dim(info)[1]==0) HTML("<p>No available generic function for the class",file=file,append=TRUE)
HTML("<p>Available generic functions which does handle the class</p>",file=file,append=TRUE)
HTML(info,file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.libraryIQR" <- function (x,file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
sQuote <- function(s) paste("`", s, "'", sep = "")
db <- x$results
out <- if (nrow(db) == 0)
NULL
else lapply(split(1:nrow(db), db[, "LibPath"]), function(ind) db[ind,
c("Package", "Title"), drop = FALSE])
first <- TRUE
for (lib in names(out)) {
HTML(paste(paste("<p>Packages in library ",
sQuote(lib), ":</p>", sep = "")),file=file,append=TRUE,...)
HTML(cbind(out[[lib]][, "Package"], out[[lib]][,
"Title"]), file=file,append=TRUE,...)
first <- FALSE
}
if (first) {
HTML("<p>no packages found</p>",file=file, append=TRUE,...) }
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.aov" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (length(x) == 1)
HTML(x[[1]], file=file)
else NextMethod()
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.aovlist" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
nn <- names(x)
for (i in nn) {
HTMLli(paste(i, "\n<br>", sep = ""),file=file)
HTML(x[[i]], file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.glm.null" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "",
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:<font class=call> ",paste(deparse(x$call), sep = "\n", collapse = "\n"),
"</font>\n<br>\n", sep = ""),file=file)
HTMLli("Deviance Residuals: \n<br>",file=file)
if (x$df.residual > 5) {
x$deviance.resid <- quantile(x$deviance.resid)
names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q",
"Max")
}
HTML.default(x$deviance.resid, digits = digits, na = "",file=file)
HTMLli("No coefficients\n<br>")
HTMLli(paste("\n(Dispersion parameter for ", x$family$family,
" family taken to be ", x$dispersion, ")\n\n Null deviance:<b> ",
x$null.deviance, " </b>on <b>", x$df.null, " </b>degrees of freedom\n\n",
"Residual deviance: <b>", x$deviance, " </b>on<b> ", x$df.residual,
" </b>degrees of freedom\n\n", "Number of Fisher Scoring iterations<b>: ",
x$iter, "</b>\n<br>\n", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.manova" <- function (x, digits = getOption("digits"),file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (length(stats <- x$stats)) {
HTML.anova(stats,file=file)
}
else {
HTML("<p>No error degrees of freedom</p>\n")
HTML(data.frame(Df = x$Df, row.names = x$row.names),file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.table" <- function (x, digits = max(1, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!inherits(x, "summary.table"))
stop("x must inherit from class `summary.table'")
if (!is.null(x$call)) {
HTMLli(paste("Call:<font class='call'> ", x$call,"</font>"),file=file)
}
HTMLli(paste("Number of cases in table:<b>", x$n.cases, "</b>\n<br>"),file=file)
HTMLli(paste("Number of factors:<b>", x$n.vars, "</b>\n<br>"),file=file)
if (x$n.vars > 1) {
HTMLli("Test for independence of all factors:\n<br>",file=file)
ch <- x$statistic
HTML(paste(" Chisq = <b>", format(round(ch, max(0, digits - log10(ch)))),
"</b>, df = <b>", x$parameter, "</b>, p-value = <b>", format.pval(x$p.value,
digits, eps = 0), "</b>\n<br>", sep = ""),file=file)
if (!x$approx.ok)
HTML("<p>Chi-squared approximation may be incorrect</p>\n",file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.TukeyHSD" <- function (x, file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<center><p><b>Tukey multiple comparisons of means</b></p>\n")
HTML(paste("<p>", format(100 * attr(x, "conf.level"), 2), "% family-wise confidence level</p></center>\n",
sep = ""),file=file)
if (attr(x, "ordered"))
HTML("<center><p>factor levels have been ordered</p></center>\n",file=file)
HTMLli(paste("Fit: ", deparse(attr(x, "orig.call")), "\n<br>\n", sep = ""),file=file)
attr(x, "orig.call") <- attr(x, "conf.level") <- attr(x, "ordered") <- NULL
lapply(unclass(x),HTML,file=file,append=TRUE,...)
#HTML.default(unclass(x), file=file,...)
invisible(return(x))
}
#----------------------------------------------------------------------------------------------------#
"HTML.simple.list" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(noquote(cbind("<-" = unlist(x))), file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.noquote" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- attr(x, "class"))) {
cl <- cl[cl != "noquote"]
attr(x, "class") <- (if (length(cl) > 0)
cl
else NULL)
}
HTML(x, file=file, append=TRUE,...)
}
###
### PACKAGES FUNCTIONS
###
### PACKAGE TS
#----------------------------------------------------------------------------------------------------#
"HTML.ar" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call:\n<font class='call'>", deparse(x$call), "</font>\n", sep = ""),file=file)
nser <- NCOL(x$var.pred)
if (nser > 1) {
if (!is.null(x$x.intercept))
res <- x[c("ar", "x.intercept", "var.pred")]
else res <- x[c("ar", "var.pred")]
res$ar <- aperm(res$ar, c(2, 3, 1))
HTML(res, digits = digits,file=file)
}
else {
if (x$order > 0) {
HTMLli("Coefficients:\n",file=file)
coef <- drop(round(x$ar, digits = digits))
names(coef) <- seq(length = x$order)
HTML.default(coef, file=file)
}
if (!is.null(xint <- x$x.intercept) && !is.na(xint))
HTML(paste("<p>Intercept: <b>", format(xint, digits = digits),
"</b> (", format(x$asy.se.coef$x.mean, digits = digits),
") ", "\n</p>", sep = ""),file=file)
HTML(paste("<p>Order selected <b>", x$order, " </b>sigma^2 estimated as <b>",
format(x$var.pred, digits = digits), "</b>\n<</p>"),file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.Arima" <- function (x, digits = max(3, getOption("digits") - 3), se = TRUE,
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("nCall:<font class='call'>", deparse(x$call, width.cutoff = 75), "</font>", sep = "\n"),file=file)
HTMLli("Coefficients:\n<br>",file=file)
coef <- round(x$coef, digits = digits)
if (se && nrow(x$var.coef)) {
ses <- rep(0, length(coef))
ses[x$mask] <- round(sqrt(diag(x$var.coef)), digits = digits)
coef <- matrix(coef, 1, dimnames = list(NULL, names(coef)))
coef <- rbind(coef, s.e. = ses)
}
HTML.default(coef,file=file)
cm <- x$call$method
if (is.null(cm) || cm != "CSS")
HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: log likelihood = <b>", format(round(x$loglik, 2)),
"</b>, aic = <b>", format(round(x$aic, 2)), "</b>\n</p>", sep = ""),file=file)
else HTML("<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: part log likelihood =<b> ", format(round(x$loglik, 2)),
"</b>\n</p>", sep = "")
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.arima0" <- function (x, digits = max(3, getOption("digits") - 3), se = TRUE,
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:<font class='call'>", deparse(x$call, width.cutoff = 75), "</font>", sep = "\n"),file=file)
HTMLli("Coefficients:\n<br>",file=file)
coef <- round(x$coef, digits = digits)
if (se && nrow(x$var.coef)) {
ses <- rep(0, length(coef))
ses[x$mask] <- round(sqrt(diag(x$var.coef)), digits = digits)
coef <- matrix(coef, 1, dimnames = list(NULL, names(coef)))
coef <- rbind(coef, s.e. = ses)
}
HTML.default(coef, file=file)
cm <- x$call$method
if (is.null(cm) || cm != "CSS")
HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: log likelihood = <b>", format(round(x$loglik, 2)),
"</b>, aic = <b>", format(round(x$aic, 2)), "</b>\n</p>", sep = ""),file=file)
else HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: part log likelihood =<b> ", format(round(x$loglik, 2)),
"</b>\n</p>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.HoltWinters" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><b>Holt-Winters exponential smoothing", if (x$beta == 0)
"without"
else "with", "trend and", if (x$gamma == 0)
"without"
else paste(if (x$beta == 0)
"with ", x$seasonal, sep = ""), "seasonal componenent.\n</b></p>"),file=file)
HTMLli(paste("\nCall:\n", deparse(x$call), "\n<br>"),file=file)
HTMLli("Smoothing parameters:\n<ul>",file=file)
HTMLli(paste(" alpha: ", x$alpha, "\n"),file=file)
HTMLli(paste(" beta: ", x$beta, "\n"),file=file)
HTMLli(paste(" gamma: ", x$gamma, "\n<br>"),file=file)
HTML("</ul>",file=file)
HTMLli("Coefficients:\n",file=file)
HTML(t(t(x$coefficients)),file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.stl" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call:\n ",deparse(x$call),"\n<br>"),file=file)
HTMLli("\nComponents\n",file=file)
HTML(x$time.series, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.StructTS" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:", deparse(x$call, width.cutoff = 75), "\n", sep = " "),file=file)
HTMLli("Variances:\n",file=file)
HTML(x$coef, digits=digits,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tskernel" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- c(rev(x$coef[2:(x$m + 1)]), x$coef)
i <- -x$m:x$m
HTML(paste("<p>",attr(x, "name"), "</p>\n"),file=file)
HTML(paste( paste("coef[", format(i), "] = ", format(y, digits = digits),sep = ""),collapse="<br>\n", sep = "\n<br>"),file=file)
}
### PACKAGE CTEST
#----------------------------------------------------------------------------------------------------#
"HTML.pairwise.htest" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Pairwise comparisons using", x$method, "\n<br>\n<br>"),file=file)
HTMLli(paste("data: <font class=dataname>", x$data.name,"</font>", "\n<br>\n<br>"),file=file)
pp <- format.pval(x$p.value, 2, na.form = "-")
attributes(pp) <- attributes(x$p.value)
HTML(pp, file=file)
HTMLli(paste("\nP value adjustment method:", x$p.adjust.method, "\n"),file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.power.htest" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste(x$method,"<br>"), file=file)
note <- x$note
x[c("method", "note")] <- NULL
HTML(paste(paste(formatC(names(x), width = 15, flag = "+"),
format(x), sep = " = "), sep = "\n<br>",collapse="\n<br>"),file=file)
if (!is.null(note))
HTML(paste("\n<p>", "NOTE:", note, "\n</p>\n"),file=file)
else HTMLbr(file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.boot" <- function (x, digits = options()$digits, index = 1:ncol(boot.out$t), file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
boot.out <- x
sim <- boot.out$sim
cl <- boot.out$call
t <- matrix(boot.out$t[, index], nrow = nrow(boot.out$t))
allNA <- apply(t, 2, function(t) all(is.na(t)))
ind1 <- index[allNA]
index <- index[!allNA]
t <- matrix(t[, !allNA], nrow = nrow(t))
rn <- paste("t", index, "*", sep = "")
if (length(index) == 0)
op <- NULL
else if (is.null(t0 <- boot.out$t0)) {
if (is.null(boot.out$call$weights))
op <- cbind(apply(t, 2, mean, na.rm = TRUE), sqrt(apply(t,
2, function(t.st) var(t.st[!is.na(t.st)]))))
else {
op <- NULL
for (i in index) op <- rbind(op, boot::imp.moments(boot.out,
index = i)$rat)
op[, 2] <- sqrt(op[, 2])
}
dimnames(op) <- list(rn, c("mean", "std. error"))
}
else {
t0 <- boot.out$t0[index]
if (is.null(boot.out$call$weights)) {
op <- cbind(t0, apply(t, 2, mean, na.rm = TRUE) -
t0, sqrt(apply(t, 2, function(t.st) var(t.st[!is.na(t.st)]))))
dimnames(op) <- list(rn, c("original", " bias ",
" std. error"))
}
else {
op <- NULL
for (i in index) op <- rbind(op, boot::imp.moments(boot.out,
index = i)$rat)
op <- cbind(t0, op[, 1] - t0, sqrt(op[, 2]), apply(t,
2, mean, na.rm = TRUE))
dimnames(op) <- list(rn, c("original", " bias ",
" std. error", " mean(t*)"))
}
}
if (cl[[1]] == "boot") {
if (sim == "parametric")
HTML(as.title("PARAMETRIC BOOTSTRAP"),file=file)
else if (sim == "antithetic") {
if (is.null(cl$strata))
HTML(as.title("ANTITHETIC BOOTSTRAP"),file=file)
else
HTML(as.title("STRATIFIED ANTITHETIC BOOTSTRAP"),file=file)
}
else if (sim == "permutation") {
if (is.null(cl$strata))
HTML(as.title("DATA PERMUTATION"),file=file)
else HTML(as.title("STRATIFIED DATA PERMUTATION"),file=file)
}
else if (sim == "balanced") {
if (is.null(cl$strata) && is.null(cl$weights))
HTML(as.title("BALANCED BOOTSTRAP"),file=file)
else if (is.null(cl$strata))
HTML(as.title("BALANCED WEIGHTED BOOTSTRAP"),file=file)
else if (is.null(cl$weights))
HTML(as.title("STRATIFIED BALANCED BOOTSTRAP"),file=file)
else HTML(as.title("STRATIFIED WEIGHTED BALANCED BOOTSTRAP"),file=file)
}
else {
if (is.null(cl$strata) && is.null(cl$weights))
HTML(as.title("ORDINARY NONPARAMETRIC BOOTSTRAP"),file=file)
else if (is.null(cl$strata))
HTML(as.title("WEIGHTED BOOTSTRAP"),file=file)
else if (is.null(cl$weights))
HTML(as.title("STRATIFIED BOOTSTRAP"),file=file)
else HTML(as.title("STRATIFIED WEIGHTED BOOTSTRAP"),file=file)
}
}
else if (cl[[1]] == "tilt.boot") {
R <- boot.out$R
th <- boot.out$theta
if (sim == "balanced")
HTML(as.title("BALANCED TITLED BOOTSTRAP"),file=file)
else HTML(as.title("TILTED BOOTSTRAP"),file=file)
if ((R[1] == 0) || is.null(cl$tilt) || eval(cl$tilt))
HTML("<p>Exponential tilting used\n</p>",file=file)
else HTML("<p>Frequency Smoothing used\n</p>",file=file)
i1 <- 1
if (boot.out$R[1] > 0)
HTML(paste("<p>First", R[1], "replicates untilted,\n</p>"),file=file)
else {
HTML(paste("<p>First ", R[2], " replicates tilted to ",
signif(th[1], 4), ",\n</p>", sep = ""),file=file)
i1 <- 2
}
if (i1 <= length(th)) {
for (j in i1:length(th)) HTML(paste("<p>Next ", R[j +
1], " replicates tilted to ", signif(th[j], 4),
ifelse(j != length(th), ",\n", ".\n</p>"), sep = ""),file=file)
}
op <- op[, 1:3]
}
else if (cl[[1]] == "tsboot") {
if (!is.null(cl$indices))
HTML(as.title("TIME SERIES BOOTSTRAP USING SUPPLIED INDICES"),file=file)
else if (sim == "model")
HTML(as.title("MODEL BASED BOOTSTRAP FOR TIME SERIES"),file=file)
else if (sim == "scramble") {
HTML(as.title("PHASE SCRAMBLED BOOTSTRAP FOR TIME SERIES"),file=file)
if (boot.out$norm)
HTML("<p>Normal margins used.\n</p>",file=file)
else HTML("<p>Observed margins used.\n</p>",file=file)
}
else if (sim == "geom") {
if (is.null(cl$ran.gen))
HTML(as.title("STATIONARY BOOTSTRAP FOR TIME SERIES"),file=file)
else HTML(as.title("POST-BLACKENED STATIONARY BOOTSTRAP FOR TIME SERIES"),file=file)
HTML(paste("<p>Average Block Length of", boot.out$l,
"\n</p>"),file=file)
}
else {
if (is.null(cl$ran.gen))
HTML("<p>BLOCK BOOTSTRAP FOR TIME SERIES</p>",file=file)
else HTML("<p>POST-BLACKENED BLOCK BOOTSTRAP FOR TIME SERIES</p>",file=file)
HTML(paste("<p>Fixed Block Length of", boot.out$l, "\n</p>"),file=file)
}
}
else {
cat("\n")
if (sim == "weird") {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED BOOTSTRAP FOR CENSORED DATA"),file=file)
}
else if ((sim == "ordinary") || ((sim == "model") &&
is.null(boot.out$cox))) {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED CASE RESAMPLING BOOTSTRAP FOR CENSORED DATA"),file=file)
}
else if (sim == "model") {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED MODEL BASED BOOTSTRAP FOR COX REGRESSION MODEL"),file=file)
}
else if (sim == "cond") {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED CONDITIONAL BOOTSTRAP"),file=file)
if (is.null(boot.out$cox))
HTML("<p>FOR CENSORED DATA\n</p>\n",file=file)
else HTML("<p>FOR COX REGRESSION MODEL\n</p>\n",file=file)
}
}
HTMLli(paste("\nCall: ",deparse(cl)),file=file)
HTMLli("Bootstrap Statistics :\n<br>",file=file)
if (!is.null(op))
HTML(op, digits = digits,file=file)
if (length(ind1) > 0)
for (j in ind1) HTML(paste("<p>WARNING: All values of t",
j, "* are NA\n</p>", sep = ""),file=file)
invisible(boot.out)
}
#----------------------------------------------------------------------------------------------------#
"HTML.simplex" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
simp.out <- x
HTML("\n<p><b>Linear Programming Results\n</b></p>\n",file=file)
cl <- simp.out$call
HTMLli(paste("Call : ",deparse(cl)),file=file)
HTML(paste("<p>", if (simp.out$maxi) "Maximization" else "Minimization", " Problem with Objective Function Coefficients\n</p>"),file=file)
HTML(simp.out$obj,file=file)
if (simp.out$solved == 1) {
HTML("\n<p>\nOptimal solution has the following values\n</p>",file=file)
HTML(simp.out$soln,file=file)
HTML(paste("<p>The optimal value of the objective ", " function is ",
simp.out$value, ".\n</p>", sep = ""),file=file)
}
else if (simp.out$solved == 0) {
HTML("\n<p>\nIteration limit exceeded without finding solution\n</p>",file=file)
HTML("<p>The coefficient values at termination were\n</p>",file=file)
HTML(simp.out$soln,file=file)
HTML(paste("<p>The objective function value was ", simp.out$value,
".\n</p>", sep = ""),file=file)
}
else HTML("\n<p>No feasible solution could be found\n</p>",file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.saddle.distn" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
sad.d <- x
cl <- sad.d$call
rg <- range(sad.d$points[, 1])
mid <- mean(rg)
digs <- ceiling(log10(abs(mid)))
if (digs <= 0)
digs <- 4
else if (digs >= 4)
digs <- 0
else digs <- 4 - digs
rg <- round(rg, digs)
level <- 100 * sad.d$quantiles[, 1]
quans <- format(round(sad.d$quantiles, digs))
quans[, 1] <- paste( format(level), "% ", sep = "")
HTML("\n<p><b>Saddlepoint Distribution Approximations\n</b></p>\n",file=file)
HTMLli(paste("Call : ",paste(deparse(cl),collapse="")),file=file)
HTML("\n<p>Quantiles of the Distribution\n</p>",file=file)
HTML(t(t(quans)),file=file)
HTML(paste("\n<p>\nSmoothing spline used ", nrow(sad.d$points),
" points in the range ", rg[1], " to ", rg[2], ".</p>", sep = ""),file=file)
if (sad.d$LR)
HTMLli("Lugananni-Rice approximations used.",file=file)
HTMLbr(file=file)
invisible(sad.d)
}
#----------------------------------------------------------------------------------------------------#
"HTML.bootci" <- function (x, hinv = NULL, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
ci.out <- x
cl <- ci.out$call
ntypes <- length(ci.out) - 3
nints <- nrow(ci.out[[4]])
t0 <- ci.out$t0
if (!is.null(hinv))
t0 <- hinv(t0)
digs <- ceiling(log10(abs(t0)))
if (digs <= 0)
digs <- 4
else if (digs >= 4)
digs <- 0
else digs <- 4 - digs
intlabs <- NULL
basrg <- strg <- perg <- bcarg <- NULL
if (!is.null(ci.out$normal))
intlabs <- c(intlabs, " Normal ")
if (!is.null(ci.out$basic)) {
intlabs <- c(intlabs, " Basic ")
basrg <- range(ci.out$basic[, 2:3])
}
if (!is.null(ci.out$student)) {
intlabs <- c(intlabs, " Studentized ")
strg <- range(ci.out$student[, 2:3])
}
if (!is.null(ci.out$percent)) {
intlabs <- c(intlabs, " Percentile ")
perg <- range(ci.out$percent[, 2:3])
}
if (!is.null(ci.out$bca)) {
intlabs <- c(intlabs, " BCa ")
bcarg <- range(ci.out$bca[, 2:3])
}
level <- 100 * ci.out[[4]][, 1]
if (ntypes == 4)
n1 <- n2 <- 2
else if (ntypes == 5) {
n1 <- 3
n2 <- 2
}
else {
n1 <- ntypes
n2 <- 0
}
ints1 <- matrix(NA, nints, 2 * n1 + 1)
ints1[, 1] <- level
n0 <- 4
for (i in n0:(n0 + n1 - 1)) {
j <- c(2 * i - 6, 2 * i - 5)
nc <- ncol(ci.out[[i]])
nc <- c(nc - 1, nc)
if (is.null(hinv))
ints1[, j] <- ci.out[[i]][, nc]
else ints1[, j] <- hinv(ci.out[[i]][, nc])
}
n0 <- 4 + n1
ints1 <- format(round(ints1, digs))
ints1[, 1] <- paste("\n<br>", level, "% ", sep = "")
ints1[, 2 * (1:n1)] <- paste("(", ints1[, 2 * (1:n1)], ",",
sep = "")
ints1[, 2 * (1:n1) + 1] <- paste(ints1[, 2 * (1:n1) + 1],
") ")
if (n2 > 0) {
ints2 <- matrix(NA, nints, 2 * n2 + 1)
ints2[, 1] <- level
j <- c(2, 3)
for (i in n0:(n0 + n2 - 1)) {
if (is.null(hinv))
ints2[, j] <- ci.out[[i]][, c(4, 5)]
else ints2[, j] <- hinv(ci.out[[i]][, c(4, 5)])
j <- j + 2
}
ints2 <- format(round(ints2, digs))
ints2[, 1] <- paste("\n<br>", level, "% ", sep = "")
ints2[, 2 * (1:n2)] <- paste("(", ints2[, 2 * (1:n2)],
",", sep = "")
ints2[, 2 * (1:n2) + 1] <- paste(ints2[, 2 * (1:n2) +
1], ") ")
}
R <- ci.out$R
HTML(as.title("BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS"),file=file)
HTML(paste("<p>Based on", R, "bootstrap replicates\n\n</p>"),file=file)
HTMLli(paste("CALL : ",paste(deparse(cl),collapse=" ")),file=file)
HTML("\n<p>Intervals : </p>",file=file)
HTML(paste("\n<p>Level", intlabs[1:n1],"</p>"),file=file)
HTML(t(ints1),file=file)
if (n2 > 0) {
HTML(paste("\n<p>\nLevel", intlabs[(n1 + 1):(n1 + n2)],"</p>"),file=file)
HTML(t(ints2),file=file)
}
if (!is.null(cl$h)) {
if (is.null(cl$hinv) && is.null(hinv))
HTML("\n<p>Calculations and Intervals on Transformed Scale\n</p>",file=file)
else HTML("\n<p>Calculations on Transformed Scale; Intervals on Original Scale\n</p>",file=file)
}
else if (is.null(cl$hinv) && is.null(hinv))
HTML("\n<p>Calculations and Intervals on Original Scale\n</p>",file=file)
else HTML("\n<p>Calculations on Original Scale but Intervals Transformed\n</p>",file=file)
if (!is.null(basrg)) {
if ((basrg[1] <= 1) || (basrg[2] >= R))
HTML("\n<p>Warning : Basic Intervals used Extreme Quantiles\n</p>",file=file)
if ((basrg[1] <= 10) || (basrg[2] >= R - 9))
HTML("\n<p>Some basic intervals may be unstable\n</p>",file=file)
}
if (!is.null(strg)) {
if ((strg[1] <= 1) || (strg[2] >= R))
HTML("\n<p>Warning : Studentized Intervals used Extreme Quantiles\n</p>",file=file)
if ((strg[1] <= 10) || (strg[2] >= R - 9))
HTML("\n<p>Some studentized intervals may be unstable\n</p>",file=file)
}
if (!is.null(perg)) {
if ((perg[1] <= 1) || (perg[2] >= R))
HTML("\n<p>Warning : Percentile Intervals used Extreme Quantiles\n</p>",file=file)
if ((perg[1] <= 10) || (perg[2] >= R - 9))
HTML("\n<p>Some percentile intervals may be unstable\n</p>",file=file)
}
if (!is.null(bcarg)) {
if ((bcarg[1] <= 1) || (bcarg[2] >= R))
HTML("\n<p>Warning : BCa Intervals used Extreme Quantiles\n</p>",file=file)
if ((bcarg[1] <= 10) || (bcarg[2] >= R - 9))
HTML("\n<p>Some BCa intervals may be unstable\n</p>",file=file)
}
invisible(ci.out)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MVA (merged into stats)
#----------------------------------------------------------------------------------------------------#
"HTML.dist" <- function (x, diag = NULL, upper = NULL, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (is.null(diag))
diag <- if (is.null(a <- attr(x, "Diag")))
FALSE
else a
if (is.null(upper))
upper <- if (is.null(a <- attr(x, "Upper")))
FALSE
else a
size <- attr(x, "Size")
df <- as.matrix(x)
if (!upper)
df[row(df) < col(df)] <- NA
if (!diag)
df[row(df) == col(df)] <- NA
HTML(if (diag || upper)
df
else df[-1, -size], file=file, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.factanal" <- function (x, digits = 3, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:\n", deparse(x$call), "\n<br>\n", sep = ""),file=file)
HTMLli("Uniquenesses:\n<br>",file=file)
HTML(round(x$uniquenesses, digits),file=file,append=TRUE,...)
HTML(x$loadings, digits = digits,file=file,append=TRUE, ...)
p <- nrow(x$loadings)
factors <- x$factors
if (!is.na(x$n.obs) && x$dof > 0) {
dof <- x$dof
stat <- (x$n.obs - 1 - (2 * p + 5)/6 - (2 * factors)/3) *
x$criteria["objective"]
HTMLli(paste("\n<p>Test of the hypothesis that", factors, if (factors ==
1)
"factor is"
else "factors are", "sufficient.\n</p>"),file=file)
HTML(paste("<p>The chi square statistic is <b>", round(stat, 2), " </b> on <b>",
dof, if (dof == 1)
" </b>degree"
else "</b>degrees", "of freedom.\n<br>The p-value is <b>", signif(pchisq(stat,
dof, lower.tail = FALSE), 3), "</b>\n</p>"),file=file)
}
else {
HTML(paste("\n<p>The degrees of freedom for the model is <b>",
x$dof, " </b>and the fit was <b>", round(x$criteria["objective"],
4), "</b>\n</p>"),file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.loadings" <- function (x, digits = 3, cutoff = 0.1, sort = FALSE, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
Lambda <- unclass(x)
p <- nrow(Lambda)
factors <- ncol(Lambda)
if (sort) {
mx <- max.col(abs(Lambda))
ind <- cbind(1:p, mx)
mx[abs(Lambda[ind]) < 0.5] <- factors + 1
Lambda <- Lambda[order(mx, 1:p), ]
}
HTMLli("Loadings:\n<br>",file=file)
fx <- format(round(Lambda, digits))
names(fx) <- NULL
nc <- nchar(fx[1])
fx[abs(Lambda) < cutoff] <- paste(rep(" ", nc), collapse = "")
HTML(fx, file=file, ...)
vx <- colSums(x^2)
varex <- rbind("SS loadings" = vx)
if (is.null(attr(x, "covariance"))) {
varex <- rbind(varex, "Proportion Var" = vx/p)
if (factors > 1)
varex <- rbind(varex, "Cumulative Var" = cumsum(vx/p))
}
HTMLbr(file=file)
HTML(round(varex, digits),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.hclust" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(x$call))
HTMLli(paste("Call : ", deparse(x$call), "\n<ul>\n", sep = ""),file=file)
if (!is.null(x$method))
HTMLli(paste("Cluster method :", x$method, "\n"),file=file)
if (!is.null(x$dist.method))
HTMLli(paste("Distance : ", x$dist.method, "\n"),file=file)
HTMLli(paste("Number of objects: ", length(x$height) + 1, "\n"),file=file)
HTML("</ul><br> <br>",file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.prcomp" <- function (x, print.x = FALSE, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Standard deviations:\n</p>",file=file,append=TRUE)
HTML(x$sdev, file=file,append=TRUE,...)
HTML("\n<p>Rotation:\n</p>")
HTML(x$rotation, file=file,append=TRUE,...)
if (print.x && length(x$x)) {
HTML("\n<p>Rotated variables:\n</p>")
HTML(x$x, file=file,append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.princomp" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call: <font class=call>",deparse(x$call),"</font>"),file=file)
HTML("\n<p>Standard deviations:\n</p>",file=file)
HTML(t(as.matrix(x$sdev)), file=file,append=TRUE,...)
HTML(paste("\n<p><b>", length(x$scale), " </b>variables and <b>", x$n.obs, " </b>observations.\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.prcomp" <- function (x, digits = min(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Importance of components:\n</p>",file=file)
HTML(x$importance, digits = digits,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.princomp" <- function (x, digits = 3, loadings = x$print.loadings, cutoff = x$cutoff, file=get(".HTML.file"), append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
vars <- x$sdev^2
vars <- vars/sum(vars)
HTML("<p>Importance of components:\n</p>",file=file)
HTML(rbind("Standard deviation" = x$sdev, "Proportion of Variance" = vars,
"Cumulative Proportion" = cumsum(vars)),file=file)
if (loadings) {
HTMLli("Loadings:\n",file=file)
cx <- format(round(x$loadings, digits = digits))
cx[abs(x$loadings) < cutoff] <- substring(" ",
1, nchar(cx[1, 1]))
HTML(cx, quote = FALSE, file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE EDA (merged into stats)
#----------------------------------------------------------------------------------------------------#
"HTML.medpolish" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("\n<p><b>Median Polish Results (Dataset: \"", x$name, "\")\n</b></p>",
sep = ""),file=file)
HTML(paste("\n<p>Overall:", x$overall, "\n</p>\n<p>Row Effects:\n</p>"),file=file)
HTML(x$row, digits = digits, file=file,append=TRUE,...)
HTML("\n<p>Column Effects:\n</p>",file=file)
HTML(x$col, digits = digits, file=file)
HTML("\n<p>Residuals:\n</p>",file=file)
HTML(x$residuals, digits = max(2, digits - 2), file=file)
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tukeyline" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call:\n", deparse(x$call), "\n<br>\n", sep = ""),file=file)
HTML("<p>Coefficients:\n</p>",file=file)
print.default(format(coef(x), digits = digits),file=file)
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tukeysmooth" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><b>",attr(x, "kind"), " Tukey smoother resulting from ", deparse(attr(x,
"call")), "\n", if (twiced <- attr(x, "twiced")) " <-<-twiced<-<- ",
if (!is.null(it <- attr(x, "iter"))) paste(" used", it, "iterations\n"),
if (!is.null(ch <- attr(x, "changed"))) paste(if (!ch) " NOT ", " changed\n</b></p>")),file=file)
if (length(class(x)) > 1)
NextMethod()
else {
y <- x
attributes(y) <- NULL
HTML(y,file=file, append=TRUE)
invisible(x)
}
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE EDA (merged into stats)
#----------------------------------------------------------------------------------------------------#
#
# 2008-05-23: Removed by Fernando H Rosa. Class appears to no longer exist on package stats
#
#"HTML.grob" <- function (x, file=get(".HTML.file"),append=TRUE,...)
#{
# cat("\n",file=file,append=append,...)
# cl <- class(get.value.grob(x))
# HTML(paste(cl[1:(length(cl) - 1)], collapse = " "),file=file)
# invisible(x)
#}
#----------------------------------------------------------------------------------------------------#
"HTML.unit" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(as.character(x), file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.viewport" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(class(x),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE LATTICE
#----------------------------------------------------------------------------------------------------#
"HTML.shingle" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("\n<p>Data:\n</p>",file=file)
HTML(as.numeric(x),file=file)
l <- levels(x)
n <- nlevels(x)
if (n < 1)
HTML("\n<p>no intervals\n</p>",file=file)
else {
int <- data.frame(min = numeric(n), max = numeric(n),
count = numeric(n))
for (i in 1:n) {
int$min[i] <- l[[i]][1]
int$max[i] <- l[[i]][2]
int$count[i] <- length(x[x >= l[[i]][1] & x <= l[[i]][2]])
}
HTML("\n<p>Intervals:\n</p>",file=file)
HTML(int,file=file)
olap <- numeric(n - 1)
if (n > 2)
for (i in 1:(n - 1)) olap[i] <- length(x[x >= l[[i]][1] &
x <= l[[i]][2] & x >= l[[i + 1]][1] & x <= l[[i +
1]][2]])
HTML("\n<p>Overlap between adjacent intervals:\n</p>",file=file)
HTML(olap,file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.shingleLevel" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(do.call("rbind", x),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MASS
#----------------------------------------------------------------------------------------------------#
"HTML.abbrev" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (is.list(x))
x <- unlist(x)
NextMethod("HTML")
}
#----------------------------------------------------------------------------------------------------#
"HTML.Anova" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
heading <- attr(x, "heading")
if (!is.null(heading))
HTML(paste("<p>",heading,"</p>", sep = " ",collapse="<br>"),file=file)
attr(x, "heading") <- NULL
HTML.data.frame(x,file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.anova.loglm" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- x
y[, 5] <- round(y[, 5], 5)
R <- array("", dim(x), dimnames(x))
for (j in 1:5) {
colj <- c(colnames(x)[j], format(y[, j]))
R[, j] <- colj[-1]
colnames(R)[j] <- colj[1]
}
R[1, 3:5] <- ""
forms <- attr(x, "formulae")
HTML("<p><b>LR tests for hierarchical log-linear models</b>\n</p>\n",file=file)
for (i in seq(along = forms))
HTML(paste(paste("<p>Model ", i, ":<br>", sep = ""), paste(deparse(forms[[i]]),collapse=""), "</p>"),file=file)
HTMLbr(file=file)
HTML(R,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.correspondence" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p>First canonical correlation(s):", format(x$cor, ...), "\n</p>"),file=file)
rcn <- names(dimnames(x$Freq))
HTML(paste("\n<p>", rcn[1], "scores:\n</p>"),file=file)
HTML(x$rscore,file=file)
HTML(paste("\n<p>", rcn[2], "scores:\n</p>"),file=file)
HTML(x$cscore,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.fitdistr" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
ans <- format(rbind(x$estimate, x$sd), digits = digits)
ans[1, ] <- sapply(ans[1, ], function(x) paste("", x))
ans[2, ] <- sapply(ans[2, ], function(x) paste("(", x, ")",
sep = ""))
dn <- dimnames(ans)
dn[[1]] <- rep("", 2)
dn[[2]] <- paste(substring(" ", 1, (nchar(ans[2, ]) -
nchar(dn[[2]]))%/%2), dn[[2]])
dn[[2]] <- paste(dn[[2]], substring(" ", 1, (nchar(ans[2,
]) - nchar(dn[[2]]))%/%2))
dimnames(ans) <- dn
HTML(ans, file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.fractions" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- attr(x, "fracs")
att <- attributes(x)
att$fracs <- att$class <- NULL
x <- do.call("structure", c(list(y), att))
NextMethod("HTML", file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.gamma.shape" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- x
x <- array(unlist(x), dim = 2:1, dimnames = list(c("Alpha ", "SE "), ""))
NextMethod("HTML",file=file)
invisible(y)
}
#----------------------------------------------------------------------------------------------------#
"HTML.glm.dose" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
M <- cbind(x, attr(x, "SE"))
dimnames(M) <- list(names(x), c("Dose", "SE"))
x <- M
NextMethod("HTML",file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.lda" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
names(cl)[2] <- ""
HTMLli(paste("Call: ",deparse(cl)),file=file)
}
HTML("\n<p>Prior probabilities of groups:\n</p>",file=file)
HTML(x$prior, file=file,...)
HTML("\n<p>Group means:\n</p>",file=file)
HTML(x$means, file=file,...)
HTML("\n<p>Coefficients of linear discriminants:\n</p>",file=file)
HTML(x$scaling, file=file,...)
svd <- x$svd
names(svd) <- dimnames(x$scaling)[[2]]
if (length(svd) > 1) {
HTML("\n<p>Proportion of trace:\n</p>",file=file)
HTML(round(svd^2/sum(svd^2), 4), file=file,append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.loglm" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call: <font class=call>",deparse(x$call),"</font>"),file=file)
ts.array <- rbind(c(x$lrt, x$df, if (x$df > 0) 1 - pchisq(x$lrt,
x$df) else 1), c(x$pearson, x$df, if (x$df > 0) 1 - pchisq(x$pearson,
x$df) else 1))
dimnames(ts.array) <- list(c("Likelihood Ratio", "Pearson"),
c("X^2", "df", "P(> X^2)"))
HTML("\n<p>Statistics:\n</p>",file=file)
HTML(ts.array,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.mca" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",deparse(cl)),file=file)
HTML(paste("\n<p>Multiple correspondence analysis of <b>", nrow(x$rs),
" </b>cases of <b> ", x$p, " </b>factors\n</p>"),file=file)
p <- 100 * cumsum(x$d)/(x$p - 1)
HTML(paste("\n<p>Correlations ",paste(round(x$d, 3),collapse=" ")," cumulative % explained ", paste(round(p, 2),collapse=" "),"</p>" ),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.polr" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",deparse(cl)),file=file)
if (length(coef(x))) {
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(coef(x), file=file,append=TRUE,...)
}
else {
HTML("\n<p>No coefficients\n</p>",file=file)
}
HTML("\n<p>Intercepts:\n</p>",file=file)
HTML(x$zeta, file=file,append=TRUE,...)
HTML(paste("\n<p>Residual Deviance: <b>", format(x$deviance, nsmall = 2), "</b>\n</p>"),file=file)
HTML(paste("<p>AIC:<b>", format(x$deviance + 2 * x$edf, nsmall = 2), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.qda" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
names(cl)[2] <- ""
HTMLli(paste("Call: ",deparse(cl)),file=file)
}
HTML("\n<p>Prior probabilities of groups:\n</p>",file=file)
HTML(x$prior, file=file,...)
HTML("\n<p>Group means:\n</p>",file=file)
HTML(x$means, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ridgelm" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
scaledcoef <- t(as.matrix(x$coef/x$scales))
if (x$Inter) {
inter <- x$ym - scaledcoef %*% x$xm
scaledcoef <- cbind(Intercept = inter, scaledcoef)
}
HTML(drop(scaledcoef), file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.rlm" <- function (x,file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call: ",paste(deparse(cl),collapse=" ")),file=file)
}
if (x$converged)
HTML(paste("<p>Converged in <b>", length(x$conv), "</b> iterations\n</p>"),file=file)
else HTML(paste("<p>Ran <b>", length(x$conv), " </b>iterations without convergence\n</p>"),file=file)
coef <- x$coef
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(coef, file=file,append=TRUE,...)
nobs <- length(x$resid)
rdf <- nobs - length(coef)
HTML(paste("\n<p>Degrees of freedom: <b>", nobs, " </b>total; <b>", rdf, " </b>residual\n</p>"),file=file)
HTML(paste("<p>Scale estimate:<b>", paste(format(signif(x$s, 3)),collapse=" "), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.rms.curv" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><li>Parameter effects: c^theta x sqrt(FALSE) =<b>", round(x$pe,
4), "</b>\n<br><li>", "Intrinsic: c^iota x sqrt(FALSE) =<b>", round(x$ic,
4), "\n</b></p>"),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.loglm" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Formula:\n</p>",file=file)
HTML(formula(x),file=file)
HTML("\n<p>Statistics:\n</p>",file=file)
HTML(x$tests,file=file)
if (!is.null(x$oe)) {
HTML("\n<p>Observed (Expected):\n</p>",file=file)
HTML(x$oe, file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.negbin" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
NextMethod(x,file=file)
dp <- 2 - floor(log10(x$SE.theta))
HTML(paste("<p><li>Theta:<b> ", round(x$theta, dp), "</b>\n<li>Std. Err.:<b> ", round(x$SE.theta, dp), "</b>\n</p>"),file=file)
if (!is.null(x$th.warn))
HTML(paste("<p>Warning while fitting theta:", x$th.warn, "\n</p>"),file=file)
HTML(paste("\n<p><li> 2 x log-likelihood: ", format(round(x$twologlik, 3), nsmall = dp), "\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.polr" <- function (x, digits = x$digits, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call: ",deparse(cl)),file=file)
}
coef <- format(round(x$coef, digits = digits))
pc <- x$pc
if (pc > 0) {
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(x$coef[seq(len = pc), ], file=file,append=TRUE, ...)
}
else {
HTML("\n<p>No coefficients\n</p>",file=file)
}
HTML("\n<p>Intercepts:\n</p>",file=file)
HTML(coef[(pc + 1):nrow(coef), ], file=file,append=TRUE, ...)
HTML(paste("\n<p>Residual Deviance:<b>", format(x$deviance, nsmall = 2), "</b>\n</p>"),file=file)
HTML(paste("\n<p>AIC:<b>", format(x$deviance + 2 * x$edf, nsmall = 2), "</b>\n</p>"),file=file)
if (!is.null(correl <- x$correlation)) {
cat("\n<p>Correlation of Coefficients:\n</p>",file=file)
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
correl[!ll] <- ""
HTML(correl[-1, -ncol(correl)], file=file, append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.rlm" <- function (x, digits = max(3, .Options$digits - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall: ",deparse(x$call)),file=file)
resid <- x$residuals
df <- x$df
rdf <- df[2]
if (rdf > 5) {
HTML("<p>Residuals:\n</p>",file=file)
if (length(dim(resid)) == 2) {
rq <- apply(t(resid), 1, quantile)
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q",
"Max"), colnames(resid))
}
else {
rq <- quantile(resid)
names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
}
HTML(rq, file=file)
}
else if (rdf > 0) {
HTML("<p>Residuals:\n</p>",file=file)
HTML(resid,file=file)
}
if (nsingular <- df[3] - df[1])
HTML(paste("\n<p>Coefficients: (", nsingular, " not defined because of singularities)\n</p>",sep = ""),file=file)
else HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(format(round(x$coef, digits = digits)), file=file)
HTML(paste("\n<p>Residual standard error:<b>", format(signif(x$sigma,
digits)), " </b>on <b> ", rdf, " </b>degrees of freedom\n</p>"),file=file)
if (!is.null(correl <- x$correlation)) {
p <- dim(correl)[2]
if (p > 1) {
HTML("\n<p>Correlation of Coefficients:\n</p>",file=file)
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
correl[!ll] <- ""
HTML(correl[-1, -p, drop = FALSE], file=file)
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE NNET
#----------------------------------------------------------------------------------------------------#
"HTML.multinom" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call: ",paste(deparse(cl),collapse="")),file=file)
}
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(coef(x), file=file)
HTML(paste("\n<p>Residual Deviance: <b>", format(x$deviance), "</b>\n</p>"),file=file)
HTML(paste("<p>AIC:<b>", format(x$AIC), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.nnet" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!inherits(x, "nnet"))
stop("Not legitimate a neural net fit")
HTML(paste("<p><b>a ", x$n[1], "-", x$n[2], "-", x$n[3], " network with ", length(x$wts), " weights.</b></p>", sep = ""),file=file)
if (length(x$coefnames))
HTML(paste("<p>inputs:", x$coefnames, "\noutput(s):", deparse(formula(x)[[2]]), "\n</p>"),file=file)
HTML("<p>options were -</p>",file=file)
tconn <- diff(x$nconn)
if (tconn[length(tconn)] > x$n[2] + 1)
HTMLli(" skip-layer connections ",file=file)
if (x$nunits > x$nsunits && !x$softmax)
HTMLli(" linear output units ",file=file)
if (x$entropy)
HTMLli(" entropy fitting ",file=file)
if (x$softmax)
HTMLli(" softmax modelling ",file=file)
if (x$decay[1] > 0)
HTMLli(paste(" decay=", x$decay[1], sep = ""),file=file)
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.multinom" <- function (x, digits = x$digits, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
}
HTML("\n<p>Coefficients:\n</p>",file=file)
if (x$is.binomial) {
HTML(cbind(Values = x$coefficients, "Std. Err." = x$standard.errors,
"Value/SE" = x$Wald.ratios), file=file)
}
else {
HTML(x$coefficients, file=file)
HTML("\n<p>Std. Errors:\n</p>",file=file)
HTML(x$standard.errors, file=file)
if (!is.null(x$Wald.ratios)) {
HTML("\n<O>Value/SE (Wald statistics):\n</p>",file=file)
HTML(x$coefficients/x$standard.errors, file=file)
}
}
HTML(paste("\n<p>Residual Deviance:<b>", format(x$deviance), "</b>\n</p>"),file=file)
HTML(paste("\n<p>AIC:<b>", format(x$AIC), "</b>\n</p>"),file=file)
if (!is.null(correl <- x$correlation)) {
p <- dim(correl)[2]
if (p > 1) {
HTML("\n</p>Correlation of Coefficients:\n</p>",file=file)
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
correl[!ll] <- ""
HTML(correl[-1, -p], file= file)
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.nnet" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><b>a ", x$n[1], "-", x$n[2], "-", x$n[3], " network with ", length(x$wts), " weights.</b></p>", sep = ""),file=file)
HTML("<p>options were -</p>",file=file)
tconn <- diff(x$nconn)
if (tconn[length(tconn)] > x$n[2] + 1)
HTMLli(" skip-layer connections ",file=file)
if (x$nunits > x$nsunits && !x$softmax)
HTMLli(" linear output units ",file=file)
if (x$entropy)
HTMLli(" entropy fitting ",file=file)
if (x$softmax)
HTMLli(" softmax modelling ",file=file)
if (x$decay[1] > 0)
HTMLli(paste(" decay=", x$decay[1], sep = ""),file=file)
wts <- format(round(nnet(x), 2))
lapply(split(wts, rep(1:x$nunits, tconn)), function(x) HTML(x,file=file))
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE CLUSTER
#----------------------------------------------------------------------------------------------------#
"HTML.agnes" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file,append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0)
x$order.lab
else x$order, file=file,append=TRUE, ...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE,...)
HTML("<p>Agglomerative coefficient:\n</p>",file=file)
HTML(x$ac, file=file,append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.clara" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Best sample:\n</p>",file=file)
HTML(x$sample, file=file, append=TRUE,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids, file=file,append=TRUE,...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering, file=file,append=TRUE,...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective, file=file,append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.diana" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file,append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0) x$order.lab else x$order, file= file, append=TRUE,...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE,...)
HTML("<p>Divisive coefficient:\n</p>",file=file)
HTML(x$dc,file=file, append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.dissimilarity" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Dissimilarities :\n</p>",file=file)
HTML(as.vector(x),file=file,append=TRUE, ...)
if (!is.null(attr(x, "na.message")))
HTML(paste("<p>Warning : ", attr(x, "NA.message"), "\n</p>"),file=file)
HTML(paste("<p>Metric : ", attr(x, "Metric"), "\n</p>"),file=file)
HTML(paste("<p>Number of objects : ", attr(x, "Size"), "\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ellipsoid" <- function (x, digits = max(1, getOption("digits") - 2), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
d <- length(x$loc)
HTML(paste("<p>`ellipsoid' in <b> ", d, " </b>dimensions:<br> center = (<b>", paste(format(x$loc,
digits = digits),collapse=" "), "</b>); squared ave.radius d^2 = <b>", format(x$d2,
digits = digits), " </b>\n<br> and shape matrix =\n</p>"),file=file)
HTML(x$cov, file=file, append=TRUE,...)
HTML(paste("<p> hence,", if (d == 2)
" area "
else " volume ", " = <b>", format(cluster::volume(x), digits = digits),
"\n</b></p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.fanny" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(x$objective, file=file,append=TRUE,...)
HTML("<p>Membership coefficients:\n</p>", file=file)
HTML(x$membership, file=file,append=TRUE, ...)
HTML("<p>Coefficients:\n</p>", file=file)
HTML(x$coeff, file=file, append=TRUE,...)
HTML("<p>Closest hard clustering:\n</p>", file=file)
HTML(x$clustering, file=file,append=TRUE, ...)
HTML("\n<p>Available components:\n</p>", file=file)
HTML(names(x), file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.mona" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Revised data:\n</p>",file=file)
HTML(x$data,file=file, append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0) x$order.lab else x$order,file=file, append=TRUE,...)
HTML("<p>Variable used:\n</p>",file=file)
HTML(x$variable, file=file, append=TRUE,...)
HTML("<p>Separation step:\n</p>",file=file)
HTML(x$step,file=file, append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.pam" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids,file=file, append=TRUE,...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering,file=file, append=TRUE,...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective,file=file, append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.agnes" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file, append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0)
x$order.lab
else x$order, file=file, append=TRUE,...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE, ...)
HTML("<p>Agglomerative coefficient:\n</p>",file=file)
HTML(x$ac, file=file, append=TRUE,...)
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE,...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.clara" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Best sample:\n</p>",file=file)
HTML(x$sample, file=file, append=TRUE,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids, file=file, append=TRUE,...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering, file=file,append=TRUE, ...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective, file=file,append=TRUE, ...)
HTML("<p>\nNumerical information per cluster:\n</p>",file=file)
HTML(x$clusinfo, file=file, append=TRUE,...)
if (length(x$silinfo) != 0) {
HTML("<p>\nSilhouette plot information for best sample:\n</p>",file=file)
HTML(x$silinfo[[1]], file=file,append=TRUE, ...)
HTML("<p>Average silhouette width per cluster:\n</p>",file=file)
HTML(x$silinfo[[2]], file=file,append=TRUE, ...)
HTML("<p>Average silhouette width of best sample:\n</p>",file=file)
HTML(x$silinfo[[3]], file=file,append=TRUE, ...)
}
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE,...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.diana" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file, append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0)
x$order.lab
else x$order, file=file, append=TRUE,...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE, ...)
HTML("<p>Divisive coefficient:\n</p>",file=file)
HTML(x$dc, file=file, append=TRUE,...)
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file,append=TRUE, ...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.fanny" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(x$objective, file=file, append=TRUE,...)
HTML("<p>Membership coefficients:\n</p>",file=file)
HTML(x$membership, file=file, append=TRUE, ...)
HTML("<p>Coefficients:\n</p>",file=file)
HTML(x$coeff, file=file, append=TRUE, ...)
HTML("<p>Closest hard clustering:\n</p>",file=file)
HTML(x$clustering, file=file, append=TRUE, ...)
if (length(x$silinfo) != 0) {
HTML("<p>\nSilhouette plot information:\n</p>",file=file)
HTML(x$silinfo[[1]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width per cluster:\n</p>",file=file)
HTML(x$silinfo[[2]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width of total data set:\n</p>",file=file)
HTML(x$silinfo[[3]], file=file, append=TRUE, ...)
}
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE, ...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file, append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.mona" <- function(x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML.mona(x, file=file, append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.pam" <- function(x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file,append=append,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids, file=file, append=TRUE, ...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering, file=file, append=TRUE, ...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective, file=file, append=TRUE, ...)
HTML("<p>\nNumerical information per cluster:\n</p>",file=file)
HTML(x$clusinfo, file=file, append=TRUE, ...)
HTML("<p>\nIsolated clusters:\n</p>",file=file)
HTML("<p>L-clusters: ")
HTML(names(x$isolation[x$isolation == "L"]),
...)
HTML("<p>L*-clusters: ")
HTML(names(x$isolation[x$isolation == "L*"]),
...)
if (length(x$silinfo) != 0) {
HTML("<p>\nSilhouette plot information:\n</p>",file=file)
HTML(x$silinfo[[1]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width per cluster:\n</p>",file=file)
HTML(x$silinfo[[2]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width of total data set:\n</p>",file=file)
HTML(x$silinfo[[3]], file=file, append=TRUE, ...)
}
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE, ...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file, append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MGCV
#----------------------------------------------------------------------------------------------------#
"HTML.gam" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML(x$family,file=file)
HTML("<p>Formula:\n</p>",file=file)
HTML(x$formula,file=file)
if (x$dim == 0)
HTML(paste("<p>Total model degrees of freedom <b>", x$nsdf, " </b>\n</p>"),file=file)
else HTML(paste("\n<p>Estimated degrees of freedom:<b>", paste(x$edf,collapse=" , "), "</b> total = <b>",
paste(sum(x$edf) + x$nsdf,collapse=" , "), "</b>\n</p>"),file=file)
gcv <- x$df.null * x$sig2/(x$df.null - sum(x$edf) - x$nsdf)
HTML("\n<p>GCV score:</p> ",file=file)
HTML(gcv,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.gam" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML(x$family,file=file)
HTML("<p>Formula:\n</p>",file=file)
HTML(x$formula,file=file)
if (length(x$p.coeff) > 0) {
HTML("\n<p>Parametric coefficients:\n</p>",file=file)
width <- max(nchar(names(x$p.coeff)))
HTML("\n<p align=center><table cellspacing=0 border=1><td><table cellspacing=0> <tr class= firstline > <th></th><th>Estimate</th><th>std.err.</th><th>t ratio</th><th>Pr(>|t[)</th></tr>\n",file=file)
for (i in 1:length(x$p.coeff)) HTML(paste("<tr><td class=firstcolumn>",formatC(names(x$p.coeff)[i], width = width),"</td><td class=\"CellInside\">", formatC(x$p.coeff[i], width = 10,digits = 5),"</td><td class=\"CellInside\">", formatC(x$se[i], width = 10, digits = 4),"</td><td class=\"CellInside\">",formatC(x$p.t[i], width = 10, digits = 4), "</td><td class=\"CellInside\">",format.pval(x$p.pv[i]),"</td></tr>\n", sep = ""),file=file)
HTML("\n</table></td></table></center>",file=file)
}
HTMLbr( file=file)
if (x$m > 0) {
HTML("<p>Approximate significance of smooth terms:\n</p>",file=file)
width <- max(nchar(names(x$chi.sq)))
HTML("\n<p align=center><table cellspacing=0 border=1><td><table cellspacing=0> <tr class= firstline > <th></th><th>edf</th><th>chi.sq</th><th>p-value</th></tr>\n",file=file)
for (i in 1:x$m)
HTML(paste("<tr><td class=firstcolumn>",formatC(names(x$chi.sq)[i], width = width),
"</td><td class=CellInside>", formatC(x$edf[i], width = 10, digits = 4), "</td><td class=CellInside>",
formatC(x$chi.sq[i], width = 10, digits = 5),"</td><td class=CellInside>",
format.pval(x$s.pv[i]), "</td></tr>\n", sep = ""),file=file)
HTML("\n</table></td></table></center>",file=file)
}
HTML(paste("\n<p>Adjusted r-sq. = <b>", formatC(x$r.sq, digits = 3, width = 5),
" </b> GCV score = <b>", formatC(x$gcv, digits = 5), "</b> \n<br>Scale estimate = <b>",
formatC(x$scale, digits = 5, width = 8, flag = "-"),
" </b> n = <b>", x$n, "</b>\n</p>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE RPART
#----------------------------------------------------------------------------------------------------#
"HTML.rpart" <- function (x, minlength = 0, spaces = 2, cp, digits = getOption("digits"),
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!inherits(x, "rpart"))
stop("Not legitimate rpart object")
if (!is.null(x$frame$splits))
x <- rpart::rpconvert(x)
if (!missing(cp))
x <- rpart::prune.rpart(x, cp = cp)
frame <- x$frame
ylevel <- attr(x, "ylevels")
node <- as.numeric(row.names(frame))
# tree.depth is not exported by rpart anymore. Defining it locally:
"Inttree.depth" <-
function (nodes)
{
depth <- floor(log(nodes, base = 2) + 1e-7)
as.vector(depth - min(depth))
}
depth <- Inttree.depth(node)
indent <- paste(rep(" ", spaces * 32), collapse = " ")
if (length(node) > 1) {
indent <- substring(indent, 1, spaces * seq(depth))
indent <- paste(c("", indent[depth]), format(node), ")",
sep = "")
}
else indent <- paste(format(node), ")", sep = "")
tfun <- (x$functions)$print
if (!is.null(tfun)) {
if (is.null(frame$yval2))
yval <- tfun(frame$yval, ylevel, digits)
else yval <- tfun(frame$yval2, ylevel, digits)
}
else yval <- format(signif(frame$yval, digits = digits))
term <- rep(" ", length(depth))
term[frame$var == "<leaf>"] <- "*"
z <- labels(x, digits = digits, minlength = minlength, ...)
n <- frame$n
z <- paste(indent, z, n, format(signif(frame$dev, digits = digits)),
yval, term)
omit <- x$na.action
if (length(omit))
HTML(paste("<p>n=<b>", n[1], "</b> (", naprint(omit), ")\n</p>\n", sep = ""),file=file)
else HTML(paste("<p>n=<b>", n[1], "</b>\n</p>\n"),file=file)
if (x$method == "class")
HTML("<p>node), split, n, loss, yval, (yprob)\n</p>",file=file)
else HTML("<p>node), split, n, deviance, yval\n</p>",file=file)
HTML("<p> * denotes terminal node\n\n</p>",file=file)
HTML(paste("<xmp>", paste(z, sep = "\n",collapse="\n"),"</xmp>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MODREG
#----------------------------------------------------------------------------------------------------#
"HTML.loess" <- function (x, digits = max(3, getOption("digits") - 3),file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",paste(deparse(cl),collapse=" ")),file=file)
HTML(paste("\n<p>Number of Observations:<b>", x$n, "</b>\n</p>"),file=file)
HTML(paste("<p>Equivalent Number of Parameters:<b>", format(round(x$enp,
2)), "</b>\n</p>"),file=file)
HTML(paste("<p>Residual", if (x$pars$family == "gaussian")
" Standard Error: <b>"
else " Scale Estimate:<b> ", format(signif(x$s, digits)), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ppr" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
mu <- x$mu
ml <- x$ml
HTML("\n<p>Goodness of fit:\n</p>",file=file)
gof <- x$gofn
names(gof) <- paste(1:ml, "terms")
HTML(format(gof[mu:ml], ...), file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.smooth.spline" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
ip <- x$iparms
cv <- cl$cv
if (is.null(cv))
cv <- FALSE
else if (is.name(cv))
cv <- eval(cv)
HTML(paste("\n<p>Smoothing Parameter spar=<b>", format(x$spar, digits = digits),
"</b> lambda=<b>", format(x$lambda, digits = digits),"</b>", if (ip["ispar"] !=
1) paste("(", ip["iter"], " iterations)", sep = ""), "\n</p>"),file=file)
HTML(paste("<p>Equivalent Degrees of Freedom (Df):<b>", format(x$df, digits = digits),
"</b>\n</p>"),file=file)
HTML(paste("<p>Penalized Criterion:<b>", format(x$pen.crit, digits = digits),
"</b>\n</p>"),file=file)
HTML(paste ("<p>",if (cv) "PRESS:"
else "GCV:", "<b>",format(x$cv.crit, digits = digits), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.loess" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
HTML(paste("\n<p>Number of Observations:<b>", x$n, "</b>\n</p>"),file=file)
HTML(paste("<p>Equivalent Number of Parameters:<b>", format(round(x$enp, 2)), "</b>\n</p>"),file=file)
if (x$pars$family == "gaussian")
HTML("<p>Residual Standard Error:</p>",file=file)
else HTML("<p>Residual Scale Estimate:</p>",file=file)
HTML(format(signif(x$s, digits)),file=file)
HTML("<p>Trace of smoother matrix:</p>",file=file)
HTML(format(round(x$trace.hat,2)), file=file)
HTML("\n<p>Control settings:\n</p><ul>",file=file)
HTMLli(paste("normalize: ", x$pars$normalize, "\n"),file=file)
HTMLli(paste(" span : ", format(x$pars$span), "\n"),file=file)
HTMLli(paste(" degree : ", x$pars$degree, "\n"),file=file)
HTMLli(paste(" family : ", x$pars$family),file=file)
if (x$pars$family != "gaussian")
HTMLli(paste(" iterations =", x$pars$iterations),file=file)
HTML("</ul>",file=file)
HTML(paste("\n<p> surface : ", x$pars$surface, if (x$pars$surface == "interpolate") paste(" cell =", format(x$pars$cell)),"</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.ppr" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML.ppr(x,file=file, ...)
mu <- x$mu
HTML("\n<p>Projection direction vectors:\n</p>",file=file)
HTML(format(x$alpha, ...),file=file)
HTML("\n<p>Coefficients of ridge terms:\n</p>",file=file)
HTML(format(x$beta, ...), file=file)
if (any(x$edf > 0)) {
HTML("\n<p>Equivalent df for ridge terms:\n</p>")
edf <- x$edf
names(edf) <- paste("term", 1:mu)
HTML(round(edf, 2),file=file, append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE SPLINES
#----------------------------------------------------------------------------------------------------#
"HTML.bSpline" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
value <- c(rep(NA, splines::splineOrder(x)), coef(x))
names(value) <- format(splines::splineKnots(x), digits = 5)
HTML(paste("<p> bSpline representation of spline", if (!is.null(form <- attr(x, "formula"))) paste (" for", paste(deparse(as.vector(form)),collapse=" ")) ,"</p>"),file=file)
HTML(value, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.polySpline" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
coeff <- coef(x)
dnames <- dimnames(coeff)
if (is.null(dnames[[2]]))
dimnames(coeff) <- list(format(splines::splineKnots(x)), c("constant",
"linear", "quadratic", "cubic", paste(4:29, "th",
sep = ""))[1:(dim(coeff)[2])])
HTML( paste( "<p>Polynomial representation of spline ", if (!is.null(form <- attr(x, "formula"))) paste(" for ", paste(deparse(as.vector(form)),collapse=" ") ) ,"</p>") ,file=file )
HTML(coeff, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ppolySpline" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML("<p>periodic </p>",file=file)
HTML(paste("\n<p>Period:<b>", format(x[["period"]]), "</b>\n</p>"),file=file)
NextMethod("HTML",file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE LSQ
#----------------------------------------------------------------------------------------------------#
"HTML.lqs" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
HTML("<p>Coefficients:\n</p>",file=file)
HTML.default(format(coef(x), digits = digits), file=file)
HTML(paste("\n<p>Scale estimates ", paste(format(x$scale, digits = digits),collapse=" "),
"\n\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE NLS
#----------------------------------------------------------------------------------------------------#
"HTML.nls" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML("<p><b>Nonlinear regression model\n</b></p>",file=file)
HTMLli(paste("Model: ", paste(deparse(formula(x)),collapse=" "), "\n"),file=file)
HTMLli(paste("Data: ", as.character(x$data), "\n"),file=file)
HTML(x$m$getAllPars(),file=file)
HTMLli(paste("Residual sum-of-squares: ", format(x$m$deviance()),"\n"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.nls" <- function (x, digits = max(3, getOption("digits") - 3), symbolic.cor = p >
4, signif.stars = getOption("show.signif.stars"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML(paste("<p>Formula:",paste(deparse(x$formula), collapse = " "),"</p>"),file=file)
df <- x$df
rdf <- df[2]
HTML("\n<p>Parameters:\n</p>",file=file)
HTML.coefmat(x$parameters, digits = digits, signif.stars = signif.stars,
file=file,append=TRUE,...)
HTML(paste("\n<p>Residual standard error:<b> ", format(signif(x$sigma,
digits)), " </b>on <b>", rdf, " </b>degrees of freedom\n</p>"),file=file)
correl <- x$correlation
if (!is.null(correl)) {
p <- dim(correl)[2]
if (p > 1) {
HTML("\n<p>Correlation of Parameter Estimates:\n</p>",file=file)
if (symbolic.cor)
HTML(symnum(correl)[-1, -p],file=file)
else {
correl[!lower.tri(correl)] <- NA
HTML(correl[-1, -p, drop = FALSE], file=file)
}
}
}
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE STEPFUN
#----------------------------------------------------------------------------------------------------#
"HTML.ecdf" <- function (x, digits = getOption("digits") - 2, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ")
HTML(paste("<p><b>Empirical CDF</b></p> \n<li>Call:<font class='call'> ", paste(deparse(attr(x, "call")),collapse=" "),"</font>"), file=file)
n <- length(xx <- eval(expression(x), envir = environment(x)))
i1 <- 1:min(3, n)
i2 <- if (n >= 4)
max(4, n - 1):n
else integer(0)
HTML(paste(" x[1:", n, "] = ", numform(xx[i1]), if (n > 3)
", ", if (n > 5)
" ..., ", numform(xx[i2]), "\n<br>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.stepfun" <- function (x, digits = getOption("digits") - 2, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ")
i1 <- function(n) 1:min(3, n)
i2 <- function(n) if (n >= 4)
max(4, n - 1):n
else integer(0)
HTML(paste("<p><b>Step function</b></p>\n<li>Call<font class='call'>: ",paste(deparse(attr(x, "call")) ,collapse=" "),"</font>"),file=file)
env <- environment(x)
n <- length(xx <- eval(expression(x), envir = env))
HTML(paste(" x[1:", n, "] = ", numform(xx[i1(n)]), if (n > 3)
", ", if (n > 5)
" ..., ", numform(xx[i2(n)]), "\n<br>", sep = ""),file=file)
y <- eval(expression(c(yleft, y)), envir = env)
HTML(paste(n + 1, " step heights = ", numform(y[i1(n + 1)]), if (n +
1 > 3)
", ", if (n + 1 > 5)
" ..., ", numform(y[i2(n + 1)]), "\n<br>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE SURVIVAL
#----------------------------------------------------------------------------------------------------#
"HTML.date" <- function (x, quote, prefix, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
y<-x
fun <- options()$print.date
if (is.null(fun)) x <- survival::date.ddmmmyy(x)
else x <- get(fun)(x)
if (missing(quote)) quote <- FALSE
HTML.atomic(x, file=file)
invisible(y)
}
#----------------------------------------------------------------------------------------------------#
"HTML.cox.zph" <- function (x, digits = max(options()$digits - 4, 3), file=get(".HTML.file"),append=TRUE,...)
HTML(x$table, file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.coxph.null" <- function (x, digits = max(options()$digits - 4, 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
HTML(paste("<p>Null model log likelihood=<b>", format(x$loglik), "</b>\n</p>"),file=file)
omit <- x$na.action
if (length(omit)) HTML(paste("<p> n=<b>", x$n, " </b>(", naprint(omit), ")\n</p>", sep = ""),file=file)
else HTML(paste("<p> n=<b>", x$n, "</b>\n</p>"),file=file)
}
#----------------------------------------------------------------------------------------------------#
### XTABLE
#----------------------------------------------------------------------------------------------------#
"HTML.xtable" <- function(x,file=get(".HTML.file"),append=TRUE,...){
cat("\n", file=file, append=append,...)
cat(capture.output(print(x,type="html")),file=file,append=TRUE,sep="\n")
}
#----------------------------------------------------------------------------------------------------#
### UTILITARY FUNCTIONS
#----------------------------------------------------------------------------------------------------#
#----------------------------------------------------------------------------------------------------#
"HTML.title"<-
function(x, HR = 2,CSSclass=NULL,file=get(".HTML.file"),append=TRUE, ...)
{
cat(paste("\n <h", HR, if(!is.null(CSSclass)) paste(" class=",CSSclass,sep="") ," > ", x, "</h", HR, ">\n", sep =
""), file = file, append=append, sep = "")
}
#----------------------------------------------------------------------------------------------------#
"HTMLstem" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<pre>",paste(capture.output(stem(x)),collapse="<br>"),"</pre>"), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTMLbr"<- function(x=1,file=get(".HTML.file"),append=TRUE) { cat(paste("\n",rep("<br> ",x),"\n",sep=""), append=append, file = file)}
#----------------------------------------------------------------------------------------------------#
"HTMLhr"<- function(file=get(".HTML.file"), Width = "100%", Size = "1",CSSclass=NULL,append=TRUE){ cat(paste("\n<hr ", ifelse(!is.null(CSSclass),paste("class=",CSSclass,sep=""),""), " width=", Width, " size=", Size, ">", sep = ""), file = file, append=append, sep = "")}
#----------------------------------------------------------------------------------------------------#
"HTMLli"<- function(txt="", file=get(".HTML.file"),append=TRUE) { cat(paste("\n<br><li>", txt, sep = ""), sep = "", append=append, file = file)}
#----------------------------------------------------------------------------------------------------#
"HTMLplot" <- function (Caption = "", file=get(".HTML.file"),append=TRUE, GraphDirectory = ".",
GraphFileName = "", GraphSaveAs = "png", GraphBorder = 1, Align = "center",
Width=500,Height=500,WidthHTML=NULL,HeightHTML=NULL,
GraphPointSize=12,GraphBackGround="white",GraphRes=72,plotFunction=NULL,...)
{
## New version with code submitted by James Wettenhall <wettenhall@wehi.edu.au>
## Change plotFunction by plotExpression...
if (exists("HTMLenv",where=".GlobalEnv",mode="environment"))
{
GraphDirectory=get(".HTML.outdir",envir=get("HTMLenv",envir=.GlobalEnv))
}
cat("\n", file=file, append=append,...)
if (GraphFileName == "") {
nowd <- date()
GraphFileName <- paste("GRAPH_", substring(nowd, 5, 7),
substring(nowd, 9, 10), "_", substring(nowd, 12,
13), substring(nowd, 15, 16), substring(nowd,
18, 19), sep = "")
}
GraphFileName <- paste(GraphFileName, ".", GraphSaveAs, sep = "")
AbsGraphFileName <- file.path(GraphDirectory, GraphFileName)
if (GraphSaveAs=="png")
{
if (is.null(plotFunction))
dev.print(device=png, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
else
{
if (exists("X11", envir=.GlobalEnv) && Sys.info()["sysname"] != "Windows" && Sys.info()["sysname"] != "Darwin")
bitmap(file = AbsGraphFileName,bg=GraphBackGround,res=GraphRes)
else
png(filename = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
plotFunction()
dev.off()
}
}
else if (GraphSaveAs %in% c("jpg","jpeg"))
{
if (is.null(plotFunction))
dev.print(device=jpeg, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
else
{
if (exists("X11", envir=.GlobalEnv) && Sys.info()["sysname"] != "Windows" && Sys.info()["sysname"] != "Darwin")
bitmap(filename = AbsGraphFileName,bg=GraphBackGround,res=GraphRes,type="jpeg")
else
jpeg(filename = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
plotFunction()
dev.off()
}
}
else if (GraphSaveAs=="gif")
{
stop("Gif support was removed from base R because of patent restrictions. Use either jpg or png")
#
# if (is.null(plotFunction))
# Gif support was removed from base R because of patent restrictions.
# see http://tolstoy.newcastle.edu.au/R/help/05/02/12809.html
# dev.print(device=gif, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
#
# else
# {
# stop("When passing a plot function to HTMLplot, device must be jpg or png.")
# }
}
else stop("GraphSaveAs must be either jpg, png or gif")
cat(paste("<p align=", Align, "><img src='", GraphFileName,
"' border=", GraphBorder, if (!is.null(Width)) paste(" width=",Width,sep="") else "",if (!is.null(HeightHTML)) paste(" height=",HeightHTML,sep=""), if(!is.null(WidthHTML)) paste(" width="),">", sep = "", collapse = ""),
file = file, append=TRUE, sep = "")
if (Caption != "") {
cat(paste("<br><font class=caption>", Caption, "</font>"), file = file, append=TRUE, sep = "")
}
cat("</p>", file = file, append=TRUE, sep = "\n")
if (substitute(file)==".HTML.file") try(assign(".HTML.graph", TRUE, envir = get("HTMLenv", envir = .GlobalEnv)))
invisible(return(TRUE))
}
#----------------------------------------------------------------------------------------------------#
"HTMLInsertGraph" <- function(GraphFileName="",Caption="",GraphBorder=1,Align="center",WidthHTML=500,HeightHTML=NULL,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
cat(paste("<p align=", Align, "><img src='", GraphFileName, "' border=", GraphBorder, if (!is.null(WidthHTML)) paste(" width=",WidthHTML,sep="") else "",if (!is.null(HeightHTML)) paste(" height=",HeightHTML,sep="") else "",">", sep = "", collapse = ""), file = file, append=TRUE, sep = "")
if (Caption != "") cat(paste("<br><i class=caption>", Caption, "</i>"), file = file, append=TRUE, sep = "")
invisible(return(TRUE))
}
#----------------------------------------------------------------------------------------------------#
"HTMLCSS" <- function(file=get(".HTML.file"),append=TRUE,CSSfile="R2HTML.css")
{
cat(paste("\n<link rel=stylesheet type=text/css href=",CSSfile,">\n",sep=""),file=file,append=append)
}
#----------------------------------------------------------------------------------------------------#
"HTMLChangeCSS" <- function(newCSS="R2HTML",from=NULL){
target=getwd()
if (exists("HTMLenv",where=".GlobalEnv")) target=file.path(get(".HTML.outdir",envir=get("HTMLenv",envir=.GlobalEnv)))
if (is.null(from)){
# PhG: .R2HTMLpath does not exist any more. .find.package(package = "R2HTML") has the same effect!
#if (!exists(".R2HTMLpath")) stop("The package R2HTML is not properly loaded")
#from=file.path(.R2HTMLpath,"output")
from=file.path(.find.package(package = "R2HTML"),"output")
}
fromfile=file.path(from,paste(newCSS,"css",sep="."))
if (!file.exists(fromfile)) stop(paste("Source CSS file",fromfile,"not found"))
file.copy(fromfile,file.path(target,"R2HTML.css"),overwrite=TRUE)
}
"HTMLCommand" <- function(x,file=get(".HTML.file"),Num="",menu=FALSE,target="index<-main.html",append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (menu==TRUE)
cat(paste("<br><li><a class=command href='./",target,"#Num",Num,"' target=main> ",paste(x,collapse=""),"</a>",sep=""),file=file,append=TRUE,sep="")
else {
if (Num!="") cat(paste("<a name=Num",Num,"> </a>",sep=""),file=file,append=TRUE,sep="")
cat(paste("\n<p><xmp class=command>> ",x,"</xmp></p>\n",sep=""),file=file,append=TRUE,sep="")
}
}
#----------------------------------------------------------------------------------------------------#
"HTMLcode" <- function(x,...){
tmpfic=tempfile()
HTML(x,file=tmpfic,...)
cat("\n",file=tmpfic,append=TRUE)
tmptxt=readLines(tmpfic)
unlink(tmpfic)
return(paste(tmptxt,collapse="\n"))
}
#----------------------------------------------------------------------------------------------------#
"HTMLReplaceNA"<-
function(Vec, Replace = " ")
{
Vec <- as.character(Vec)
#Vec <- format( Vec, ... )
for(i in 1:length(Vec))
{
try(if((Vec[i] == "NA") | (Vec[i] == "NaN") | is.na(Vec[i])){ Vec[i] <- Replace})
}
Vec
}
#----------------------------------------------------------------------------------------------------#
"HTML.cormat" <- function(x, file=get(".HTML.file"), digits=2,append=TRUE,align="center",caption="",captionalign="bottom",classcaption="captiondataframe",classtable="cormat",useCSS=TRUE,...)
{
cat("\n", file=file,append=append)
x<-as.matrix(x)
if (is.numeric(x)) x<-round(x,digits=digits)
if (is.null(dimnames(x))) x <- as.data.frame(x)
txt <- paste("<p align=",align,">")
txtcaption <- ifelse(is.null(caption),"",paste("<caption align=",captionalign," class=",classcaption,">",caption,"</caption>",sep=""))
cormat=x
abscormat=abs(cormat)
backcolors=matrix(grey(1-as.matrix(abscormat)),ncol=ncol(cormat))
css = 10*round(abs(x),1)
css=matrix(paste("cor",unlist(css),sep=""),ncol=ncol(x))
diag(css)="cordiag"
diag(backcolors)="#FFFFFF"
forecolors=matrix("#000000",ncol=ncol(cormat),nrow=nrow(cormat))
forecolors[abscormat>0.5]="#FFFFFF"
forecolors[abscormat>0.8]="#F6FF6E"
diag(forecolors)="#FFFFFF"
forebold=matrix(FALSE,ncol=ncol(cormat),nrow=nrow(cormat))
forebold[abscormat>0.9]=TRUE
txt<- paste(txt,"<table cellspacing=0 cellpading=0 border=0 >",txtcaption,"<td valign=middle class=corbody><table cellspacing=0 border=0>")
txt <- paste(txt,paste("\n<tr><td align=right class=corvarname>",dimnames(x)[[2]],"</td><td width=2> </td></tr>",collapse="\n"))
txt <- paste(txt,"</table></td><td valign=top class=corsep> </td><td valign=top>")
txt <- paste(txt, "<table cellspacing=0 cellpadding=0 border=1 ><td><table class=",classtable," cellspacing=0>", sep = "")
for(i in 1:dim(x)[1]) {
VecDebut <- c(rep(paste("\n\t<td align=right", sep = ""), dim(x)[2]))
if (useCSS) VecAttrib=c(paste(" class= ",css[i,],">")) else VecAttrib=c(paste(" bgcolor=",backcolors[i,],"><font color=",forecolors[i,],">",ifelse(forebold[i,],"<b>","")))
VecMilieu <- HTMLReplaceNA(as.matrix(x[i, ]))
VecFin <- rep("</td>", dim(x)[2] )
txt <- paste(txt, "\n<tr>",paste(VecDebut,VecAttrib, VecMilieu, VecFin, sep = "", collapse = ""),"</tr>")
}
txt <- paste(txt, "</table></td></table></td></table>")
cat(txt, "\n", file = file, sep = "", append=TRUE,...)
invisible(return(x))
}
#----------------------------------------------------------------------------------------------------#
"as.title"<-
function(x)
{
if (!is.character(x)) {
x <- try(as.character(x))
if (!is.character(x)) stop("Input argument must be of character mode")
}
class(x) <- "title"
return(x)
}
#----------------------------------------------------------------------------------------------------#
### R2HTML CORE
#----------------------------------------------------------------------------------------------------#
"HTMLStart" <- function(outdir=tempdir(),filename="index",extension="html",echo=FALSE, autobrowse=FALSE, HTMLframe=TRUE, withprompt="HTML> ",CSSFile="R2HTML.css",BackGroundColor="FFFFFF",BackGroundImg="",Title="R output")
{
if (outdir!=tempdir())
{
# Copy of CSS and logo, if outdir != tempdir
file.copy(file.path(tempdir(),'R2HTML.css'), file.path(outdir,'R2HTML.css'))
file.copy(file.path(tempdir(),'R2HTMLlogo.gif'), file.path(outdir,'R2HTMLlogo.gif'))
}
# Creation of an environment to save some parameters
assign("HTMLenv",new.env(parent=.GlobalEnv),envir=.GlobalEnv)
assign("oldprompt",getOption("prompt"),envir=get("HTMLenv",envir=.GlobalEnv))
assign("HTMLframe",HTMLframe,envir=get("HTMLenv",envir=.GlobalEnv))
assign(".HTML.outdir",outdir,envir=get("HTMLenv",envir=.GlobalEnv))
assign("HTMLtorefresh",file.path(outdir,paste(filename,extension,sep=".")),envir=get("HTMLenv",envir=.GlobalEnv))
options(prompt=withprompt)
# Utilitary functions replacement
fix<-function (x, ...) {
subx <- substitute(x)
if (is.name(subx))
subx <- deparse(subx)
if (!is.character(subx) || length(subx) != 1)
stop("fix requires a name")
assign(".HTML.fix",TRUE,envir=get("HTMLenv",envir=.GlobalEnv))
assign(".HTML.fixed",subx,envir=get("HTMLenv",envir=.GlobalEnv))
parent <- parent.frame()
if (exists(subx, envir = parent, inherits = TRUE))
x <- edit(get(subx, envir = parent), ...)
else {
x <- edit(function() {
}, ...)
environment(x) <- .GlobalEnv }
assign(subx, x, envir = .GlobalEnv)
}
assign("fix",fix,envir=.GlobalEnv)
assign(".HTML.fix",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
assign(".HTML.graph",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
# Creation of required HTML files
try(.HTML.file <- HTMLInitFile(outdir = outdir,filename=filename,extension=extension,HTMLframe=HTMLframe, BackGroundColor = BackGroundColor, BackGroundImg = BackGroundImg, Title = Title,CSSFile=CSSFile,useLaTeX=TRUE))
ToHTML <- function(file,echo,HTMLframe,HTMLMenuFile,target,outdir)
{
NumCom<-0
function(expr,value,ok,visible)
{
NumCom<<- NumCom+1
if (NumCom>1){
ToPrint<-TRUE
if (get(".HTML.fix",envir=get("HTMLenv",envir=.GlobalEnv))==TRUE)
{
ToPrint<-FALSE
ficName<-paste("fun",format(Sys.time(), "%j%m%H%M%S"),"-",floor(runif(1,1,10000)),".txt",sep="")
AbsficName<-file.path(outdir,ficName)
FunName<-get(".HTML.fixed",envir=get("HTMLenv",envir=.GlobalEnv))
if (echo) HTMLCommand(paste("fix(",FunName,")",sep=""),file,NumCom) else cat(paste("<A NAME=Num",NumCom,"> </a>",sep=""),file=file,sep="",append=TRUE)
if (HTMLframe) HTMLCommand(paste("fix(",FunName,")",sep=""),HTMLMenuFile,NumCom,menu=TRUE,target=target)
dput(get(FunName),file=AbsficName)
HTML(paste("<p> Function <a href=", ficName, " target=_blank>", FunName, "</a> fixed. </p>",sep=""),file=file)
assign(".HTML.fix",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
}
else
{
if (get(".HTML.graph",envir=get("HTMLenv",envir=.GlobalEnv))==TRUE)
{
ToPrint <- FALSE
assign(".HTML.graph",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
}
else
{
if (length(expr)>1) {if ((expr[[1]]=="=")||(expr[[1]]=="<-")) ToPrint<-FALSE}
# Print the commands and/or it's number
if (echo) HTMLCommand(deparse(expr),file,NumCom) else cat(paste("<a name=Num",NumCom,"> </a>",sep=""),file=file,sep="",append=TRUE)
if (HTMLframe) HTMLCommand(deparse(expr),HTMLMenuFile,NumCom,menu=TRUE,target=target)
if (ToPrint) HTML(value,file=file)
}
}
}
if (autobrowse) browseURL(url=get("HTMLtorefresh",envir=get("HTMLenv",envir=.GlobalEnv)))
invisible(return(TRUE))
}
}
on.exit(addTaskCallback(ToHTML(.HTML.file,echo=echo,HTMLframe=HTMLframe,HTMLMenuFile=file.path(outdir,paste(filename,"_menu.",extension,sep="")),target=paste(filename,"_main.",extension,sep=""),outdir=outdir),name="HTML"),add=TRUE)
cat("\n *** Output redirected to directory: ", outdir)
cat("\n *** Use HTMLStop() to end redirection.")
invisible(return(TRUE))
}
#----------------------------------------------------------------------------------------------------#
"HTMLInitFile"<-function(outdir = tempdir(),filename="index",extension="html",
HTMLframe=FALSE, BackGroundColor = "FFFFFF", BackGroundImg = "",
Title = "R output",CSSFile="R2HTML.css",useLaTeX=TRUE,useGrid=TRUE)
{
if (HTMLframe==FALSE){
file<-file.path(outdir,paste(filename,".",extension,sep=""))
assign(".HTML.file",file,envir=.GlobalEnv)
txt <- ifelse(useLaTeX,"<html xmlns:mml=\"http://www.w3.org/1998/Math/MathML\">","<html>")
#<HEAD>
txt <- c(txt, "<head>")
txt <- c(txt, paste("<title>",Title,"</title>"))
# css
txt <- c(txt, paste("<link rel=stylesheet href=\"",CSSFile,"\" type=text/css>",sep=""))
# LaTeX ?
if (useLaTeX) txt <- c(txt, "<object id=\"mathplayer\" classid=\"clsid:32F66A20-7614-11D4-BD11-00104BD3F987\"></object>\n<?import namespace=\"mml\" implementation=\"#mathplayer\"?>\n<script type=\"text/javascript\" src=\"ASCIIMathML.js\"></script>")
# Grid?
if (useGrid) {
txt <- c(txt, HTMLgrid_references())
txt <- c(txt, "<script>\n nequations=0;\n</script>")
}
# </HEAD>
txt <- c(txt, "</head>")
# <BODY>
body <- c("<body")
if(useLaTeX) body=c(body," onload=\"translate()\"")
body=c(body,paste(" bgcolor=",BackGroundColor))
if (BackGroundImg!="") body = c(body, paste(" background=\"",BackGroundImg,"\"",sep=""))
body <- c(body," >")
body=paste(body,collapse="")
txt <- c(txt, body)
txt <- paste(txt, collapse="\n")
cat(txt, file=file,append=FALSE)
}
else {
filemenu<-paste(filename,"_menu.",extension,sep="")
filemain<-paste(filename,"_main.",extension,sep="")
absfilemenu<-file.path(outdir,filemenu)
file<-absfilemain<-file.path(outdir,filemain)
absfileindex<-file.path(outdir,paste(filename,".",extension,sep=""))
assign(".HTML.file",absfilemain,envir=.GlobalEnv)
cat(paste("<html><head> \n <title>",Title,"</title>\n <meta http-equiv=content-type content=text/html;charset=iso-8859-1>\n <frameset cols=250,* border=1 frameborder=yes><frame src=",filemenu," name=menu scrolling=yes><frame src=",filemain," name=main scrolling=yes></frameset></body></html>"), append = FALSE, sep = "", file = absfileindex)
cat("<html><head><link rel=stylesheet href=",CSSFile," type=text/css> </head><body bgcolor=\"#E5F5FF\"> <center> <img src=R2HTMLlogo.gif> <hr size=1></center><br>",sep="",append=FALSE,file=absfilemenu)
txt <- ifelse(useLaTeX,"<html xmlns:mml=\"http://www.w3.org/1998/Math/MathML\">","<html>")
#<HEAD>
txt <- c(txt, "<head>")
txt <- c(txt, paste("<title>",Title,"</title>"))
# css
txt <- c(txt, paste("<link rel=stylesheet href=\"",CSSFile,"\" type=text/css>",sep=""))
# LaTeX ?
if (useLaTeX) txt <- c(txt, "<object id=\"mathplayer\" classid=\"clsid:32F66A20-7614-11D4-BD11-00104BD3F987\"></object>\n<?import namespace=\"mml\" implementation=\"#mathplayer\"?>\n<script type=\"text/javascript\" src=\"ASCIIMathML.js\"></script>")
# Grid?
if (useGrid) {
txt <- c(txt, HTMLgrid_references())
txt <- c(txt, "<script>\n nequations=0;\n</script>")
} # </HEAD>
txt <- c(txt, "</head>")
# <BODY>
body <- c("<body")
if(useLaTeX) body=c(body," onload=\"translate()\"")
body=c(body,paste(" bgcolor=",BackGroundColor))
if (!is.null(BackGroundImg)) body = c(body, paste(" background=\"",BackGroundImg,"\"",sep=""))
body <- c(body," >")
body=paste(body,collapse="")
txt <- c(txt, body)
txt <- paste(txt, collapse="\n")
cat(txt, file=absfilemain,append=FALSE)
}
invisible(return(file))
}
#----------------------------------------------------------------------------------------------------#
"HTMLEndFile"<- function(file=get(".HTML.file"))
{
cat("\n<hr size=1>\n<font size=-1>\n\t Generated on: <i>", date(),
"</i> - <b>R2HTML</b> \n<hr size=1>\n\t</body>\n</html>",
sep = "", append=TRUE, file = file)
}
#----------------------------------------------------------------------------------------------------#
"HTMLStop"<-function()
{
invisible(removeTaskCallback("HTML"))
options(prompt=get("oldprompt",envir=get("HTMLenv",envir=.GlobalEnv)))
.tmp=get(".HTML.file",envir=get("HTMLenv",envir=.GlobalEnv))
HTMLEndFile(file=get(".HTML.file",envir=get("HTMLenv",envir=.GlobalEnv)))
on.exit(rm("HTMLenv",envir=.GlobalEnv),add=TRUE)
on.exit(try(rm("fix",pos=1)),add=TRUE)
invisible(return(.tmp))
}
#----------------------------------------------------------------------------------------------------#
"RweaveHTML" <- function()
{
list(setup = RweaveHTMLSetup,
runcode = RweaveHTMLRuncode,
writedoc = RweaveHTMLWritedoc,
finish = RweaveHTMLFinish,
checkopts = RweaveHTMLOptions)
}
"RweaveHTMLSetup" <-
function(file, syntax,
output=NULL, quiet=FALSE, debug=FALSE, echo=TRUE,
eval=TRUE, split=FALSE, cssfile="R2HTML.css",havecss=FALSE,width=500,height=500,border=1,png=TRUE)
{
# This driver requires R2HTML package to work...
#if(!require(R2HTML)) stop("R2HTML package is required.")
if(is.null(output)){
prefix.string <- basename(sub(syntax$extension, "", file))
output <- paste(prefix.string, "html", sep=".")
}
else{
prefix.string <- basename(sub("\\.html$", "", output))
}
if(!quiet) cat("Writing to file ", output, "\n",
"Processing code chunks ...\n", sep="")
output <- file(output, open="w+")
options <- list(prefix=TRUE, prefix.string=prefix.string,
engine="R", print=FALSE, eval=eval,
fig=FALSE, png=png,width=width, height=height, term=TRUE,
echo=echo, results="Robj", split=split,
strip.white=TRUE, include=TRUE,align="center",caption=NULL,bg="white",pointsize=12)
list(output=output, debug=debug, quiet=quiet, syntax = syntax,
options=options, chunkout=list(),cssfile=cssfile,havecss=havecss)
}
"RweaveHTMLRuncode" <- function(object, chunk, options)
{
if(!(options$engine %in% c("R", "S"))) return(object)
if(!object$quiet){
cat(formatC(options$chunknr, width=2), ":")
if(options$echo) cat(" echo")
if(options$eval){
if(options$print) cat(" print")
if(options$term) cat(" term")
cat("", options$results)
if(options$fig){
if(options$png) cat(" png")
}
}
if(!is.null(options$label))
cat(" (label=", options$label, ")", sep="")
cat("\n")
}
#chunkprefix <- utils:::RweaveChunkPrefix(options)
chunkprefix <- RweaveChunkPrefix(options)
if(options$split){
chunkout <- object$chunkout[[chunkprefix]]
if(is.null(chunkout)){
chunkout <- file(paste(chunkprefix, "html", sep="."), "w")
if(!is.null(options$label))
object$chunkout[[chunkprefix]] <- chunkout
}
}
else
chunkout <- object$output
assign(".HTML.file",chunkout,pos=.GlobalEnv, immediate=TRUE)
#utils:::SweaveHooks(options, run=TRUE)
SweaveHooks(options, run=TRUE)
chunkexps <- try(parse(text=chunk), silent=TRUE)
#utils:::RweaveTryStop(chunkexps, options)
RweaveTryStop(chunkexps, options)
openSinput <- FALSE
openSchunk <- FALSE
if(length(chunkexps)==0)
return(object)
for(nce in 1:length(chunkexps))
{
ce <- chunkexps[[nce]]
#dce <- deparse(ce, width.cutoff=0.75*getOption("width"))
if(object$debug)
cat("\nRnw> ", paste(ce, collapse="\n+ "),"\n")
if(options$echo){
if(!openSinput){
if(!openSchunk){
cat("<!-- begin{Schunk} !-->\n",
file=chunkout, append=TRUE)
openSchunk <- TRUE
}
cat("<!-- begin{Sinput} !-->",
file=chunkout, append=TRUE)
openSinput <- TRUE
}
cat("\n", paste(HTMLCommand(deparse(ce)),
collapse=paste("\n", getOption("continue"), sep="")),
file=chunkout, append=TRUE, sep="")
}
# tmpcon <- textConnection("output", "w")
# avoid the limitations (and overhead) of output text connections
tmpcon <- file()
sink(file=tmpcon)
err <- NULL
#if(options$eval) err <- utils:::RweaveEvalWithOpt(ce, options)
if(options$eval) err <- RweaveEvalWithOpt(ce, options)
cat("\n") # make sure final line is complete
sink()
output <- readLines(tmpcon)
close(tmpcon)
# delete empty output
if(length(output)==1 & output[1]=="") output <- NULL
#utils:::RweaveTryStop(err, options) #### !!! err$value peut etre exporte via HTML(err.value)
RweaveTryStop(err, options) #### !!! err$value peut etre exporte via HTML(err.value)
if(object$debug)
cat(paste(output, collapse="\n"))
if(length(output)>0 & (options$results!="hide")){
if(!openSchunk){
cat("<!-- begin{Schunk} !--> \n",
file=chunkout, append=TRUE)
openSchunk <- TRUE
}
if(openSinput){
cat("\n<!-- end{Sinput} !-->\n", file=chunkout, append=TRUE)
openSinput <- FALSE
}
if (options$results=="Robj") HTML(err$value, file=chunkout, append=TRUE)
if (options$results=="html") cat(err$value, file=chunkout, append=TRUE)
remove(output)
}
}
if(openSinput){
cat("\n<!--\\end{Sinput}!-->\n", file=chunkout, append=TRUE)
}
if(openSchunk){
cat("\n<!--\\end{Schunk}!-->\n", file=chunkout, append=TRUE)
}
if(is.null(options$label) & options$split)
close(chunkout)
if(options$fig && options$eval){
if(options$png){
png(filename=paste(chunkprefix, "png", sep="."),width=options$width,height=options$height,bg=options$bg,pointsize=options$pointsize)
#err <- try({utils:::SweaveHooks(options, run=TRUE);
err <- try({SweaveHooks(options, run=TRUE);
eval(chunkexps, envir=.GlobalEnv)})
dev.off()
if(inherits(err, "try-error")) stop(err)
}
if(options$include)
cat("<p align='",options$align,"'><img height=",options$HTMLheight, " width=",options$HTMLwidth," src='", chunkprefix, ".png'",if (!is.null(options$border)) paste("border=",options$border,sep=""),">",if(!is.null(options$caption)) paste("<br><font class='caption='>",options$caption,"</font>",sep=""),"</p>", sep="",
file=object$output, append=TRUE)
}
return(object)
}
"RweaveHTMLWritedoc" <- function(object, chunk)
{
# Very temporary and ugly fix: importing function definition from
# latest R source code (r45768)
InternalSweaveParseOptions <- function(text, defaults=list(), check=NULL)
{
x <- sub("^[[:space:]]*(.*)", "\\1", text)
x <- sub("(.*[^[:space:]])[[:space:]]*$", "\\1", x)
x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*"))
x <- strsplit(x, "[[:space:]]*=[[:space:]]*")
## only the first option may have no name: the chunk label
if(length(x)>0){
if(length(x[[1]])==1){
x[[1]] <- c("label", x[[1]])
}
}
else
return(defaults)
if(any(sapply(x, length)!=2))
stop(gettextf("parse error or empty option in\n%s", text), domain = NA)
options <- defaults
for(k in 1:length(x))
options[[ x[[k]][1] ]] <- x[[k]][2]
if(!is.null(options[["label"]]) && !is.null(options[["engine"]]))
options[["label"]] <- sub(paste("\\.", options[["engine"]], "$",
sep=""),
"", options[["label"]])
if(!is.null(check))
options <- check(options)
options
}
if(any(grep("text/css", chunk)))
object$havecss <- TRUE
if(!object$havecss){
if(any(grep("<body>", chunk, ignore.case = TRUE))) chunk <- gsub("<body>",paste("\n<link rel=stylesheet type=text/css href=",object$cssfile,"><body>",sep="") ,chunk,ignore.case=TRUE)
else {
if(any(grep("</head>", chunk, ignore.case = TRUE))) chunk <- gsub("</head>",paste("\n<link rel=stylesheet type=text/css href=",object$cssfile,"></head>",sep="") ,chunk,ignore.case=TRUE)
else chunk <- gsub("<html>",paste("<html>","\n<link rel=stylesheet type=text/css href=",object$cssfile,">",sep="") ,chunk,ignore.case=TRUE)
}
object$havecss <- TRUE
}
while(any(pos <- grep(object$syntax$docexpr, chunk)))
{
cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1]])
cmd <- substr(chunk[pos[1]], cmdloc,
cmdloc+attr(cmdloc, "match.length")-1)
cmd <- sub(object$syntax$docexpr, "\\1", cmd)
if(object$options$eval)
val <- as.character(eval(parse(text=cmd), envir=.GlobalEnv))
else
val <- paste("<font class='Rcmd'>", cmd, "</font>", sep="")
chunk[pos[1]] <- sub(object$syntax$docexpr, val, chunk[pos[1]])
}
while(any(pos <- grep(object$syntax$docopt, chunk)))
{
opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
"\\1", chunk[pos[1]])
object$options <- InternalSweaveParseOptions(opts, object$options, RweaveHTMLOptions)
chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
}
cat(chunk, sep="\n", file=object$output, append=TRUE)
return(object)
}
"RweaveHTMLFinish" <- function(object, error=FALSE)
{
if(!object$quiet && !error)
cat(paste("file ",summary(object$output)$description),"is completed", "\n")
close(object$output)
if(length(object$chunkout)>0){
for(con in object$chunkout) close(con)
}
}
"RweaveHTMLOptions" <- function(options)
{
## convert a character string to logical
c2l <- function(x){
if(is.null(x)) return(FALSE)
else return(as.logical(toupper(as.character(x))))
}
NUMOPTS <- c("width", "height")
NOLOGOPTS <- c(NUMOPTS, "results", "prefix.string",
"engine", "label","align","caption","border","height","width","HTMLheight","HTMLwidth","bg","pointsize")
for(opt in names(options)){
if(! (opt %in% NOLOGOPTS)){
oldval <- options[[opt]]
if(!is.logical(options[[opt]])){
options[[opt]] <- c2l(options[[opt]])
}
if(is.na(options[[opt]]))
stop(paste("invalid value for", opt, ":", oldval))
}
else if(opt %in% NUMOPTS){
options[[opt]] <- as.numeric(options[[opt]])
}
}
options$results <- match.arg(options$results,c("Robj","html", "hide"))
options
}
#----------------------------------------------------------------------------------------------------#
# Function contributed by Gabor Grothendieck (ggrothendieck_at_gmail.com)
HTML2clip <- function(x, filename = file("clipboard", ifelse(.Platform$OS == "windows","w",stop("Writing to clipboard only supported on Windows"))), append = FALSE, ...) {
HTML(x, file = filename, append = append, ...)
}
#----------------------------------------------------------------------------------------------------#
SweaveSyntaxHTML <- SweaveSyntaxNoweb
SweaveSyntaxHTML$docexpr <- "<[/]?Sexpr([^>]*)>"
SweaveSyntaxHTML$syntaxname <- "<[/]?SweaveSyntax([^>]*)>"
SweaveSyntaxHTML$trans$docexpr <- "<[/]?Sexpr\\1>"
SweaveSyntaxHTML$trans$syntaxname <- "<!--SweaveSyntax{SweaveSyntaxHTML}!-->"
#----------------------------------------------------------------------------------------------------#
# "myunzip" <- function (zipname, dest)
# {
# if (file.exists(zipname)) {
# if (.Platform$OS.type=="unix") system(paste(getOption("unzip"), "-oq", zipname, "-d", dest))
# else .Internal(int.unzip(zipname, NULL, dest))
# }
# else stop(paste("zipfile", zipname, "not found"))
# }
".onLoad" <- function(lib,pkg)
{
#cat("\nLoading R2HTML package...\n")
#ps.options(bg="white")
# Copy all the content of "output" directory to tempdir()
# now we use a zip file as there are subdirectories...
unzip(zipfile=file.path(lib,pkg,'output','R2HTMLstuff.zip'),exdir=tempdir())
# PhG: eliminated! No temp variables in .GlobalEnv, please assign(".R2HTMLpath",file.path(lib,pkg),pos=.GlobalEnv)
# EL: now can use getOption("R2HTML.CSSdir")
options(R2HTML.CSSdir=file.path(lib,pkg,"output"))
options(R2HTML.sortableDF=FALSE)
options(R2HTML.format.digits=2)
options(R2HTML.format.nsmall=0)
options(R2HTML.format.big.mark="")
options(R2HTML.format.big.interval=3)
options(R2HTML.format.decimal.mark=Sys.localeconv()[["decimal_point"]])
options(R2HTML.grid.first=TRUE)
options(R2HTML.grid.stuffbasepath="./")
}
options(R2HTML.sortableDF=FALSE)
options(R2HTML.format.digits=2)
options(R2HTML.format.nsmall=0)
options(R2HTML.format.big.mark="")
options(R2HTML.format.big.interval=3)
options(R2HTML.format.decimal.mark=Sys.localeconv()[["decimal_point"]])
options(R2HTML.grid.first=TRUE)
options(R2HTML.grid.stuffbasepath="./")
Try the R2HTML package in your browser
Any scripts or data that you put into this service are public.
R2HTML documentation built on May 2, 2019, 5:11 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions HTML2clip
Documented in HTML2clip
# $Id: HTMLcore.R 47 2008-05-23 17:29:31Z mentus $
# R2HTML - Library of exportation to HTML for R
# Copyright (C) 2002-2004 - Eric Lecoutre
# R2HTML Package
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#----------------------------------------------------------------------------------------------------#
#
# Contact:
#
# Eric Lecoutre
# <lecoutre@stat.ucl.ac.be>
#
# Institut de statistique
# Voie du Roman Pays, 20
# 1348 Louvain-la-Neuve
# BELGIQUE
#
#----------------------------------------------------------------------------------------------------#
"HTML"<- function(x,...) {
UseMethod("HTML")
}
#----------------------------------------------------------------------------------------------------#
"HTML.default"<-
function(x, file=get(".HTML.file"),append=TRUE,...)
{
HTML(paste(capture.output(x),collapse="\n<br>\n"),file=file,append=append,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.atomic"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("\n<p class='atomic'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.complex"<- function(x, file=get(".HTML.file"), append=TRUE,...){
cat(paste("\n<p><font class='complexRe'>",Re(x),"</font>",ifelse(sign(Im(x))<0,"-","+"),"<font class='complexIm'>",Im(x),"</font><font class='complexI'>i</font>","</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.numeric"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
if(!is.null(names(x))) {
HTML(as.table(x),file=file,append=append,...)
}
else {
cat(paste("\n<p class='numeric'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
}
#----------------------------------------------------------------------------------------------------#
"HTML.integer"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("\n<p class='integer'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.logical"<- function(x, file=get(".HTML.file"), append=TRUE,...){
cat(paste("\n<p class='logical'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.character"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("\n<p class='character'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.call"<- function(x, file=get(".HTML.file"),append=TRUE, ...){
cat(paste("<font class='call'>",deparse(x),"</font>",sep="",collapse=""), file= file, append = append, sep = " ")
}
#----------------------------------------------------------------------------------------------------#
"HTML.function"<-function(x,file=get(".HTML.file"),append=TRUE,...){
cat(paste("\n<br>\n<xmp class=function>",
paste(capture.output(x),collapse="\n"),"\n</xmp><br>\n",sep=""),
file=file,append=append,sep="\n<br>\n")
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.environment"<-function(x,file=get(".HTML.file"),append=TRUE,...){
cat(paste("\n<br>environment: <font class='environment'>",attributes(x)$name,"</font><br>\n",sep=""),
file=file,append=append)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.formula"<-function(x,file=get(".HTML.file"),append=TRUE,...) {
HTML(paste("<font class='formula'>",deparse(unclass(x)),"</font>",collapse=""),file=file,append=append,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.array"<- function(x, file=get(".HTML.file"),append=TRUE, ...)
{
odometer <- function(current, radix)
{
if(any(c(current, radix) < 0))
stop("arguments must be non-negative")
lc <- length(current)
if(length(radix) != lc)
radix <- rep(radix, length = lc)
radix <- radix - 1
for(i in 1:lc) {
if((ii <- current[i]) < radix[i]) {
current[i] <- ii + 1
return(current)
}
else current[i] <- 0
}
current
}
d <- dim(x)
ndim <- length(d)
dn <- dimnames(x)
if(ndim == 1)
HTML.matrix(matrix(x, 1, dimnames = list("", if(is.null(
dn)) paste("[", 1:d[1], "]", sep = "") else dn[[1]])),
file = file, append=append,...)
else if(ndim == 2)
HTML.matrix(x, Border = 0, file = file, append=append,...)
else {
if(length(dn) < ndim)
dn <- vector("list", ndim)
for(i in 3:ndim)
if(length(dn[[i]]) < d[i]) dn[[i]] <- paste(1:d[i])
xm <- array(x[1], d[1:2])
dimnames(xm) <- dn[1:2]
d <- d[ - (1:2)]
nm <- length(xm)
which <- 1:nm
dn <- dn[ - (1:2)]
ndim <- ndim - 2
counter <- rep(0, length(d))
for(i in 1:(length(x)/nm)) {
cat("<br>, , ", file = file, append = TRUE)
for(j in 1:ndim)
cat(dn[[j]][counter[j] + 1], if(j < ndim) ", "
else "<br>", sep = "", file = file, append
= TRUE)
xm[1:nm] <- x[which]
HTML.matrix(xm, Border = 0, file = file, append=TRUE,...)
counter <- odometer(counter, d)
which <- which + nm
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.by"<- function (x, file=get(".HTML.file"),vsep="\n<hr size=1 width=100%>\n",append=TRUE,...)
{
HTML("\n",file=file,append=append,...)
d <- dim(x)
dn <- dimnames(x)
dnn <- names(dn)
if (missing(vsep))
vsep <- "\n<hr size=1 width=100%>\n"
lapply(seq(along = x), function(i, x, vsep, ...) {
if (i != 1 && !is.null(vsep))
HTML(vsep, file=file,append=TRUE)
ii <- i - 1
for (j in seq(along = dn)) {
iii <- ii%%d[j] + 1
ii <- ii%/%d[j]
HTML(paste(dnn[j], ": ", dn[[j]][iii], "\n<br>", sep = ""),file=file,append=TRUE,...)
}
HTML(x[[i]], file=file,append=TRUE)
}, x, vsep, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.family" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
HTML(paste("\n<br><b>Family</b>:<font class='family'>", x$family, "\n</font><br>",sep=""),file=get(".HTML.file",pos=1),append=append,...)
HTML(paste("\n<b>Link function</b>:<font class='link'>", x$link, "\n</font><br>\n<br>",sep=""),file=get(".HTML.file",pos=1),append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.terms" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML.default(paste("<font class='terms'>",unclass(x),"</font>",sep=""),file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.factor" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
HTML("\n\n<font class='factor'>",file=file,append=append,...)
if (length(x) <= 0)
HTML("factor(0)\n<br>\n",file=file,append=TRUE,...)
else HTML(as.character(x), file=file,append=TRUE, ...)
HTML("</font>\n",file=file,append=TRUE,...)
HTMLbr(file=file,append=TRUE,...)
HTML(paste("Levels:<font class='factorlevels'> ", paste(levels(x), collapse = " "), "</font>\n<br>",sep=""),file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.density" <- function (x,file=get(".HTML.file"), digits=4,append=TRUE,...)
{
HTML(paste("\n<br><b>Call</b>:<font class='call'>\n ", deparse(x$call), "</font><br><br>\n\n<b>Data</b><font class='dataname'>: ", x$data.name,
"</font> (", x$n, " obs.);", " <b>Bandwidth</b> 'bw' = ", round(x$bw, digits), "\n<br>\n<br>", sep = ""),append=append,file=file)
HTML(summary(as.data.frame(x[c("x", "y")])),append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.infl" <- function (x, file=get(".HTML.file"),digits = max(3, getOption("digits") - 4),append=TRUE,...)
{
HTML(paste("\n<br>Influence measures of\n<br> <font class='call'> ", deparse(x$call), ":</font>\n<br>\n<br>",sep=""),file=file,append=append,...)
is.star <- apply(x$is.inf, 1, any, na.rm = TRUE)
HTML(data.frame(round(x$infmat,digits), inf = ifelse(is.star, "*", " ")),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.lm"<-function(x,file=get(".HTML.file"),digits= max(3, getOption("digits") - 3),append=TRUE,...)
{
HTMLli(paste("Call: <font class='call'>",deparse(x$call),"</font>",sep=""),file=file,append=append,...)
HTMLli("Coefficients<br>",file=file,append=TRUE,...)
HTML(round(x$coeff,3),file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.lm.null" <- function (x, file=get(".HTML.file"),digits = max(3, getOption("digits") - 3),append=TRUE,...)
{
HTMLli(paste("Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>", sep = ""),file=file,append=append,...)
HTMLli("No coefficients<br>\n",append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ftable" <- function (x, file=get(".HTML.file"),digits = getOption("digits"),append=TRUE,...)
{
if (!inherits(x, "ftable"))
stop("x must be an `ftable'")
ox <- x
makeLabels <- function(lst) {
lens <- sapply(lst, length)
cplensU <- c(1, cumprod(lens))
cplensD <- rev(c(1, cumprod(rev(lens))))
y <- NULL
for (i in rev(seq(along = lst))) {
ind <- 1 + seq(from = 0, to = lens[i] - 1) * cplensD[i +
1]
tmp <- character(length = cplensD[i])
tmp[ind] <- lst[[i]]
y <- cbind(rep(tmp, times = cplensU[i]), y)
}
y
}
makeNames <- function(x) {
nmx <- names(x)
if (is.null(nmx)) nmx <- rep("", length = length(x))
nmx
}
xrv <- attr(x, "row.vars")
xcv <- attr(x, "col.vars")
LABS <- cbind(rbind(matrix("", nrow = length(xcv), ncol = length(xrv)), makeNames(xrv), makeLabels(xrv)), c(makeNames(xcv),rep("", times = nrow(x) + 1)))
DATA <- rbind(t(makeLabels(xcv)), rep("", times = ncol(x)), format(unclass(x), digits = digits))
x <- cbind(apply(LABS, 2, format, justify = "left"), apply(DATA, 2, format, justify = "right"))
HTML(x,file=file,append=append,...)
invisible(ox)
}
#----------------------------------------------------------------------------------------------------#
"HTML.POSIXlt" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<P class='POSIXlt'>",format(x, usetz = TRUE),"</p>",sep=""), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.POSIXct" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<P class='POSIXct'>",format(x, usetz = TRUE),"</p>",sep=""), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.octmode" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<P class='octmode'>",format(x),"</p>",sep=""), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.rle" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
HTML("<b><center>Run Length Encoding</center></b>\n<br>\n",file=file,append=append,...)
tab<-rbind(x$length,x$values)
tab<-cbind(c("Length","Values"),tab)
HTML(tab,file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.logLik" <- function (x, file=get(".HTML.file"),digits = getOption("digits"),append=TRUE,...) HTML(paste("<p>`log Lik.' ", format(c(x), digits = digits), " (df=", format(attr(x, "df")), ")\n</p>", sep = ""),file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.xtabs" <- function (x,file=get(".HTML.file"),append=TRUE,...)
{
ox <- x
attr(x, "call") <- NULL
HTML.table(x,file=file, append=append,...)
invisible(ox)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.lm"<-function (x, file=get(".HTML.file"),digits = max(3, getOption("digits") - 3), symbolic.cor = p > 4, signif.stars = getOption("show.signif.stars"),append=TRUE,...)
{
HTML("\n",file=file,append=append)
HTMLli(paste("Call:<font class='call'> ",deparse(x$call),"</font>","\n", sep = "", collapse = ""),file=file,append=TRUE)
resid <- x$residuals
df <- x$df
rdf <- df[2]
HTMLli(paste(if (!is.null(x$w) && diff(range(x$w))) "Weighted "," Residuals<br>\n"),file=file,append=TRUE)
if (rdf > 5) {
nam <- c("Min", "1Q", "Median", "3Q", "Max")
rq <- if (length(dim(resid)) == 2)
structure(apply(t(resid), 1, quantile), dimnames = list(nam, dimnames(resid)[[2]]))
else structure(quantile(resid), names = nam)
HTML(rq, file=file,append=TRUE,...)
}
else if (rdf > 0) {
HTML(resid,file=file,append=TRUE,...)
}
else {
HTML(paste("ALL", df[1], "residuals are 0: no residual degrees of freedom!<br>\n",sep=""),file=file,append=TRUE,...)
}
if (nsingular <- df[3] - df[1])
HTMLli(paste("Coefficients (",nsingular, "not defined because of singularities)<br>\n",sep=""),file=file,append=TRUE)
else HTMLli("Coefficients\n",file=file,append=TRUE)
HTML.coefmat(x$coef, digits = digits, signif.stars = signif.stars, file=file,append=TRUE,...)
HTMLli(paste("Residuals standard error: ",round(x$sigma,digits)," on ",rdf," degrees of freedom\n",sep=""),file=file,append=TRUE)
if (!is.null(x$fstatistic)) {
HTMLli(paste("Multiple R-Squared:<b>",round(x$r.squared,digits),"</b>",sep=""),file=file,append=TRUE)
HTMLli(paste("Adjusted R-Squared:<b>",round(x$adj.r.squared,digits),"</b>",sep=""),file=file,append=TRUE)
HTMLli(paste("F-statistics: <b>", round(x$fstatistic[1],digits), "</b> on ",x$fstatistic[2], " and ", x$fstatistic[3], " DF. P-value:<b>",round(1-pf(x$fstatistic[1],x$fstatistic[2],x$fstatistic[3]),digits),"</b>." ,sep=""),file=file,append=TRUE)
}
correl <- x$correlation
if (!is.null(correl)) {
p <- NCOL(correl)
if (p > 1) {
HTMLli("Correlation of Coefficients:\n",file=file,append=TRUE,...)
if (symbolic.cor)
HTML(symnum(correl)[-1, -p],file=file,append=TRUE,...)
else {
correl[!lower.tri(correl)] <- NA
HTML(correl[-1, -p, drop = FALSE],file=file,append=TRUE,...)
}
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.coefmat"<- function (x, digits = max(3, getOption("digits") - 2), signif.stars = getOption("show.signif.stars"),
dig.tst = max(1, min(5, digits - 1)), cs.ind = 1:k, tst.ind = k +
1, zap.ind = integer(0), P.values = NULL, has.Pvalue = nc >=
4 && substr(colnames(x)[nc], 1, 3) == "Pr(", na.print = "",file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (is.null(d <- dim(x)) || length(d) != 2)
stop("1st arg. 'x' must be coefficient matrix/d.f./...")
nc <- d[2]
if (is.null(P.values)) {
scp <- getOption("show.coef.Pvalues")
if (!is.logical(scp) || is.na(scp)) {
warning("option `show.coef.Pvalues' is invalid: assuming TRUE")
scp <- TRUE
}
P.values <- has.Pvalue && scp
}
else if (P.values && !has.Pvalue)
stop("'P.values is TRUE, but has.Pvalue not!")
if (has.Pvalue && !P.values) {
d <- dim(xm <- data.matrix(x[, -nc, drop = FALSE]))
nc <- nc - 1
has.Pvalue <- FALSE
}
else xm <- data.matrix(x)
k <- nc - has.Pvalue - (if (missing(tst.ind))
1
else length(tst.ind))
if (!missing(cs.ind) && length(cs.ind) > k)
stop("wrong k / cs.ind")
Cf <- array("", dim = d, dimnames = dimnames(xm))
ok <- !(ina <- is.na(xm))
if (length(cs.ind) > 0) {
acs <- abs(coef.se <- xm[, cs.ind, drop = FALSE])
digmin <- 1 + floor(log10(range(acs[acs != 0], na.rm = TRUE)))
Cf[, cs.ind] <- format(round(coef.se, max(1, digits -
digmin)), digits = digits)
}
if (length(tst.ind) > 0)
Cf[, tst.ind] <- format(round(xm[, tst.ind], digits = dig.tst),
digits = digits)
if (length(zap.ind) > 0)
Cf[, zap.ind] <- format(zapsmall(xm[, zap.ind], digits = digits),
digits = digits)
if (any(r.ind <- !((1:nc) %in% c(cs.ind, tst.ind, zap.ind,
if (has.Pvalue) nc))))
Cf[, r.ind] <- format(xm[, r.ind], digits = digits)
okP <- if (has.Pvalue)
ok[, -nc]
else ok
x0 <- (xm[okP] == 0) != (as.numeric(Cf[okP]) == 0)
if (length(not.both.0 <- which(x0 & !is.na(x0)))) {
Cf[okP][not.both.0] <- format(xm[okP][not.both.0], digits = max(1,
digits - 1))
}
if (any(ina))
Cf[ina] <- na.print
if (P.values) {
if (!is.logical(signif.stars) || is.na(signif.stars)) {
warning("option `show.signif.stars' is invalid: assuming TRUE")
signif.stars <- TRUE
}
pv <- xm[, nc]
if (any(okP <- ok[, nc])) {
Cf[okP, nc] <- format.pval(pv[okP], digits = dig.tst)
signif.stars <- signif.stars && any(pv[okP] < 0.1)
if (signif.stars) {
Signif <- symnum(pv, corr = FALSE, na = FALSE,
cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
symbols = c("***", "**", "*", ".", " "))
Cf <- cbind(Cf, formatC(Signif))
}
}
else signif.stars <- FALSE
}
else signif.stars <- FALSE
HTML.matrix(Cf, file=file, ...)
if (signif.stars) HTML(paste("\n<p>--- Signif. codes: ", attr(Signif, "legend"), "</p>\n",sep=""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.table"<- function(x, file=get(".HTML.file"),append=TRUE,digits=4,...)
{
cat("\n",file=file,append=append)
if (!is.null(digits) && is.numeric(x)) x <- round(x,digits) # PhG, because summary(iris) returns a table, but it is not numeric!
if (is.null(dim(x))) HTML(t(as.matrix(x)),file=file,append=TRUE,digits=NULL,...)
else HTML(unclass(x),file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.listof" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
nn <- names(x)
ll <- length(x)
if (length(nn) != ll)
nn <- paste("Component ", seq(ll))
for (i in seq(length = ll)) {
HTMLli(paste(nn[i],":\n<br>",sep=""),file=file)
HTML(x[[i]], file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ts" <- function (x, calendar=NULL, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
x.orig <- x
x <- as.ts(x)
fr.x <- frequency(x)
if (missing(calendar))
calendar <- any(fr.x == c(4, 12))
if (!calendar)
header <- function(x) {
if ((fr.x <- frequency(x)) != 1)
HTML(paste("\n<br><b>Time series</b>:\n<br><li>Start=",deparse(start(x)),"\n<br><li>End=",deparse(end(x)),"\n<br><li>Frequency=",deparse(fr.x),"\n<br>",sep=""),file=file)
else
HTML(paste("\n<br><b>Time series</b>:\n<br><li>Start=",format(tsp(x)[1]),"\n<br><li>End=",format(tsp(x)[2]),"\n<br><li>Frequency=",deparse(fr.x),"\n<br>",sep=""),file=file)
}
if (NCOL(x) == 1) {
if (calendar) {
if (fr.x > 1) {
dn2 <- if (fr.x == 12)
month.abb
else if (fr.x == 4) {
c("Qtr1", "Qtr2", "Qtr3", "Qtr4")
}
else paste("p", 1:fr.x, sep = "")
if (NROW(x) <= fr.x && start(x)[1] == end(x)[1]) {
dn1 <- start(x)[1]
dn2 <- dn2[1 + (start(x)[2] - 2 + seq(along = x))%%fr.x]
x <- matrix(format(x, ...), nrow = 1, byrow = TRUE,
dimnames = list(dn1, dn2))
}
else {
start.pad <- start(x)[2] - 1
end.pad <- fr.x - end(x)[2]
dn1 <- start(x)[1]:end(x)[1]
x <- matrix(c(rep("", start.pad), format(x,
...), rep("", end.pad)), ncol = fr.x, byrow = TRUE,
dimnames = list(dn1, dn2))
}
}
else {
tx <- time(x)
attributes(x) <- NULL
names(x) <- tx
}
}
else {
header(x)
attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL
}
}
else {
if (calendar && fr.x > 1) {
tm <- time(x)
t2 <- 1 + round(fr.x * ((tm + 0.001)%%1))
p1 <- format(floor(tm))
rownames(x) <- if (fr.x == 12)
paste(month.abb[t2], p1, sep = " ")
else paste(p1, if (fr.x == 4)
c("Q1", "Q2", "Q3", "Q4")[t2]
else format(t2), sep = " ")
}
else {
if (!calendar)
header(x)
rownames(x) <- format(time(x))
}
attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL
}
NextMethod("HTML", x, file=file, ...)
invisible(x.orig)
}
#----------------------------------------------------------------------------------------------------#
"HTML.list" <- function(x,file=get(".HTML.file"),first=TRUE,append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (first) {HTML("<hr class='hr'>",file=file,append=TRUE,sep="\n")}
for (i in 1:length(x)) {
cat("<ul>",file=file,append=TRUE,sep="\n")
cat("</center><li>",file=file,append=TRUE,sep="\n")
HTML(x[[i]],file=file,first=FALSE,...)
cat("</ul>",file=file,append=TRUE,sep="\n")
}
cat("\n<br><hr class='hr'>",file=file,append=TRUE,sep="\n")
}
#----------------------------------------------------------------------------------------------------#
"HTML.pairlist" <- function(x,file=get(".HTML.file"),first=TRUE,append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (first) {HTML("<hr class='hr'>",file=file,append=TRUE,sep="\n")}
for (i in 1:length(x)) {
cat("<ul>",file=file,append=TRUE,sep="\n")
cat("</center><li>",file=file,append=TRUE,sep="\n")
HTML(x[[i]],file=file,first=FALSE,...)
cat("</ul>",file=file,append=TRUE,sep="\n")
}
cat("\n<br><hr class='hr'>",file=file,append=TRUE,sep="\n")
}
#----------------------------------------------------------------------------------------------------#
# row.names option contributed by
# Tobias Verbeke on 2006-05-27
#
# Fixed bug of invalid HTML output when using
# row.names = FALSE, as patch contributed
# by Michael Irskens on 2006-11-04
#
"HTML.data.frame" <- function(
x, file=get(".HTML.file"),
Border = 1, innerBorder = 0,
classfirstline = "firstline",
classfirstcolumn = "firstcolumn",
classcellinside = "cellinside",
append = TRUE,
align = "center",
caption = "",
captionalign = "bottom",
classcaption = "captiondataframe",
classtable = "dataframe",
digits = getOption("R2HTML.format.digits"),
nsmall = getOption("R2HTML.format.nsmall"),
big.mark = getOption("R2HTML.format.big.mark"),
big.interval = getOption("R2HTML.format.big.interval"),
decimal.mark = getOption("R2HTML.format.decimal.mark"),
sortableDF = getOption("R2HTML.sortableDF"),
row.names = TRUE,
...)
{
cat("\n", file = file, append = append)
# Handle sortableDF argument
if (is.null(sortableDF)) sortableDF = FALSE
if (sortableDF)
cat(paste(c("\n<style>", ".tablesort {",
"cursor: pointer ;",
" behavior:url(tablesort.htc);",
" -moz-binding: url(moz-behaviors.xml#tablesort.htc);",
"}",
"</style>\n"),
collapse="\n"),
file = file, append = TRUE)
# if (!is.null(digits)) x[] = lapply(x, FUN = function(vec) if (is.numeric(vec)) round(vec, digits) else vec)
txt <- paste("\n<p align=",align,">")
txtcaption <- ifelse(is.null(caption),
"",
paste("\n<caption align=", captionalign,
" class=", classcaption, ">",
caption,
"</caption>\n", sep=""))
if (!is.null(Border))
txt <- paste(txt, "\n<table cellspacing=0 border=", Border, ">",
txtcaption,"<tr><td>",
"\n\t<table border=", innerBorder, " class=",classtable,">",
sep = "")
else txt <- paste(txt, "\n<table border=", innerBorder,
" class=",classtable," cellspacing=0>",
txtcaption, sep = "")
txt <- paste(txt,"\t<tbody>",sep="\n")
VecDebut <- c(
if(row.names)
paste("\n\t\t<th>",
if(sortableDF) '<b class="tablesort">',
sep = "", collapse = ""),
rep(paste("\n\t\t<th>",
if(sortableDF) '<b class="tablesort">',
sep = "", collapse = ""), ncol(x) - 1)
)
VecMilieu <- c(
if(row.names) " ",
as.character(dimnames(x)[[2]])
)
VecFin <- c(
if(row.names)
paste(if(sortableDF) '</b>', "", "</th>", collapse = ""),
rep(
paste(if(sortableDF) '</b>',"", "</th>", collapse = ""), ncol(x) - 1
),
"</th>"
)
txt <- paste(txt, "\n\t<tr class=", classfirstline, ">",
paste(VecDebut, VecMilieu, VecFin, sep = "", collapse = ""),
"\n\t</tr>"
)
x.formatted <- format(x, digits = digits, nsmall = nsmall,
big.mark = big.mark, big.interval = big.interval,
decimal.mark = decimal.mark)
x.formatted <- as.matrix(x.formatted)
x.formatted[is.na(x.formatted)] <- " "
x.formatted[is.nan(x.formatted)] <- " "
for(i in 1:dim(x)[1]) {
if(i == 1) {
VecDebut <- c(if(row.names)
paste("\n<td class=", classfirstcolumn, ">",
sep = ""),
paste("\n<td class=", classcellinside, ">", sep = ""),
rep(paste("\n<td class=", classcellinside, ">",
sep = ""),
dim(x)[2] - 1)
)
VecMilieu <- c(if(row.names)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,])
)
VecFin <- c(if(row.names) "\n</td>",
rep("\n</td>", dim(x)[2] - 1),
"\n</td></tr>\n"
)
}
else {
VecDebut <- c(if(row.names)
paste("\n<td class=", classfirstcolumn, ">",
sep = ""),
paste(rep(paste("\n<td class=", classcellinside, ">",
sep = ""),
dim(x)[2])
)
)
VecMilieu <- c(if(row.names)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,]))
VecFin <- c(if(row.names) "\n</td>",
rep("\n</td>", dim(x)[2] - 1),
"\n</td></tr>\n")
}
txt <- paste(txt, "\n<tr>",
paste(VecDebut, VecMilieu, VecFin, sep = "", collapse = ""))
}
txt <- paste(txt, "\n\t</tbody>\n</table>\n",
if (!is.null(Border)) "</td></table>\n","<br>")
cat(txt, "\n", file = file, sep = "", append = TRUE)
}
#----------------------------------------------------------------------------------------------------#
"HTML.matrix" <- function(x, file=get(".HTML.file"), Border = 1, innerBorder = 0, classfirstline = "firstline", classfirstcolumn = "firstcolumn", classcellinside = "cellinside", append=TRUE,align="center",caption="",captionalign="bottom",classcaption="captiondataframe",classtable="dataframe",digits=getOption("R2HTML.format.digits"),nsmall = getOption("R2HTML.format.nsmall"), big.mark = getOption("R2HTML.format.big.mark"), big.interval = getOption("R2HTML.format.big.interval"), decimal.mark = getOption("R2HTML.format.decimal.mark"),...)
{
cat("\n", file=file,append=append)
# if (is.numeric(x) & !is.null(digits)) x<-round(x,digits=digits)
txt <- paste("\n<p align=",align,">")
txtcaption <- ifelse(is.null(caption),"",paste("<caption align=",captionalign," class=",classcaption,">",caption,"</caption>\n",sep=""))
if (!is.null(Border)) txt <- paste(txt, "\n<table cellspacing=0 border=",Border,">",txtcaption,"<tr><td>","\n\t<table border=", innerBorder, " class=",classtable,">", sep = "")
else txt <- paste(txt, "\n\t<table border=", innerBorder, " class=", classtable," cellspacing=0>", txtcaption, sep = "")
txt <- paste(txt,"\t<tbody>",sep="\n")
if(is.null(dimnames(x)[[2]]) == FALSE) {
VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste(
"<th>", sep = ""),
rep(paste("<th>", sep = ""), dim(
x)[2] - 1))
VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "",
as.character(dimnames(x)[[2]]))
VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</th>", rep(
"</th>", dim(x)[2] - 1), "</th>")
txt <- paste(txt,"<tr class=",classfirstline,">", paste(VecDebut, VecMilieu, VecFin, sep = "",collapse = ""),"</tr>\n")
}
x.formatted <- format(x, digits=digits, nsmall=nsmall, big.mark=big.mark, big.interval=big.interval, decimal.mark=decimal.mark)
x.formatted <- as.matrix(x.formatted)
x.formatted[is.na(x.formatted)] <- " "
x.formatted[is.nan(x.formatted)] <- " "
for(i in 1:dim(x)[1]) {
if(i == 1) {
VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste(
"\n<tr><td class=", classfirstcolumn, ">", sep = ""),
paste("\n<td class=", classcellinside, ">", sep = ""),
rep(paste("\n<td class=", classcellinside, ">", sep =
""), dim(x)[2] - 1))
VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,]))
VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</td>",
rep("</td>", dim(x)[2] - 1), "</td></tr>\n")
}
else {
VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste(
"\n<tr><td class=", classfirstcolumn, ">", sep = ""),
paste(rep(paste("\n<td class=", classcellinside, ">", sep
= ""), dim(x)[2])))
VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE)
dimnames(x)[[1]][i],
HTMLReplaceNA(x.formatted[i,]))
VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</td>",
rep("</td>", dim(x)[2] - 1), "</td></tr>\n")
}
txt <- paste(txt, paste(VecDebut, VecMilieu, VecFin, sep = "",collapse = ""))
}
txt <- paste(txt, "\n\t</tbody>\n</table>\n",if (!is.null(Border)) "</td></table>\n","<br>")
cat(txt, "\n", file = file, sep = "", append=TRUE)
}
#----------------------------------------------------------------------------------------------------#
"HTML.structure"<-
function(x, a = attributes(x), prefix = "", file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
n <- length(dim(x))
nn <- names(a)
ate <- character(0)
if(n > 0) {
if(n == 2)
HTML.matrix(x, file = file,append=TRUE, ...)
else HTML.array(x, file = file,append=TRUE, ...)
ate <- c("dim", "dimnames")
if(n == 1)
ate <- c(ate, "names")
}
else if(!is.atomic(x)) {
HTML(as.vector(x), file = file,append=TRUE, ...)
ate <- "names"
}
else if(length(tsp(x))) {
HTML.ts(x, file = file,append=TRUE, ...)
ate <- "tsp"
}
else if(length(names(x))) {
HTML.matrix(matrix(x, 1, dimnames = list("", names(x))),
file = file,append=TRUE, ...)
ate <- "names"
}
else HTML(as.vector(x), file = file,append=TRUE, ...)
ii <- !match(nn, ate, nomatch = FALSE)
nn <- nn[ii]
a <- a[ii]
for(i in seq(nn)) {
this <- paste("attr(", prefix, ", \"", nn[i], "\")", sep = "")
HTML(this, file=file,append=TRUE)
HTML(a[[i]], file = file, append=TRUE, ...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.connection" <- function(x,file=get(".HTML.file"),append=TRUE,...) HTML(paste("<font class='connection'>",unlist(summary(x)),"</font>",sep=""),file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.socket" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
if (length(port <- as.integer(x$socket)) != 1)
stop("invalid `socket' argument")
HTML(paste("Socket connection #", x$socket, "to", x$host, "on port",
x$port, "\n<br>",sep=""),file=file,append=append,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.htest" <- function (x, digits = 4, quote = TRUE, prefix = "",file=get(".HTML.file"),append=TRUE, ...)
{
HTML("\n", file=file,append=append)
HTML(as.title(paste(" ",x$method,sep="")),file=file,append=TRUE,...)
HTMLli(paste("\n data:<font class=dataname>",x$data.name,"</font>\n",sep=""),file=file,append=TRUE,...)
out <- character()
if (!is.null(x$statistic))
out <- c(out, paste(names(x$statistic), "=<b>", format(round(x$statistic,4)),"</b>"))
if (!is.null(x$parameter))
out <- c(out, paste(names(x$parameter), "=<b>", format(round(x$parameter,3)),"</b>"))
if (!is.null(x$p.value))
out <- c(out, paste("p-value =<font class='pvalue'>", format.pval(x$p.value,digits = digits),"</font>"))
HTMLli(paste(out,collapse=" , "),file=file,append=TRUE,...)
if (!is.null(x$alternative)) {
HTMLli("alternative hypothesis: ",file=file)
if (!is.null(x$null.value)) {
if (length(x$null.value) == 1) {
alt.char <- switch(x$alternative, two.sided = "not equal to",
less = "less than", greater = "greater than")
HTML(paste("true", names(x$null.value), "is", alt.char,
x$null.value, "\n"),file=file,append=TRUE,...)
}
else {
HTMLli(paste(x$alternative, "\nnull values:\n<br>"),file=file,append=TRUE,...)
HTML(x$null.value, file=file,append=TRUE,...)
}
}
else HTML(paste(x$alternative, "\n<br>"),file=file,append=TRUE,...)
}
if (!is.null(x$conf.int)) {
HTMLli(paste("<b>",format(100 * attr(x$conf.int, "conf.level")), "</b> percent confidence interval:\n",
"<b>[", paste(format(c(x$conf.int[1], x$conf.int[2])),sep="",collapse=" ;"),"]</b>",sep=""),file=file,append=TRUE,...)
}
if (!is.null(x$estimate)) {
HTMLli("sample estimates:\n",file=file,...)
HTML(t(as.matrix(x$estimate)),file=file,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.aov" <- function (x, intercept = FALSE, tol = .Machine$double.eps^0.5, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:\n<br><font class='call'>", deparse(cl)),"</font>",file=file)
asgn <- x$assign[x$qr$pivot[1:x$rank]]
effects <- x$effects
if (!is.null(effects))
effects <- as.matrix(effects)[seq(along = asgn), , drop = FALSE]
rdf <- x$df.resid
uasgn <- unique(asgn)
nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))[1 + uasgn]
nterms <- length(uasgn)
nresp <- NCOL(effects)
df <- numeric(nterms)
ss <- matrix(NA, nterms, nresp)
if (nterms) {
for (i in seq(nterms)) {
ai <- asgn == uasgn[i]
df[i] <- sum(ai)
ef <- effects[ai, , drop = FALSE]
ss[i, ] <- if (sum(ai) > 1)
colSums(ef^2)
else ef^2 }
keep <- df > 0
if (!intercept && uasgn[1] == 0)
keep[1] <- FALSE
nmeffect <- nmeffect[keep]
df <- df[keep]
ss <- ss[keep, , drop = FALSE]
nterms <- length(df) }
HTMLli("Terms:\n<br>",file=file)
if (nterms == 0) {
if (rdf > 0) {
ss <- colSums(as.matrix(x$residuals)^2)
ssp <- sapply(ss, format)
if (!is.matrix(ssp))
ssp <- t(ssp)
tmp <- as.matrix(c(ssp, format(rdf)))
if (length(ss) > 1) {
rn <- colnames(x$fitted)
if (is.null(rn))
rn <- paste("resp", 1:length(ss))
}
else rn <- "Sum of Squares"
dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), "Residuals")
HTML(as.data.frame(tmp), file=file,..)
HTMLli(paste("Residual standard error:", paste(sapply(sqrt(ss/rdf),format),collapse=" "), "\n"),file=file)
}
else HTML.matrix(matrix(0, 2, 1, dimnames = list(c("Sum of Squares","Deg. of Freedom"), "<empty>")),file=file)
}
else {
if (rdf > 0) {
resid <- as.matrix(x$residuals)
nterms <- nterms + 1
df <- c(df, rdf)
ss <- rbind(ss, colSums(resid^2))
nmeffect <- c(nmeffect, "Residuals") }
ssp <- apply(zapsmall(ss), 2, format)
tmp <- t(cbind(ssp, format(df)))
if (ncol(effects) > 1) {
rn <- colnames(x$coef)
if (is.null(rn))
rn <- paste("resp", seq(ncol(effects))) }
else rn <- "Sum of Squares"
dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), nmeffect)
HTML(as.data.frame(tmp), file=file)
rank <- x$rank
int <- attr(x$terms, "intercept")
nobs <- NROW(x$residuals) - !(is.null(int) || int == 0)
if (rdf > 0) {
rs <- sqrt(colSums(as.matrix(x$residuals)^2)/rdf)
HTMLli(paste("Residual standard error:", paste(sapply(rs,format),collapse=" "), "\n"),file=file) }
coef <- as.matrix(x$coef)[, 1]
R <- x$qr$qr
R <- R[1:min(dim(R)), , drop = FALSE]
R[lower.tri(R)] <- 0
if (rank < (nc <- length(coef))) {
HTMLli(paste(nc - rank, "out of", nc, "effects not estimable\n"),file=file)
R <- R[, 1:rank, drop = FALSE] }
d2 <- sum(abs(diag(R)))
diag(R) <- 0
if (sum(abs(R))/d2 > tol)
HTMLli("Estimated effects may be unbalanced\n",file=file)
else HTMLli("Estimated effects are balanced\n",file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.anova" <- function (x, digits = max(getOption("digits") - 2, 3), signif.stars = getOption("show.signif.stars"),file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
if (!is.null(heading <- attr(x, "heading")))
HTML(paste("<p><b>",heading, "</b></p>"),file=file)
nc <- (d <- dim(x))[2]
if (is.null(cn <- colnames(x)))
stop("anova object must have colnames(.)!")
ncn <- nchar(cn)
has.P <- substr(cn[nc], 1, 3) == "Pr("
zap.i <- 1:(if (has.P) nc - 1 else nc)
i <- which(substr(cn, 2, 7) == " value")
i <- c(i, which(!is.na(match(cn, c("FALSE", "Cp", "Chisq")))))
if (length(i))
zap.i <- zap.i[!(zap.i %in% i)]
tst.i <- i
if (length(i <- which(substr(cn, ncn - 1, ncn) == "Df")))
zap.i <- zap.i[!(zap.i %in% i)]
HTML.coefmat(x, digits = digits, signif.stars = signif.stars,
has.Pvalue = has.P, P.values = has.P, cs.ind = NULL,
zap.ind = zap.i, tst.ind = tst.i, na.print = "", file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.glm" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "", file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
HTMLli(paste("Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>\n<br>"),file=file)
HTMLli("Coefficients",file=file)
if (is.character(co <- x$contrasts))
HTML(paste(" [contrasts: ", apply(cbind(names(co), co), 1,
paste, collapse = "="), "]"),file=file)
HTMLbr(file=file)
HTML(format(x$coefficients, digits = digits),file=file)
HTMLli(paste("\nDegrees of Freedom:<b>", x$df.null, "</b>Total (i.e. Null);<b> ",
x$df.residual, "</b> Residual\n"),file=file)
HTMLli(paste("Null Deviance:<b> ", format(signif(x$null.deviance,
digits)), "</b> Residual Deviance:<b>", format(signif(x$deviance,
digits)), " </b> AIC:<b> ", format(signif(x$aic, digits)), "</b>\n<br>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tables.aov" <- function (x, digits = 4, file=get(".HTML.file"),...)
{
HTML("<center>",file=file)
tables.aov <- x$tables
n.aov <- x$n
se.aov <- if (se <- !is.na(match("se", names(x))))
x$se
type <- attr(x, "type")
switch(type, effects = HTML("<p class=partitle>Tables of effects\n</p>",file=file), means = HTML("<P CLASS=partitle>Tables of means\n</p>",file=file),
residuals = if (length(tables.aov) > 1)
HTML("<p class=partitle>Table of residuals from each stratum\n</p>",file=file))
if (!is.na(ii <- match("Grand mean", names(tables.aov)))) {
HTML("<p>Grand mean\n</p>",file=file)
gmtable <- tables.aov[[ii]]
HTML.mtable(gmtable, digits = digits, file=file)
}
for (i in names(tables.aov)) {
if (i == "Grand mean")
next
table <- tables.aov[[i]]
HTML(paste("\n<p>", i, "\n</p>"),file=file)
if (!is.list(n.aov))
HTML.mtable(table, digits = digits,file=file,append=TRUE, ...)
else {
n <- n.aov[[i]]
if (length(dim(table)) < 2) {
table <- rbind(table, n)
rownames(table) <- c("", "rep")
HTML(table, digits = digits, file=file)
}
else {
ctable <- array(c(table, n), dim = c(dim(table),
2))
dim.t <- dim(ctable)
d <- length(dim.t)
ctable <- aperm(ctable, c(1, d, 2:(d - 1)))
dim(ctable) <- c(dim.t[1] * dim.t[d], dim.t[-c(1,
d)])
dimnames(ctable) <- c(list(format(c(rownames(table),
rep("rep", dim.t[1])))), dimnames(table)[-1])
ctable <- eval(parse(text = paste("ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))",
paste(rep(", ", d - 2), collapse = " "), "]")))
names(dimnames(ctable)) <- names(dimnames(table))
class(ctable) <- "mtable"
HTML.mtable(ctable, digits = digits,file=file, append=TRUE,...)
}
}
}
if (se) {
if (type == "residuals")
rn <- "df"
else rn <- "replic."
switch(attr(se.aov, "type"), effects = HTML("\n<p class=partitle>Standard errors of effects\n</p>",file=file),
means = HTML("\n<p class=partitle>Standard errors for differences of means\n</p>",file=file),
residuals = HTML("\n<p class=partitle>Standard errors of residuals\n</p>",file=file))
if (length(unlist(se.aov)) == length(se.aov)) {
n.aov <- n.aov[!is.na(n.aov)]
se.aov <- unlist(se.aov)
cn <- names(se.aov)
se.aov <- rbind(format(se.aov, digits = digits),
format(n.aov))
dimnames(se.aov) <- list(c(" ", rn), cn)
HTML.matrix(se.aov,file=file)
}
else for (i in names(se.aov)) {
se <- se.aov[[i]]
if (length(se) == 1) {
se <- rbind(se, n.aov[i])
dimnames(se) <- list(c(i, rn), "")
HTML(se, file=file)
}
else {
dimnames(se)[[1]] <- ""
HTML(paste("\n<p>", i, "\n</p>"),file=file)
HTML("When comparing means with same levels of:\n<br>",file=file)
HTML(se, file=file, ...)
HTML(paste("replic.", n.aov[i], "\n<br>"),file=file)
}
}
}
HTML("</center>",file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.mtable" <- function (x, digits = getOption("digits"),file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file,append=append,...)
xxx <- x
xx <- attr(x, "Notes")
nn <- names(dimnames(x))
a.ind <- match(names(a <- attributes(x)), c("dim", "dimnames",
"names"))
a <- a[!is.na(a.ind)]
class(x) <- attributes(x) <- NULL
attributes(x) <- a
if (length(x) == 1 && is.null(names(x)) && is.null(dimnames(x)))
names(x) <- rep("", length(x))
if (length(dim(x)) && is.numeric(x)) {
xna <- is.na(x)
x <- format(zapsmall(x, digits))
x[xna] <- " "
}
HTML(x, file=file, ...)
if (length(xx)) {
HTML("\n<br>Notes:\n<br>",file=file)
HTML(xx,file=file)
}
invisible(xxx)
}
#----------------------------------------------------------------------------------------------------#
"HTML.integrate" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
if (x$message == "OK")
HTML(paste("<p>",format(x$value, digits = digits), " with absolute error < ",
format(x$abs.error, digits = 2), "\n</p>", sep = ""),file=file)
else HTML(paste("<p>failed with message `", x$message, "'\n</p>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.lm.null" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
HTMLli(paste("<br><p>Call:<font class=call> ", paste(deparse(x$call), sep = "\n<br>", collapse = "\n<br>"), "</font></p>" ),file=file)
resid <- x$residuals
df <- x$df
rdf <- df[2]
if (rdf > 5) {
HTMLli("Residuals:\n<br>",file=file)
if (length(dim(resid)) == 2) {
rq <- apply(t(resid), 1, quantile)
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q",
"Max"), dimnames(resid)[[2]])
}
else {
rq <- quantile(resid)
names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
}
HTML(round(rq, digits) ,file=file)
}
else if (rdf > 0) {
HTMLli("Residuals:\n<br>",file=file)
HTML(round(resid, digits ), file=file)
}
else HTMLli("\n<br>No Coefficients:\n<br>",file=file)
HTMLli(paste("\n<br>Residual standard error:<b> ", format(signif(x$sigma,
digits)), "on <b> ", rdf, " </b>degrees of freedom\n<br><br>",sep=""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.glm" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "",
symbolic.cor = p > 4, signif.stars = getOption("show.signif.stars"), file=get(".HTML.file"),append=TRUE,
...)
{
cat("\n", file=file,append=append,...)
HTMLli(paste("\n<p>Call: <font class=call>",paste(deparse(x$call),collapse=" "),"</font>"),file=file)
HTML("<p>Deviance Residuals: \n</p>",file=file)
if (x$df.residual > 5) {
x$deviance.resid <- quantile(x$deviance.resid, na.rm = TRUE)
names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q",
"Max")
}
HTML(t(round(x$deviance.resid,digits)) , file=file)
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML.coefmat(x$coef, signif.stars = signif.stars, file=file)
HTML(paste("\n<p>(Dispersion parameter for ", x$family$family, " family taken to be ",
format(x$dispersion), ")\n</p>\n"),file=file)
HTML(paste("<li>Null deviance:<b>", round(x$null.deviance,digits), "</b> on <b>", x[c("df.null")],"</b> degrees of freedom."),file=file)
HTML(paste("<li>Residual deviance:<b>", round(x$deviance,digits), "</b> on <b>", x[c("df.residual")],"</b> degrees of freedom."),file=file)
HTML(paste("<p>AIC:<b> ", format(x$aic, digits = max(4, digits + 1)), "</b>\n</p>\n<p>Number of Fisher Scoring iterations: <b>", x$iter, "</b>\n</p>", sep = ""),file=file)
correl <- x$correlation
if (!is.null(correl)) {
p <- NCOL(correl)
if (p > 1) {
HTML("\n<p>Correlation of Coefficients:\n</p>")
if (symbolic.cor)
HTML(symnum(correl)[-1, -p],file=file)
else {
correl[!lower.tri(correl)] <- NA
HTML(correl[-1, -p, drop = FALSE], file=file)
}
}
}
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.hsearch" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
fields <- paste(x$fields, collapse = " or ")
db <- x$matches
if (NROW(db) > 0) {
HTML(paste("<p>Help files with ", fields, " matching `",
x$pattern, "',\n", "type `help(FOO, package = PKG)' to inspect ",
"entry `FOO(PKG) TITLE':", "\n</p>", sep = ""), file=file)
dbnam <- paste(db[, "name"], "(", db[, "Package"], ")",sep = "")
dbtit <- paste(db[, "title"], sep = "")
HTML(cbind(dbnam, dbtit), file=file)
}
else HTML(paste("<p>No help files found with ", fields, " matching `", x$pattern, "'\n</p>", sep = ""),file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.aov" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
NextMethod("HTML")
}
"HTML.aovlist" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n", file=file,append=append,...)
cl <- attr(x, "call")
if (!is.null(cl)) {
cat("\nCall:\n<font class=call>",file=file,append=TRUE,...)
dput(cl,file=file)
cat("\n</font>",file=file,append=TRUE,...)
}
if (!is.null(attr(x, "weights")))
cat("Note: The results below are on the weighted scale\n",file=file,append=TRUE,...)
nx <- names(x)
if (nx[1] == "(Intercept)") {
mn <- x[[1]]$coef
if (is.matrix(mn)) {
cat("\nGrand Means:\n",file=file,append=TRUE,...)
cat(format(mn[1, ]), file=file,append=TRUE,...)
}
else cat("\nGrand Mean:", format(mn[1]), "\n",file=file,append=TRUE,...)
nx <- nx[-1]
}
for (ii in seq(along = nx)) {
i <- nx[ii]
cat("\nStratum ", ii, ": ", i, "\n", sep = "",file=file,append=TRUE,...)
xi <- x[[i]]
cat(xi,file=file,append=TRUE, ...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.SavedPlots" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\"n",file=file,append=append,...)
if (x[[1]] != 31416) {
HTML("<p>object is not of class `SavedPlots'</p>\n<br>",file=file)
return()
}
HTML("<p>Saved Plots from R version 1.4.0 or later</p>\n<br>\n<br>",file=file,append=TRUE,...)
HTML(" Contains", x[[2]], "out of a maximum", x[[3]], "plots\n",file=file,append=TRUE,...)
lens <- sapply(x[[5]], length)[1:x[[2]]]
cat(" #plot calls are", paste(lens, collapse = ", "), "\n",file=file,append=TRUE,...)
cat(" Current position is plot", 1 + x[[4]], "\n",file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ordered" <- function (x, quote = FALSE,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (length(x) <= 0)
HTML("\n<p>ordered(0)\n</p>",file=file,append=TRUE,...)
else HTML(as.character(x), file,file, append=TRUE,...)
HTML(paste("\n<p>Levels<font class=factorlevels>: ", paste(levels(x), collapse = " < "), "</font>\n</p>"),file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.difftime" <- function (x, digits = getOption("digits"),file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
if (length(x) > 1)
HTML(paste("<p>Time differences of ", paste(format(unclass(x),
digits = digits), collapse = ", "), " ", attr(x,
"units"), "\n</p>", sep = ""),file=file,append=TRUE,...)
else HTML(paste("<p>Time difference of ", format(unclass(x), digits = digits),
" ", attr(x, "units"), "\n", sep = ""),file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.dummy.coef" <- function (x, file=get(".HTML.file"),append=TRUE,title="",...)
{
cat("\n",file=file,append=append,...)
terms <- names(x)
n <- length(x)
nm <- max(sapply(x, length))
ans <- matrix("", 2 * n, nm)
rn <- rep("", 2 * n)
line <- 0
for (j in seq(n)) {
this <- x[[j]]
n1 <- length(this)
if (n1 > 1) {
line <- line + 2
ans[line - 1, 1:n1] <- names(this)
ans[line, 1:n1] <- format(this, ...)
rn[line - 1] <- paste(terms[j], ": ", sep = "")
}
else {
line <- line + 1
ans[line, 1:n1] <- format(this, ...)
rn[line] <- paste(terms[j], ": ", sep = "")
}
}
rownames(ans) <- rn
colnames(ans) <- rep("", nm)
HTML(paste("\n<p>",if (title=="")
"Full coefficients are"
else title, "\n</p>"),file=file,append=TRUE,...)
HTML.matrix(ans[1:line, , drop = FALSE],file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.dummy.coef.list" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
for (strata in names(x)) HTML.dummy.coef(x[[strata]], file=file, title = paste("\n<p> Error:", strata,"</p>"),append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.glm.null" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "",
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste(" Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>\n"),file=file)
HTMLli("No coefficients\n<br>")
HTMLli(paste("Degrees of Freedom:<b>", length(x$residuals), "</b> Total; <b>",
x$df.residual, " </b>Residual\n<br>"),file=file)
HTMLli(paste("Null Deviance:<b>", format(signif(x$null.deviance, digits)),
"</b>\n<br>"),file=file)
HTMLli(paste("Residual Deviance: <b>", format(signif(x$deviance, digits)),
" </b><br>\n"),file=file)
HTMLli(paste("AIC:<b>", format(signif(x$aic, digits)), "</b><br>\n"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.MethodsFunction"<- function (x,file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
info=attr(x,"info")
if (dim(info)[1]==0) HTML("<p>No available generic function for the class",file=file,append=TRUE)
HTML("<p>Available generic functions which does handle the class</p>",file=file,append=TRUE)
HTML(info,file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.libraryIQR" <- function (x,file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
sQuote <- function(s) paste("`", s, "'", sep = "")
db <- x$results
out <- if (nrow(db) == 0)
NULL
else lapply(split(1:nrow(db), db[, "LibPath"]), function(ind) db[ind,
c("Package", "Title"), drop = FALSE])
first <- TRUE
for (lib in names(out)) {
HTML(paste(paste("<p>Packages in library ",
sQuote(lib), ":</p>", sep = "")),file=file,append=TRUE,...)
HTML(cbind(out[[lib]][, "Package"], out[[lib]][,
"Title"]), file=file,append=TRUE,...)
first <- FALSE
}
if (first) {
HTML("<p>no packages found</p>",file=file, append=TRUE,...) }
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.aov" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (length(x) == 1)
HTML(x[[1]], file=file)
else NextMethod()
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.aovlist" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
nn <- names(x)
for (i in nn) {
HTMLli(paste(i, "\n<br>", sep = ""),file=file)
HTML(x[[i]], file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.glm.null" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "",
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:<font class=call> ",paste(deparse(x$call), sep = "\n", collapse = "\n"),
"</font>\n<br>\n", sep = ""),file=file)
HTMLli("Deviance Residuals: \n<br>",file=file)
if (x$df.residual > 5) {
x$deviance.resid <- quantile(x$deviance.resid)
names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q",
"Max")
}
HTML.default(x$deviance.resid, digits = digits, na = "",file=file)
HTMLli("No coefficients\n<br>")
HTMLli(paste("\n(Dispersion parameter for ", x$family$family,
" family taken to be ", x$dispersion, ")\n\n Null deviance:<b> ",
x$null.deviance, " </b>on <b>", x$df.null, " </b>degrees of freedom\n\n",
"Residual deviance: <b>", x$deviance, " </b>on<b> ", x$df.residual,
" </b>degrees of freedom\n\n", "Number of Fisher Scoring iterations<b>: ",
x$iter, "</b>\n<br>\n", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.manova" <- function (x, digits = getOption("digits"),file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (length(stats <- x$stats)) {
HTML.anova(stats,file=file)
}
else {
HTML("<p>No error degrees of freedom</p>\n")
HTML(data.frame(Df = x$Df, row.names = x$row.names),file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.table" <- function (x, digits = max(1, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!inherits(x, "summary.table"))
stop("x must inherit from class `summary.table'")
if (!is.null(x$call)) {
HTMLli(paste("Call:<font class='call'> ", x$call,"</font>"),file=file)
}
HTMLli(paste("Number of cases in table:<b>", x$n.cases, "</b>\n<br>"),file=file)
HTMLli(paste("Number of factors:<b>", x$n.vars, "</b>\n<br>"),file=file)
if (x$n.vars > 1) {
HTMLli("Test for independence of all factors:\n<br>",file=file)
ch <- x$statistic
HTML(paste(" Chisq = <b>", format(round(ch, max(0, digits - log10(ch)))),
"</b>, df = <b>", x$parameter, "</b>, p-value = <b>", format.pval(x$p.value,
digits, eps = 0), "</b>\n<br>", sep = ""),file=file)
if (!x$approx.ok)
HTML("<p>Chi-squared approximation may be incorrect</p>\n",file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.TukeyHSD" <- function (x, file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<center><p><b>Tukey multiple comparisons of means</b></p>\n")
HTML(paste("<p>", format(100 * attr(x, "conf.level"), 2), "% family-wise confidence level</p></center>\n",
sep = ""),file=file)
if (attr(x, "ordered"))
HTML("<center><p>factor levels have been ordered</p></center>\n",file=file)
HTMLli(paste("Fit: ", deparse(attr(x, "orig.call")), "\n<br>\n", sep = ""),file=file)
attr(x, "orig.call") <- attr(x, "conf.level") <- attr(x, "ordered") <- NULL
lapply(unclass(x),HTML,file=file,append=TRUE,...)
#HTML.default(unclass(x), file=file,...)
invisible(return(x))
}
#----------------------------------------------------------------------------------------------------#
"HTML.simple.list" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(noquote(cbind("<-" = unlist(x))), file=file,append=TRUE,...)
}
#----------------------------------------------------------------------------------------------------#
"HTML.noquote" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- attr(x, "class"))) {
cl <- cl[cl != "noquote"]
attr(x, "class") <- (if (length(cl) > 0)
cl
else NULL)
}
HTML(x, file=file, append=TRUE,...)
}
###
### PACKAGES FUNCTIONS
###
### PACKAGE TS
#----------------------------------------------------------------------------------------------------#
"HTML.ar" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call:\n<font class='call'>", deparse(x$call), "</font>\n", sep = ""),file=file)
nser <- NCOL(x$var.pred)
if (nser > 1) {
if (!is.null(x$x.intercept))
res <- x[c("ar", "x.intercept", "var.pred")]
else res <- x[c("ar", "var.pred")]
res$ar <- aperm(res$ar, c(2, 3, 1))
HTML(res, digits = digits,file=file)
}
else {
if (x$order > 0) {
HTMLli("Coefficients:\n",file=file)
coef <- drop(round(x$ar, digits = digits))
names(coef) <- seq(length = x$order)
HTML.default(coef, file=file)
}
if (!is.null(xint <- x$x.intercept) && !is.na(xint))
HTML(paste("<p>Intercept: <b>", format(xint, digits = digits),
"</b> (", format(x$asy.se.coef$x.mean, digits = digits),
") ", "\n</p>", sep = ""),file=file)
HTML(paste("<p>Order selected <b>", x$order, " </b>sigma^2 estimated as <b>",
format(x$var.pred, digits = digits), "</b>\n<</p>"),file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.Arima" <- function (x, digits = max(3, getOption("digits") - 3), se = TRUE,
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("nCall:<font class='call'>", deparse(x$call, width.cutoff = 75), "</font>", sep = "\n"),file=file)
HTMLli("Coefficients:\n<br>",file=file)
coef <- round(x$coef, digits = digits)
if (se && nrow(x$var.coef)) {
ses <- rep(0, length(coef))
ses[x$mask] <- round(sqrt(diag(x$var.coef)), digits = digits)
coef <- matrix(coef, 1, dimnames = list(NULL, names(coef)))
coef <- rbind(coef, s.e. = ses)
}
HTML.default(coef,file=file)
cm <- x$call$method
if (is.null(cm) || cm != "CSS")
HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: log likelihood = <b>", format(round(x$loglik, 2)),
"</b>, aic = <b>", format(round(x$aic, 2)), "</b>\n</p>", sep = ""),file=file)
else HTML("<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: part log likelihood =<b> ", format(round(x$loglik, 2)),
"</b>\n</p>", sep = "")
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.arima0" <- function (x, digits = max(3, getOption("digits") - 3), se = TRUE,
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:<font class='call'>", deparse(x$call, width.cutoff = 75), "</font>", sep = "\n"),file=file)
HTMLli("Coefficients:\n<br>",file=file)
coef <- round(x$coef, digits = digits)
if (se && nrow(x$var.coef)) {
ses <- rep(0, length(coef))
ses[x$mask] <- round(sqrt(diag(x$var.coef)), digits = digits)
coef <- matrix(coef, 1, dimnames = list(NULL, names(coef)))
coef <- rbind(coef, s.e. = ses)
}
HTML.default(coef, file=file)
cm <- x$call$method
if (is.null(cm) || cm != "CSS")
HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: log likelihood = <b>", format(round(x$loglik, 2)),
"</b>, aic = <b>", format(round(x$aic, 2)), "</b>\n</p>", sep = ""),file=file)
else HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits),
"</b>: part log likelihood =<b> ", format(round(x$loglik, 2)),
"</b>\n</p>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.HoltWinters" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><b>Holt-Winters exponential smoothing", if (x$beta == 0)
"without"
else "with", "trend and", if (x$gamma == 0)
"without"
else paste(if (x$beta == 0)
"with ", x$seasonal, sep = ""), "seasonal componenent.\n</b></p>"),file=file)
HTMLli(paste("\nCall:\n", deparse(x$call), "\n<br>"),file=file)
HTMLli("Smoothing parameters:\n<ul>",file=file)
HTMLli(paste(" alpha: ", x$alpha, "\n"),file=file)
HTMLli(paste(" beta: ", x$beta, "\n"),file=file)
HTMLli(paste(" gamma: ", x$gamma, "\n<br>"),file=file)
HTML("</ul>",file=file)
HTMLli("Coefficients:\n",file=file)
HTML(t(t(x$coefficients)),file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.stl" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call:\n ",deparse(x$call),"\n<br>"),file=file)
HTMLli("\nComponents\n",file=file)
HTML(x$time.series, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.StructTS" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:", deparse(x$call, width.cutoff = 75), "\n", sep = " "),file=file)
HTMLli("Variances:\n",file=file)
HTML(x$coef, digits=digits,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tskernel" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- c(rev(x$coef[2:(x$m + 1)]), x$coef)
i <- -x$m:x$m
HTML(paste("<p>",attr(x, "name"), "</p>\n"),file=file)
HTML(paste( paste("coef[", format(i), "] = ", format(y, digits = digits),sep = ""),collapse="<br>\n", sep = "\n<br>"),file=file)
}
### PACKAGE CTEST
#----------------------------------------------------------------------------------------------------#
"HTML.pairwise.htest" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Pairwise comparisons using", x$method, "\n<br>\n<br>"),file=file)
HTMLli(paste("data: <font class=dataname>", x$data.name,"</font>", "\n<br>\n<br>"),file=file)
pp <- format.pval(x$p.value, 2, na.form = "-")
attributes(pp) <- attributes(x$p.value)
HTML(pp, file=file)
HTMLli(paste("\nP value adjustment method:", x$p.adjust.method, "\n"),file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.power.htest" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste(x$method,"<br>"), file=file)
note <- x$note
x[c("method", "note")] <- NULL
HTML(paste(paste(formatC(names(x), width = 15, flag = "+"),
format(x), sep = " = "), sep = "\n<br>",collapse="\n<br>"),file=file)
if (!is.null(note))
HTML(paste("\n<p>", "NOTE:", note, "\n</p>\n"),file=file)
else HTMLbr(file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.boot" <- function (x, digits = options()$digits, index = 1:ncol(boot.out$t), file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
boot.out <- x
sim <- boot.out$sim
cl <- boot.out$call
t <- matrix(boot.out$t[, index], nrow = nrow(boot.out$t))
allNA <- apply(t, 2, function(t) all(is.na(t)))
ind1 <- index[allNA]
index <- index[!allNA]
t <- matrix(t[, !allNA], nrow = nrow(t))
rn <- paste("t", index, "*", sep = "")
if (length(index) == 0)
op <- NULL
else if (is.null(t0 <- boot.out$t0)) {
if (is.null(boot.out$call$weights))
op <- cbind(apply(t, 2, mean, na.rm = TRUE), sqrt(apply(t,
2, function(t.st) var(t.st[!is.na(t.st)]))))
else {
op <- NULL
for (i in index) op <- rbind(op, boot::imp.moments(boot.out,
index = i)$rat)
op[, 2] <- sqrt(op[, 2])
}
dimnames(op) <- list(rn, c("mean", "std. error"))
}
else {
t0 <- boot.out$t0[index]
if (is.null(boot.out$call$weights)) {
op <- cbind(t0, apply(t, 2, mean, na.rm = TRUE) -
t0, sqrt(apply(t, 2, function(t.st) var(t.st[!is.na(t.st)]))))
dimnames(op) <- list(rn, c("original", " bias ",
" std. error"))
}
else {
op <- NULL
for (i in index) op <- rbind(op, boot::imp.moments(boot.out,
index = i)$rat)
op <- cbind(t0, op[, 1] - t0, sqrt(op[, 2]), apply(t,
2, mean, na.rm = TRUE))
dimnames(op) <- list(rn, c("original", " bias ",
" std. error", " mean(t*)"))
}
}
if (cl[[1]] == "boot") {
if (sim == "parametric")
HTML(as.title("PARAMETRIC BOOTSTRAP"),file=file)
else if (sim == "antithetic") {
if (is.null(cl$strata))
HTML(as.title("ANTITHETIC BOOTSTRAP"),file=file)
else
HTML(as.title("STRATIFIED ANTITHETIC BOOTSTRAP"),file=file)
}
else if (sim == "permutation") {
if (is.null(cl$strata))
HTML(as.title("DATA PERMUTATION"),file=file)
else HTML(as.title("STRATIFIED DATA PERMUTATION"),file=file)
}
else if (sim == "balanced") {
if (is.null(cl$strata) && is.null(cl$weights))
HTML(as.title("BALANCED BOOTSTRAP"),file=file)
else if (is.null(cl$strata))
HTML(as.title("BALANCED WEIGHTED BOOTSTRAP"),file=file)
else if (is.null(cl$weights))
HTML(as.title("STRATIFIED BALANCED BOOTSTRAP"),file=file)
else HTML(as.title("STRATIFIED WEIGHTED BALANCED BOOTSTRAP"),file=file)
}
else {
if (is.null(cl$strata) && is.null(cl$weights))
HTML(as.title("ORDINARY NONPARAMETRIC BOOTSTRAP"),file=file)
else if (is.null(cl$strata))
HTML(as.title("WEIGHTED BOOTSTRAP"),file=file)
else if (is.null(cl$weights))
HTML(as.title("STRATIFIED BOOTSTRAP"),file=file)
else HTML(as.title("STRATIFIED WEIGHTED BOOTSTRAP"),file=file)
}
}
else if (cl[[1]] == "tilt.boot") {
R <- boot.out$R
th <- boot.out$theta
if (sim == "balanced")
HTML(as.title("BALANCED TITLED BOOTSTRAP"),file=file)
else HTML(as.title("TILTED BOOTSTRAP"),file=file)
if ((R[1] == 0) || is.null(cl$tilt) || eval(cl$tilt))
HTML("<p>Exponential tilting used\n</p>",file=file)
else HTML("<p>Frequency Smoothing used\n</p>",file=file)
i1 <- 1
if (boot.out$R[1] > 0)
HTML(paste("<p>First", R[1], "replicates untilted,\n</p>"),file=file)
else {
HTML(paste("<p>First ", R[2], " replicates tilted to ",
signif(th[1], 4), ",\n</p>", sep = ""),file=file)
i1 <- 2
}
if (i1 <= length(th)) {
for (j in i1:length(th)) HTML(paste("<p>Next ", R[j +
1], " replicates tilted to ", signif(th[j], 4),
ifelse(j != length(th), ",\n", ".\n</p>"), sep = ""),file=file)
}
op <- op[, 1:3]
}
else if (cl[[1]] == "tsboot") {
if (!is.null(cl$indices))
HTML(as.title("TIME SERIES BOOTSTRAP USING SUPPLIED INDICES"),file=file)
else if (sim == "model")
HTML(as.title("MODEL BASED BOOTSTRAP FOR TIME SERIES"),file=file)
else if (sim == "scramble") {
HTML(as.title("PHASE SCRAMBLED BOOTSTRAP FOR TIME SERIES"),file=file)
if (boot.out$norm)
HTML("<p>Normal margins used.\n</p>",file=file)
else HTML("<p>Observed margins used.\n</p>",file=file)
}
else if (sim == "geom") {
if (is.null(cl$ran.gen))
HTML(as.title("STATIONARY BOOTSTRAP FOR TIME SERIES"),file=file)
else HTML(as.title("POST-BLACKENED STATIONARY BOOTSTRAP FOR TIME SERIES"),file=file)
HTML(paste("<p>Average Block Length of", boot.out$l,
"\n</p>"),file=file)
}
else {
if (is.null(cl$ran.gen))
HTML("<p>BLOCK BOOTSTRAP FOR TIME SERIES</p>",file=file)
else HTML("<p>POST-BLACKENED BLOCK BOOTSTRAP FOR TIME SERIES</p>",file=file)
HTML(paste("<p>Fixed Block Length of", boot.out$l, "\n</p>"),file=file)
}
}
else {
cat("\n")
if (sim == "weird") {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED BOOTSTRAP FOR CENSORED DATA"),file=file)
}
else if ((sim == "ordinary") || ((sim == "model") &&
is.null(boot.out$cox))) {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED CASE RESAMPLING BOOTSTRAP FOR CENSORED DATA"),file=file)
}
else if (sim == "model") {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED MODEL BASED BOOTSTRAP FOR COX REGRESSION MODEL"),file=file)
}
else if (sim == "cond") {
if (!is.null(cl$strata))
HTML(as.title("STRATIFIED CONDITIONAL BOOTSTRAP"),file=file)
if (is.null(boot.out$cox))
HTML("<p>FOR CENSORED DATA\n</p>\n",file=file)
else HTML("<p>FOR COX REGRESSION MODEL\n</p>\n",file=file)
}
}
HTMLli(paste("\nCall: ",deparse(cl)),file=file)
HTMLli("Bootstrap Statistics :\n<br>",file=file)
if (!is.null(op))
HTML(op, digits = digits,file=file)
if (length(ind1) > 0)
for (j in ind1) HTML(paste("<p>WARNING: All values of t",
j, "* are NA\n</p>", sep = ""),file=file)
invisible(boot.out)
}
#----------------------------------------------------------------------------------------------------#
"HTML.simplex" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
simp.out <- x
HTML("\n<p><b>Linear Programming Results\n</b></p>\n",file=file)
cl <- simp.out$call
HTMLli(paste("Call : ",deparse(cl)),file=file)
HTML(paste("<p>", if (simp.out$maxi) "Maximization" else "Minimization", " Problem with Objective Function Coefficients\n</p>"),file=file)
HTML(simp.out$obj,file=file)
if (simp.out$solved == 1) {
HTML("\n<p>\nOptimal solution has the following values\n</p>",file=file)
HTML(simp.out$soln,file=file)
HTML(paste("<p>The optimal value of the objective ", " function is ",
simp.out$value, ".\n</p>", sep = ""),file=file)
}
else if (simp.out$solved == 0) {
HTML("\n<p>\nIteration limit exceeded without finding solution\n</p>",file=file)
HTML("<p>The coefficient values at termination were\n</p>",file=file)
HTML(simp.out$soln,file=file)
HTML(paste("<p>The objective function value was ", simp.out$value,
".\n</p>", sep = ""),file=file)
}
else HTML("\n<p>No feasible solution could be found\n</p>",file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.saddle.distn" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
sad.d <- x
cl <- sad.d$call
rg <- range(sad.d$points[, 1])
mid <- mean(rg)
digs <- ceiling(log10(abs(mid)))
if (digs <= 0)
digs <- 4
else if (digs >= 4)
digs <- 0
else digs <- 4 - digs
rg <- round(rg, digs)
level <- 100 * sad.d$quantiles[, 1]
quans <- format(round(sad.d$quantiles, digs))
quans[, 1] <- paste( format(level), "% ", sep = "")
HTML("\n<p><b>Saddlepoint Distribution Approximations\n</b></p>\n",file=file)
HTMLli(paste("Call : ",paste(deparse(cl),collapse="")),file=file)
HTML("\n<p>Quantiles of the Distribution\n</p>",file=file)
HTML(t(t(quans)),file=file)
HTML(paste("\n<p>\nSmoothing spline used ", nrow(sad.d$points),
" points in the range ", rg[1], " to ", rg[2], ".</p>", sep = ""),file=file)
if (sad.d$LR)
HTMLli("Lugananni-Rice approximations used.",file=file)
HTMLbr(file=file)
invisible(sad.d)
}
#----------------------------------------------------------------------------------------------------#
"HTML.bootci" <- function (x, hinv = NULL, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
ci.out <- x
cl <- ci.out$call
ntypes <- length(ci.out) - 3
nints <- nrow(ci.out[[4]])
t0 <- ci.out$t0
if (!is.null(hinv))
t0 <- hinv(t0)
digs <- ceiling(log10(abs(t0)))
if (digs <= 0)
digs <- 4
else if (digs >= 4)
digs <- 0
else digs <- 4 - digs
intlabs <- NULL
basrg <- strg <- perg <- bcarg <- NULL
if (!is.null(ci.out$normal))
intlabs <- c(intlabs, " Normal ")
if (!is.null(ci.out$basic)) {
intlabs <- c(intlabs, " Basic ")
basrg <- range(ci.out$basic[, 2:3])
}
if (!is.null(ci.out$student)) {
intlabs <- c(intlabs, " Studentized ")
strg <- range(ci.out$student[, 2:3])
}
if (!is.null(ci.out$percent)) {
intlabs <- c(intlabs, " Percentile ")
perg <- range(ci.out$percent[, 2:3])
}
if (!is.null(ci.out$bca)) {
intlabs <- c(intlabs, " BCa ")
bcarg <- range(ci.out$bca[, 2:3])
}
level <- 100 * ci.out[[4]][, 1]
if (ntypes == 4)
n1 <- n2 <- 2
else if (ntypes == 5) {
n1 <- 3
n2 <- 2
}
else {
n1 <- ntypes
n2 <- 0
}
ints1 <- matrix(NA, nints, 2 * n1 + 1)
ints1[, 1] <- level
n0 <- 4
for (i in n0:(n0 + n1 - 1)) {
j <- c(2 * i - 6, 2 * i - 5)
nc <- ncol(ci.out[[i]])
nc <- c(nc - 1, nc)
if (is.null(hinv))
ints1[, j] <- ci.out[[i]][, nc]
else ints1[, j] <- hinv(ci.out[[i]][, nc])
}
n0 <- 4 + n1
ints1 <- format(round(ints1, digs))
ints1[, 1] <- paste("\n<br>", level, "% ", sep = "")
ints1[, 2 * (1:n1)] <- paste("(", ints1[, 2 * (1:n1)], ",",
sep = "")
ints1[, 2 * (1:n1) + 1] <- paste(ints1[, 2 * (1:n1) + 1],
") ")
if (n2 > 0) {
ints2 <- matrix(NA, nints, 2 * n2 + 1)
ints2[, 1] <- level
j <- c(2, 3)
for (i in n0:(n0 + n2 - 1)) {
if (is.null(hinv))
ints2[, j] <- ci.out[[i]][, c(4, 5)]
else ints2[, j] <- hinv(ci.out[[i]][, c(4, 5)])
j <- j + 2
}
ints2 <- format(round(ints2, digs))
ints2[, 1] <- paste("\n<br>", level, "% ", sep = "")
ints2[, 2 * (1:n2)] <- paste("(", ints2[, 2 * (1:n2)],
",", sep = "")
ints2[, 2 * (1:n2) + 1] <- paste(ints2[, 2 * (1:n2) +
1], ") ")
}
R <- ci.out$R
HTML(as.title("BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS"),file=file)
HTML(paste("<p>Based on", R, "bootstrap replicates\n\n</p>"),file=file)
HTMLli(paste("CALL : ",paste(deparse(cl),collapse=" ")),file=file)
HTML("\n<p>Intervals : </p>",file=file)
HTML(paste("\n<p>Level", intlabs[1:n1],"</p>"),file=file)
HTML(t(ints1),file=file)
if (n2 > 0) {
HTML(paste("\n<p>\nLevel", intlabs[(n1 + 1):(n1 + n2)],"</p>"),file=file)
HTML(t(ints2),file=file)
}
if (!is.null(cl$h)) {
if (is.null(cl$hinv) && is.null(hinv))
HTML("\n<p>Calculations and Intervals on Transformed Scale\n</p>",file=file)
else HTML("\n<p>Calculations on Transformed Scale; Intervals on Original Scale\n</p>",file=file)
}
else if (is.null(cl$hinv) && is.null(hinv))
HTML("\n<p>Calculations and Intervals on Original Scale\n</p>",file=file)
else HTML("\n<p>Calculations on Original Scale but Intervals Transformed\n</p>",file=file)
if (!is.null(basrg)) {
if ((basrg[1] <= 1) || (basrg[2] >= R))
HTML("\n<p>Warning : Basic Intervals used Extreme Quantiles\n</p>",file=file)
if ((basrg[1] <= 10) || (basrg[2] >= R - 9))
HTML("\n<p>Some basic intervals may be unstable\n</p>",file=file)
}
if (!is.null(strg)) {
if ((strg[1] <= 1) || (strg[2] >= R))
HTML("\n<p>Warning : Studentized Intervals used Extreme Quantiles\n</p>",file=file)
if ((strg[1] <= 10) || (strg[2] >= R - 9))
HTML("\n<p>Some studentized intervals may be unstable\n</p>",file=file)
}
if (!is.null(perg)) {
if ((perg[1] <= 1) || (perg[2] >= R))
HTML("\n<p>Warning : Percentile Intervals used Extreme Quantiles\n</p>",file=file)
if ((perg[1] <= 10) || (perg[2] >= R - 9))
HTML("\n<p>Some percentile intervals may be unstable\n</p>",file=file)
}
if (!is.null(bcarg)) {
if ((bcarg[1] <= 1) || (bcarg[2] >= R))
HTML("\n<p>Warning : BCa Intervals used Extreme Quantiles\n</p>",file=file)
if ((bcarg[1] <= 10) || (bcarg[2] >= R - 9))
HTML("\n<p>Some BCa intervals may be unstable\n</p>",file=file)
}
invisible(ci.out)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MVA (merged into stats)
#----------------------------------------------------------------------------------------------------#
"HTML.dist" <- function (x, diag = NULL, upper = NULL, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (is.null(diag))
diag <- if (is.null(a <- attr(x, "Diag")))
FALSE
else a
if (is.null(upper))
upper <- if (is.null(a <- attr(x, "Upper")))
FALSE
else a
size <- attr(x, "Size")
df <- as.matrix(x)
if (!upper)
df[row(df) < col(df)] <- NA
if (!diag)
df[row(df) == col(df)] <- NA
HTML(if (diag || upper)
df
else df[-1, -size], file=file, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.factanal" <- function (x, digits = 3, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall:\n", deparse(x$call), "\n<br>\n", sep = ""),file=file)
HTMLli("Uniquenesses:\n<br>",file=file)
HTML(round(x$uniquenesses, digits),file=file,append=TRUE,...)
HTML(x$loadings, digits = digits,file=file,append=TRUE, ...)
p <- nrow(x$loadings)
factors <- x$factors
if (!is.na(x$n.obs) && x$dof > 0) {
dof <- x$dof
stat <- (x$n.obs - 1 - (2 * p + 5)/6 - (2 * factors)/3) *
x$criteria["objective"]
HTMLli(paste("\n<p>Test of the hypothesis that", factors, if (factors ==
1)
"factor is"
else "factors are", "sufficient.\n</p>"),file=file)
HTML(paste("<p>The chi square statistic is <b>", round(stat, 2), " </b> on <b>",
dof, if (dof == 1)
" </b>degree"
else "</b>degrees", "of freedom.\n<br>The p-value is <b>", signif(pchisq(stat,
dof, lower.tail = FALSE), 3), "</b>\n</p>"),file=file)
}
else {
HTML(paste("\n<p>The degrees of freedom for the model is <b>",
x$dof, " </b>and the fit was <b>", round(x$criteria["objective"],
4), "</b>\n</p>"),file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.loadings" <- function (x, digits = 3, cutoff = 0.1, sort = FALSE, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
Lambda <- unclass(x)
p <- nrow(Lambda)
factors <- ncol(Lambda)
if (sort) {
mx <- max.col(abs(Lambda))
ind <- cbind(1:p, mx)
mx[abs(Lambda[ind]) < 0.5] <- factors + 1
Lambda <- Lambda[order(mx, 1:p), ]
}
HTMLli("Loadings:\n<br>",file=file)
fx <- format(round(Lambda, digits))
names(fx) <- NULL
nc <- nchar(fx[1])
fx[abs(Lambda) < cutoff] <- paste(rep(" ", nc), collapse = "")
HTML(fx, file=file, ...)
vx <- colSums(x^2)
varex <- rbind("SS loadings" = vx)
if (is.null(attr(x, "covariance"))) {
varex <- rbind(varex, "Proportion Var" = vx/p)
if (factors > 1)
varex <- rbind(varex, "Cumulative Var" = cumsum(vx/p))
}
HTMLbr(file=file)
HTML(round(varex, digits),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.hclust" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(x$call))
HTMLli(paste("Call : ", deparse(x$call), "\n<ul>\n", sep = ""),file=file)
if (!is.null(x$method))
HTMLli(paste("Cluster method :", x$method, "\n"),file=file)
if (!is.null(x$dist.method))
HTMLli(paste("Distance : ", x$dist.method, "\n"),file=file)
HTMLli(paste("Number of objects: ", length(x$height) + 1, "\n"),file=file)
HTML("</ul><br> <br>",file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.prcomp" <- function (x, print.x = FALSE, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Standard deviations:\n</p>",file=file,append=TRUE)
HTML(x$sdev, file=file,append=TRUE,...)
HTML("\n<p>Rotation:\n</p>")
HTML(x$rotation, file=file,append=TRUE,...)
if (print.x && length(x$x)) {
HTML("\n<p>Rotated variables:\n</p>")
HTML(x$x, file=file,append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.princomp" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call: <font class=call>",deparse(x$call),"</font>"),file=file)
HTML("\n<p>Standard deviations:\n</p>",file=file)
HTML(t(as.matrix(x$sdev)), file=file,append=TRUE,...)
HTML(paste("\n<p><b>", length(x$scale), " </b>variables and <b>", x$n.obs, " </b>observations.\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.prcomp" <- function (x, digits = min(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Importance of components:\n</p>",file=file)
HTML(x$importance, digits = digits,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.princomp" <- function (x, digits = 3, loadings = x$print.loadings, cutoff = x$cutoff, file=get(".HTML.file"), append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
vars <- x$sdev^2
vars <- vars/sum(vars)
HTML("<p>Importance of components:\n</p>",file=file)
HTML(rbind("Standard deviation" = x$sdev, "Proportion of Variance" = vars,
"Cumulative Proportion" = cumsum(vars)),file=file)
if (loadings) {
HTMLli("Loadings:\n",file=file)
cx <- format(round(x$loadings, digits = digits))
cx[abs(x$loadings) < cutoff] <- substring(" ",
1, nchar(cx[1, 1]))
HTML(cx, quote = FALSE, file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE EDA (merged into stats)
#----------------------------------------------------------------------------------------------------#
"HTML.medpolish" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("\n<p><b>Median Polish Results (Dataset: \"", x$name, "\")\n</b></p>",
sep = ""),file=file)
HTML(paste("\n<p>Overall:", x$overall, "\n</p>\n<p>Row Effects:\n</p>"),file=file)
HTML(x$row, digits = digits, file=file,append=TRUE,...)
HTML("\n<p>Column Effects:\n</p>",file=file)
HTML(x$col, digits = digits, file=file)
HTML("\n<p>Residuals:\n</p>",file=file)
HTML(x$residuals, digits = max(2, digits - 2), file=file)
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tukeyline" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call:\n", deparse(x$call), "\n<br>\n", sep = ""),file=file)
HTML("<p>Coefficients:\n</p>",file=file)
print.default(format(coef(x), digits = digits),file=file)
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.tukeysmooth" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><b>",attr(x, "kind"), " Tukey smoother resulting from ", deparse(attr(x,
"call")), "\n", if (twiced <- attr(x, "twiced")) " <-<-twiced<-<- ",
if (!is.null(it <- attr(x, "iter"))) paste(" used", it, "iterations\n"),
if (!is.null(ch <- attr(x, "changed"))) paste(if (!ch) " NOT ", " changed\n</b></p>")),file=file)
if (length(class(x)) > 1)
NextMethod()
else {
y <- x
attributes(y) <- NULL
HTML(y,file=file, append=TRUE)
invisible(x)
}
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE EDA (merged into stats)
#----------------------------------------------------------------------------------------------------#
#
# 2008-05-23: Removed by Fernando H Rosa. Class appears to no longer exist on package stats
#
#"HTML.grob" <- function (x, file=get(".HTML.file"),append=TRUE,...)
#{
# cat("\n",file=file,append=append,...)
# cl <- class(get.value.grob(x))
# HTML(paste(cl[1:(length(cl) - 1)], collapse = " "),file=file)
# invisible(x)
#}
#----------------------------------------------------------------------------------------------------#
"HTML.unit" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(as.character(x), file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.viewport" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(class(x),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE LATTICE
#----------------------------------------------------------------------------------------------------#
"HTML.shingle" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("\n<p>Data:\n</p>",file=file)
HTML(as.numeric(x),file=file)
l <- levels(x)
n <- nlevels(x)
if (n < 1)
HTML("\n<p>no intervals\n</p>",file=file)
else {
int <- data.frame(min = numeric(n), max = numeric(n),
count = numeric(n))
for (i in 1:n) {
int$min[i] <- l[[i]][1]
int$max[i] <- l[[i]][2]
int$count[i] <- length(x[x >= l[[i]][1] & x <= l[[i]][2]])
}
HTML("\n<p>Intervals:\n</p>",file=file)
HTML(int,file=file)
olap <- numeric(n - 1)
if (n > 2)
for (i in 1:(n - 1)) olap[i] <- length(x[x >= l[[i]][1] &
x <= l[[i]][2] & x >= l[[i + 1]][1] & x <= l[[i +
1]][2]])
HTML("\n<p>Overlap between adjacent intervals:\n</p>",file=file)
HTML(olap,file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.shingleLevel" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(do.call("rbind", x),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MASS
#----------------------------------------------------------------------------------------------------#
"HTML.abbrev" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (is.list(x))
x <- unlist(x)
NextMethod("HTML")
}
#----------------------------------------------------------------------------------------------------#
"HTML.Anova" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
heading <- attr(x, "heading")
if (!is.null(heading))
HTML(paste("<p>",heading,"</p>", sep = " ",collapse="<br>"),file=file)
attr(x, "heading") <- NULL
HTML.data.frame(x,file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.anova.loglm" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- x
y[, 5] <- round(y[, 5], 5)
R <- array("", dim(x), dimnames(x))
for (j in 1:5) {
colj <- c(colnames(x)[j], format(y[, j]))
R[, j] <- colj[-1]
colnames(R)[j] <- colj[1]
}
R[1, 3:5] <- ""
forms <- attr(x, "formulae")
HTML("<p><b>LR tests for hierarchical log-linear models</b>\n</p>\n",file=file)
for (i in seq(along = forms))
HTML(paste(paste("<p>Model ", i, ":<br>", sep = ""), paste(deparse(forms[[i]]),collapse=""), "</p>"),file=file)
HTMLbr(file=file)
HTML(R,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.correspondence" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p>First canonical correlation(s):", format(x$cor, ...), "\n</p>"),file=file)
rcn <- names(dimnames(x$Freq))
HTML(paste("\n<p>", rcn[1], "scores:\n</p>"),file=file)
HTML(x$rscore,file=file)
HTML(paste("\n<p>", rcn[2], "scores:\n</p>"),file=file)
HTML(x$cscore,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.fitdistr" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
ans <- format(rbind(x$estimate, x$sd), digits = digits)
ans[1, ] <- sapply(ans[1, ], function(x) paste("", x))
ans[2, ] <- sapply(ans[2, ], function(x) paste("(", x, ")",
sep = ""))
dn <- dimnames(ans)
dn[[1]] <- rep("", 2)
dn[[2]] <- paste(substring(" ", 1, (nchar(ans[2, ]) -
nchar(dn[[2]]))%/%2), dn[[2]])
dn[[2]] <- paste(dn[[2]], substring(" ", 1, (nchar(ans[2,
]) - nchar(dn[[2]]))%/%2))
dimnames(ans) <- dn
HTML(ans, file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.fractions" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- attr(x, "fracs")
att <- attributes(x)
att$fracs <- att$class <- NULL
x <- do.call("structure", c(list(y), att))
NextMethod("HTML", file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.gamma.shape" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
y <- x
x <- array(unlist(x), dim = 2:1, dimnames = list(c("Alpha ", "SE "), ""))
NextMethod("HTML",file=file)
invisible(y)
}
#----------------------------------------------------------------------------------------------------#
"HTML.glm.dose" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
M <- cbind(x, attr(x, "SE"))
dimnames(M) <- list(names(x), c("Dose", "SE"))
x <- M
NextMethod("HTML",file=file)
}
#----------------------------------------------------------------------------------------------------#
"HTML.lda" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
names(cl)[2] <- ""
HTMLli(paste("Call: ",deparse(cl)),file=file)
}
HTML("\n<p>Prior probabilities of groups:\n</p>",file=file)
HTML(x$prior, file=file,...)
HTML("\n<p>Group means:\n</p>",file=file)
HTML(x$means, file=file,...)
HTML("\n<p>Coefficients of linear discriminants:\n</p>",file=file)
HTML(x$scaling, file=file,...)
svd <- x$svd
names(svd) <- dimnames(x$scaling)[[2]]
if (length(svd) > 1) {
HTML("\n<p>Proportion of trace:\n</p>",file=file)
HTML(round(svd^2/sum(svd^2), 4), file=file,append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.loglm" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("Call: <font class=call>",deparse(x$call),"</font>"),file=file)
ts.array <- rbind(c(x$lrt, x$df, if (x$df > 0) 1 - pchisq(x$lrt,
x$df) else 1), c(x$pearson, x$df, if (x$df > 0) 1 - pchisq(x$pearson,
x$df) else 1))
dimnames(ts.array) <- list(c("Likelihood Ratio", "Pearson"),
c("X^2", "df", "P(> X^2)"))
HTML("\n<p>Statistics:\n</p>",file=file)
HTML(ts.array,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.mca" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",deparse(cl)),file=file)
HTML(paste("\n<p>Multiple correspondence analysis of <b>", nrow(x$rs),
" </b>cases of <b> ", x$p, " </b>factors\n</p>"),file=file)
p <- 100 * cumsum(x$d)/(x$p - 1)
HTML(paste("\n<p>Correlations ",paste(round(x$d, 3),collapse=" ")," cumulative % explained ", paste(round(p, 2),collapse=" "),"</p>" ),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.polr" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",deparse(cl)),file=file)
if (length(coef(x))) {
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(coef(x), file=file,append=TRUE,...)
}
else {
HTML("\n<p>No coefficients\n</p>",file=file)
}
HTML("\n<p>Intercepts:\n</p>",file=file)
HTML(x$zeta, file=file,append=TRUE,...)
HTML(paste("\n<p>Residual Deviance: <b>", format(x$deviance, nsmall = 2), "</b>\n</p>"),file=file)
HTML(paste("<p>AIC:<b>", format(x$deviance + 2 * x$edf, nsmall = 2), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.qda" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
names(cl)[2] <- ""
HTMLli(paste("Call: ",deparse(cl)),file=file)
}
HTML("\n<p>Prior probabilities of groups:\n</p>",file=file)
HTML(x$prior, file=file,...)
HTML("\n<p>Group means:\n</p>",file=file)
HTML(x$means, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ridgelm" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
scaledcoef <- t(as.matrix(x$coef/x$scales))
if (x$Inter) {
inter <- x$ym - scaledcoef %*% x$xm
scaledcoef <- cbind(Intercept = inter, scaledcoef)
}
HTML(drop(scaledcoef), file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.rlm" <- function (x,file=get(".HTML.file"),append=TRUE, ...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call: ",paste(deparse(cl),collapse=" ")),file=file)
}
if (x$converged)
HTML(paste("<p>Converged in <b>", length(x$conv), "</b> iterations\n</p>"),file=file)
else HTML(paste("<p>Ran <b>", length(x$conv), " </b>iterations without convergence\n</p>"),file=file)
coef <- x$coef
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(coef, file=file,append=TRUE,...)
nobs <- length(x$resid)
rdf <- nobs - length(coef)
HTML(paste("\n<p>Degrees of freedom: <b>", nobs, " </b>total; <b>", rdf, " </b>residual\n</p>"),file=file)
HTML(paste("<p>Scale estimate:<b>", paste(format(signif(x$s, 3)),collapse=" "), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.rms.curv" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><li>Parameter effects: c^theta x sqrt(FALSE) =<b>", round(x$pe,
4), "</b>\n<br><li>", "Intrinsic: c^iota x sqrt(FALSE) =<b>", round(x$ic,
4), "\n</b></p>"),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.loglm" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Formula:\n</p>",file=file)
HTML(formula(x),file=file)
HTML("\n<p>Statistics:\n</p>",file=file)
HTML(x$tests,file=file)
if (!is.null(x$oe)) {
HTML("\n<p>Observed (Expected):\n</p>",file=file)
HTML(x$oe, file=file)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.negbin" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
NextMethod(x,file=file)
dp <- 2 - floor(log10(x$SE.theta))
HTML(paste("<p><li>Theta:<b> ", round(x$theta, dp), "</b>\n<li>Std. Err.:<b> ", round(x$SE.theta, dp), "</b>\n</p>"),file=file)
if (!is.null(x$th.warn))
HTML(paste("<p>Warning while fitting theta:", x$th.warn, "\n</p>"),file=file)
HTML(paste("\n<p><li> 2 x log-likelihood: ", format(round(x$twologlik, 3), nsmall = dp), "\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.polr" <- function (x, digits = x$digits, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call: ",deparse(cl)),file=file)
}
coef <- format(round(x$coef, digits = digits))
pc <- x$pc
if (pc > 0) {
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(x$coef[seq(len = pc), ], file=file,append=TRUE, ...)
}
else {
HTML("\n<p>No coefficients\n</p>",file=file)
}
HTML("\n<p>Intercepts:\n</p>",file=file)
HTML(coef[(pc + 1):nrow(coef), ], file=file,append=TRUE, ...)
HTML(paste("\n<p>Residual Deviance:<b>", format(x$deviance, nsmall = 2), "</b>\n</p>"),file=file)
HTML(paste("\n<p>AIC:<b>", format(x$deviance + 2 * x$edf, nsmall = 2), "</b>\n</p>"),file=file)
if (!is.null(correl <- x$correlation)) {
cat("\n<p>Correlation of Coefficients:\n</p>",file=file)
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
correl[!ll] <- ""
HTML(correl[-1, -ncol(correl)], file=file, append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.rlm" <- function (x, digits = max(3, .Options$digits - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTMLli(paste("\nCall: ",deparse(x$call)),file=file)
resid <- x$residuals
df <- x$df
rdf <- df[2]
if (rdf > 5) {
HTML("<p>Residuals:\n</p>",file=file)
if (length(dim(resid)) == 2) {
rq <- apply(t(resid), 1, quantile)
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q",
"Max"), colnames(resid))
}
else {
rq <- quantile(resid)
names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
}
HTML(rq, file=file)
}
else if (rdf > 0) {
HTML("<p>Residuals:\n</p>",file=file)
HTML(resid,file=file)
}
if (nsingular <- df[3] - df[1])
HTML(paste("\n<p>Coefficients: (", nsingular, " not defined because of singularities)\n</p>",sep = ""),file=file)
else HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(format(round(x$coef, digits = digits)), file=file)
HTML(paste("\n<p>Residual standard error:<b>", format(signif(x$sigma,
digits)), " </b>on <b> ", rdf, " </b>degrees of freedom\n</p>"),file=file)
if (!is.null(correl <- x$correlation)) {
p <- dim(correl)[2]
if (p > 1) {
HTML("\n<p>Correlation of Coefficients:\n</p>",file=file)
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
correl[!ll] <- ""
HTML(correl[-1, -p, drop = FALSE], file=file)
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE NNET
#----------------------------------------------------------------------------------------------------#
"HTML.multinom" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call: ",paste(deparse(cl),collapse="")),file=file)
}
HTML("\n<p>Coefficients:\n</p>",file=file)
HTML(coef(x), file=file)
HTML(paste("\n<p>Residual Deviance: <b>", format(x$deviance), "</b>\n</p>"),file=file)
HTML(paste("<p>AIC:<b>", format(x$AIC), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.nnet" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!inherits(x, "nnet"))
stop("Not legitimate a neural net fit")
HTML(paste("<p><b>a ", x$n[1], "-", x$n[2], "-", x$n[3], " network with ", length(x$wts), " weights.</b></p>", sep = ""),file=file)
if (length(x$coefnames))
HTML(paste("<p>inputs:", x$coefnames, "\noutput(s):", deparse(formula(x)[[2]]), "\n</p>"),file=file)
HTML("<p>options were -</p>",file=file)
tconn <- diff(x$nconn)
if (tconn[length(tconn)] > x$n[2] + 1)
HTMLli(" skip-layer connections ",file=file)
if (x$nunits > x$nsunits && !x$softmax)
HTMLli(" linear output units ",file=file)
if (x$entropy)
HTMLli(" entropy fitting ",file=file)
if (x$softmax)
HTMLli(" softmax modelling ",file=file)
if (x$decay[1] > 0)
HTMLli(paste(" decay=", x$decay[1], sep = ""),file=file)
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.multinom" <- function (x, digits = x$digits, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (!is.null(cl <- x$call)) {
HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
}
HTML("\n<p>Coefficients:\n</p>",file=file)
if (x$is.binomial) {
HTML(cbind(Values = x$coefficients, "Std. Err." = x$standard.errors,
"Value/SE" = x$Wald.ratios), file=file)
}
else {
HTML(x$coefficients, file=file)
HTML("\n<p>Std. Errors:\n</p>",file=file)
HTML(x$standard.errors, file=file)
if (!is.null(x$Wald.ratios)) {
HTML("\n<O>Value/SE (Wald statistics):\n</p>",file=file)
HTML(x$coefficients/x$standard.errors, file=file)
}
}
HTML(paste("\n<p>Residual Deviance:<b>", format(x$deviance), "</b>\n</p>"),file=file)
HTML(paste("\n<p>AIC:<b>", format(x$AIC), "</b>\n</p>"),file=file)
if (!is.null(correl <- x$correlation)) {
p <- dim(correl)[2]
if (p > 1) {
HTML("\n</p>Correlation of Coefficients:\n</p>",file=file)
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
correl[!ll] <- ""
HTML(correl[-1, -p], file= file)
}
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.nnet" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(paste("<p><b>a ", x$n[1], "-", x$n[2], "-", x$n[3], " network with ", length(x$wts), " weights.</b></p>", sep = ""),file=file)
HTML("<p>options were -</p>",file=file)
tconn <- diff(x$nconn)
if (tconn[length(tconn)] > x$n[2] + 1)
HTMLli(" skip-layer connections ",file=file)
if (x$nunits > x$nsunits && !x$softmax)
HTMLli(" linear output units ",file=file)
if (x$entropy)
HTMLli(" entropy fitting ",file=file)
if (x$softmax)
HTMLli(" softmax modelling ",file=file)
if (x$decay[1] > 0)
HTMLli(paste(" decay=", x$decay[1], sep = ""),file=file)
wts <- format(round(nnet(x), 2))
lapply(split(wts, rep(1:x$nunits, tconn)), function(x) HTML(x,file=file))
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE CLUSTER
#----------------------------------------------------------------------------------------------------#
"HTML.agnes" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file,append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0)
x$order.lab
else x$order, file=file,append=TRUE, ...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE,...)
HTML("<p>Agglomerative coefficient:\n</p>",file=file)
HTML(x$ac, file=file,append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.clara" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Best sample:\n</p>",file=file)
HTML(x$sample, file=file, append=TRUE,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids, file=file,append=TRUE,...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering, file=file,append=TRUE,...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective, file=file,append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.diana" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file,append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0) x$order.lab else x$order, file= file, append=TRUE,...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE,...)
HTML("<p>Divisive coefficient:\n</p>",file=file)
HTML(x$dc,file=file, append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.dissimilarity" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Dissimilarities :\n</p>",file=file)
HTML(as.vector(x),file=file,append=TRUE, ...)
if (!is.null(attr(x, "na.message")))
HTML(paste("<p>Warning : ", attr(x, "NA.message"), "\n</p>"),file=file)
HTML(paste("<p>Metric : ", attr(x, "Metric"), "\n</p>"),file=file)
HTML(paste("<p>Number of objects : ", attr(x, "Size"), "\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ellipsoid" <- function (x, digits = max(1, getOption("digits") - 2), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
d <- length(x$loc)
HTML(paste("<p>`ellipsoid' in <b> ", d, " </b>dimensions:<br> center = (<b>", paste(format(x$loc,
digits = digits),collapse=" "), "</b>); squared ave.radius d^2 = <b>", format(x$d2,
digits = digits), " </b>\n<br> and shape matrix =\n</p>"),file=file)
HTML(x$cov, file=file, append=TRUE,...)
HTML(paste("<p> hence,", if (d == 2)
" area "
else " volume ", " = <b>", format(cluster::volume(x), digits = digits),
"\n</b></p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.fanny" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(x$objective, file=file,append=TRUE,...)
HTML("<p>Membership coefficients:\n</p>", file=file)
HTML(x$membership, file=file,append=TRUE, ...)
HTML("<p>Coefficients:\n</p>", file=file)
HTML(x$coeff, file=file, append=TRUE,...)
HTML("<p>Closest hard clustering:\n</p>", file=file)
HTML(x$clustering, file=file,append=TRUE, ...)
HTML("\n<p>Available components:\n</p>", file=file)
HTML(names(x), file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.mona" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Revised data:\n</p>",file=file)
HTML(x$data,file=file, append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0) x$order.lab else x$order,file=file, append=TRUE,...)
HTML("<p>Variable used:\n</p>",file=file)
HTML(x$variable, file=file, append=TRUE,...)
HTML("<p>Separation step:\n</p>",file=file)
HTML(x$step,file=file, append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.pam" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids,file=file, append=TRUE,...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering,file=file, append=TRUE,...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective,file=file, append=TRUE,...)
HTML("\n<p>Available components:\n</p>",file=file)
HTML(names(x),file=file, append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.agnes" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file, append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0)
x$order.lab
else x$order, file=file, append=TRUE,...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE, ...)
HTML("<p>Agglomerative coefficient:\n</p>",file=file)
HTML(x$ac, file=file, append=TRUE,...)
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE,...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.clara" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Best sample:\n</p>",file=file)
HTML(x$sample, file=file, append=TRUE,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids, file=file, append=TRUE,...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering, file=file,append=TRUE, ...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective, file=file,append=TRUE, ...)
HTML("<p>\nNumerical information per cluster:\n</p>",file=file)
HTML(x$clusinfo, file=file, append=TRUE,...)
if (length(x$silinfo) != 0) {
HTML("<p>\nSilhouette plot information for best sample:\n</p>",file=file)
HTML(x$silinfo[[1]], file=file,append=TRUE, ...)
HTML("<p>Average silhouette width per cluster:\n</p>",file=file)
HTML(x$silinfo[[2]], file=file,append=TRUE, ...)
HTML("<p>Average silhouette width of best sample:\n</p>",file=file)
HTML(x$silinfo[[3]], file=file,append=TRUE, ...)
}
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE,...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.diana" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML("<p>Merge:\n</p>",file=file)
HTML(x$merge, file=file, append=TRUE,...)
HTML("<p>Order of objects:\n</p>",file=file)
HTML(if (length(x$order.lab) != 0)
x$order.lab
else x$order, file=file, append=TRUE,...)
HTML("<p>Height:\n</p>",file=file)
HTML(x$height, file=file,append=TRUE, ...)
HTML("<p>Divisive coefficient:\n</p>",file=file)
HTML(x$dc, file=file, append=TRUE,...)
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file,append=TRUE, ...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file,append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.fanny" <- function(x,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n",file=file,append=append,...)
HTML(x$objective, file=file, append=TRUE,...)
HTML("<p>Membership coefficients:\n</p>",file=file)
HTML(x$membership, file=file, append=TRUE, ...)
HTML("<p>Coefficients:\n</p>",file=file)
HTML(x$coeff, file=file, append=TRUE, ...)
HTML("<p>Closest hard clustering:\n</p>",file=file)
HTML(x$clustering, file=file, append=TRUE, ...)
if (length(x$silinfo) != 0) {
HTML("<p>\nSilhouette plot information:\n</p>",file=file)
HTML(x$silinfo[[1]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width per cluster:\n</p>",file=file)
HTML(x$silinfo[[2]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width of total data set:\n</p>",file=file)
HTML(x$silinfo[[3]], file=file, append=TRUE, ...)
}
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE, ...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file, append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.mona" <- function(x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML.mona(x, file=file, append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.pam" <- function(x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file,append=append,...)
HTML("<p>Medoids:\n</p>",file=file)
HTML(x$medoids, file=file, append=TRUE, ...)
HTML("<p>Clustering vector:\n</p>",file=file)
HTML(x$clustering, file=file, append=TRUE, ...)
HTML("<p>Objective function:\n</p>",file=file)
HTML(x$objective, file=file, append=TRUE, ...)
HTML("<p>\nNumerical information per cluster:\n</p>",file=file)
HTML(x$clusinfo, file=file, append=TRUE, ...)
HTML("<p>\nIsolated clusters:\n</p>",file=file)
HTML("<p>L-clusters: ")
HTML(names(x$isolation[x$isolation == "L"]),
...)
HTML("<p>L*-clusters: ")
HTML(names(x$isolation[x$isolation == "L*"]),
...)
if (length(x$silinfo) != 0) {
HTML("<p>\nSilhouette plot information:\n</p>",file=file)
HTML(x$silinfo[[1]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width per cluster:\n</p>",file=file)
HTML(x$silinfo[[2]], file=file, append=TRUE, ...)
HTML("<p>Average silhouette width of total data set:\n</p>",file=file)
HTML(x$silinfo[[3]], file=file, append=TRUE, ...)
}
HTML("<p>\n</p>",file=file)
HTML(x$diss, file=file, append=TRUE, ...)
HTML("<p>\nAvailable components:\n</p>",file=file)
HTML(names(x), file=file, append=TRUE, ...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MGCV
#----------------------------------------------------------------------------------------------------#
"HTML.gam" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML(x$family,file=file)
HTML("<p>Formula:\n</p>",file=file)
HTML(x$formula,file=file)
if (x$dim == 0)
HTML(paste("<p>Total model degrees of freedom <b>", x$nsdf, " </b>\n</p>"),file=file)
else HTML(paste("\n<p>Estimated degrees of freedom:<b>", paste(x$edf,collapse=" , "), "</b> total = <b>",
paste(sum(x$edf) + x$nsdf,collapse=" , "), "</b>\n</p>"),file=file)
gcv <- x$df.null * x$sig2/(x$df.null - sum(x$edf) - x$nsdf)
HTML("\n<p>GCV score:</p> ",file=file)
HTML(gcv,file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.gam" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML(x$family,file=file)
HTML("<p>Formula:\n</p>",file=file)
HTML(x$formula,file=file)
if (length(x$p.coeff) > 0) {
HTML("\n<p>Parametric coefficients:\n</p>",file=file)
width <- max(nchar(names(x$p.coeff)))
HTML("\n<p align=center><table cellspacing=0 border=1><td><table cellspacing=0> <tr class= firstline > <th></th><th>Estimate</th><th>std.err.</th><th>t ratio</th><th>Pr(>|t[)</th></tr>\n",file=file)
for (i in 1:length(x$p.coeff)) HTML(paste("<tr><td class=firstcolumn>",formatC(names(x$p.coeff)[i], width = width),"</td><td class=\"CellInside\">", formatC(x$p.coeff[i], width = 10,digits = 5),"</td><td class=\"CellInside\">", formatC(x$se[i], width = 10, digits = 4),"</td><td class=\"CellInside\">",formatC(x$p.t[i], width = 10, digits = 4), "</td><td class=\"CellInside\">",format.pval(x$p.pv[i]),"</td></tr>\n", sep = ""),file=file)
HTML("\n</table></td></table></center>",file=file)
}
HTMLbr( file=file)
if (x$m > 0) {
HTML("<p>Approximate significance of smooth terms:\n</p>",file=file)
width <- max(nchar(names(x$chi.sq)))
HTML("\n<p align=center><table cellspacing=0 border=1><td><table cellspacing=0> <tr class= firstline > <th></th><th>edf</th><th>chi.sq</th><th>p-value</th></tr>\n",file=file)
for (i in 1:x$m)
HTML(paste("<tr><td class=firstcolumn>",formatC(names(x$chi.sq)[i], width = width),
"</td><td class=CellInside>", formatC(x$edf[i], width = 10, digits = 4), "</td><td class=CellInside>",
formatC(x$chi.sq[i], width = 10, digits = 5),"</td><td class=CellInside>",
format.pval(x$s.pv[i]), "</td></tr>\n", sep = ""),file=file)
HTML("\n</table></td></table></center>",file=file)
}
HTML(paste("\n<p>Adjusted r-sq. = <b>", formatC(x$r.sq, digits = 3, width = 5),
" </b> GCV score = <b>", formatC(x$gcv, digits = 5), "</b> \n<br>Scale estimate = <b>",
formatC(x$scale, digits = 5, width = 8, flag = "-"),
" </b> n = <b>", x$n, "</b>\n</p>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE RPART
#----------------------------------------------------------------------------------------------------#
"HTML.rpart" <- function (x, minlength = 0, spaces = 2, cp, digits = getOption("digits"),
file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!inherits(x, "rpart"))
stop("Not legitimate rpart object")
if (!is.null(x$frame$splits))
x <- rpart::rpconvert(x)
if (!missing(cp))
x <- rpart::prune.rpart(x, cp = cp)
frame <- x$frame
ylevel <- attr(x, "ylevels")
node <- as.numeric(row.names(frame))
# tree.depth is not exported by rpart anymore. Defining it locally:
"Inttree.depth" <-
function (nodes)
{
depth <- floor(log(nodes, base = 2) + 1e-7)
as.vector(depth - min(depth))
}
depth <- Inttree.depth(node)
indent <- paste(rep(" ", spaces * 32), collapse = " ")
if (length(node) > 1) {
indent <- substring(indent, 1, spaces * seq(depth))
indent <- paste(c("", indent[depth]), format(node), ")",
sep = "")
}
else indent <- paste(format(node), ")", sep = "")
tfun <- (x$functions)$print
if (!is.null(tfun)) {
if (is.null(frame$yval2))
yval <- tfun(frame$yval, ylevel, digits)
else yval <- tfun(frame$yval2, ylevel, digits)
}
else yval <- format(signif(frame$yval, digits = digits))
term <- rep(" ", length(depth))
term[frame$var == "<leaf>"] <- "*"
z <- labels(x, digits = digits, minlength = minlength, ...)
n <- frame$n
z <- paste(indent, z, n, format(signif(frame$dev, digits = digits)),
yval, term)
omit <- x$na.action
if (length(omit))
HTML(paste("<p>n=<b>", n[1], "</b> (", naprint(omit), ")\n</p>\n", sep = ""),file=file)
else HTML(paste("<p>n=<b>", n[1], "</b>\n</p>\n"),file=file)
if (x$method == "class")
HTML("<p>node), split, n, loss, yval, (yprob)\n</p>",file=file)
else HTML("<p>node), split, n, deviance, yval\n</p>",file=file)
HTML("<p> * denotes terminal node\n\n</p>",file=file)
HTML(paste("<xmp>", paste(z, sep = "\n",collapse="\n"),"</xmp>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE MODREG
#----------------------------------------------------------------------------------------------------#
"HTML.loess" <- function (x, digits = max(3, getOption("digits") - 3),file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",paste(deparse(cl),collapse=" ")),file=file)
HTML(paste("\n<p>Number of Observations:<b>", x$n, "</b>\n</p>"),file=file)
HTML(paste("<p>Equivalent Number of Parameters:<b>", format(round(x$enp,
2)), "</b>\n</p>"),file=file)
HTML(paste("<p>Residual", if (x$pars$family == "gaussian")
" Standard Error: <b>"
else " Scale Estimate:<b> ", format(signif(x$s, digits)), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ppr" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
mu <- x$mu
ml <- x$ml
HTML("\n<p>Goodness of fit:\n</p>",file=file)
gof <- x$gofn
names(gof) <- paste(1:ml, "terms")
HTML(format(gof[mu:ml], ...), file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.smooth.spline" <- function (x, digits = getOption("digits"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
ip <- x$iparms
cv <- cl$cv
if (is.null(cv))
cv <- FALSE
else if (is.name(cv))
cv <- eval(cv)
HTML(paste("\n<p>Smoothing Parameter spar=<b>", format(x$spar, digits = digits),
"</b> lambda=<b>", format(x$lambda, digits = digits),"</b>", if (ip["ispar"] !=
1) paste("(", ip["iter"], " iterations)", sep = ""), "\n</p>"),file=file)
HTML(paste("<p>Equivalent Degrees of Freedom (Df):<b>", format(x$df, digits = digits),
"</b>\n</p>"),file=file)
HTML(paste("<p>Penalized Criterion:<b>", format(x$pen.crit, digits = digits),
"</b>\n</p>"),file=file)
HTML(paste ("<p>",if (cv) "PRESS:"
else "GCV:", "<b>",format(x$cv.crit, digits = digits), "</b>\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.loess" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
HTML(paste("\n<p>Number of Observations:<b>", x$n, "</b>\n</p>"),file=file)
HTML(paste("<p>Equivalent Number of Parameters:<b>", format(round(x$enp, 2)), "</b>\n</p>"),file=file)
if (x$pars$family == "gaussian")
HTML("<p>Residual Standard Error:</p>",file=file)
else HTML("<p>Residual Scale Estimate:</p>",file=file)
HTML(format(signif(x$s, digits)),file=file)
HTML("<p>Trace of smoother matrix:</p>",file=file)
HTML(format(round(x$trace.hat,2)), file=file)
HTML("\n<p>Control settings:\n</p><ul>",file=file)
HTMLli(paste("normalize: ", x$pars$normalize, "\n"),file=file)
HTMLli(paste(" span : ", format(x$pars$span), "\n"),file=file)
HTMLli(paste(" degree : ", x$pars$degree, "\n"),file=file)
HTMLli(paste(" family : ", x$pars$family),file=file)
if (x$pars$family != "gaussian")
HTMLli(paste(" iterations =", x$pars$iterations),file=file)
HTML("</ul>",file=file)
HTML(paste("\n<p> surface : ", x$pars$surface, if (x$pars$surface == "interpolate") paste(" cell =", format(x$pars$cell)),"</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.ppr" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML.ppr(x,file=file, ...)
mu <- x$mu
HTML("\n<p>Projection direction vectors:\n</p>",file=file)
HTML(format(x$alpha, ...),file=file)
HTML("\n<p>Coefficients of ridge terms:\n</p>",file=file)
HTML(format(x$beta, ...), file=file)
if (any(x$edf > 0)) {
HTML("\n<p>Equivalent df for ridge terms:\n</p>")
edf <- x$edf
names(edf) <- paste("term", 1:mu)
HTML(round(edf, 2),file=file, append=TRUE,...)
}
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE SPLINES
#----------------------------------------------------------------------------------------------------#
"HTML.bSpline" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
value <- c(rep(NA, splines::splineOrder(x)), coef(x))
names(value) <- format(splines::splineKnots(x), digits = 5)
HTML(paste("<p> bSpline representation of spline", if (!is.null(form <- attr(x, "formula"))) paste (" for", paste(deparse(as.vector(form)),collapse=" ")) ,"</p>"),file=file)
HTML(value, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.polySpline" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
coeff <- coef(x)
dnames <- dimnames(coeff)
if (is.null(dnames[[2]]))
dimnames(coeff) <- list(format(splines::splineKnots(x)), c("constant",
"linear", "quadratic", "cubic", paste(4:29, "th",
sep = ""))[1:(dim(coeff)[2])])
HTML( paste( "<p>Polynomial representation of spline ", if (!is.null(form <- attr(x, "formula"))) paste(" for ", paste(deparse(as.vector(form)),collapse=" ") ) ,"</p>") ,file=file )
HTML(coeff, file=file,append=TRUE,...)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.ppolySpline" <- function (x,file=get(".HTML.file"), append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML("<p>periodic </p>",file=file)
HTML(paste("\n<p>Period:<b>", format(x[["period"]]), "</b>\n</p>"),file=file)
NextMethod("HTML",file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE LSQ
#----------------------------------------------------------------------------------------------------#
"HTML.lqs" <- function (x, digits = max(3, getOption("digits") - 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
HTML("<p>Coefficients:\n</p>",file=file)
HTML.default(format(coef(x), digits = digits), file=file)
HTML(paste("\n<p>Scale estimates ", paste(format(x$scale, digits = digits),collapse=" "),
"\n\n</p>"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE NLS
#----------------------------------------------------------------------------------------------------#
"HTML.nls" <- function (x, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML("<p><b>Nonlinear regression model\n</b></p>",file=file)
HTMLli(paste("Model: ", paste(deparse(formula(x)),collapse=" "), "\n"),file=file)
HTMLli(paste("Data: ", as.character(x$data), "\n"),file=file)
HTML(x$m$getAllPars(),file=file)
HTMLli(paste("Residual sum-of-squares: ", format(x$m$deviance()),"\n"),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.summary.nls" <- function (x, digits = max(3, getOption("digits") - 3), symbolic.cor = p >
4, signif.stars = getOption("show.signif.stars"), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
HTML(paste("<p>Formula:",paste(deparse(x$formula), collapse = " "),"</p>"),file=file)
df <- x$df
rdf <- df[2]
HTML("\n<p>Parameters:\n</p>",file=file)
HTML.coefmat(x$parameters, digits = digits, signif.stars = signif.stars,
file=file,append=TRUE,...)
HTML(paste("\n<p>Residual standard error:<b> ", format(signif(x$sigma,
digits)), " </b>on <b>", rdf, " </b>degrees of freedom\n</p>"),file=file)
correl <- x$correlation
if (!is.null(correl)) {
p <- dim(correl)[2]
if (p > 1) {
HTML("\n<p>Correlation of Parameter Estimates:\n</p>",file=file)
if (symbolic.cor)
HTML(symnum(correl)[-1, -p],file=file)
else {
correl[!lower.tri(correl)] <- NA
HTML(correl[-1, -p, drop = FALSE], file=file)
}
}
}
HTMLbr(file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE STEPFUN
#----------------------------------------------------------------------------------------------------#
"HTML.ecdf" <- function (x, digits = getOption("digits") - 2, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ")
HTML(paste("<p><b>Empirical CDF</b></p> \n<li>Call:<font class='call'> ", paste(deparse(attr(x, "call")),collapse=" "),"</font>"), file=file)
n <- length(xx <- eval(expression(x), envir = environment(x)))
i1 <- 1:min(3, n)
i2 <- if (n >= 4)
max(4, n - 1):n
else integer(0)
HTML(paste(" x[1:", n, "] = ", numform(xx[i1]), if (n > 3)
", ", if (n > 5)
" ..., ", numform(xx[i2]), "\n<br>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
"HTML.stepfun" <- function (x, digits = getOption("digits") - 2, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ")
i1 <- function(n) 1:min(3, n)
i2 <- function(n) if (n >= 4)
max(4, n - 1):n
else integer(0)
HTML(paste("<p><b>Step function</b></p>\n<li>Call<font class='call'>: ",paste(deparse(attr(x, "call")) ,collapse=" "),"</font>"),file=file)
env <- environment(x)
n <- length(xx <- eval(expression(x), envir = env))
HTML(paste(" x[1:", n, "] = ", numform(xx[i1(n)]), if (n > 3)
", ", if (n > 5)
" ..., ", numform(xx[i2(n)]), "\n<br>", sep = ""),file=file)
y <- eval(expression(c(yleft, y)), envir = env)
HTML(paste(n + 1, " step heights = ", numform(y[i1(n + 1)]), if (n +
1 > 3)
", ", if (n + 1 > 5)
" ..., ", numform(y[i2(n + 1)]), "\n<br>", sep = ""),file=file)
invisible(x)
}
#----------------------------------------------------------------------------------------------------#
### PACKAGE SURVIVAL
#----------------------------------------------------------------------------------------------------#
"HTML.date" <- function (x, quote, prefix, file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
y<-x
fun <- options()$print.date
if (is.null(fun)) x <- survival::date.ddmmmyy(x)
else x <- get(fun)(x)
if (missing(quote)) quote <- FALSE
HTML.atomic(x, file=file)
invisible(y)
}
#----------------------------------------------------------------------------------------------------#
"HTML.cox.zph" <- function (x, digits = max(options()$digits - 4, 3), file=get(".HTML.file"),append=TRUE,...)
HTML(x$table, file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTML.coxph.null" <- function (x, digits = max(options()$digits - 4, 3), file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file)
HTML(paste("<p>Null model log likelihood=<b>", format(x$loglik), "</b>\n</p>"),file=file)
omit <- x$na.action
if (length(omit)) HTML(paste("<p> n=<b>", x$n, " </b>(", naprint(omit), ")\n</p>", sep = ""),file=file)
else HTML(paste("<p> n=<b>", x$n, "</b>\n</p>"),file=file)
}
#----------------------------------------------------------------------------------------------------#
### XTABLE
#----------------------------------------------------------------------------------------------------#
"HTML.xtable" <- function(x,file=get(".HTML.file"),append=TRUE,...){
cat("\n", file=file, append=append,...)
cat(capture.output(print(x,type="html")),file=file,append=TRUE,sep="\n")
}
#----------------------------------------------------------------------------------------------------#
### UTILITARY FUNCTIONS
#----------------------------------------------------------------------------------------------------#
#----------------------------------------------------------------------------------------------------#
"HTML.title"<-
function(x, HR = 2,CSSclass=NULL,file=get(".HTML.file"),append=TRUE, ...)
{
cat(paste("\n <h", HR, if(!is.null(CSSclass)) paste(" class=",CSSclass,sep="") ," > ", x, "</h", HR, ">\n", sep =
""), file = file, append=append, sep = "")
}
#----------------------------------------------------------------------------------------------------#
"HTMLstem" <- function (x, file=get(".HTML.file"),append=TRUE,...) HTML(paste("<pre>",paste(capture.output(stem(x)),collapse="<br>"),"</pre>"), file=file,append=append,...)
#----------------------------------------------------------------------------------------------------#
"HTMLbr"<- function(x=1,file=get(".HTML.file"),append=TRUE) { cat(paste("\n",rep("<br> ",x),"\n",sep=""), append=append, file = file)}
#----------------------------------------------------------------------------------------------------#
"HTMLhr"<- function(file=get(".HTML.file"), Width = "100%", Size = "1",CSSclass=NULL,append=TRUE){ cat(paste("\n<hr ", ifelse(!is.null(CSSclass),paste("class=",CSSclass,sep=""),""), " width=", Width, " size=", Size, ">", sep = ""), file = file, append=append, sep = "")}
#----------------------------------------------------------------------------------------------------#
"HTMLli"<- function(txt="", file=get(".HTML.file"),append=TRUE) { cat(paste("\n<br><li>", txt, sep = ""), sep = "", append=append, file = file)}
#----------------------------------------------------------------------------------------------------#
"HTMLplot" <- function (Caption = "", file=get(".HTML.file"),append=TRUE, GraphDirectory = ".",
GraphFileName = "", GraphSaveAs = "png", GraphBorder = 1, Align = "center",
Width=500,Height=500,WidthHTML=NULL,HeightHTML=NULL,
GraphPointSize=12,GraphBackGround="white",GraphRes=72,plotFunction=NULL,...)
{
## New version with code submitted by James Wettenhall <wettenhall@wehi.edu.au>
## Change plotFunction by plotExpression...
if (exists("HTMLenv",where=".GlobalEnv",mode="environment"))
{
GraphDirectory=get(".HTML.outdir",envir=get("HTMLenv",envir=.GlobalEnv))
}
cat("\n", file=file, append=append,...)
if (GraphFileName == "") {
nowd <- date()
GraphFileName <- paste("GRAPH_", substring(nowd, 5, 7),
substring(nowd, 9, 10), "_", substring(nowd, 12,
13), substring(nowd, 15, 16), substring(nowd,
18, 19), sep = "")
}
GraphFileName <- paste(GraphFileName, ".", GraphSaveAs, sep = "")
AbsGraphFileName <- file.path(GraphDirectory, GraphFileName)
if (GraphSaveAs=="png")
{
if (is.null(plotFunction))
dev.print(device=png, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
else
{
if (exists("X11", envir=.GlobalEnv) && Sys.info()["sysname"] != "Windows" && Sys.info()["sysname"] != "Darwin")
bitmap(file = AbsGraphFileName,bg=GraphBackGround,res=GraphRes)
else
png(filename = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
plotFunction()
dev.off()
}
}
else if (GraphSaveAs %in% c("jpg","jpeg"))
{
if (is.null(plotFunction))
dev.print(device=jpeg, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
else
{
if (exists("X11", envir=.GlobalEnv) && Sys.info()["sysname"] != "Windows" && Sys.info()["sysname"] != "Darwin")
bitmap(filename = AbsGraphFileName,bg=GraphBackGround,res=GraphRes,type="jpeg")
else
jpeg(filename = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
plotFunction()
dev.off()
}
}
else if (GraphSaveAs=="gif")
{
stop("Gif support was removed from base R because of patent restrictions. Use either jpg or png")
#
# if (is.null(plotFunction))
# Gif support was removed from base R because of patent restrictions.
# see http://tolstoy.newcastle.edu.au/R/help/05/02/12809.html
# dev.print(device=gif, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround)
#
# else
# {
# stop("When passing a plot function to HTMLplot, device must be jpg or png.")
# }
}
else stop("GraphSaveAs must be either jpg, png or gif")
cat(paste("<p align=", Align, "><img src='", GraphFileName,
"' border=", GraphBorder, if (!is.null(Width)) paste(" width=",Width,sep="") else "",if (!is.null(HeightHTML)) paste(" height=",HeightHTML,sep=""), if(!is.null(WidthHTML)) paste(" width="),">", sep = "", collapse = ""),
file = file, append=TRUE, sep = "")
if (Caption != "") {
cat(paste("<br><font class=caption>", Caption, "</font>"), file = file, append=TRUE, sep = "")
}
cat("</p>", file = file, append=TRUE, sep = "\n")
if (substitute(file)==".HTML.file") try(assign(".HTML.graph", TRUE, envir = get("HTMLenv", envir = .GlobalEnv)))
invisible(return(TRUE))
}
#----------------------------------------------------------------------------------------------------#
"HTMLInsertGraph" <- function(GraphFileName="",Caption="",GraphBorder=1,Align="center",WidthHTML=500,HeightHTML=NULL,file=get(".HTML.file"),append=TRUE,...)
{
cat("\n", file=file, append=append,...)
cat(paste("<p align=", Align, "><img src='", GraphFileName, "' border=", GraphBorder, if (!is.null(WidthHTML)) paste(" width=",WidthHTML,sep="") else "",if (!is.null(HeightHTML)) paste(" height=",HeightHTML,sep="") else "",">", sep = "", collapse = ""), file = file, append=TRUE, sep = "")
if (Caption != "") cat(paste("<br><i class=caption>", Caption, "</i>"), file = file, append=TRUE, sep = "")
invisible(return(TRUE))
}
#----------------------------------------------------------------------------------------------------#
"HTMLCSS" <- function(file=get(".HTML.file"),append=TRUE,CSSfile="R2HTML.css")
{
cat(paste("\n<link rel=stylesheet type=text/css href=",CSSfile,">\n",sep=""),file=file,append=append)
}
#----------------------------------------------------------------------------------------------------#
"HTMLChangeCSS" <- function(newCSS="R2HTML",from=NULL){
target=getwd()
if (exists("HTMLenv",where=".GlobalEnv")) target=file.path(get(".HTML.outdir",envir=get("HTMLenv",envir=.GlobalEnv)))
if (is.null(from)){
# PhG: .R2HTMLpath does not exist any more. .find.package(package = "R2HTML") has the same effect!
#if (!exists(".R2HTMLpath")) stop("The package R2HTML is not properly loaded")
#from=file.path(.R2HTMLpath,"output")
from=file.path(.find.package(package = "R2HTML"),"output")
}
fromfile=file.path(from,paste(newCSS,"css",sep="."))
if (!file.exists(fromfile)) stop(paste("Source CSS file",fromfile,"not found"))
file.copy(fromfile,file.path(target,"R2HTML.css"),overwrite=TRUE)
}
"HTMLCommand" <- function(x,file=get(".HTML.file"),Num="",menu=FALSE,target="index<-main.html",append=TRUE,...)
{
cat("\n",file=file,append=append,...)
if (menu==TRUE)
cat(paste("<br><li><a class=command href='./",target,"#Num",Num,"' target=main> ",paste(x,collapse=""),"</a>",sep=""),file=file,append=TRUE,sep="")
else {
if (Num!="") cat(paste("<a name=Num",Num,"> </a>",sep=""),file=file,append=TRUE,sep="")
cat(paste("\n<p><xmp class=command>> ",x,"</xmp></p>\n",sep=""),file=file,append=TRUE,sep="")
}
}
#----------------------------------------------------------------------------------------------------#
"HTMLcode" <- function(x,...){
tmpfic=tempfile()
HTML(x,file=tmpfic,...)
cat("\n",file=tmpfic,append=TRUE)
tmptxt=readLines(tmpfic)
unlink(tmpfic)
return(paste(tmptxt,collapse="\n"))
}
#----------------------------------------------------------------------------------------------------#
"HTMLReplaceNA"<-
function(Vec, Replace = " ")
{
Vec <- as.character(Vec)
#Vec <- format( Vec, ... )
for(i in 1:length(Vec))
{
try(if((Vec[i] == "NA") | (Vec[i] == "NaN") | is.na(Vec[i])){ Vec[i] <- Replace})
}
Vec
}
#----------------------------------------------------------------------------------------------------#
"HTML.cormat" <- function(x, file=get(".HTML.file"), digits=2,append=TRUE,align="center",caption="",captionalign="bottom",classcaption="captiondataframe",classtable="cormat",useCSS=TRUE,...)
{
cat("\n", file=file,append=append)
x<-as.matrix(x)
if (is.numeric(x)) x<-round(x,digits=digits)
if (is.null(dimnames(x))) x <- as.data.frame(x)
txt <- paste("<p align=",align,">")
txtcaption <- ifelse(is.null(caption),"",paste("<caption align=",captionalign," class=",classcaption,">",caption,"</caption>",sep=""))
cormat=x
abscormat=abs(cormat)
backcolors=matrix(grey(1-as.matrix(abscormat)),ncol=ncol(cormat))
css = 10*round(abs(x),1)
css=matrix(paste("cor",unlist(css),sep=""),ncol=ncol(x))
diag(css)="cordiag"
diag(backcolors)="#FFFFFF"
forecolors=matrix("#000000",ncol=ncol(cormat),nrow=nrow(cormat))
forecolors[abscormat>0.5]="#FFFFFF"
forecolors[abscormat>0.8]="#F6FF6E"
diag(forecolors)="#FFFFFF"
forebold=matrix(FALSE,ncol=ncol(cormat),nrow=nrow(cormat))
forebold[abscormat>0.9]=TRUE
txt<- paste(txt,"<table cellspacing=0 cellpading=0 border=0 >",txtcaption,"<td valign=middle class=corbody><table cellspacing=0 border=0>")
txt <- paste(txt,paste("\n<tr><td align=right class=corvarname>",dimnames(x)[[2]],"</td><td width=2> </td></tr>",collapse="\n"))
txt <- paste(txt,"</table></td><td valign=top class=corsep> </td><td valign=top>")
txt <- paste(txt, "<table cellspacing=0 cellpadding=0 border=1 ><td><table class=",classtable," cellspacing=0>", sep = "")
for(i in 1:dim(x)[1]) {
VecDebut <- c(rep(paste("\n\t<td align=right", sep = ""), dim(x)[2]))
if (useCSS) VecAttrib=c(paste(" class= ",css[i,],">")) else VecAttrib=c(paste(" bgcolor=",backcolors[i,],"><font color=",forecolors[i,],">",ifelse(forebold[i,],"<b>","")))
VecMilieu <- HTMLReplaceNA(as.matrix(x[i, ]))
VecFin <- rep("</td>", dim(x)[2] )
txt <- paste(txt, "\n<tr>",paste(VecDebut,VecAttrib, VecMilieu, VecFin, sep = "", collapse = ""),"</tr>")
}
txt <- paste(txt, "</table></td></table></td></table>")
cat(txt, "\n", file = file, sep = "", append=TRUE,...)
invisible(return(x))
}
#----------------------------------------------------------------------------------------------------#
"as.title"<-
function(x)
{
if (!is.character(x)) {
x <- try(as.character(x))
if (!is.character(x)) stop("Input argument must be of character mode")
}
class(x) <- "title"
return(x)
}
#----------------------------------------------------------------------------------------------------#
### R2HTML CORE
#----------------------------------------------------------------------------------------------------#
"HTMLStart" <- function(outdir=tempdir(),filename="index",extension="html",echo=FALSE, autobrowse=FALSE, HTMLframe=TRUE, withprompt="HTML> ",CSSFile="R2HTML.css",BackGroundColor="FFFFFF",BackGroundImg="",Title="R output")
{
if (outdir!=tempdir())
{
# Copy of CSS and logo, if outdir != tempdir
file.copy(file.path(tempdir(),'R2HTML.css'), file.path(outdir,'R2HTML.css'))
file.copy(file.path(tempdir(),'R2HTMLlogo.gif'), file.path(outdir,'R2HTMLlogo.gif'))
}
# Creation of an environment to save some parameters
assign("HTMLenv",new.env(parent=.GlobalEnv),envir=.GlobalEnv)
assign("oldprompt",getOption("prompt"),envir=get("HTMLenv",envir=.GlobalEnv))
assign("HTMLframe",HTMLframe,envir=get("HTMLenv",envir=.GlobalEnv))
assign(".HTML.outdir",outdir,envir=get("HTMLenv",envir=.GlobalEnv))
assign("HTMLtorefresh",file.path(outdir,paste(filename,extension,sep=".")),envir=get("HTMLenv",envir=.GlobalEnv))
options(prompt=withprompt)
# Utilitary functions replacement
fix<-function (x, ...) {
subx <- substitute(x)
if (is.name(subx))
subx <- deparse(subx)
if (!is.character(subx) || length(subx) != 1)
stop("fix requires a name")
assign(".HTML.fix",TRUE,envir=get("HTMLenv",envir=.GlobalEnv))
assign(".HTML.fixed",subx,envir=get("HTMLenv",envir=.GlobalEnv))
parent <- parent.frame()
if (exists(subx, envir = parent, inherits = TRUE))
x <- edit(get(subx, envir = parent), ...)
else {
x <- edit(function() {
}, ...)
environment(x) <- .GlobalEnv }
assign(subx, x, envir = .GlobalEnv)
}
assign("fix",fix,envir=.GlobalEnv)
assign(".HTML.fix",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
assign(".HTML.graph",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
# Creation of required HTML files
try(.HTML.file <- HTMLInitFile(outdir = outdir,filename=filename,extension=extension,HTMLframe=HTMLframe, BackGroundColor = BackGroundColor, BackGroundImg = BackGroundImg, Title = Title,CSSFile=CSSFile,useLaTeX=TRUE))
ToHTML <- function(file,echo,HTMLframe,HTMLMenuFile,target,outdir)
{
NumCom<-0
function(expr,value,ok,visible)
{
NumCom<<- NumCom+1
if (NumCom>1){
ToPrint<-TRUE
if (get(".HTML.fix",envir=get("HTMLenv",envir=.GlobalEnv))==TRUE)
{
ToPrint<-FALSE
ficName<-paste("fun",format(Sys.time(), "%j%m%H%M%S"),"-",floor(runif(1,1,10000)),".txt",sep="")
AbsficName<-file.path(outdir,ficName)
FunName<-get(".HTML.fixed",envir=get("HTMLenv",envir=.GlobalEnv))
if (echo) HTMLCommand(paste("fix(",FunName,")",sep=""),file,NumCom) else cat(paste("<A NAME=Num",NumCom,"> </a>",sep=""),file=file,sep="",append=TRUE)
if (HTMLframe) HTMLCommand(paste("fix(",FunName,")",sep=""),HTMLMenuFile,NumCom,menu=TRUE,target=target)
dput(get(FunName),file=AbsficName)
HTML(paste("<p> Function <a href=", ficName, " target=_blank>", FunName, "</a> fixed. </p>",sep=""),file=file)
assign(".HTML.fix",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
}
else
{
if (get(".HTML.graph",envir=get("HTMLenv",envir=.GlobalEnv))==TRUE)
{
ToPrint <- FALSE
assign(".HTML.graph",FALSE,envir=get("HTMLenv",envir=.GlobalEnv))
}
else
{
if (length(expr)>1) {if ((expr[[1]]=="=")||(expr[[1]]=="<-")) ToPrint<-FALSE}
# Print the commands and/or it's number
if (echo) HTMLCommand(deparse(expr),file,NumCom) else cat(paste("<a name=Num",NumCom,"> </a>",sep=""),file=file,sep="",append=TRUE)
if (HTMLframe) HTMLCommand(deparse(expr),HTMLMenuFile,NumCom,menu=TRUE,target=target)
if (ToPrint) HTML(value,file=file)
}
}
}
if (autobrowse) browseURL(url=get("HTMLtorefresh",envir=get("HTMLenv",envir=.GlobalEnv)))
invisible(return(TRUE))
}
}
on.exit(addTaskCallback(ToHTML(.HTML.file,echo=echo,HTMLframe=HTMLframe,HTMLMenuFile=file.path(outdir,paste(filename,"_menu.",extension,sep="")),target=paste(filename,"_main.",extension,sep=""),outdir=outdir),name="HTML"),add=TRUE)
cat("\n *** Output redirected to directory: ", outdir)
cat("\n *** Use HTMLStop() to end redirection.")
invisible(return(TRUE))
}
#----------------------------------------------------------------------------------------------------#
"HTMLInitFile"<-function(outdir = tempdir(),filename="index",extension="html",
HTMLframe=FALSE, BackGroundColor = "FFFFFF", BackGroundImg = "",
Title = "R output",CSSFile="R2HTML.css",useLaTeX=TRUE,useGrid=TRUE)
{
if (HTMLframe==FALSE){
file<-file.path(outdir,paste(filename,".",extension,sep=""))
assign(".HTML.file",file,envir=.GlobalEnv)
txt <- ifelse(useLaTeX,"<html xmlns:mml=\"http://www.w3.org/1998/Math/MathML\">","<html>")
#<HEAD>
txt <- c(txt, "<head>")
txt <- c(txt, paste("<title>",Title,"</title>"))
# css
txt <- c(txt, paste("<link rel=stylesheet href=\"",CSSFile,"\" type=text/css>",sep=""))
# LaTeX ?
if (useLaTeX) txt <- c(txt, "<object id=\"mathplayer\" classid=\"clsid:32F66A20-7614-11D4-BD11-00104BD3F987\"></object>\n<?import namespace=\"mml\" implementation=\"#mathplayer\"?>\n<script type=\"text/javascript\" src=\"ASCIIMathML.js\"></script>")
# Grid?
if (useGrid) {
txt <- c(txt, HTMLgrid_references())
txt <- c(txt, "<script>\n nequations=0;\n</script>")
}
# </HEAD>
txt <- c(txt, "</head>")
# <BODY>
body <- c("<body")
if(useLaTeX) body=c(body," onload=\"translate()\"")
body=c(body,paste(" bgcolor=",BackGroundColor))
if (BackGroundImg!="") body = c(body, paste(" background=\"",BackGroundImg,"\"",sep=""))
body <- c(body," >")
body=paste(body,collapse="")
txt <- c(txt, body)
txt <- paste(txt, collapse="\n")
cat(txt, file=file,append=FALSE)
}
else {
filemenu<-paste(filename,"_menu.",extension,sep="")
filemain<-paste(filename,"_main.",extension,sep="")
absfilemenu<-file.path(outdir,filemenu)
file<-absfilemain<-file.path(outdir,filemain)
absfileindex<-file.path(outdir,paste(filename,".",extension,sep=""))
assign(".HTML.file",absfilemain,envir=.GlobalEnv)
cat(paste("<html><head> \n <title>",Title,"</title>\n <meta http-equiv=content-type content=text/html;charset=iso-8859-1>\n <frameset cols=250,* border=1 frameborder=yes><frame src=",filemenu," name=menu scrolling=yes><frame src=",filemain," name=main scrolling=yes></frameset></body></html>"), append = FALSE, sep = "", file = absfileindex)
cat("<html><head><link rel=stylesheet href=",CSSFile," type=text/css> </head><body bgcolor=\"#E5F5FF\"> <center> <img src=R2HTMLlogo.gif> <hr size=1></center><br>",sep="",append=FALSE,file=absfilemenu)
txt <- ifelse(useLaTeX,"<html xmlns:mml=\"http://www.w3.org/1998/Math/MathML\">","<html>")
#<HEAD>
txt <- c(txt, "<head>")
txt <- c(txt, paste("<title>",Title,"</title>"))
# css
txt <- c(txt, paste("<link rel=stylesheet href=\"",CSSFile,"\" type=text/css>",sep=""))
# LaTeX ?
if (useLaTeX) txt <- c(txt, "<object id=\"mathplayer\" classid=\"clsid:32F66A20-7614-11D4-BD11-00104BD3F987\"></object>\n<?import namespace=\"mml\" implementation=\"#mathplayer\"?>\n<script type=\"text/javascript\" src=\"ASCIIMathML.js\"></script>")
# Grid?
if (useGrid) {
txt <- c(txt, HTMLgrid_references())
txt <- c(txt, "<script>\n nequations=0;\n</script>")
} # </HEAD>
txt <- c(txt, "</head>")
# <BODY>
body <- c("<body")
if(useLaTeX) body=c(body," onload=\"translate()\"")
body=c(body,paste(" bgcolor=",BackGroundColor))
if (!is.null(BackGroundImg)) body = c(body, paste(" background=\"",BackGroundImg,"\"",sep=""))
body <- c(body," >")
body=paste(body,collapse="")
txt <- c(txt, body)
txt <- paste(txt, collapse="\n")
cat(txt, file=absfilemain,append=FALSE)
}
invisible(return(file))
}
#----------------------------------------------------------------------------------------------------#
"HTMLEndFile"<- function(file=get(".HTML.file"))
{
cat("\n<hr size=1>\n<font size=-1>\n\t Generated on: <i>", date(),
"</i> - <b>R2HTML</b> \n<hr size=1>\n\t</body>\n</html>",
sep = "", append=TRUE, file = file)
}
#----------------------------------------------------------------------------------------------------#
"HTMLStop"<-function()
{
invisible(removeTaskCallback("HTML"))
options(prompt=get("oldprompt",envir=get("HTMLenv",envir=.GlobalEnv)))
.tmp=get(".HTML.file",envir=get("HTMLenv",envir=.GlobalEnv))
HTMLEndFile(file=get(".HTML.file",envir=get("HTMLenv",envir=.GlobalEnv)))
on.exit(rm("HTMLenv",envir=.GlobalEnv),add=TRUE)
on.exit(try(rm("fix",pos=1)),add=TRUE)
invisible(return(.tmp))
}
#----------------------------------------------------------------------------------------------------#
"RweaveHTML" <- function()
{
list(setup = RweaveHTMLSetup,
runcode = RweaveHTMLRuncode,
writedoc = RweaveHTMLWritedoc,
finish = RweaveHTMLFinish,
checkopts = RweaveHTMLOptions)
}
"RweaveHTMLSetup" <-
function(file, syntax,
output=NULL, quiet=FALSE, debug=FALSE, echo=TRUE,
eval=TRUE, split=FALSE, cssfile="R2HTML.css",havecss=FALSE,width=500,height=500,border=1,png=TRUE)
{
# This driver requires R2HTML package to work...
#if(!require(R2HTML)) stop("R2HTML package is required.")
if(is.null(output)){
prefix.string <- basename(sub(syntax$extension, "", file))
output <- paste(prefix.string, "html", sep=".")
}
else{
prefix.string <- basename(sub("\\.html$", "", output))
}
if(!quiet) cat("Writing to file ", output, "\n",
"Processing code chunks ...\n", sep="")
output <- file(output, open="w+")
options <- list(prefix=TRUE, prefix.string=prefix.string,
engine="R", print=FALSE, eval=eval,
fig=FALSE, png=png,width=width, height=height, term=TRUE,
echo=echo, results="Robj", split=split,
strip.white=TRUE, include=TRUE,align="center",caption=NULL,bg="white",pointsize=12)
list(output=output, debug=debug, quiet=quiet, syntax = syntax,
options=options, chunkout=list(),cssfile=cssfile,havecss=havecss)
}
"RweaveHTMLRuncode" <- function(object, chunk, options)
{
if(!(options$engine %in% c("R", "S"))) return(object)
if(!object$quiet){
cat(formatC(options$chunknr, width=2), ":")
if(options$echo) cat(" echo")
if(options$eval){
if(options$print) cat(" print")
if(options$term) cat(" term")
cat("", options$results)
if(options$fig){
if(options$png) cat(" png")
}
}
if(!is.null(options$label))
cat(" (label=", options$label, ")", sep="")
cat("\n")
}
#chunkprefix <- utils:::RweaveChunkPrefix(options)
chunkprefix <- RweaveChunkPrefix(options)
if(options$split){
chunkout <- object$chunkout[[chunkprefix]]
if(is.null(chunkout)){
chunkout <- file(paste(chunkprefix, "html", sep="."), "w")
if(!is.null(options$label))
object$chunkout[[chunkprefix]] <- chunkout
}
}
else
chunkout <- object$output
assign(".HTML.file",chunkout,pos=.GlobalEnv, immediate=TRUE)
#utils:::SweaveHooks(options, run=TRUE)
SweaveHooks(options, run=TRUE)
chunkexps <- try(parse(text=chunk), silent=TRUE)
#utils:::RweaveTryStop(chunkexps, options)
RweaveTryStop(chunkexps, options)
openSinput <- FALSE
openSchunk <- FALSE
if(length(chunkexps)==0)
return(object)
for(nce in 1:length(chunkexps))
{
ce <- chunkexps[[nce]]
#dce <- deparse(ce, width.cutoff=0.75*getOption("width"))
if(object$debug)
cat("\nRnw> ", paste(ce, collapse="\n+ "),"\n")
if(options$echo){
if(!openSinput){
if(!openSchunk){
cat("<!-- begin{Schunk} !-->\n",
file=chunkout, append=TRUE)
openSchunk <- TRUE
}
cat("<!-- begin{Sinput} !-->",
file=chunkout, append=TRUE)
openSinput <- TRUE
}
cat("\n", paste(HTMLCommand(deparse(ce)),
collapse=paste("\n", getOption("continue"), sep="")),
file=chunkout, append=TRUE, sep="")
}
# tmpcon <- textConnection("output", "w")
# avoid the limitations (and overhead) of output text connections
tmpcon <- file()
sink(file=tmpcon)
err <- NULL
#if(options$eval) err <- utils:::RweaveEvalWithOpt(ce, options)
if(options$eval) err <- RweaveEvalWithOpt(ce, options)
cat("\n") # make sure final line is complete
sink()
output <- readLines(tmpcon)
close(tmpcon)
# delete empty output
if(length(output)==1 & output[1]=="") output <- NULL
#utils:::RweaveTryStop(err, options) #### !!! err$value peut etre exporte via HTML(err.value)
RweaveTryStop(err, options) #### !!! err$value peut etre exporte via HTML(err.value)
if(object$debug)
cat(paste(output, collapse="\n"))
if(length(output)>0 & (options$results!="hide")){
if(!openSchunk){
cat("<!-- begin{Schunk} !--> \n",
file=chunkout, append=TRUE)
openSchunk <- TRUE
}
if(openSinput){
cat("\n<!-- end{Sinput} !-->\n", file=chunkout, append=TRUE)
openSinput <- FALSE
}
if (options$results=="Robj") HTML(err$value, file=chunkout, append=TRUE)
if (options$results=="html") cat(err$value, file=chunkout, append=TRUE)
remove(output)
}
}
if(openSinput){
cat("\n<!--\\end{Sinput}!-->\n", file=chunkout, append=TRUE)
}
if(openSchunk){
cat("\n<!--\\end{Schunk}!-->\n", file=chunkout, append=TRUE)
}
if(is.null(options$label) & options$split)
close(chunkout)
if(options$fig && options$eval){
if(options$png){
png(filename=paste(chunkprefix, "png", sep="."),width=options$width,height=options$height,bg=options$bg,pointsize=options$pointsize)
#err <- try({utils:::SweaveHooks(options, run=TRUE);
err <- try({SweaveHooks(options, run=TRUE);
eval(chunkexps, envir=.GlobalEnv)})
dev.off()
if(inherits(err, "try-error")) stop(err)
}
if(options$include)
cat("<p align='",options$align,"'><img height=",options$HTMLheight, " width=",options$HTMLwidth," src='", chunkprefix, ".png'",if (!is.null(options$border)) paste("border=",options$border,sep=""),">",if(!is.null(options$caption)) paste("<br><font class='caption='>",options$caption,"</font>",sep=""),"</p>", sep="",
file=object$output, append=TRUE)
}
return(object)
}
"RweaveHTMLWritedoc" <- function(object, chunk)
{
# Very temporary and ugly fix: importing function definition from
# latest R source code (r45768)
InternalSweaveParseOptions <- function(text, defaults=list(), check=NULL)
{
x <- sub("^[[:space:]]*(.*)", "\\1", text)
x <- sub("(.*[^[:space:]])[[:space:]]*$", "\\1", x)
x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*"))
x <- strsplit(x, "[[:space:]]*=[[:space:]]*")
## only the first option may have no name: the chunk label
if(length(x)>0){
if(length(x[[1]])==1){
x[[1]] <- c("label", x[[1]])
}
}
else
return(defaults)
if(any(sapply(x, length)!=2))
stop(gettextf("parse error or empty option in\n%s", text), domain = NA)
options <- defaults
for(k in 1:length(x))
options[[ x[[k]][1] ]] <- x[[k]][2]
if(!is.null(options[["label"]]) && !is.null(options[["engine"]]))
options[["label"]] <- sub(paste("\\.", options[["engine"]], "$",
sep=""),
"", options[["label"]])
if(!is.null(check))
options <- check(options)
options
}
if(any(grep("text/css", chunk)))
object$havecss <- TRUE
if(!object$havecss){
if(any(grep("<body>", chunk, ignore.case = TRUE))) chunk <- gsub("<body>",paste("\n<link rel=stylesheet type=text/css href=",object$cssfile,"><body>",sep="") ,chunk,ignore.case=TRUE)
else {
if(any(grep("</head>", chunk, ignore.case = TRUE))) chunk <- gsub("</head>",paste("\n<link rel=stylesheet type=text/css href=",object$cssfile,"></head>",sep="") ,chunk,ignore.case=TRUE)
else chunk <- gsub("<html>",paste("<html>","\n<link rel=stylesheet type=text/css href=",object$cssfile,">",sep="") ,chunk,ignore.case=TRUE)
}
object$havecss <- TRUE
}
while(any(pos <- grep(object$syntax$docexpr, chunk)))
{
cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1]])
cmd <- substr(chunk[pos[1]], cmdloc,
cmdloc+attr(cmdloc, "match.length")-1)
cmd <- sub(object$syntax$docexpr, "\\1", cmd)
if(object$options$eval)
val <- as.character(eval(parse(text=cmd), envir=.GlobalEnv))
else
val <- paste("<font class='Rcmd'>", cmd, "</font>", sep="")
chunk[pos[1]] <- sub(object$syntax$docexpr, val, chunk[pos[1]])
}
while(any(pos <- grep(object$syntax$docopt, chunk)))
{
opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
"\\1", chunk[pos[1]])
object$options <- InternalSweaveParseOptions(opts, object$options, RweaveHTMLOptions)
chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
}
cat(chunk, sep="\n", file=object$output, append=TRUE)
return(object)
}
"RweaveHTMLFinish" <- function(object, error=FALSE)
{
if(!object$quiet && !error)
cat(paste("file ",summary(object$output)$description),"is completed", "\n")
close(object$output)
if(length(object$chunkout)>0){
for(con in object$chunkout) close(con)
}
}
"RweaveHTMLOptions" <- function(options)
{
## convert a character string to logical
c2l <- function(x){
if(is.null(x)) return(FALSE)
else return(as.logical(toupper(as.character(x))))
}
NUMOPTS <- c("width", "height")
NOLOGOPTS <- c(NUMOPTS, "results", "prefix.string",
"engine", "label","align","caption","border","height","width","HTMLheight","HTMLwidth","bg","pointsize")
for(opt in names(options)){
if(! (opt %in% NOLOGOPTS)){
oldval <- options[[opt]]
if(!is.logical(options[[opt]])){
options[[opt]] <- c2l(options[[opt]])
}
if(is.na(options[[opt]]))
stop(paste("invalid value for", opt, ":", oldval))
}
else if(opt %in% NUMOPTS){
options[[opt]] <- as.numeric(options[[opt]])
}
}
options$results <- match.arg(options$results,c("Robj","html", "hide"))
options
}
#----------------------------------------------------------------------------------------------------#
# Function contributed by Gabor Grothendieck (ggrothendieck_at_gmail.com)
HTML2clip <- function(x, filename = file("clipboard", ifelse(.Platform$OS == "windows","w",stop("Writing to clipboard only supported on Windows"))), append = FALSE, ...) {
HTML(x, file = filename, append = append, ...)
}
#----------------------------------------------------------------------------------------------------#
SweaveSyntaxHTML <- SweaveSyntaxNoweb
SweaveSyntaxHTML$docexpr <- "<[/]?Sexpr([^>]*)>"
SweaveSyntaxHTML$syntaxname <- "<[/]?SweaveSyntax([^>]*)>"
SweaveSyntaxHTML$trans$docexpr <- "<[/]?Sexpr\\1>"
SweaveSyntaxHTML$trans$syntaxname <- "<!--SweaveSyntax{SweaveSyntaxHTML}!-->"
#----------------------------------------------------------------------------------------------------#
# "myunzip" <- function (zipname, dest)
# {
# if (file.exists(zipname)) {
# if (.Platform$OS.type=="unix") system(paste(getOption("unzip"), "-oq", zipname, "-d", dest))
# else .Internal(int.unzip(zipname, NULL, dest))
# }
# else stop(paste("zipfile", zipname, "not found"))
# }
".onLoad" <- function(lib,pkg)
{
#cat("\nLoading R2HTML package...\n")
#ps.options(bg="white")
# Copy all the content of "output" directory to tempdir()
# now we use a zip file as there are subdirectories...
unzip(zipfile=file.path(lib,pkg,'output','R2HTMLstuff.zip'),exdir=tempdir())
# PhG: eliminated! No temp variables in .GlobalEnv, please assign(".R2HTMLpath",file.path(lib,pkg),pos=.GlobalEnv)
# EL: now can use getOption("R2HTML.CSSdir")
options(R2HTML.CSSdir=file.path(lib,pkg,"output"))
options(R2HTML.sortableDF=FALSE)
options(R2HTML.format.digits=2)
options(R2HTML.format.nsmall=0)
options(R2HTML.format.big.mark="")
options(R2HTML.format.big.interval=3)
options(R2HTML.format.decimal.mark=Sys.localeconv()[["decimal_point"]])
options(R2HTML.grid.first=TRUE)
options(R2HTML.grid.stuffbasepath="./")
}
options(R2HTML.sortableDF=FALSE)
options(R2HTML.format.digits=2)
options(R2HTML.format.nsmall=0)
options(R2HTML.format.big.mark="")
options(R2HTML.format.big.interval=3)
options(R2HTML.format.decimal.mark=Sys.localeconv()[["decimal_point"]])
options(R2HTML.grid.first=TRUE)
options(R2HTML.grid.stuffbasepath="./")
Try the R2HTML package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.