1# $Id: HTMLcore.R 47 2008-05-23 17:29:31Z mentus $ 2# R2HTML - Library of exportation to HTML for R 3# Copyright (C) 2002-2004 - Eric Lecoutre 4 5# R2HTML Package 6 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 2 of the License, or 10# (at your option) any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# You should have received a copy of the GNU General Public License 18# along with this program; if not, write to the Free Software 19# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20# 21#----------------------------------------------------------------------------------------------------# 22# 23# Contact: 24# 25# Eric Lecoutre 26# <lecoutre@stat.ucl.ac.be> 27# 28# Institut de statistique 29# Voie du Roman Pays, 20 30# 1348 Louvain-la-Neuve 31# BELGIQUE 32# 33#----------------------------------------------------------------------------------------------------# 34".HTMLEnv" <- new.env(parent=emptyenv()) 35 36#----------------------------------------------------------------------------------------------------# 37"HTMLSetFile" <- function(file) { 38 assign(".HTML.file", file, .HTMLEnv) 39 file 40} 41 42#----------------------------------------------------------------------------------------------------# 43"HTMLGetFile" <- function() { 44 if(exists(".HTML.file", .HTMLEnv)) 45 get(".HTML.file", .HTMLEnv) 46 else 47 stop("not default HTML output file defined; please call HTMLSetFile() to set it") 48} 49 50#----------------------------------------------------------------------------------------------------# 51 52"HTML"<- function(x,...) { 53 UseMethod("HTML") 54 } 55 56#----------------------------------------------------------------------------------------------------# 57 58"HTML.default"<- 59function(x, file=HTMLGetFile(), append=TRUE,...) 60{ 61 HTML(paste(capture.output(x),collapse="\n<br>\n"),file=file,append=append,...) 62 invisible(x) 63} 64 65 66#----------------------------------------------------------------------------------------------------# 67 68"HTML.atomic"<- function(x, file=HTMLGetFile(), append=TRUE, ...){ 69 cat(paste("\n<p class='atomic'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ") 70} 71 72#----------------------------------------------------------------------------------------------------# 73 74"HTML.complex"<- function(x, file=HTMLGetFile(), append=TRUE,...){ 75 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 = " ") 76 } 77 78#----------------------------------------------------------------------------------------------------# 79 80"HTML.numeric"<- function(x, file=HTMLGetFile(), append=TRUE, ...){ 81 if(!is.null(names(x))) { 82 HTML(as.table(x),file=file,append=append,...) 83 } 84 else { 85 cat(paste("\n<p class='numeric'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ") 86 } 87 } 88#----------------------------------------------------------------------------------------------------# 89 90"HTML.integer"<- function(x, file=HTMLGetFile(), append=TRUE, ...){ 91 cat(paste("\n<p class='integer'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ") 92 } 93 94#----------------------------------------------------------------------------------------------------# 95 96"HTML.logical"<- function(x, file=HTMLGetFile(), append=TRUE,...){ 97 cat(paste("\n<p class='logical'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ") 98 } 99 100#----------------------------------------------------------------------------------------------------# 101 102"HTML.character"<- function(x, file=HTMLGetFile(), append=TRUE, ...){ 103 cat(paste("\n<p class='character'>",paste(x,collapse=" "),"</p>\n",sep="",collapse=""), file= file, append = append, sep = " ") 104 } 105 106#----------------------------------------------------------------------------------------------------# 107 108"HTML.call"<- function(x, file=HTMLGetFile(), append=TRUE, ...){ 109 cat(paste("<font class='call'>",deparse(x),"</font>",sep="",collapse=""), file= file, append = append, sep = " ") 110 } 111 112#----------------------------------------------------------------------------------------------------# 113 114"HTML.function"<-function(x,file=HTMLGetFile(), append=TRUE,...){ 115 cat(paste("\n<br>\n<xmp class=function>", 116 paste(capture.output(x),collapse="\n"),"\n</xmp><br>\n",sep=""), 117 file=file,append=append,sep="\n<br>\n") 118 invisible(x) 119} 120 121#----------------------------------------------------------------------------------------------------# 122 123"HTML.environment"<-function(x,file=HTMLGetFile(), append=TRUE,...){ 124 cat(paste("\n<br>environment: <font class='environment'>",attributes(x)$name,"</font><br>\n",sep=""), 125 file=file,append=append) 126 invisible(x) 127} 128#----------------------------------------------------------------------------------------------------# 129 130"HTML.formula"<-function(x,file=HTMLGetFile(), append=TRUE,...) { 131 HTML(paste("<font class='formula'>",deparse(unclass(x)),"</font>",collapse=""),file=file,append=append,...) 132 } 133 134#----------------------------------------------------------------------------------------------------# 135 136"HTML.array"<- function(x, file=HTMLGetFile(), append=TRUE, ...) 137{ 138 odometer <- function(current, radix) 139 { 140 if(any(c(current, radix) < 0)) 141 stop("arguments must be non-negative") 142 lc <- length(current) 143 if(length(radix) != lc) 144 radix <- rep(radix, length = lc) 145 radix <- radix - 1 146 for(i in 1:lc) { 147 if((ii <- current[i]) < radix[i]) { 148 current[i] <- ii + 1 149 return(current) 150 } 151 else current[i] <- 0 152 } 153 current 154 } 155 156 157 d <- dim(x) 158 ndim <- length(d) 159 dn <- dimnames(x) 160 if(ndim == 1) 161 HTML.matrix(matrix(x, 1, dimnames = list("", if(is.null( 162 dn)) paste("[", 1:d[1], "]", sep = "") else dn[[1]])), 163 file = file, append=append,...) 164 else if(ndim == 2) 165 HTML.matrix(x, Border = 0, file = file, append=append,...) 166 else { 167 if(length(dn) < ndim) 168 dn <- vector("list", ndim) 169 for(i in 3:ndim) 170 if(length(dn[[i]]) < d[i]) dn[[i]] <- paste(1:d[i]) 171 xm <- array(x[1], d[1:2]) 172 dimnames(xm) <- dn[1:2] 173 d <- d[ - (1:2)] 174 nm <- length(xm) 175 which <- 1:nm 176 dn <- dn[ - (1:2)] 177 ndim <- ndim - 2 178 counter <- rep(0, length(d)) 179 for(i in 1:(length(x)/nm)) { 180 cat("<br>, , ", file = file, append = TRUE) 181 for(j in 1:ndim) 182 cat(dn[[j]][counter[j] + 1], if(j < ndim) ", " 183 else "<br>", sep = "", file = file, append 184 = TRUE) 185 xm[1:nm] <- x[which] 186 HTML.matrix(xm, Border = 0, file = file, append=TRUE,...) 187 counter <- odometer(counter, d) 188 which <- which + nm 189 } 190 } 191 invisible(x) 192} 193 194#----------------------------------------------------------------------------------------------------# 195 196"HTML.by"<- function (x, file=HTMLGetFile(),vsep="\n<hr size=1 width=100%>\n",append=TRUE,...) 197{ 198 199 HTML("\n",file=file,append=append,...) 200 d <- dim(x) 201 dn <- dimnames(x) 202 dnn <- names(dn) 203 if (missing(vsep)) 204 vsep <- "\n<hr size=1 width=100%>\n" 205 lapply(seq(along = x), function(i, x, vsep, ...) { 206 if (i != 1 && !is.null(vsep)) 207 HTML(vsep, file=file,append=TRUE) 208 ii <- i - 1 209 for (j in seq(along = dn)) { 210 iii <- ii%%d[j] + 1 211 ii <- ii%/%d[j] 212 HTML(paste(dnn[j], ": ", dn[[j]][iii], "\n<br>", sep = ""),file=file,append=TRUE,...) 213 } 214 HTML(x[[i]], file=file,append=TRUE) 215 }, x, vsep, ...) 216 invisible(x) 217} 218 219#----------------------------------------------------------------------------------------------------# 220 221"HTML.family" <- function (x, file=HTMLGetFile(), append=TRUE,...) 222{ 223 HTML(paste("\n<br><b>Family</b>:<font class='family'>", x$family, "\n</font><br>",sep=""),file=get(".HTML.file",pos=1),append=append,...) 224 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,...) 225} 226 227#----------------------------------------------------------------------------------------------------# 228 229"HTML.terms" <- function (x, file=HTMLGetFile(), append=TRUE,...) HTML.default(paste("<font class='terms'>",unclass(x),"</font>",sep=""),file=file,append=append,...) 230 231#----------------------------------------------------------------------------------------------------# 232 233"HTML.factor" <- function (x, file=HTMLGetFile(), append=TRUE,...) 234{ 235 HTML("\n\n<font class='factor'>",file=file,append=append,...) 236 if (length(x) <= 0) 237 HTML("factor(0)\n<br>\n",file=file,append=TRUE,...) 238 else HTML(as.character(x), file=file,append=TRUE, ...) 239 HTML("</font>\n",file=file,append=TRUE,...) 240 HTMLbr(file=file,append=TRUE,...) 241 HTML(paste("Levels:<font class='factorlevels'> ", paste(levels(x), collapse = " "), "</font>\n<br>",sep=""),file=file,append=TRUE,...) 242 invisible(x) 243} 244 245#----------------------------------------------------------------------------------------------------# 246"HTML.density" <- function (x,file=HTMLGetFile(), digits=4,append=TRUE,...) 247{ 248 249 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, 250 "</font> (", x$n, " obs.);", " <b>Bandwidth</b> 'bw' = ", round(x$bw, digits), "\n<br>\n<br>", sep = ""),append=append,file=file) 251 HTML(summary(as.data.frame(x[c("x", "y")])),append=TRUE, ...) 252 invisible(x) 253} 254 255 256#----------------------------------------------------------------------------------------------------# 257"HTML.infl" <- function (x, file=HTMLGetFile(),digits = max(3, getOption("digits") - 4),append=TRUE,...) 258{ 259 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,...) 260 is.star <- apply(x$is.inf, 1, any, na.rm = TRUE) 261 HTML(data.frame(round(x$infmat,digits), inf = ifelse(is.star, "*", " ")),file=file, append=TRUE,...) 262 invisible(x) 263} 264 265 266#----------------------------------------------------------------------------------------------------# 267 268"HTML.lm"<-function(x,file=HTMLGetFile(),digits= max(3, getOption("digits") - 3),append=TRUE,...) 269{ 270 HTMLli(paste("Call: <font class='call'>",deparse(x$call),"</font>",sep=""),file=file,append=append,...) 271 HTMLli("Coefficients<br>",file=file,append=TRUE,...) 272 HTML(round(x$coeff,3),file=file,append=TRUE,...) 273 274} 275 276#----------------------------------------------------------------------------------------------------# 277"HTML.lm.null" <- function (x, file=HTMLGetFile(),digits = max(3, getOption("digits") - 3),append=TRUE,...) 278{ 279 HTMLli(paste("Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>", sep = ""),file=file,append=append,...) 280 HTMLli("No coefficients<br>\n",append=TRUE,...) 281 invisible(x) 282} 283#----------------------------------------------------------------------------------------------------# 284 285 286"HTML.ftable" <- function (x, file=HTMLGetFile(),digits = getOption("digits"),append=TRUE,...) 287{ 288 if (!inherits(x, "ftable")) 289 stop("x must be an `ftable'") 290 ox <- x 291 makeLabels <- function(lst) { 292 lens <- sapply(lst, length) 293 cplensU <- c(1, cumprod(lens)) 294 cplensD <- rev(c(1, cumprod(rev(lens)))) 295 y <- NULL 296 for (i in rev(seq(along = lst))) { 297 ind <- 1 + seq(from = 0, to = lens[i] - 1) * cplensD[i + 298 1] 299 tmp <- character(length = cplensD[i]) 300 tmp[ind] <- lst[[i]] 301 y <- cbind(rep(tmp, times = cplensU[i]), y) 302 } 303 y 304 } 305 makeNames <- function(x) { 306 nmx <- names(x) 307 if (is.null(nmx)) nmx <- rep("", length = length(x)) 308 nmx 309 } 310 xrv <- attr(x, "row.vars") 311 xcv <- attr(x, "col.vars") 312 LABS <- cbind(rbind(matrix("", nrow = length(xcv), ncol = length(xrv)), makeNames(xrv), makeLabels(xrv)), c(makeNames(xcv),rep("", times = nrow(x) + 1))) 313 DATA <- rbind(t(makeLabels(xcv)), rep("", times = ncol(x)), format(unclass(x), digits = digits)) 314 x <- cbind(apply(LABS, 2, format, justify = "left"), apply(DATA, 2, format, justify = "right")) 315 HTML(x,file=file,append=append,...) 316 invisible(ox) 317} 318 319#----------------------------------------------------------------------------------------------------# 320 321"HTML.POSIXlt" <- function (x, file=HTMLGetFile(), append=TRUE,...) HTML(paste("<P class='POSIXlt'>",format(x, usetz = TRUE),"</p>",sep=""), file=file,append=append,...) 322 323#----------------------------------------------------------------------------------------------------# 324 325"HTML.POSIXct" <- function (x, file=HTMLGetFile(), append=TRUE,...) HTML(paste("<P class='POSIXct'>",format(x, usetz = TRUE),"</p>",sep=""), file=file,append=append,...) 326 327 328#----------------------------------------------------------------------------------------------------# 329 330"HTML.octmode" <- function (x, file=HTMLGetFile(), append=TRUE,...) HTML(paste("<P class='octmode'>",format(x),"</p>",sep=""), file=file,append=append,...) 331 332#----------------------------------------------------------------------------------------------------# 333 334"HTML.rle" <- function (x, digits = getOption("digits"), file=HTMLGetFile(), append=TRUE,...) 335{ 336 HTML("<b><center>Run Length Encoding</center></b>\n<br>\n",file=file,append=append,...) 337 tab<-rbind(x$length,x$values) 338 tab<-cbind(c("Length","Values"),tab) 339 HTML(tab,file=file,append=TRUE,...) 340} 341 342#----------------------------------------------------------------------------------------------------# 343 344"HTML.logLik" <- function (x, file=HTMLGetFile(),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,...) 345 346#----------------------------------------------------------------------------------------------------# 347 348 "HTML.xtabs" <- function (x,file=HTMLGetFile(), append=TRUE,...) 349{ 350 ox <- x 351 attr(x, "call") <- NULL 352 HTML.table(x,file=file, append=append,...) 353 invisible(ox) 354} 355 356#----------------------------------------------------------------------------------------------------# 357 358"HTML.summary.lm"<-function (x, file=HTMLGetFile(),digits = max(3, getOption("digits") - 3), symbolic.cor = p > 4, signif.stars = getOption("show.signif.stars"),append=TRUE,...) 359{ 360 361 HTML("\n",file=file,append=append) 362 HTMLli(paste("Call:<font class='call'> ",deparse(x$call),"</font>","\n", sep = "", collapse = ""),file=file,append=TRUE) 363 364 resid <- x$residuals 365 df <- x$df 366 rdf <- df[2] 367 368 HTMLli(paste(if (!is.null(x$w) && diff(range(x$w))) "Weighted "," Residuals<br>\n"),file=file,append=TRUE) 369 if (rdf > 5) { 370 nam <- c("Min", "1Q", "Median", "3Q", "Max") 371 rq <- if (length(dim(resid)) == 2) 372 structure(apply(t(resid), 1, quantile), dimnames = list(nam, dimnames(resid)[[2]])) 373 else structure(quantile(resid), names = nam) 374 HTML(rq, file=file,append=TRUE,...) 375 } 376 else if (rdf > 0) { 377 HTML(resid,file=file,append=TRUE,...) 378 } 379 else { 380 HTML(paste("ALL", df[1], "residuals are 0: no residual degrees of freedom!<br>\n",sep=""),file=file,append=TRUE,...) 381 } 382 if (nsingular <- df[3] - df[1]) 383 384 HTMLli(paste("Coefficients (",nsingular, "not defined because of singularities)<br>\n",sep=""),file=file,append=TRUE) 385 else HTMLli("Coefficients\n",file=file,append=TRUE) 386 387 388 HTML.coefmat(x$coef, digits = digits, signif.stars = signif.stars, file=file,append=TRUE,...) 389 390 HTMLli(paste("Residuals standard error: ",round(x$sigma,digits)," on ",rdf," degrees of freedom\n",sep=""),file=file,append=TRUE) 391 392 393 394 if (!is.null(x$fstatistic)) { 395 HTMLli(paste("Multiple R-Squared:<b>",round(x$r.squared,digits),"</b>",sep=""),file=file,append=TRUE) 396 HTMLli(paste("Adjusted R-Squared:<b>",round(x$adj.r.squared,digits),"</b>",sep=""),file=file,append=TRUE) 397 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) 398 } 399 correl <- x$correlation 400 if (!is.null(correl)) { 401 p <- NCOL(correl) 402 if (p > 1) { 403 HTMLli("Correlation of Coefficients:\n",file=file,append=TRUE,...) 404 if (symbolic.cor) 405 HTML(symnum(correl)[-1, -p],file=file,append=TRUE,...) 406 else { 407 correl[!lower.tri(correl)] <- NA 408 HTML(correl[-1, -p, drop = FALSE],file=file,append=TRUE,...) 409 } 410 } 411 } 412 invisible(x) 413} 414 415 416#----------------------------------------------------------------------------------------------------# 417"HTML.coefmat"<- function (x, digits = max(3, getOption("digits") - 2), signif.stars = getOption("show.signif.stars"), 418 dig.tst = max(1, min(5, digits - 1)), cs.ind = 1:k, tst.ind = k + 419 1, zap.ind = integer(0), P.values = NULL, has.Pvalue = nc >= 420 4 && substr(colnames(x)[nc], 1, 3) == "Pr(", na.print = "",file=HTMLGetFile(), append=TRUE,...) 421{ 422 cat("\n",file=file,append=append,...) 423 if (is.null(d <- dim(x)) || length(d) != 2) 424 stop("1st arg. 'x' must be coefficient matrix/d.f./...") 425 nc <- d[2] 426 if (is.null(P.values)) { 427 scp <- getOption("show.coef.Pvalues") 428 if (!is.logical(scp) || is.na(scp)) { 429 warning("option `show.coef.Pvalues' is invalid: assuming TRUE") 430 scp <- TRUE 431 } 432 P.values <- has.Pvalue && scp 433 } 434 else if (P.values && !has.Pvalue) 435 stop("'P.values is TRUE, but has.Pvalue not!") 436 if (has.Pvalue && !P.values) { 437 d <- dim(xm <- data.matrix(x[, -nc, drop = FALSE])) 438 nc <- nc - 1 439 has.Pvalue <- FALSE 440 } 441 else xm <- data.matrix(x) 442 k <- nc - has.Pvalue - (if (missing(tst.ind)) 443 1 444 else length(tst.ind)) 445 if (!missing(cs.ind) && length(cs.ind) > k) 446 stop("wrong k / cs.ind") 447 Cf <- array("", dim = d, dimnames = dimnames(xm)) 448 ok <- !(ina <- is.na(xm)) 449 if (length(cs.ind) > 0) { 450 acs <- abs(coef.se <- xm[, cs.ind, drop = FALSE]) 451 digmin <- 1 + floor(log10(range(acs[acs != 0], na.rm = TRUE))) 452 Cf[, cs.ind] <- format(round(coef.se, max(1, digits - 453 digmin)), digits = digits) 454 } 455 if (length(tst.ind) > 0) 456 Cf[, tst.ind] <- format(round(xm[, tst.ind], digits = dig.tst), 457 digits = digits) 458 if (length(zap.ind) > 0) 459 Cf[, zap.ind] <- format(zapsmall(xm[, zap.ind], digits = digits), 460 digits = digits) 461 if (any(r.ind <- !((1:nc) %in% c(cs.ind, tst.ind, zap.ind, 462 if (has.Pvalue) nc)))) 463 Cf[, r.ind] <- format(xm[, r.ind], digits = digits) 464 okP <- if (has.Pvalue) 465 ok[, -nc] 466 else ok 467 x0 <- (xm[okP] == 0) != (as.numeric(Cf[okP]) == 0) 468 if (length(not.both.0 <- which(x0 & !is.na(x0)))) { 469 Cf[okP][not.both.0] <- format(xm[okP][not.both.0], digits = max(1, 470 digits - 1)) 471 } 472 if (any(ina)) 473 Cf[ina] <- na.print 474 if (P.values) { 475 if (!is.logical(signif.stars) || is.na(signif.stars)) { 476 warning("option `show.signif.stars' is invalid: assuming TRUE") 477 signif.stars <- TRUE 478 } 479 pv <- xm[, nc] 480 if (any(okP <- ok[, nc])) { 481 Cf[okP, nc] <- format.pval(pv[okP], digits = dig.tst) 482 signif.stars <- signif.stars && any(pv[okP] < 0.1) 483 if (signif.stars) { 484 Signif <- symnum(pv, corr = FALSE, na = FALSE, 485 cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), 486 symbols = c("***", "**", "*", ".", " ")) 487 Cf <- cbind(Cf, formatC(unclass(Signif))) 488 } 489 } 490 else signif.stars <- FALSE 491 } 492 else signif.stars <- FALSE 493 494 HTML.matrix(Cf, file=file, ...) 495 if (signif.stars) HTML(paste("\n<p>--- Signif. codes: ", attr(Signif, "legend"), "</p>\n",sep=""),file=file) 496 invisible(x) 497} 498 499 500#----------------------------------------------------------------------------------------------------# 501 502"HTML.table"<- function(x, file=HTMLGetFile(), append=TRUE,digits=4,...) 503{ 504 cat("\n",file=file,append=append) 505 if (!is.null(digits) && is.numeric(x)) x <- round(x,digits) # PhG, because summary(iris) returns a table, but it is not numeric! 506 if (is.null(dim(x))) HTML(t(as.matrix(x)),file=file,append=TRUE,digits=NULL,...) 507 else HTML(unclass(x),file=file,append=TRUE,...) 508} 509 510 511#----------------------------------------------------------------------------------------------------# 512 513"HTML.listof" <- function (x, file=HTMLGetFile(), append=TRUE,...) 514{ 515 cat("\n",file=file,append=append,...) 516 nn <- names(x) 517 ll <- length(x) 518 if (length(nn) != ll) 519 nn <- paste("Component ", seq(ll)) 520 for (i in seq(length = ll)) { 521 HTMLli(paste(nn[i],":\n<br>",sep=""),file=file) 522 HTML(x[[i]], file=file) 523 } 524 invisible(x) 525} 526 527#----------------------------------------------------------------------------------------------------# 528 529"HTML.ts" <- function (x, calendar=NULL, file=HTMLGetFile(), append=TRUE,...) 530{ 531 cat("\n", file=file,append=append,...) 532 x.orig <- x 533 x <- as.ts(x) 534 fr.x <- frequency(x) 535 if (missing(calendar)) 536 calendar <- any(fr.x == c(4, 12)) 537 if (!calendar) 538 header <- function(x) { 539 if ((fr.x <- frequency(x)) != 1) 540 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) 541 else 542 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) 543 } 544 if (NCOL(x) == 1) { 545 if (calendar) { 546 if (fr.x > 1) { 547 dn2 <- if (fr.x == 12) 548 month.abb 549 else if (fr.x == 4) { 550 c("Qtr1", "Qtr2", "Qtr3", "Qtr4") 551 } 552 else paste("p", 1:fr.x, sep = "") 553 if (NROW(x) <= fr.x && start(x)[1] == end(x)[1]) { 554 dn1 <- start(x)[1] 555 dn2 <- dn2[1 + (start(x)[2] - 2 + seq(along = x))%%fr.x] 556 x <- matrix(format(x, ...), nrow = 1, byrow = TRUE, 557 dimnames = list(dn1, dn2)) 558 } 559 else { 560 start.pad <- start(x)[2] - 1 561 end.pad <- fr.x - end(x)[2] 562 dn1 <- start(x)[1]:end(x)[1] 563 x <- matrix(c(rep("", start.pad), format(x, 564 ...), rep("", end.pad)), ncol = fr.x, byrow = TRUE, 565 dimnames = list(dn1, dn2)) 566 } 567 } 568 else { 569 tx <- time(x) 570 attributes(x) <- NULL 571 names(x) <- tx 572 } 573 } 574 else { 575 header(x) 576 attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL 577 } 578 } 579 else { 580 if (calendar && fr.x > 1) { 581 tm <- time(x) 582 t2 <- 1 + round(fr.x * ((tm + 0.001)%%1)) 583 p1 <- format(floor(tm)) 584 rownames(x) <- if (fr.x == 12) 585 paste(month.abb[t2], p1, sep = " ") 586 else paste(p1, if (fr.x == 4) 587 c("Q1", "Q2", "Q3", "Q4")[t2] 588 else format(t2), sep = " ") 589 } 590 else { 591 if (!calendar) 592 header(x) 593 rownames(x) <- format(time(x)) 594 } 595 attr(x, "class") <- attr(x, "tsp") <- attr(x, "na.action") <- NULL 596 } 597 NextMethod("HTML", x, file=file, ...) 598 invisible(x.orig) 599} 600 601#----------------------------------------------------------------------------------------------------# 602 603 604"HTML.list" <- function(x,file=HTMLGetFile(),first=TRUE,append=TRUE,...) 605{ 606 cat("\n", file=file,append=append,...) 607 if (first) {HTML("<hr class='hr'>",file=file,append=TRUE,sep="\n")} 608 for (i in 1:length(x)) { 609 cat("<ul>",file=file,append=TRUE,sep="\n") 610 cat("</center><li>",file=file,append=TRUE,sep="\n") 611 HTML(x[[i]],file=file,first=FALSE,...) 612 cat("</ul>",file=file,append=TRUE,sep="\n") 613 614 } 615 cat("\n<br><hr class='hr'>",file=file,append=TRUE,sep="\n") 616} 617#----------------------------------------------------------------------------------------------------# 618 619"HTML.pairlist" <- function(x,file=HTMLGetFile(),first=TRUE,append=TRUE,...) 620{ 621 cat("\n", file=file,append=append,...) 622 if (first) {HTML("<hr class='hr'>",file=file,append=TRUE,sep="\n")} 623 for (i in 1:length(x)) { 624 cat("<ul>",file=file,append=TRUE,sep="\n") 625 cat("</center><li>",file=file,append=TRUE,sep="\n") 626 HTML(x[[i]],file=file,first=FALSE,...) 627 cat("</ul>",file=file,append=TRUE,sep="\n") 628 629 } 630 cat("\n<br><hr class='hr'>",file=file,append=TRUE,sep="\n") 631} 632 633 634 635#----------------------------------------------------------------------------------------------------# 636 637# row.names option contributed by 638# Tobias Verbeke on 2006-05-27 639# 640# Fixed bug of invalid HTML output when using 641# row.names = FALSE, as patch contributed 642# by Michael Irskens on 2006-11-04 643# 644 645"HTML.data.frame" <- function( 646 x, file=HTMLGetFile(), 647 Border = 1, innerBorder = 0, 648 classfirstline = "firstline", 649 classfirstcolumn = "firstcolumn", 650 classcellinside = "cellinside", 651 append = TRUE, 652 align = "center", 653 caption = "", 654 captionalign = "bottom", 655 classcaption = "captiondataframe", 656 classtable = "dataframe", 657 digits = getOption("R2HTML.format.digits"), 658 nsmall = getOption("R2HTML.format.nsmall"), 659 big.mark = getOption("R2HTML.format.big.mark"), 660 big.interval = getOption("R2HTML.format.big.interval"), 661 decimal.mark = getOption("R2HTML.format.decimal.mark"), 662 sortableDF = getOption("R2HTML.sortableDF"), 663 row.names = TRUE, 664 ...) 665{ 666 cat("\n", file = file, append = append) 667 668 # Handle sortableDF argument 669 if (is.null(sortableDF)) sortableDF = FALSE 670 if (sortableDF) 671 cat(paste(c("\n<style>", ".tablesort {", 672 "cursor: pointer ;", 673 " behavior:url(tablesort.htc);", 674 " -moz-binding: url(moz-behaviors.xml#tablesort.htc);", 675 "}", 676 "</style>\n"), 677 collapse="\n"), 678 file = file, append = TRUE) 679 680 681 # if (!is.null(digits)) x[] = lapply(x, FUN = function(vec) if (is.numeric(vec)) round(vec, digits) else vec) 682 683 txt <- paste("\n<p align=",align,">") 684 txtcaption <- ifelse(is.null(caption), 685 "", 686 paste("\n<caption align=", captionalign, 687 " class=", classcaption, ">", 688 caption, 689 "</caption>\n", sep="")) 690 691 if (!is.null(Border)) 692 txt <- paste(txt, "\n<table cellspacing=0 border=", Border, ">", 693 txtcaption,"<tr><td>", 694 "\n\t<table border=", innerBorder, " class=",classtable,">", 695 sep = "") 696 else txt <- paste(txt, "\n<table border=", innerBorder, 697 " class=",classtable," cellspacing=0>", 698 txtcaption, sep = "") 699 txt <- paste(txt,"\t<tbody>",sep="\n") 700 701 VecDebut <- c( 702 if(row.names) 703 paste("\n\t\t<th>", 704 if(sortableDF) '<b class="tablesort">', 705 sep = "", collapse = ""), 706 rep(paste("\n\t\t<th>", 707 if(sortableDF) '<b class="tablesort">', 708 sep = "", collapse = ""), ncol(x) - 1) 709 ) 710 VecMilieu <- c( 711 if(row.names) " ", 712 as.character(dimnames(x)[[2]]) 713 ) 714 VecFin <- c( 715 if(row.names) 716 paste(if(sortableDF) '</b>', "", "</th>", collapse = ""), 717 rep( 718 paste(if(sortableDF) '</b>',"", "</th>", collapse = ""), ncol(x) - 1 719 ), 720 "</th>" 721 ) 722 txt <- paste(txt, "\n\t<tr class=", classfirstline, ">", 723 paste(VecDebut, VecMilieu, VecFin, sep = "", collapse = ""), 724 "\n\t</tr>" 725 ) 726 727 x.formatted <- format(x, digits = digits, nsmall = nsmall, 728 big.mark = big.mark, big.interval = big.interval, 729 decimal.mark = decimal.mark) 730 x.formatted <- as.matrix(x.formatted) 731 x.formatted[is.na(x.formatted)] <- " " 732 x.formatted[is.nan(x.formatted)] <- " " 733 734 for(i in 1:dim(x)[1]) { 735 if(i == 1) { 736 VecDebut <- c(if(row.names) 737 paste("\n<td class=", classfirstcolumn, ">", 738 sep = ""), 739 paste("\n<td class=", classcellinside, ">", sep = ""), 740 rep(paste("\n<td class=", classcellinside, ">", 741 sep = ""), 742 dim(x)[2] - 1) 743 ) 744 VecMilieu <- c(if(row.names) 745 dimnames(x)[[1]][i], 746 HTMLReplaceNA(x.formatted[i,]) 747 ) 748 VecFin <- c(if(row.names) "\n</td>", 749 rep("\n</td>", dim(x)[2] - 1), 750 "\n</td></tr>\n" 751 ) 752 } 753 else { 754 VecDebut <- c(if(row.names) 755 paste("\n<td class=", classfirstcolumn, ">", 756 sep = ""), 757 paste(rep(paste("\n<td class=", classcellinside, ">", 758 sep = ""), 759 dim(x)[2]) 760 ) 761 ) 762 VecMilieu <- c(if(row.names) 763 dimnames(x)[[1]][i], 764 HTMLReplaceNA(x.formatted[i,])) 765 VecFin <- c(if(row.names) "\n</td>", 766 rep("\n</td>", dim(x)[2] - 1), 767 "\n</td></tr>\n") 768 } 769 txt <- paste(txt, "\n<tr>", 770 paste(VecDebut, VecMilieu, VecFin, sep = "", collapse = "")) 771 } 772 txt <- paste(txt, "\n\t</tbody>\n</table>\n", 773 if (!is.null(Border)) "</td></table>\n","<br>") 774 cat(txt, "\n", file = file, sep = "", append = TRUE) 775 776} 777 778#----------------------------------------------------------------------------------------------------# 779 780"HTML.matrix" <- function(x, file=HTMLGetFile(), 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"),...) 781{ 782 cat("\n", file=file,append=append) 783 784 # if (is.numeric(x) & !is.null(digits)) x<-round(x,digits=digits) 785 786 txt <- paste("\n<p align=",align,">") 787 txtcaption <- ifelse(is.null(caption),"",paste("<caption align=",captionalign," class=",classcaption,">",caption,"</caption>\n",sep="")) 788 789 if (!is.null(Border)) txt <- paste(txt, "\n<table cellspacing=0 border=",Border,">",txtcaption,"<tr><td>","\n\t<table border=", innerBorder, " class=",classtable,">", sep = "") 790 else txt <- paste(txt, "\n\t<table border=", innerBorder, " class=", classtable," cellspacing=0>", txtcaption, sep = "") 791 792 793 txt <- paste(txt,"\t<tbody>",sep="\n") 794 795 796 if(is.null(dimnames(x)[[2]]) == FALSE) { 797 VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste( 798 "<th>", sep = ""), 799 rep(paste("<th>", sep = ""), dim( 800 x)[2] - 1)) 801 VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "", 802 as.character(dimnames(x)[[2]])) 803 VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</th>", rep( 804 "</th>", dim(x)[2] - 1), "</th>") 805 txt <- paste(txt,"<tr class=",classfirstline,">", paste(VecDebut, VecMilieu, VecFin, sep = "",collapse = ""),"</tr>\n") 806 } 807 808 x.formatted <- format(x, digits=digits, nsmall=nsmall, big.mark=big.mark, big.interval=big.interval, decimal.mark=decimal.mark) 809 x.formatted <- as.matrix(x.formatted) 810 x.formatted[is.na(x.formatted)] <- " " 811 x.formatted[is.nan(x.formatted)] <- " " 812 813 for(i in 1:dim(x)[1]) { 814 if(i == 1) { 815 VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste( 816 "\n<tr><td class=", classfirstcolumn, ">", sep = ""), 817 paste("\n<td class=", classcellinside, ">", sep = ""), 818 rep(paste("\n<td class=", classcellinside, ">", sep = 819 ""), dim(x)[2] - 1)) 820 VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE) 821 dimnames(x)[[1]][i], 822 HTMLReplaceNA(x.formatted[i,])) 823 VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</td>", 824 rep("</td>", dim(x)[2] - 1), "</td>") 825 } 826 else { 827 VecDebut <- c(if(is.null(dimnames(x)[[1]]) == FALSE) paste( 828 "\n<tr><td class=", classfirstcolumn, ">", sep = ""), 829 paste(rep(paste("\n<td class=", classcellinside, ">", sep 830 = ""), dim(x)[2]))) 831 VecMilieu <- c(if(is.null(dimnames(x)[[1]]) == FALSE) 832 dimnames(x)[[1]][i], 833 HTMLReplaceNA(x.formatted[i,])) 834 VecFin <- c(if(is.null(dimnames(x)[[1]]) == FALSE) "</td>", 835 rep("</td>", dim(x)[2] - 1), "</td>") 836 } 837 txt <- paste(txt, "<tr>", paste(VecDebut, VecMilieu, VecFin, sep = "",collapse = ""), "</tr>\n") 838 } 839 txt <- paste(txt, "\n\t</tbody>\n</table>\n",if (!is.null(Border)) "</td></table>\n","<br>") 840 cat(txt, "\n", file = file, sep = "", append=TRUE) 841 } 842 843#----------------------------------------------------------------------------------------------------# 844 845"HTML.structure"<- 846function(x, a = attributes(x), prefix = "", file=HTMLGetFile(), append=TRUE, ...) 847{ 848 cat("\n",file=file,append=append,...) 849 n <- length(dim(x)) 850 nn <- names(a) 851 ate <- character(0) 852 if(n > 0) { 853 if(n == 2) 854 HTML.matrix(x, file = file,append=TRUE, ...) 855 else HTML.array(x, file = file,append=TRUE, ...) 856 ate <- c("dim", "dimnames") 857 if(n == 1) 858 ate <- c(ate, "names") 859 } 860 else if(!is.atomic(x)) { 861 HTML(as.vector(x), file = file,append=TRUE, ...) 862 ate <- "names" 863 } 864 else if(length(tsp(x))) { 865 HTML.ts(x, file = file,append=TRUE, ...) 866 ate <- "tsp" 867 } 868 else if(length(names(x))) { 869 HTML.matrix(matrix(x, 1, dimnames = list("", names(x))), 870 file = file,append=TRUE, ...) 871 ate <- "names" 872 } 873 else HTML(as.vector(x), file = file,append=TRUE, ...) 874 ii <- !match(nn, ate, nomatch = FALSE) 875 nn <- nn[ii] 876 a <- a[ii] 877 for(i in seq(nn)) { 878 this <- paste("attr(", prefix, ", \"", nn[i], "\")", sep = "") 879 HTML(this, file=file,append=TRUE) 880 HTML(a[[i]], file = file, append=TRUE, ...) 881 } 882 invisible(x) 883} 884 885#----------------------------------------------------------------------------------------------------# 886 887"HTML.connection" <- function(x,file=HTMLGetFile(), append=TRUE,...) HTML(paste("<font class='connection'>",unlist(summary(x)),"</font>",sep=""),file=file,append=append,...) 888 889#----------------------------------------------------------------------------------------------------# 890 891"HTML.socket" <- function (x, file=HTMLGetFile(), append=TRUE,...) 892{ 893 if (length(port <- as.integer(x$socket)) != 1) 894 stop("invalid `socket' argument") 895 HTML(paste("Socket connection #", x$socket, "to", x$host, "on port", 896 x$port, "\n<br>",sep=""),file=file,append=append,...) 897 invisible(x) 898} 899 900#----------------------------------------------------------------------------------------------------# 901"HTML.htest" <- function (x, digits = 4, quote = TRUE, prefix = "",file=HTMLGetFile(), append=TRUE, ...) 902{ 903 HTML("\n", file=file,append=append) 904 HTML(as.title(paste(" ",x$method,sep="")),file=file,append=TRUE,...) 905 HTMLli(paste("\n data:<font class=dataname>",x$data.name,"</font>\n",sep=""),file=file,append=TRUE,...) 906 out <- character() 907 if (!is.null(x$statistic)) 908 out <- c(out, paste(names(x$statistic), "=<b>", format(round(x$statistic,4)),"</b>")) 909 if (!is.null(x$parameter)) 910 out <- c(out, paste(names(x$parameter), "=<b>", format(round(x$parameter,3)),"</b>")) 911 if (!is.null(x$p.value)) 912 out <- c(out, paste("p-value =<font class='pvalue'>", format.pval(x$p.value,digits = digits),"</font>")) 913 HTMLli(paste(out,collapse=" , "),file=file,append=TRUE,...) 914 if (!is.null(x$alternative)) { 915 HTMLli("alternative hypothesis: ",file=file) 916 if (!is.null(x$null.value)) { 917 if (length(x$null.value) == 1) { 918 alt.char <- switch(x$alternative, two.sided = "not equal to", 919 less = "less than", greater = "greater than") 920 HTML(paste("true", names(x$null.value), "is", alt.char, 921 x$null.value, "\n"),file=file,append=TRUE,...) 922 } 923 else { 924 HTMLli(paste(x$alternative, "\nnull values:\n<br>"),file=file,append=TRUE,...) 925 HTML(x$null.value, file=file,append=TRUE,...) 926 } 927 } 928 else HTML(paste(x$alternative, "\n<br>"),file=file,append=TRUE,...) 929 } 930 if (!is.null(x$conf.int)) { 931 HTMLli(paste("<b>",format(100 * attr(x$conf.int, "conf.level")), "</b> percent confidence interval:\n", 932 "<b>[", paste(format(c(x$conf.int[1], x$conf.int[2])),sep="",collapse=" ;"),"]</b>",sep=""),file=file,append=TRUE,...) 933 } 934 if (!is.null(x$estimate)) { 935 HTMLli("sample estimates:\n",file=file,...) 936 HTML(t(as.matrix(x$estimate)),file=file,...) 937 } 938 invisible(x) 939} 940 941 942#----------------------------------------------------------------------------------------------------# 943 944 "HTML.aov" <- function (x, intercept = FALSE, tol = .Machine$double.eps^0.5, file=HTMLGetFile(), append=TRUE,...) 945{ 946 cat("\n", file=file,append=append,...) 947 if (!is.null(cl <- x$call)) HTMLli(paste("Call:\n<br><font class='call'>", deparse(cl)),"</font>",file=file) 948 asgn <- x$assign[x$qr$pivot[1:x$rank]] 949 effects <- x$effects 950 if (!is.null(effects)) 951 effects <- as.matrix(effects)[seq(along = asgn), , drop = FALSE] 952 rdf <- x$df.resid 953 uasgn <- unique(asgn) 954 nmeffect <- c("(Intercept)", attr(x$terms, "term.labels"))[1 + uasgn] 955 nterms <- length(uasgn) 956 nresp <- NCOL(effects) 957 df <- numeric(nterms) 958 ss <- matrix(NA, nterms, nresp) 959 if (nterms) { 960 for (i in seq(nterms)) { 961 ai <- asgn == uasgn[i] 962 df[i] <- sum(ai) 963 ef <- effects[ai, , drop = FALSE] 964 ss[i, ] <- if (sum(ai) > 1) 965 colSums(ef^2) 966 else ef^2 } 967 keep <- df > 0 968 if (!intercept && uasgn[1] == 0) 969 keep[1] <- FALSE 970 nmeffect <- nmeffect[keep] 971 df <- df[keep] 972 ss <- ss[keep, , drop = FALSE] 973 nterms <- length(df) } 974 HTMLli("Terms:\n<br>",file=file) 975 if (nterms == 0) { 976 if (rdf > 0) { 977 ss <- colSums(as.matrix(x$residuals)^2) 978 ssp <- sapply(ss, format) 979 if (!is.matrix(ssp)) 980 ssp <- t(ssp) 981 tmp <- as.matrix(c(ssp, format(rdf))) 982 if (length(ss) > 1) { 983 rn <- colnames(x$fitted) 984 if (is.null(rn)) 985 rn <- paste("resp", 1:length(ss)) 986 } 987 else rn <- "Sum of Squares" 988 dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), "Residuals") 989 HTML(as.data.frame(tmp), file=file,...) 990 HTMLli(paste("Residual standard error:", paste(sapply(sqrt(ss/rdf),format),collapse=" "), "\n"),file=file) 991 } 992 else HTML.matrix(matrix(0, 2, 1, dimnames = list(c("Sum of Squares","Deg. of Freedom"), "<empty>")),file=file) 993 } 994 else { 995 if (rdf > 0) { 996 resid <- as.matrix(x$residuals) 997 nterms <- nterms + 1 998 df <- c(df, rdf) 999 ss <- rbind(ss, colSums(resid^2)) 1000 nmeffect <- c(nmeffect, "Residuals") } 1001 ssp <- apply(zapsmall(ss), 2, format) 1002 tmp <- t(cbind(ssp, format(df))) 1003 if (ncol(effects) > 1) { 1004 rn <- colnames(x$coef) 1005 if (is.null(rn)) 1006 rn <- paste("resp", seq(ncol(effects))) } 1007 else rn <- "Sum of Squares" 1008 dimnames(tmp) <- list(c(rn, "Deg. of Freedom"), nmeffect) 1009 HTML(as.data.frame(tmp), file=file) 1010 rank <- x$rank 1011 int <- attr(x$terms, "intercept") 1012 nobs <- NROW(x$residuals) - !(is.null(int) || int == 0) 1013 if (rdf > 0) { 1014 rs <- sqrt(colSums(as.matrix(x$residuals)^2)/rdf) 1015 HTMLli(paste("Residual standard error:", paste(sapply(rs,format),collapse=" "), "\n"),file=file) } 1016 coef <- as.matrix(x$coef)[, 1] 1017 R <- x$qr$qr 1018 R <- R[1:min(dim(R)), , drop = FALSE] 1019 R[lower.tri(R)] <- 0 1020 if (rank < (nc <- length(coef))) { 1021 HTMLli(paste(nc - rank, "out of", nc, "effects not estimable\n"),file=file) 1022 R <- R[, 1:rank, drop = FALSE] } 1023 d2 <- sum(abs(diag(R))) 1024 diag(R) <- 0 1025 if (sum(abs(R))/d2 > tol) 1026 HTMLli("Estimated effects may be unbalanced\n",file=file) 1027 else HTMLli("Estimated effects are balanced\n",file=file) 1028 } 1029 invisible(x) 1030} 1031 1032#----------------------------------------------------------------------------------------------------# 1033 1034"HTML.anova" <- function (x, digits = max(getOption("digits") - 2, 3), signif.stars = getOption("show.signif.stars"),file=HTMLGetFile(), append=TRUE,...) 1035{ 1036 cat("\n", file=file,append=append,...) 1037 if (!is.null(heading <- attr(x, "heading"))) 1038 HTML(paste("<p><b>",heading, "</b></p>"),file=file) 1039 nc <- (d <- dim(x))[2] 1040 if (is.null(cn <- colnames(x))) 1041 stop("anova object must have colnames(.)!") 1042 ncn <- nchar(cn) 1043 has.P <- substr(cn[nc], 1, 3) == "Pr(" 1044 zap.i <- 1:(if (has.P) nc - 1 else nc) 1045 i <- which(substr(cn, 2, 7) == " value") 1046 i <- c(i, which(!is.na(match(cn, c("FALSE", "Cp", "Chisq"))))) 1047 if (length(i)) 1048 zap.i <- zap.i[!(zap.i %in% i)] 1049 tst.i <- i 1050 if (length(i <- which(substr(cn, ncn - 1, ncn) == "Df"))) 1051 zap.i <- zap.i[!(zap.i %in% i)] 1052 HTML.coefmat(x, digits = digits, signif.stars = signif.stars, 1053 has.Pvalue = has.P, P.values = has.P, cs.ind = NULL, 1054 zap.ind = zap.i, tst.ind = tst.i, na.print = "", file=file) 1055 invisible(x) 1056} 1057 1058#----------------------------------------------------------------------------------------------------# 1059 1060"HTML.glm" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "", file=HTMLGetFile(), append=TRUE,...) 1061{ 1062 cat("\n", file=file,append=append,...) 1063 HTMLli(paste("Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>\n<br>"),file=file) 1064 HTMLli("Coefficients",file=file) 1065 if (is.character(co <- x$contrasts)) 1066 HTML(paste(" [contrasts: ", apply(cbind(names(co), co), 1, 1067 paste, collapse = "="), "]"),file=file) 1068 HTMLbr(file=file) 1069 HTML(format(x$coefficients, digits = digits),file=file) 1070 HTMLli(paste("\nDegrees of Freedom:<b>", x$df.null, "</b>Total (i.e. Null);<b> ", 1071 x$df.residual, "</b> Residual\n"),file=file) 1072 HTMLli(paste("Null Deviance:<b> ", format(signif(x$null.deviance, 1073 digits)), "</b> Residual Deviance:<b>", format(signif(x$deviance, 1074 digits)), " </b> AIC:<b> ", format(signif(x$aic, digits)), "</b>\n<br>"),file=file) 1075 invisible(x) 1076} 1077 1078 1079#----------------------------------------------------------------------------------------------------# 1080 1081 "HTML.tables.aov" <- function (x, digits = 4, file=HTMLGetFile(),...) 1082 { 1083HTML("<center>",file=file) 1084 tables.aov <- x$tables 1085 n.aov <- x$n 1086 se.aov <- if (se <- !is.na(match("se", names(x)))) 1087 x$se 1088 type <- attr(x, "type") 1089 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), 1090 residuals = if (length(tables.aov) > 1) 1091 HTML("<p class=partitle>Table of residuals from each stratum\n</p>",file=file)) 1092 if (!is.na(ii <- match("Grand mean", names(tables.aov)))) { 1093 HTML("<p>Grand mean\n</p>",file=file) 1094 gmtable <- tables.aov[[ii]] 1095 HTML.mtable(gmtable, digits = digits, file=file) 1096 } 1097 for (i in names(tables.aov)) { 1098 if (i == "Grand mean") 1099 next 1100 table <- tables.aov[[i]] 1101 HTML(paste("\n<p>", i, "\n</p>"),file=file) 1102 if (!is.list(n.aov)) 1103 HTML.mtable(table, digits = digits,file=file,append=TRUE, ...) 1104 else { 1105 n <- n.aov[[i]] 1106 if (length(dim(table)) < 2) { 1107 table <- rbind(table, n) 1108 rownames(table) <- c("", "rep") 1109 HTML(table, digits = digits, file=file) 1110 } 1111 else { 1112 ctable <- array(c(table, n), dim = c(dim(table), 1113 2)) 1114 dim.t <- dim(ctable) 1115 d <- length(dim.t) 1116 ctable <- aperm(ctable, c(1, d, 2:(d - 1))) 1117 dim(ctable) <- c(dim.t[1] * dim.t[d], dim.t[-c(1, 1118 d)]) 1119 dimnames(ctable) <- c(list(format(c(rownames(table), 1120 rep("rep", dim.t[1])))), dimnames(table)[-1]) 1121 ctable <- eval(parse(text = paste("ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))", 1122 paste(rep(", ", d - 2), collapse = " "), "]"))) 1123 names(dimnames(ctable)) <- names(dimnames(table)) 1124 class(ctable) <- "mtable" 1125 HTML.mtable(ctable, digits = digits,file=file, append=TRUE,...) 1126 } 1127 } 1128 } 1129 if (se) { 1130 if (type == "residuals") 1131 rn <- "df" 1132 else rn <- "replic." 1133 switch(attr(se.aov, "type"), effects = HTML("\n<p class=partitle>Standard errors of effects\n</p>",file=file), 1134 means = HTML("\n<p class=partitle>Standard errors for differences of means\n</p>",file=file), 1135 residuals = HTML("\n<p class=partitle>Standard errors of residuals\n</p>",file=file)) 1136 if (length(unlist(se.aov)) == length(se.aov)) { 1137 n.aov <- n.aov[!is.na(n.aov)] 1138 se.aov <- unlist(se.aov) 1139 cn <- names(se.aov) 1140 se.aov <- rbind(format(se.aov, digits = digits), 1141 format(n.aov)) 1142 dimnames(se.aov) <- list(c(" ", rn), cn) 1143 HTML.matrix(se.aov,file=file) 1144 } 1145 else for (i in names(se.aov)) { 1146 se <- se.aov[[i]] 1147 if (length(se) == 1) { 1148 se <- rbind(se, n.aov[i]) 1149 dimnames(se) <- list(c(i, rn), "") 1150 HTML(se, file=file) 1151 } 1152 else { 1153 dimnames(se)[[1]] <- "" 1154 HTML(paste("\n<p>", i, "\n</p>"),file=file) 1155 HTML("When comparing means with same levels of:\n<br>",file=file) 1156 HTML(se, file=file, ...) 1157 HTML(paste("replic.", n.aov[i], "\n<br>"),file=file) 1158 } 1159 } 1160 } 1161 HTML("</center>",file=file) 1162 invisible(x) 1163 } 1164 1165 1166#----------------------------------------------------------------------------------------------------# 1167 1168"HTML.mtable" <- function (x, digits = getOption("digits"),file=HTMLGetFile(), append=TRUE,...) 1169{ 1170 cat("\n", file=file,append=append,...) 1171 xxx <- x 1172 xx <- attr(x, "Notes") 1173 nn <- names(dimnames(x)) 1174 a.ind <- match(names(a <- attributes(x)), c("dim", "dimnames", 1175 "names")) 1176 a <- a[!is.na(a.ind)] 1177 class(x) <- attributes(x) <- NULL 1178 attributes(x) <- a 1179 if (length(x) == 1 && is.null(names(x)) && is.null(dimnames(x))) 1180 names(x) <- rep("", length(x)) 1181 if (length(dim(x)) && is.numeric(x)) { 1182 xna <- is.na(x) 1183 x <- format(zapsmall(x, digits)) 1184 x[xna] <- " " 1185 } 1186 HTML(x, file=file, ...) 1187 if (length(xx)) { 1188 HTML("\n<br>Notes:\n<br>",file=file) 1189 HTML(xx,file=file) 1190 } 1191 invisible(xxx) 1192} 1193 1194#----------------------------------------------------------------------------------------------------# 1195 1196"HTML.integrate" <- function (x, digits = getOption("digits"), file=HTMLGetFile(), append=TRUE,...) 1197{ 1198 cat("\"n", file=file,append=append,...) 1199 if (x$message == "OK") 1200 HTML(paste("<p>",format(x$value, digits = digits), " with absolute error < ", 1201 format(x$abs.error, digits = 2), "\n</p>", sep = ""),file=file) 1202 else HTML(paste("<p>failed with message `", x$message, "'\n</p>", sep = ""),file=file) 1203 invisible(x) 1204} 1205 1206 1207#----------------------------------------------------------------------------------------------------# 1208 1209"HTML.summary.lm.null" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 1210{ 1211 1212 cat("\"n", file=file,append=append,...) 1213 HTMLli(paste("<br><p>Call:<font class=call> ", paste(deparse(x$call), sep = "\n<br>", collapse = "\n<br>"), "</font></p>" ),file=file) 1214 resid <- x$residuals 1215 df <- x$df 1216 rdf <- df[2] 1217 if (rdf > 5) { 1218 HTMLli("Residuals:\n<br>",file=file) 1219 if (length(dim(resid)) == 2) { 1220 rq <- apply(t(resid), 1, quantile) 1221 dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", 1222 "Max"), dimnames(resid)[[2]]) 1223 } 1224 else { 1225 rq <- quantile(resid) 1226 names(rq) <- c("Min", "1Q", "Median", "3Q", "Max") 1227 } 1228 HTML(round(rq, digits) ,file=file) 1229 } 1230 else if (rdf > 0) { 1231 HTMLli("Residuals:\n<br>",file=file) 1232 HTML(round(resid, digits ), file=file) 1233 } 1234 else HTMLli("\n<br>No Coefficients:\n<br>",file=file) 1235 HTMLli(paste("\n<br>Residual standard error:<b> ", format(signif(x$sigma, 1236 digits)), "on <b> ", rdf, " </b>degrees of freedom\n<br><br>",sep=""),file=file) 1237 invisible(x) 1238} 1239 1240#----------------------------------------------------------------------------------------------------# 1241 1242"HTML.summary.glm" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "", 1243 symbolic.cor = p > 4, signif.stars = getOption("show.signif.stars"), file=HTMLGetFile(), append=TRUE, 1244 ...) 1245{ 1246 cat("\n", file=file,append=append,...) 1247 HTMLli(paste("\n<p>Call: <font class=call>",paste(deparse(x$call),collapse=" "),"</font>"),file=file) 1248 1249 HTML("<p>Deviance Residuals: \n</p>",file=file) 1250 if (x$df.residual > 5) { 1251 x$deviance.resid <- quantile(x$deviance.resid, na.rm = TRUE) 1252 names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q", 1253 "Max") 1254 } 1255 HTML(t(round(x$deviance.resid,digits)) , file=file) 1256 HTML("\n<p>Coefficients:\n</p>",file=file) 1257 HTML.coefmat(x$coef, signif.stars = signif.stars, file=file) 1258 1259 HTML(paste("\n<p>(Dispersion parameter for ", x$family$family, " family taken to be ", 1260 format(x$dispersion), ")\n</p>\n"),file=file) 1261 1262 HTML(paste("<li>Null deviance:<b>", round(x$null.deviance,digits), "</b> on <b>", x[c("df.null")],"</b> degrees of freedom."),file=file) 1263 1264 HTML(paste("<li>Residual deviance:<b>", round(x$deviance,digits), "</b> on <b>", x[c("df.residual")],"</b> degrees of freedom."),file=file) 1265 1266 1267 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) 1268 correl <- x$correlation 1269 if (!is.null(correl)) { 1270 p <- NCOL(correl) 1271 if (p > 1) { 1272 HTML("\n<p>Correlation of Coefficients:\n</p>") 1273 if (symbolic.cor) 1274 HTML(symnum(correl)[-1, -p],file=file) 1275 else { 1276 correl[!lower.tri(correl)] <- NA 1277 HTML(correl[-1, -p, drop = FALSE], file=file) 1278 } 1279 } 1280 } 1281 HTMLbr(file=file) 1282 invisible(x) 1283} 1284 1285 1286#----------------------------------------------------------------------------------------------------# 1287 1288"HTML.hsearch" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1289{ 1290 cat("\"n", file=file,append=append,...) 1291 fields <- paste(x$fields, collapse = " or ") 1292 db <- x$matches 1293 if (NROW(db) > 0) { 1294 HTML(paste("<p>Help files with ", fields, " matching `", 1295 x$pattern, "',\n", "type `help(FOO, package = PKG)' to inspect ", 1296 "entry `FOO(PKG) TITLE':", "\n</p>", sep = ""), file=file) 1297 dbnam <- paste(db[, "name"], "(", db[, "Package"], ")",sep = "") 1298 dbtit <- paste(db[, "title"], sep = "") 1299 HTML(cbind(dbnam, dbtit), file=file) 1300 } 1301 else HTML(paste("<p>No help files found with ", fields, " matching `", x$pattern, "'\n</p>", sep = ""),file=file) 1302} 1303 1304#----------------------------------------------------------------------------------------------------# 1305 1306"HTML.aov" <- function(x,file=HTMLGetFile(), append=TRUE,...) 1307{ 1308NextMethod("HTML") 1309} 1310 1311"HTML.aovlist" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1312{ 1313 cat("\"n", file=file,append=append,...) 1314 cl <- attr(x, "call") 1315 if (!is.null(cl)) { 1316 cat("\nCall:\n<font class=call>",file=file,append=TRUE,...) 1317 dput(cl,file=file) 1318 cat("\n</font>",file=file,append=TRUE,...) 1319 } 1320 if (!is.null(attr(x, "weights"))) 1321 cat("Note: The results below are on the weighted scale\n",file=file,append=TRUE,...) 1322 nx <- names(x) 1323 if (nx[1] == "(Intercept)") { 1324 mn <- x[[1]]$coef 1325 if (is.matrix(mn)) { 1326 cat("\nGrand Means:\n",file=file,append=TRUE,...) 1327 cat(format(mn[1, ]), file=file,append=TRUE,...) 1328 } 1329 else cat("\nGrand Mean:", format(mn[1]), "\n",file=file,append=TRUE,...) 1330 nx <- nx[-1] 1331 } 1332 for (ii in seq(along = nx)) { 1333 i <- nx[ii] 1334 cat("\nStratum ", ii, ": ", i, "\n", sep = "",file=file,append=TRUE,...) 1335 xi <- x[[i]] 1336 cat(xi,file=file,append=TRUE, ...) 1337 } 1338 invisible(x) 1339} 1340 1341 1342#----------------------------------------------------------------------------------------------------# 1343 1344"HTML.SavedPlots" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1345{ 1346 cat("\"n",file=file,append=append,...) 1347 if (x[[1]] != 31416) { 1348 HTML("<p>object is not of class `SavedPlots'</p>\n<br>",file=file) 1349 return() 1350 } 1351 HTML("<p>Saved Plots from R version 1.4.0 or later</p>\n<br>\n<br>",file=file,append=TRUE,...) 1352 HTML(" Contains", x[[2]], "out of a maximum", x[[3]], "plots\n",file=file,append=TRUE,...) 1353 lens <- sapply(x[[5]], length)[1:x[[2]]] 1354 cat(" #plot calls are", paste(lens, collapse = ", "), "\n",file=file,append=TRUE,...) 1355 cat(" Current position is plot", 1 + x[[4]], "\n",file=file,append=TRUE,...) 1356} 1357 1358#----------------------------------------------------------------------------------------------------# 1359 1360"HTML.ordered" <- function (x, quote = FALSE,file=HTMLGetFile(), append=TRUE,...) 1361{ 1362 cat("\n",file=file,append=append,...) 1363 if (length(x) <= 0) 1364 HTML("\n<p>ordered(0)\n</p>",file=file,append=TRUE,...) 1365 else HTML(as.character(x), file,file, append=TRUE,...) 1366 HTML(paste("\n<p>Levels<font class=factorlevels>: ", paste(levels(x), collapse = " < "), "</font>\n</p>"),file=file,append=TRUE,...) 1367 invisible(x) 1368} 1369 1370#----------------------------------------------------------------------------------------------------# 1371 1372"HTML.difftime" <- function (x, digits = getOption("digits"),file=HTMLGetFile(), append=TRUE, ...) 1373{ 1374 cat("\n",file=file,append=append,...) 1375 if (length(x) > 1) 1376 HTML(paste("<p>Time differences of ", paste(format(unclass(x), 1377 digits = digits), collapse = ", "), " ", attr(x, 1378 "units"), "\n</p>", sep = ""),file=file,append=TRUE,...) 1379 else HTML(paste("<p>Time difference of ", format(unclass(x), digits = digits), 1380 " ", attr(x, "units"), "\n", sep = ""),file=file,append=TRUE,...) 1381 invisible(x) 1382} 1383 1384 1385#----------------------------------------------------------------------------------------------------# 1386 1387"HTML.dummy.coef" <- function (x, file=HTMLGetFile(), append=TRUE,title="",...) 1388{ 1389 cat("\n",file=file,append=append,...) 1390 terms <- names(x) 1391 n <- length(x) 1392 nm <- max(sapply(x, length)) 1393 ans <- matrix("", 2 * n, nm) 1394 rn <- rep("", 2 * n) 1395 line <- 0 1396 for (j in seq(n)) { 1397 this <- x[[j]] 1398 n1 <- length(this) 1399 if (n1 > 1) { 1400 line <- line + 2 1401 ans[line - 1, 1:n1] <- names(this) 1402 ans[line, 1:n1] <- format(this, ...) 1403 rn[line - 1] <- paste(terms[j], ": ", sep = "") 1404 } 1405 else { 1406 line <- line + 1 1407 ans[line, 1:n1] <- format(this, ...) 1408 rn[line] <- paste(terms[j], ": ", sep = "") 1409 } 1410 } 1411 rownames(ans) <- rn 1412 colnames(ans) <- rep("", nm) 1413 HTML(paste("\n<p>",if (title=="") 1414 "Full coefficients are" 1415 else title, "\n</p>"),file=file,append=TRUE,...) 1416 HTML.matrix(ans[1:line, , drop = FALSE],file=file,append=TRUE,...) 1417 invisible(x) 1418} 1419 1420 1421#----------------------------------------------------------------------------------------------------# 1422 1423"HTML.dummy.coef.list" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1424{ 1425 cat("\n",file=file,append=append,...) 1426 for (strata in names(x)) HTML.dummy.coef(x[[strata]], file=file, title = paste("\n<p> Error:", strata,"</p>"),append=TRUE,...) 1427 invisible(x) 1428} 1429 1430 1431#----------------------------------------------------------------------------------------------------# 1432 1433 "HTML.glm.null" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "", 1434 file=HTMLGetFile(), append=TRUE,...) 1435{ 1436 1437 cat("\n",file=file,append=append,...) 1438 HTMLli(paste(" Call: <font class='call'>", deparse(x$call),"</font>", "\n<br>\n"),file=file) 1439 HTMLli("No coefficients\n<br>") 1440 HTMLli(paste("Degrees of Freedom:<b>", length(x$residuals), "</b> Total; <b>", 1441 x$df.residual, " </b>Residual\n<br>"),file=file) 1442 HTMLli(paste("Null Deviance:<b>", format(signif(x$null.deviance, digits)), 1443 "</b>\n<br>"),file=file) 1444 HTMLli(paste("Residual Deviance: <b>", format(signif(x$deviance, digits)), 1445 " </b><br>\n"),file=file) 1446 HTMLli(paste("AIC:<b>", format(signif(x$aic, digits)), "</b><br>\n"),file=file) 1447 invisible(x) 1448} 1449 1450#----------------------------------------------------------------------------------------------------# 1451 1452"HTML.MethodsFunction"<- function (x,file=HTMLGetFile(), append=TRUE, ...) 1453{ 1454 cat("\n",file=file,append=append,...) 1455 info=attr(x,"info") 1456 if (dim(info)[1]==0) HTML("<p>No available generic function for the class",file=file,append=TRUE) 1457 HTML("<p>Available generic functions which does handle the class</p>",file=file,append=TRUE) 1458 HTML(info,file=file,append=TRUE,...) 1459 invisible(x) 1460} 1461 1462#----------------------------------------------------------------------------------------------------# 1463 1464"HTML.libraryIQR" <- function (x,file=HTMLGetFile(), append=TRUE, ...) 1465{ 1466 cat("\n",file=file,append=append,...) 1467 sQuote <- function(s) paste("`", s, "'", sep = "") 1468 db <- x$results 1469 out <- if (nrow(db) == 0) 1470 NULL 1471 else lapply(split(1:nrow(db), db[, "LibPath"]), function(ind) db[ind, 1472 c("Package", "Title"), drop = FALSE]) 1473 first <- TRUE 1474 for (lib in names(out)) { 1475 HTML(paste(paste("<p>Packages in library ", 1476 sQuote(lib), ":</p>", sep = "")),file=file,append=TRUE,...) 1477 HTML(cbind(out[[lib]][, "Package"], out[[lib]][, 1478 "Title"]), file=file,append=TRUE,...) 1479 first <- FALSE 1480 } 1481 if (first) { 1482 HTML("<p>no packages found</p>",file=file, append=TRUE,...) } 1483 invisible(x) 1484} 1485 1486#----------------------------------------------------------------------------------------------------# 1487 1488"HTML.summary.aov" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 1489{ 1490 cat("\n",file=file,append=append,...) 1491 if (length(x) == 1) 1492 HTML(x[[1]], file=file) 1493 else NextMethod() 1494 invisible(x) 1495} 1496 1497 1498#----------------------------------------------------------------------------------------------------# 1499 1500"HTML.summary.aovlist" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1501{ 1502 cat("\n",file=file,append=append,...) 1503 nn <- names(x) 1504 for (i in nn) { 1505 HTMLli(paste(i, "\n<br>", sep = ""),file=file) 1506 HTML(x[[i]], file=file) 1507 } 1508 invisible(x) 1509} 1510 1511 1512#----------------------------------------------------------------------------------------------------# 1513 1514"HTML.summary.glm.null" <- function (x, digits = max(3, getOption("digits") - 3), na.print = "", 1515 file=HTMLGetFile(), append=TRUE,...) 1516{ 1517 cat("\n",file=file,append=append,...) 1518 HTMLli(paste("\nCall:<font class=call> ",paste(deparse(x$call), sep = "\n", collapse = "\n"), 1519 "</font>\n<br>\n", sep = ""),file=file) 1520 HTMLli("Deviance Residuals: \n<br>",file=file) 1521 if (x$df.residual > 5) { 1522 x$deviance.resid <- quantile(x$deviance.resid) 1523 names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q", 1524 "Max") 1525 } 1526 HTML.default(x$deviance.resid, digits = digits, na = "",file=file) 1527 HTMLli("No coefficients\n<br>") 1528 HTMLli(paste("\n(Dispersion parameter for ", x$family$family, 1529 " family taken to be ", x$dispersion, ")\n\n Null deviance:<b> ", 1530 x$null.deviance, " </b>on <b>", x$df.null, " </b>degrees of freedom\n\n", 1531 "Residual deviance: <b>", x$deviance, " </b>on<b> ", x$df.residual, 1532 " </b>degrees of freedom\n\n", "Number of Fisher Scoring iterations<b>: ", 1533 x$iter, "</b>\n<br>\n", sep = ""),file=file) 1534 invisible(x) 1535} 1536 1537 1538#----------------------------------------------------------------------------------------------------# 1539 1540"HTML.summary.manova" <- function (x, digits = getOption("digits"),file=HTMLGetFile(), append=TRUE,...) 1541{ 1542 cat("\n",file=file,append=append,...) 1543 if (length(stats <- x$stats)) { 1544 HTML.anova(stats,file=file) 1545 } 1546 else { 1547 HTML("<p>No error degrees of freedom</p>\n") 1548 HTML(data.frame(Df = x$Df, row.names = x$row.names),file=file) 1549 } 1550 invisible(x) 1551} 1552 1553 1554 1555#----------------------------------------------------------------------------------------------------# 1556 1557"HTML.summary.table" <- function (x, digits = max(1, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 1558{ 1559 cat("\n",file=file,append=append,...) 1560 if (!inherits(x, "summary.table")) 1561 stop("x must inherit from class `summary.table'") 1562 if (!is.null(x$call)) { 1563 HTMLli(paste("Call:<font class='call'> ", x$call,"</font>"),file=file) 1564 } 1565 HTMLli(paste("Number of cases in table:<b>", x$n.cases, "</b>\n<br>"),file=file) 1566 HTMLli(paste("Number of factors:<b>", x$n.vars, "</b>\n<br>"),file=file) 1567 if (x$n.vars > 1) { 1568 HTMLli("Test for independence of all factors:\n<br>",file=file) 1569 ch <- x$statistic 1570 HTML(paste(" Chisq = <b>", format(round(ch, max(0, digits - log10(ch)))), 1571 "</b>, df = <b>", x$parameter, "</b>, p-value = <b>", format.pval(x$p.value, 1572 digits, eps = 0), "</b>\n<br>", sep = ""),file=file) 1573 if (!x$approx.ok) 1574 HTML("<p>Chi-squared approximation may be incorrect</p>\n",file=file) 1575 } 1576 invisible(x) 1577} 1578 1579 1580#----------------------------------------------------------------------------------------------------# 1581"HTML.TukeyHSD" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1582{ 1583 cat("\n",file=file,append=append,...) 1584 HTML("<center><p><b>Tukey multiple comparisons of means</b></p>\n") 1585 HTML(paste("<p>", format(100 * attr(x, "conf.level"), 2), "% family-wise confidence level</p></center>\n", 1586 sep = ""),file=file) 1587 1588 if (attr(x, "ordered")) 1589 HTML("<center><p>factor levels have been ordered</p></center>\n",file=file) 1590 HTMLli(paste("Fit: ", deparse(attr(x, "orig.call")), "\n<br>\n", sep = ""),file=file) 1591 attr(x, "orig.call") <- attr(x, "conf.level") <- attr(x, "ordered") <- NULL 1592 lapply(unclass(x),HTML,file=file,append=TRUE,...) 1593 #HTML.default(unclass(x), file=file,...) 1594 invisible(return(x)) 1595} 1596 1597 1598#----------------------------------------------------------------------------------------------------# 1599 1600"HTML.simple.list" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1601{ 1602 cat("\n",file=file,append=append,...) 1603 HTML(noquote(cbind("<-" = unlist(x))), file=file,append=TRUE,...) 1604} 1605 1606#----------------------------------------------------------------------------------------------------# 1607 1608"HTML.noquote" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1609{ 1610 cat("\n",file=file,append=append,...) 1611 if (!is.null(cl <- attr(x, "class"))) { 1612 cl <- cl[cl != "noquote"] 1613 attr(x, "class") <- (if (length(cl) > 0) 1614 cl 1615 else NULL) 1616 } 1617 HTML(x, file=file, append=TRUE,...) 1618} 1619 1620 1621 1622### 1623### PACKAGES FUNCTIONS 1624### 1625 1626 1627### PACKAGE TS 1628 1629#----------------------------------------------------------------------------------------------------# 1630 1631"HTML.ar" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 1632{ 1633 cat("\n",file=file,append=append,...) 1634 HTMLli(paste("Call:\n<font class='call'>", deparse(x$call), "</font>\n", sep = ""),file=file) 1635 nser <- NCOL(x$var.pred) 1636 if (nser > 1) { 1637 if (!is.null(x$x.intercept)) 1638 res <- x[c("ar", "x.intercept", "var.pred")] 1639 else res <- x[c("ar", "var.pred")] 1640 res$ar <- aperm(res$ar, c(2, 3, 1)) 1641 HTML(res, digits = digits,file=file) 1642 } 1643 else { 1644 if (x$order > 0) { 1645 HTMLli("Coefficients:\n",file=file) 1646 coef <- drop(round(x$ar, digits = digits)) 1647 names(coef) <- seq(length = x$order) 1648 HTML.default(coef, file=file) 1649 } 1650 if (!is.null(xint <- x$x.intercept) && !is.na(xint)) 1651 HTML(paste("<p>Intercept: <b>", format(xint, digits = digits), 1652 "</b> (", format(x$asy.se.coef$x.mean, digits = digits), 1653 ") ", "\n</p>", sep = ""),file=file) 1654 HTML(paste("<p>Order selected <b>", x$order, " </b>sigma^2 estimated as <b>", 1655 format(x$var.pred, digits = digits), "</b>\n<</p>"),file=file) 1656 } 1657 invisible(x) 1658} 1659 1660#----------------------------------------------------------------------------------------------------# 1661 1662"HTML.Arima" <- function (x, digits = max(3, getOption("digits") - 3), se = TRUE, 1663 file=HTMLGetFile(), append=TRUE,...) 1664{ 1665 cat("\n",file=file,append=append,...) 1666 HTMLli(paste("nCall:<font class='call'>", deparse(x$call, width.cutoff = 75), "</font>", sep = "\n"),file=file) 1667 HTMLli("Coefficients:\n<br>",file=file) 1668 coef <- round(x$coef, digits = digits) 1669 if (se && nrow(x$var.coef)) { 1670 ses <- rep(0, length(coef)) 1671 ses[x$mask] <- round(sqrt(diag(x$var.coef)), digits = digits) 1672 coef <- matrix(coef, 1, dimnames = list(NULL, names(coef))) 1673 coef <- rbind(coef, s.e. = ses) 1674 } 1675 HTML.default(coef,file=file) 1676 cm <- x$call$method 1677 if (is.null(cm) || cm != "CSS") 1678 HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits), 1679 "</b>: log likelihood = <b>", format(round(x$loglik, 2)), 1680 "</b>, aic = <b>", format(round(x$aic, 2)), "</b>\n</p>", sep = ""),file=file) 1681 else HTML("<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits), 1682 "</b>: part log likelihood =<b> ", format(round(x$loglik, 2)), 1683 "</b>\n</p>", sep = "") 1684 invisible(x) 1685} 1686 1687 1688#----------------------------------------------------------------------------------------------------# 1689 1690"HTML.arima0" <- function (x, digits = max(3, getOption("digits") - 3), se = TRUE, 1691 file=HTMLGetFile(), append=TRUE,...) 1692{ 1693 cat("\n",file=file,append=append,...) 1694 HTMLli(paste("\nCall:<font class='call'>", deparse(x$call, width.cutoff = 75), "</font>", sep = "\n"),file=file) 1695 HTMLli("Coefficients:\n<br>",file=file) 1696 coef <- round(x$coef, digits = digits) 1697 if (se && nrow(x$var.coef)) { 1698 ses <- rep(0, length(coef)) 1699 ses[x$mask] <- round(sqrt(diag(x$var.coef)), digits = digits) 1700 coef <- matrix(coef, 1, dimnames = list(NULL, names(coef))) 1701 coef <- rbind(coef, s.e. = ses) 1702 } 1703 HTML.default(coef, file=file) 1704 cm <- x$call$method 1705 if (is.null(cm) || cm != "CSS") 1706 HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits), 1707 "</b>: log likelihood = <b>", format(round(x$loglik, 2)), 1708 "</b>, aic = <b>", format(round(x$aic, 2)), "</b>\n</p>", sep = ""),file=file) 1709 else HTML(paste("\n<p>sigma^2 estimated as <b>", format(x$sigma2, digits = digits), 1710 "</b>: part log likelihood =<b> ", format(round(x$loglik, 2)), 1711 "</b>\n</p>", sep = ""),file=file) 1712 invisible(x) 1713} 1714 1715#----------------------------------------------------------------------------------------------------# 1716 1717"HTML.HoltWinters" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1718{ 1719 cat("\n",file=file,append=append,...) 1720 HTML(paste("<p><b>Holt-Winters exponential smoothing", if (x$beta == 0) 1721 "without" 1722 else "with", "trend and", if (x$gamma == 0) 1723 "without" 1724 else paste(if (x$beta == 0) 1725 "with ", x$seasonal, sep = ""), "seasonal componenent.\n</b></p>"),file=file) 1726 1727 HTMLli(paste("\nCall:\n", deparse(x$call), "\n<br>"),file=file) 1728 HTMLli("Smoothing parameters:\n<ul>",file=file) 1729 HTMLli(paste(" alpha: ", x$alpha, "\n"),file=file) 1730 HTMLli(paste(" beta: ", x$beta, "\n"),file=file) 1731 HTMLli(paste(" gamma: ", x$gamma, "\n<br>"),file=file) 1732 HTML("</ul>",file=file) 1733 HTMLli("Coefficients:\n",file=file) 1734 HTML(t(t(x$coefficients)),file=file) 1735} 1736 1737 1738#----------------------------------------------------------------------------------------------------# 1739 1740"HTML.stl" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1741{ 1742 cat("\n",file=file,append=append,...) 1743 HTMLli(paste("Call:\n ",deparse(x$call),"\n<br>"),file=file) 1744 HTMLli("\nComponents\n",file=file) 1745 HTML(x$time.series, file=file,append=TRUE,...) 1746 invisible(x) 1747} 1748 1749#----------------------------------------------------------------------------------------------------# 1750 1751"HTML.StructTS" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 1752{ 1753 cat("\n",file=file,append=append,...) 1754 HTMLli(paste("\nCall:", deparse(x$call, width.cutoff = 75), "\n", sep = " "),file=file) 1755 HTMLli("Variances:\n",file=file) 1756 HTML(x$coef, digits=digits,file=file) 1757 invisible(x) 1758} 1759 1760 1761#----------------------------------------------------------------------------------------------------# 1762 1763"HTML.tskernel" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 1764{ 1765 cat("\n",file=file,append=append,...) 1766 y <- c(rev(x$coef[2:(x$m + 1)]), x$coef) 1767 i <- -x$m:x$m 1768 HTML(paste("<p>",attr(x, "name"), "</p>\n"),file=file) 1769 HTML(paste( paste("coef[", format(i), "] = ", format(y, digits = digits),sep = ""),collapse="<br>\n", sep = "\n<br>"),file=file) 1770} 1771 1772 1773### PACKAGE CTEST 1774 1775#----------------------------------------------------------------------------------------------------# 1776 1777"HTML.pairwise.htest" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1778{ 1779 cat("\n",file=file,append=append,...) 1780 HTMLli(paste("Pairwise comparisons using", x$method, "\n<br>\n<br>"),file=file) 1781 HTMLli(paste("data: <font class=dataname>", x$data.name,"</font>", "\n<br>\n<br>"),file=file) 1782 pp <- format.pval(x$p.value, 2, na.form = "-") 1783 attributes(pp) <- attributes(x$p.value) 1784 HTML(pp, file=file) 1785 HTMLli(paste("\nP value adjustment method:", x$p.adjust.method, "\n"),file=file) 1786} 1787 1788#----------------------------------------------------------------------------------------------------# 1789 1790"HTML.power.htest" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1791{ 1792 cat("\n",file=file,append=append,...) 1793 HTMLli(paste(x$method,"<br>"), file=file) 1794 note <- x$note 1795 x[c("method", "note")] <- NULL 1796 HTML(paste(paste(formatC(names(x), width = 15, flag = "+"), 1797 format(x), sep = " = "), sep = "\n<br>",collapse="\n<br>"),file=file) 1798 if (!is.null(note)) 1799 HTML(paste("\n<p>", "NOTE:", note, "\n</p>\n"),file=file) 1800 else HTMLbr(file=file) 1801} 1802 1803 1804#----------------------------------------------------------------------------------------------------# 1805 1806"HTML.boot" <- function (x, digits = options()$digits, index = 1:ncol(boot.out$t), file=HTMLGetFile(), append=TRUE,...) 1807{ 1808 cat("\n",file=file,append=append,...) 1809 boot.out <- x 1810 sim <- boot.out$sim 1811 cl <- boot.out$call 1812 t <- matrix(boot.out$t[, index], nrow = nrow(boot.out$t)) 1813 allNA <- apply(t, 2, function(t) all(is.na(t))) 1814 ind1 <- index[allNA] 1815 index <- index[!allNA] 1816 t <- matrix(t[, !allNA], nrow = nrow(t)) 1817 rn <- paste("t", index, "*", sep = "") 1818 if (length(index) == 0) 1819 op <- NULL 1820 else if (is.null(t0 <- boot.out$t0)) { 1821 if (is.null(boot.out$call$weights)) 1822 op <- cbind(apply(t, 2, mean, na.rm = TRUE), sqrt(apply(t, 1823 2, function(t.st) var(t.st[!is.na(t.st)])))) 1824 else { 1825 op <- NULL 1826 for (i in index) op <- rbind(op, boot::imp.moments(boot.out, 1827 index = i)$rat) 1828 op[, 2] <- sqrt(op[, 2]) 1829 } 1830 dimnames(op) <- list(rn, c("mean", "std. error")) 1831 } 1832 else { 1833 t0 <- boot.out$t0[index] 1834 if (is.null(boot.out$call$weights)) { 1835 op <- cbind(t0, apply(t, 2, mean, na.rm = TRUE) - 1836 t0, sqrt(apply(t, 2, function(t.st) var(t.st[!is.na(t.st)])))) 1837 dimnames(op) <- list(rn, c("original", " bias ", 1838 " std. error")) 1839 } 1840 else { 1841 op <- NULL 1842 for (i in index) op <- rbind(op, boot::imp.moments(boot.out, 1843 index = i)$rat) 1844 op <- cbind(t0, op[, 1] - t0, sqrt(op[, 2]), apply(t, 1845 2, mean, na.rm = TRUE)) 1846 dimnames(op) <- list(rn, c("original", " bias ", 1847 " std. error", " mean(t*)")) 1848 } 1849 } 1850 if (cl[[1]] == "boot") { 1851 if (sim == "parametric") 1852 HTML(as.title("PARAMETRIC BOOTSTRAP"),file=file) 1853 else if (sim == "antithetic") { 1854 if (is.null(cl$strata)) 1855 HTML(as.title("ANTITHETIC BOOTSTRAP"),file=file) 1856 else 1857 HTML(as.title("STRATIFIED ANTITHETIC BOOTSTRAP"),file=file) 1858 1859 } 1860 else if (sim == "permutation") { 1861 if (is.null(cl$strata)) 1862 HTML(as.title("DATA PERMUTATION"),file=file) 1863 else HTML(as.title("STRATIFIED DATA PERMUTATION"),file=file) 1864 } 1865 else if (sim == "balanced") { 1866 if (is.null(cl$strata) && is.null(cl$weights)) 1867 HTML(as.title("BALANCED BOOTSTRAP"),file=file) 1868 else if (is.null(cl$strata)) 1869 HTML(as.title("BALANCED WEIGHTED BOOTSTRAP"),file=file) 1870 else if (is.null(cl$weights)) 1871 HTML(as.title("STRATIFIED BALANCED BOOTSTRAP"),file=file) 1872 else HTML(as.title("STRATIFIED WEIGHTED BALANCED BOOTSTRAP"),file=file) 1873 } 1874 else { 1875 if (is.null(cl$strata) && is.null(cl$weights)) 1876 HTML(as.title("ORDINARY NONPARAMETRIC BOOTSTRAP"),file=file) 1877 else if (is.null(cl$strata)) 1878 HTML(as.title("WEIGHTED BOOTSTRAP"),file=file) 1879 else if (is.null(cl$weights)) 1880 HTML(as.title("STRATIFIED BOOTSTRAP"),file=file) 1881 else HTML(as.title("STRATIFIED WEIGHTED BOOTSTRAP"),file=file) 1882 } 1883 } 1884 else if (cl[[1]] == "tilt.boot") { 1885 R <- boot.out$R 1886 th <- boot.out$theta 1887 if (sim == "balanced") 1888 HTML(as.title("BALANCED TITLED BOOTSTRAP"),file=file) 1889 else HTML(as.title("TILTED BOOTSTRAP"),file=file) 1890 if ((R[1] == 0) || is.null(cl$tilt) || eval(cl$tilt)) 1891 HTML("<p>Exponential tilting used\n</p>",file=file) 1892 else HTML("<p>Frequency Smoothing used\n</p>",file=file) 1893 i1 <- 1 1894 if (boot.out$R[1] > 0) 1895 HTML(paste("<p>First", R[1], "replicates untilted,\n</p>"),file=file) 1896 else { 1897 HTML(paste("<p>First ", R[2], " replicates tilted to ", 1898 signif(th[1], 4), ",\n</p>", sep = ""),file=file) 1899 i1 <- 2 1900 } 1901 if (i1 <= length(th)) { 1902 for (j in i1:length(th)) HTML(paste("<p>Next ", R[j + 1903 1], " replicates tilted to ", signif(th[j], 4), 1904 ifelse(j != length(th), ",\n", ".\n</p>"), sep = ""),file=file) 1905 } 1906 op <- op[, 1:3] 1907 } 1908 else if (cl[[1]] == "tsboot") { 1909 if (!is.null(cl$indices)) 1910 HTML(as.title("TIME SERIES BOOTSTRAP USING SUPPLIED INDICES"),file=file) 1911 else if (sim == "model") 1912 HTML(as.title("MODEL BASED BOOTSTRAP FOR TIME SERIES"),file=file) 1913 else if (sim == "scramble") { 1914 HTML(as.title("PHASE SCRAMBLED BOOTSTRAP FOR TIME SERIES"),file=file) 1915 if (boot.out$norm) 1916 HTML("<p>Normal margins used.\n</p>",file=file) 1917 else HTML("<p>Observed margins used.\n</p>",file=file) 1918 } 1919 else if (sim == "geom") { 1920 if (is.null(cl$ran.gen)) 1921 HTML(as.title("STATIONARY BOOTSTRAP FOR TIME SERIES"),file=file) 1922 else HTML(as.title("POST-BLACKENED STATIONARY BOOTSTRAP FOR TIME SERIES"),file=file) 1923 HTML(paste("<p>Average Block Length of", boot.out$l, 1924 "\n</p>"),file=file) 1925 } 1926 else { 1927 if (is.null(cl$ran.gen)) 1928 HTML("<p>BLOCK BOOTSTRAP FOR TIME SERIES</p>",file=file) 1929 else HTML("<p>POST-BLACKENED BLOCK BOOTSTRAP FOR TIME SERIES</p>",file=file) 1930 HTML(paste("<p>Fixed Block Length of", boot.out$l, "\n</p>"),file=file) 1931 } 1932 } 1933 else { 1934 cat("\n") 1935 if (sim == "weird") { 1936 if (!is.null(cl$strata)) 1937 HTML(as.title("STRATIFIED BOOTSTRAP FOR CENSORED DATA"),file=file) 1938 } 1939 else if ((sim == "ordinary") || ((sim == "model") && 1940 is.null(boot.out$cox))) { 1941 if (!is.null(cl$strata)) 1942 HTML(as.title("STRATIFIED CASE RESAMPLING BOOTSTRAP FOR CENSORED DATA"),file=file) 1943 } 1944 else if (sim == "model") { 1945 if (!is.null(cl$strata)) 1946 1947 HTML(as.title("STRATIFIED MODEL BASED BOOTSTRAP FOR COX REGRESSION MODEL"),file=file) 1948 } 1949 else if (sim == "cond") { 1950 if (!is.null(cl$strata)) 1951 HTML(as.title("STRATIFIED CONDITIONAL BOOTSTRAP"),file=file) 1952 if (is.null(boot.out$cox)) 1953 HTML("<p>FOR CENSORED DATA\n</p>\n",file=file) 1954 else HTML("<p>FOR COX REGRESSION MODEL\n</p>\n",file=file) 1955 } 1956 } 1957 HTMLli(paste("\nCall: ",deparse(cl)),file=file) 1958 1959 HTMLli("Bootstrap Statistics :\n<br>",file=file) 1960 if (!is.null(op)) 1961 HTML(op, digits = digits,file=file) 1962 if (length(ind1) > 0) 1963 for (j in ind1) HTML(paste("<p>WARNING: All values of t", 1964 j, "* are NA\n</p>", sep = ""),file=file) 1965 invisible(boot.out) 1966} 1967 1968#----------------------------------------------------------------------------------------------------# 1969 1970"HTML.simplex" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1971{ 1972 cat("\n",file=file,append=append,...) 1973 simp.out <- x 1974 HTML("\n<p><b>Linear Programming Results\n</b></p>\n",file=file) 1975 cl <- simp.out$call 1976 HTMLli(paste("Call : ",deparse(cl)),file=file) 1977 HTML(paste("<p>", if (simp.out$maxi) "Maximization" else "Minimization", " Problem with Objective Function Coefficients\n</p>"),file=file) 1978 HTML(simp.out$obj,file=file) 1979 if (simp.out$solved == 1) { 1980 HTML("\n<p>\nOptimal solution has the following values\n</p>",file=file) 1981 HTML(simp.out$soln,file=file) 1982 HTML(paste("<p>The optimal value of the objective ", " function is ", 1983 simp.out$value, ".\n</p>", sep = ""),file=file) 1984 } 1985 else if (simp.out$solved == 0) { 1986 HTML("\n<p>\nIteration limit exceeded without finding solution\n</p>",file=file) 1987 HTML("<p>The coefficient values at termination were\n</p>",file=file) 1988 HTML(simp.out$soln,file=file) 1989 HTML(paste("<p>The objective function value was ", simp.out$value, 1990 ".\n</p>", sep = ""),file=file) 1991 } 1992 else HTML("\n<p>No feasible solution could be found\n</p>",file=file) 1993} 1994 1995#----------------------------------------------------------------------------------------------------# 1996 1997"HTML.saddle.distn" <- function (x, file=HTMLGetFile(), append=TRUE,...) 1998{ 1999 cat("\n",file=file,append=append,...) 2000 sad.d <- x 2001 cl <- sad.d$call 2002 rg <- range(sad.d$points[, 1]) 2003 mid <- mean(rg) 2004 digs <- ceiling(log10(abs(mid))) 2005 if (digs <= 0) 2006 digs <- 4 2007 else if (digs >= 4) 2008 digs <- 0 2009 else digs <- 4 - digs 2010 rg <- round(rg, digs) 2011 level <- 100 * sad.d$quantiles[, 1] 2012 quans <- format(round(sad.d$quantiles, digs)) 2013 quans[, 1] <- paste( format(level), "% ", sep = "") 2014 HTML("\n<p><b>Saddlepoint Distribution Approximations\n</b></p>\n",file=file) 2015 HTMLli(paste("Call : ",paste(deparse(cl),collapse="")),file=file) 2016 HTML("\n<p>Quantiles of the Distribution\n</p>",file=file) 2017 HTML(t(t(quans)),file=file) 2018 HTML(paste("\n<p>\nSmoothing spline used ", nrow(sad.d$points), 2019 " points in the range ", rg[1], " to ", rg[2], ".</p>", sep = ""),file=file) 2020 if (sad.d$LR) 2021 HTMLli("Lugananni-Rice approximations used.",file=file) 2022 HTMLbr(file=file) 2023 invisible(sad.d) 2024} 2025 2026#----------------------------------------------------------------------------------------------------# 2027 2028"HTML.bootci" <- function (x, hinv = NULL, file=HTMLGetFile(), append=TRUE,...) 2029{ 2030 cat("\n",file=file,append=append,...) 2031 ci.out <- x 2032 cl <- ci.out$call 2033 ntypes <- length(ci.out) - 3 2034 nints <- nrow(ci.out[[4]]) 2035 t0 <- ci.out$t0 2036 if (!is.null(hinv)) 2037 t0 <- hinv(t0) 2038 digs <- ceiling(log10(abs(t0))) 2039 if (digs <= 0) 2040 digs <- 4 2041 else if (digs >= 4) 2042 digs <- 0 2043 else digs <- 4 - digs 2044 intlabs <- NULL 2045 basrg <- strg <- perg <- bcarg <- NULL 2046 if (!is.null(ci.out$normal)) 2047 intlabs <- c(intlabs, " Normal ") 2048 if (!is.null(ci.out$basic)) { 2049 intlabs <- c(intlabs, " Basic ") 2050 basrg <- range(ci.out$basic[, 2:3]) 2051 } 2052 if (!is.null(ci.out$student)) { 2053 intlabs <- c(intlabs, " Studentized ") 2054 strg <- range(ci.out$student[, 2:3]) 2055 } 2056 if (!is.null(ci.out$percent)) { 2057 intlabs <- c(intlabs, " Percentile ") 2058 perg <- range(ci.out$percent[, 2:3]) 2059 } 2060 if (!is.null(ci.out$bca)) { 2061 intlabs <- c(intlabs, " BCa ") 2062 bcarg <- range(ci.out$bca[, 2:3]) 2063 } 2064 level <- 100 * ci.out[[4]][, 1] 2065 if (ntypes == 4) 2066 n1 <- n2 <- 2 2067 else if (ntypes == 5) { 2068 n1 <- 3 2069 n2 <- 2 2070 } 2071 else { 2072 n1 <- ntypes 2073 n2 <- 0 2074 } 2075 ints1 <- matrix(NA, nints, 2 * n1 + 1) 2076 ints1[, 1] <- level 2077 n0 <- 4 2078 for (i in n0:(n0 + n1 - 1)) { 2079 j <- c(2 * i - 6, 2 * i - 5) 2080 nc <- ncol(ci.out[[i]]) 2081 nc <- c(nc - 1, nc) 2082 if (is.null(hinv)) 2083 ints1[, j] <- ci.out[[i]][, nc] 2084 else ints1[, j] <- hinv(ci.out[[i]][, nc]) 2085 } 2086 n0 <- 4 + n1 2087 ints1 <- format(round(ints1, digs)) 2088 ints1[, 1] <- paste("\n<br>", level, "% ", sep = "") 2089 ints1[, 2 * (1:n1)] <- paste("(", ints1[, 2 * (1:n1)], ",", 2090 sep = "") 2091 ints1[, 2 * (1:n1) + 1] <- paste(ints1[, 2 * (1:n1) + 1], 2092 ") ") 2093 if (n2 > 0) { 2094 ints2 <- matrix(NA, nints, 2 * n2 + 1) 2095 ints2[, 1] <- level 2096 j <- c(2, 3) 2097 for (i in n0:(n0 + n2 - 1)) { 2098 if (is.null(hinv)) 2099 ints2[, j] <- ci.out[[i]][, c(4, 5)] 2100 else ints2[, j] <- hinv(ci.out[[i]][, c(4, 5)]) 2101 j <- j + 2 2102 } 2103 ints2 <- format(round(ints2, digs)) 2104 ints2[, 1] <- paste("\n<br>", level, "% ", sep = "") 2105 ints2[, 2 * (1:n2)] <- paste("(", ints2[, 2 * (1:n2)], 2106 ",", sep = "") 2107 ints2[, 2 * (1:n2) + 1] <- paste(ints2[, 2 * (1:n2) + 2108 1], ") ") 2109 } 2110 R <- ci.out$R 2111 HTML(as.title("BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS"),file=file) 2112 HTML(paste("<p>Based on", R, "bootstrap replicates\n\n</p>"),file=file) 2113 HTMLli(paste("CALL : ",paste(deparse(cl),collapse=" ")),file=file) 2114 HTML("\n<p>Intervals : </p>",file=file) 2115 HTML(paste("\n<p>Level", intlabs[1:n1],"</p>"),file=file) 2116 HTML(t(ints1),file=file) 2117 if (n2 > 0) { 2118 HTML(paste("\n<p>\nLevel", intlabs[(n1 + 1):(n1 + n2)],"</p>"),file=file) 2119 HTML(t(ints2),file=file) 2120 } 2121 if (!is.null(cl$h)) { 2122 if (is.null(cl$hinv) && is.null(hinv)) 2123 HTML("\n<p>Calculations and Intervals on Transformed Scale\n</p>",file=file) 2124 else HTML("\n<p>Calculations on Transformed Scale; Intervals on Original Scale\n</p>",file=file) 2125 } 2126 else if (is.null(cl$hinv) && is.null(hinv)) 2127 HTML("\n<p>Calculations and Intervals on Original Scale\n</p>",file=file) 2128 else HTML("\n<p>Calculations on Original Scale but Intervals Transformed\n</p>",file=file) 2129 if (!is.null(basrg)) { 2130 if ((basrg[1] <= 1) || (basrg[2] >= R)) 2131 HTML("\n<p>Warning : Basic Intervals used Extreme Quantiles\n</p>",file=file) 2132 if ((basrg[1] <= 10) || (basrg[2] >= R - 9)) 2133 HTML("\n<p>Some basic intervals may be unstable\n</p>",file=file) 2134 } 2135 if (!is.null(strg)) { 2136 if ((strg[1] <= 1) || (strg[2] >= R)) 2137 HTML("\n<p>Warning : Studentized Intervals used Extreme Quantiles\n</p>",file=file) 2138 if ((strg[1] <= 10) || (strg[2] >= R - 9)) 2139 HTML("\n<p>Some studentized intervals may be unstable\n</p>",file=file) 2140 } 2141 if (!is.null(perg)) { 2142 if ((perg[1] <= 1) || (perg[2] >= R)) 2143 HTML("\n<p>Warning : Percentile Intervals used Extreme Quantiles\n</p>",file=file) 2144 if ((perg[1] <= 10) || (perg[2] >= R - 9)) 2145 HTML("\n<p>Some percentile intervals may be unstable\n</p>",file=file) 2146 } 2147 if (!is.null(bcarg)) { 2148 if ((bcarg[1] <= 1) || (bcarg[2] >= R)) 2149 HTML("\n<p>Warning : BCa Intervals used Extreme Quantiles\n</p>",file=file) 2150 if ((bcarg[1] <= 10) || (bcarg[2] >= R - 9)) 2151 HTML("\n<p>Some BCa intervals may be unstable\n</p>",file=file) 2152 } 2153 invisible(ci.out) 2154} 2155 2156 2157#----------------------------------------------------------------------------------------------------# 2158 2159### PACKAGE MVA (merged into stats) 2160 2161#----------------------------------------------------------------------------------------------------# 2162 2163"HTML.dist" <- function (x, diag = NULL, upper = NULL, file=HTMLGetFile(), append=TRUE,...) 2164{ 2165 cat("\n",file=file,append=append,...) 2166 if (is.null(diag)) 2167 diag <- if (is.null(a <- attr(x, "Diag"))) 2168 FALSE 2169 else a 2170 if (is.null(upper)) 2171 upper <- if (is.null(a <- attr(x, "Upper"))) 2172 FALSE 2173 else a 2174 size <- attr(x, "Size") 2175 df <- as.matrix(x) 2176 if (!upper) 2177 df[row(df) < col(df)] <- NA 2178 if (!diag) 2179 df[row(df) == col(df)] <- NA 2180 HTML(if (diag || upper) 2181 df 2182 else df[-1, -size], file=file, ...) 2183 invisible(x) 2184} 2185 2186#----------------------------------------------------------------------------------------------------# 2187 2188"HTML.factanal" <- function (x, digits = 3, file=HTMLGetFile(), append=TRUE,...) 2189{ 2190 cat("\n",file=file,append=append,...) 2191 HTMLli(paste("\nCall:\n", deparse(x$call), "\n<br>\n", sep = ""),file=file) 2192 HTMLli("Uniquenesses:\n<br>",file=file) 2193 HTML(round(x$uniquenesses, digits),file=file,append=TRUE,...) 2194 HTML(x$loadings, digits = digits,file=file,append=TRUE, ...) 2195 p <- nrow(x$loadings) 2196 factors <- x$factors 2197 if (!is.na(x$n.obs) && x$dof > 0) { 2198 dof <- x$dof 2199 stat <- (x$n.obs - 1 - (2 * p + 5)/6 - (2 * factors)/3) * 2200 x$criteria["objective"] 2201 HTMLli(paste("\n<p>Test of the hypothesis that", factors, if (factors == 2202 1) 2203 "factor is" 2204 else "factors are", "sufficient.\n</p>"),file=file) 2205 HTML(paste("<p>The chi square statistic is <b>", round(stat, 2), " </b> on <b>", 2206 dof, if (dof == 1) 2207 " </b>degree" 2208 else "</b>degrees", "of freedom.\n<br>The p-value is <b>", signif(pchisq(stat, 2209 dof, lower.tail = FALSE), 3), "</b>\n</p>"),file=file) 2210 } 2211 else { 2212 HTML(paste("\n<p>The degrees of freedom for the model is <b>", 2213 x$dof, " </b>and the fit was <b>", round(x$criteria["objective"], 2214 4), "</b>\n</p>"),file=file) 2215 } 2216 invisible(x) 2217} 2218 2219 2220#----------------------------------------------------------------------------------------------------# 2221 2222"HTML.loadings" <- function (x, digits = 3, cutoff = 0.1, sort = FALSE, file=HTMLGetFile(), append=TRUE,...) 2223{ 2224 cat("\n",file=file,append=append,...) 2225 Lambda <- unclass(x) 2226 p <- nrow(Lambda) 2227 factors <- ncol(Lambda) 2228 if (sort) { 2229 mx <- max.col(abs(Lambda)) 2230 ind <- cbind(1:p, mx) 2231 mx[abs(Lambda[ind]) < 0.5] <- factors + 1 2232 Lambda <- Lambda[order(mx, 1:p), ] 2233 } 2234 HTMLli("Loadings:\n<br>",file=file) 2235 fx <- format(round(Lambda, digits)) 2236 names(fx) <- NULL 2237 nc <- nchar(fx[1]) 2238 fx[abs(Lambda) < cutoff] <- paste(rep(" ", nc), collapse = "") 2239 HTML(fx, file=file, ...) 2240 vx <- colSums(x^2) 2241 varex <- rbind("SS loadings" = vx) 2242 if (is.null(attr(x, "covariance"))) { 2243 varex <- rbind(varex, "Proportion Var" = vx/p) 2244 if (factors > 1) 2245 varex <- rbind(varex, "Cumulative Var" = cumsum(vx/p)) 2246 } 2247 HTMLbr(file=file) 2248 HTML(round(varex, digits),file=file) 2249 invisible(x) 2250} 2251 2252 2253#----------------------------------------------------------------------------------------------------# 2254 2255"HTML.hclust" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2256{ 2257 cat("\n",file=file,append=append,...) 2258 if (!is.null(x$call)) 2259 HTMLli(paste("Call : ", deparse(x$call), "\n<ul>\n", sep = ""),file=file) 2260 if (!is.null(x$method)) 2261 HTMLli(paste("Cluster method :", x$method, "\n"),file=file) 2262 if (!is.null(x$dist.method)) 2263 HTMLli(paste("Distance : ", x$dist.method, "\n"),file=file) 2264 HTMLli(paste("Number of objects: ", length(x$height) + 1, "\n"),file=file) 2265 HTML("</ul><br> <br>",file=file) 2266 invisible(x) 2267} 2268 2269 2270#----------------------------------------------------------------------------------------------------# 2271 2272"HTML.prcomp" <- function (x, print.x = FALSE, file=HTMLGetFile(), append=TRUE,...) 2273{ 2274 cat("\n",file=file,append=append,...) 2275 HTML("<p>Standard deviations:\n</p>",file=file,append=TRUE) 2276 HTML(x$sdev, file=file,append=TRUE,...) 2277 HTML("\n<p>Rotation:\n</p>") 2278 HTML(x$rotation, file=file,append=TRUE,...) 2279 if (print.x && length(x$x)) { 2280 HTML("\n<p>Rotated variables:\n</p>") 2281 HTML(x$x, file=file,append=TRUE,...) 2282 } 2283 invisible(x) 2284} 2285 2286 2287 2288#----------------------------------------------------------------------------------------------------# 2289 2290"HTML.princomp" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2291{ 2292 cat("\n",file=file,append=append,...) 2293 HTMLli(paste("Call: <font class=call>",deparse(x$call),"</font>"),file=file) 2294 HTML("\n<p>Standard deviations:\n</p>",file=file) 2295 HTML(t(as.matrix(x$sdev)), file=file,append=TRUE,...) 2296 HTML(paste("\n<p><b>", length(x$scale), " </b>variables and <b>", x$n.obs, " </b>observations.\n</p>"),file=file) 2297 invisible(x) 2298} 2299 2300 2301#----------------------------------------------------------------------------------------------------# 2302 2303"HTML.summary.prcomp" <- function (x, digits = min(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 2304{ 2305 cat("\n",file=file,append=append,...) 2306 HTML("<p>Importance of components:\n</p>",file=file) 2307 HTML(x$importance, digits = digits,file=file) 2308 invisible(x) 2309} 2310 2311 2312#----------------------------------------------------------------------------------------------------# 2313 2314"HTML.summary.princomp" <- function (x, digits = 3, loadings = x$print.loadings, cutoff = x$cutoff, file=HTMLGetFile(), append=TRUE, ...) 2315{ 2316 cat("\n",file=file,append=append,...) 2317 vars <- x$sdev^2 2318 vars <- vars/sum(vars) 2319 HTML("<p>Importance of components:\n</p>",file=file) 2320 HTML(rbind("Standard deviation" = x$sdev, "Proportion of Variance" = vars, 2321 "Cumulative Proportion" = cumsum(vars)),file=file) 2322 if (loadings) { 2323 HTMLli("Loadings:\n",file=file) 2324 cx <- format(round(x$loadings, digits = digits)) 2325 cx[abs(x$loadings) < cutoff] <- substring(" ", 2326 1, nchar(cx[1, 1])) 2327 HTML(cx, quote = FALSE, file=file) 2328 } 2329 invisible(x) 2330} 2331 2332#----------------------------------------------------------------------------------------------------# 2333### PACKAGE EDA (merged into stats) 2334#----------------------------------------------------------------------------------------------------# 2335 2336"HTML.medpolish" <- function (x, digits = getOption("digits"), file=HTMLGetFile(), append=TRUE,...) 2337{ 2338 cat("\n",file=file,append=append,...) 2339 HTML(paste("\n<p><b>Median Polish Results (Dataset: \"", x$name, "\")\n</b></p>", 2340 sep = ""),file=file) 2341 HTML(paste("\n<p>Overall:", x$overall, "\n</p>\n<p>Row Effects:\n</p>"),file=file) 2342 HTML(x$row, digits = digits, file=file,append=TRUE,...) 2343 HTML("\n<p>Column Effects:\n</p>",file=file) 2344 HTML(x$col, digits = digits, file=file) 2345 HTML("\n<p>Residuals:\n</p>",file=file) 2346 HTML(x$residuals, digits = max(2, digits - 2), file=file) 2347 HTMLbr(file=file) 2348 invisible(x) 2349} 2350 2351#----------------------------------------------------------------------------------------------------# 2352 2353"HTML.tukeyline" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 2354{ 2355 cat("\n",file=file,append=append,...) 2356 HTMLli(paste("Call:\n", deparse(x$call), "\n<br>\n", sep = ""),file=file) 2357 HTML("<p>Coefficients:\n</p>",file=file) 2358 print.default(format(coef(x), digits = digits),file=file) 2359 HTMLbr(file=file) 2360 invisible(x) 2361} 2362 2363#----------------------------------------------------------------------------------------------------# 2364 2365"HTML.tukeysmooth" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2366{ 2367 cat("\n",file=file,append=append,...) 2368 HTML(paste("<p><b>",attr(x, "kind"), " Tukey smoother resulting from ", deparse(attr(x, 2369 "call")), "\n", if (twiced <- attr(x, "twiced")) " <-<-twiced<-<- ", 2370 if (!is.null(it <- attr(x, "iter"))) paste(" used", it, "iterations\n"), 2371 if (!is.null(ch <- attr(x, "changed"))) paste(if (!ch) " NOT ", " changed\n</b></p>")),file=file) 2372 if (length(class(x)) > 1) 2373 NextMethod() 2374 else { 2375 y <- x 2376 attributes(y) <- NULL 2377 HTML(y,file=file, append=TRUE) 2378 invisible(x) 2379 } 2380} 2381 2382 2383#----------------------------------------------------------------------------------------------------# 2384### PACKAGE EDA (merged into stats) 2385#----------------------------------------------------------------------------------------------------# 2386 2387# 2388# 2008-05-23: Removed by Fernando H Rosa. Class appears to no longer exist on package stats 2389# 2390#"HTML.grob" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2391#{ 2392# cat("\n",file=file,append=append,...) 2393# cl <- class(get.value.grob(x)) 2394# HTML(paste(cl[1:(length(cl) - 1)], collapse = " "),file=file) 2395# invisible(x) 2396#} 2397 2398#----------------------------------------------------------------------------------------------------# 2399 2400"HTML.unit" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2401{ 2402 cat("\n",file=file,append=append,...) 2403 HTML(as.character(x), file=file) 2404 invisible(x) 2405} 2406 2407#----------------------------------------------------------------------------------------------------# 2408 2409"HTML.viewport" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2410{ 2411 cat("\n",file=file,append=append,...) 2412 HTML(class(x),file=file) 2413 invisible(x) 2414} 2415 2416 2417#----------------------------------------------------------------------------------------------------# 2418### PACKAGE LATTICE 2419#----------------------------------------------------------------------------------------------------# 2420 2421"HTML.shingle" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2422{ 2423 cat("\n",file=file,append=append,...) 2424 HTML("\n<p>Data:\n</p>",file=file) 2425 HTML(as.numeric(x),file=file) 2426 l <- levels(x) 2427 n <- nlevels(x) 2428 if (n < 1) 2429 HTML("\n<p>no intervals\n</p>",file=file) 2430 else { 2431 int <- data.frame(min = numeric(n), max = numeric(n), 2432 count = numeric(n)) 2433 for (i in 1:n) { 2434 int$min[i] <- l[[i]][1] 2435 int$max[i] <- l[[i]][2] 2436 int$count[i] <- length(x[x >= l[[i]][1] & x <= l[[i]][2]]) 2437 } 2438 HTML("\n<p>Intervals:\n</p>",file=file) 2439 HTML(int,file=file) 2440 olap <- numeric(n - 1) 2441 if (n > 2) 2442 for (i in 1:(n - 1)) olap[i] <- length(x[x >= l[[i]][1] & 2443 x <= l[[i]][2] & x >= l[[i + 1]][1] & x <= l[[i + 2444 1]][2]]) 2445 HTML("\n<p>Overlap between adjacent intervals:\n</p>",file=file) 2446 HTML(olap,file=file) 2447 } 2448 invisible(x) 2449} 2450 2451 2452#----------------------------------------------------------------------------------------------------# 2453 2454 "HTML.shingleLevel" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2455{ 2456 cat("\n",file=file,append=append,...) 2457 HTML(do.call("rbind", x),file=file) 2458 invisible(x) 2459} 2460 2461 2462 2463#----------------------------------------------------------------------------------------------------# 2464### PACKAGE MASS 2465#----------------------------------------------------------------------------------------------------# 2466 2467"HTML.abbrev" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2468{ 2469 cat("\n",file=file,append=append,...) 2470 if (is.list(x)) 2471 x <- unlist(x) 2472 NextMethod("HTML") 2473} 2474 2475 2476#----------------------------------------------------------------------------------------------------# 2477 2478"HTML.Anova" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2479{ 2480 cat("\n",file=file,append=append,...) 2481 heading <- attr(x, "heading") 2482 if (!is.null(heading)) 2483 HTML(paste("<p>",heading,"</p>", sep = " ",collapse="<br>"),file=file) 2484 attr(x, "heading") <- NULL 2485 HTML.data.frame(x,file=file) 2486} 2487 2488#----------------------------------------------------------------------------------------------------# 2489 2490"HTML.anova.loglm" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2491{ 2492 cat("\n",file=file,append=append,...) 2493 y <- x 2494 y[, 5] <- round(y[, 5], 5) 2495 R <- array("", dim(x), dimnames(x)) 2496 for (j in 1:5) { 2497 colj <- c(colnames(x)[j], format(y[, j])) 2498 R[, j] <- colj[-1] 2499 colnames(R)[j] <- colj[1] 2500 } 2501 R[1, 3:5] <- "" 2502 forms <- attr(x, "formulae") 2503 HTML("<p><b>LR tests for hierarchical log-linear models</b>\n</p>\n",file=file) 2504 for (i in seq(along = forms)) 2505 HTML(paste(paste("<p>Model ", i, ":<br>", sep = ""), paste(deparse(forms[[i]]),collapse=""), "</p>"),file=file) 2506 HTMLbr(file=file) 2507 HTML(R,file=file) 2508 invisible(x) 2509} 2510 2511 2512#----------------------------------------------------------------------------------------------------# 2513 2514"HTML.correspondence" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2515{ 2516 cat("\n",file=file,append=append,...) 2517 HTML(paste("<p>First canonical correlation(s):", format(x$cor, ...), "\n</p>"),file=file) 2518 rcn <- names(dimnames(x$Freq)) 2519 HTML(paste("\n<p>", rcn[1], "scores:\n</p>"),file=file) 2520 HTML(x$rscore,file=file) 2521 HTML(paste("\n<p>", rcn[2], "scores:\n</p>"),file=file) 2522 HTML(x$cscore,file=file) 2523 invisible(x) 2524} 2525 2526 2527#----------------------------------------------------------------------------------------------------# 2528 2529"HTML.fitdistr" <- function (x, digits = getOption("digits"), file=HTMLGetFile(), append=TRUE,...) 2530{ 2531 cat("\n",file=file,append=append,...) 2532 ans <- format(rbind(x$estimate, x$sd), digits = digits) 2533 ans[1, ] <- sapply(ans[1, ], function(x) paste("", x)) 2534 ans[2, ] <- sapply(ans[2, ], function(x) paste("(", x, ")", 2535 sep = "")) 2536 dn <- dimnames(ans) 2537 dn[[1]] <- rep("", 2) 2538 dn[[2]] <- paste(substring(" ", 1, (nchar(ans[2, ]) - 2539 nchar(dn[[2]]))%/%2), dn[[2]]) 2540 dn[[2]] <- paste(dn[[2]], substring(" ", 1, (nchar(ans[2, 2541 ]) - nchar(dn[[2]]))%/%2)) 2542 dimnames(ans) <- dn 2543 HTML(ans, file=file) 2544 invisible(x) 2545} 2546 2547 2548#----------------------------------------------------------------------------------------------------# 2549 2550"HTML.fractions" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2551{ 2552 cat("\n",file=file,append=append,...) 2553 y <- attr(x, "fracs") 2554 att <- attributes(x) 2555 att$fracs <- att$class <- NULL 2556 x <- do.call("structure", c(list(y), att)) 2557 NextMethod("HTML", file=file) 2558} 2559 2560 2561#----------------------------------------------------------------------------------------------------# 2562 2563"HTML.gamma.shape" <- function (x,file=HTMLGetFile(), append=TRUE,...) 2564{ 2565 cat("\n",file=file,append=append,...) 2566 y <- x 2567 x <- array(unlist(x), dim = 2:1, dimnames = list(c("Alpha ", "SE "), "")) 2568 NextMethod("HTML",file=file) 2569 invisible(y) 2570} 2571 2572#----------------------------------------------------------------------------------------------------# 2573 2574"HTML.glm.dose" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2575{ 2576 cat("\n",file=file,append=append,...) 2577 M <- cbind(x, attr(x, "SE")) 2578 dimnames(M) <- list(names(x), c("Dose", "SE")) 2579 x <- M 2580 NextMethod("HTML",file=file) 2581} 2582 2583#----------------------------------------------------------------------------------------------------# 2584 2585"HTML.lda" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2586{ 2587 cat("\n",file=file,append=append,...) 2588 if (!is.null(cl <- x$call)) { 2589 names(cl)[2] <- "" 2590 HTMLli(paste("Call: ",deparse(cl)),file=file) 2591 } 2592 HTML("\n<p>Prior probabilities of groups:\n</p>",file=file) 2593 HTML(x$prior, file=file,...) 2594 HTML("\n<p>Group means:\n</p>",file=file) 2595 HTML(x$means, file=file,...) 2596 HTML("\n<p>Coefficients of linear discriminants:\n</p>",file=file) 2597 HTML(x$scaling, file=file,...) 2598 svd <- x$svd 2599 names(svd) <- dimnames(x$scaling)[[2]] 2600 if (length(svd) > 1) { 2601 HTML("\n<p>Proportion of trace:\n</p>",file=file) 2602 HTML(round(svd^2/sum(svd^2), 4), file=file,append=TRUE,...) 2603 } 2604 invisible(x) 2605} 2606 2607#----------------------------------------------------------------------------------------------------# 2608 2609"HTML.loglm" <- function (x,file=HTMLGetFile(), append=TRUE,...) 2610{ 2611 cat("\n",file=file,append=append,...) 2612 HTMLli(paste("Call: <font class=call>",deparse(x$call),"</font>"),file=file) 2613 ts.array <- rbind(c(x$lrt, x$df, if (x$df > 0) 1 - pchisq(x$lrt, 2614 x$df) else 1), c(x$pearson, x$df, if (x$df > 0) 1 - pchisq(x$pearson, 2615 x$df) else 1)) 2616 dimnames(ts.array) <- list(c("Likelihood Ratio", "Pearson"), 2617 c("X^2", "df", "P(> X^2)")) 2618 HTML("\n<p>Statistics:\n</p>",file=file) 2619 HTML(ts.array,file=file) 2620 invisible(x) 2621} 2622 2623#----------------------------------------------------------------------------------------------------# 2624 2625"HTML.mca" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2626{ 2627 cat("\n",file=file,append=append,...) 2628 if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",deparse(cl)),file=file) 2629 2630 HTML(paste("\n<p>Multiple correspondence analysis of <b>", nrow(x$rs), 2631 " </b>cases of <b> ", x$p, " </b>factors\n</p>"),file=file) 2632 2633 p <- 100 * cumsum(x$d)/(x$p - 1) 2634 HTML(paste("\n<p>Correlations ",paste(round(x$d, 3),collapse=" ")," cumulative % explained ", paste(round(p, 2),collapse=" "),"</p>" ),file=file) 2635 2636 invisible(x) 2637} 2638 2639 2640#----------------------------------------------------------------------------------------------------# 2641 2642"HTML.polr" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2643{ 2644 cat("\n",file=file,append=append,...) 2645 if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",deparse(cl)),file=file) 2646 if (length(coef(x))) { 2647 HTML("\n<p>Coefficients:\n</p>",file=file) 2648 HTML(coef(x), file=file,append=TRUE,...) 2649 } 2650 else { 2651 HTML("\n<p>No coefficients\n</p>",file=file) 2652 } 2653 HTML("\n<p>Intercepts:\n</p>",file=file) 2654 HTML(x$zeta, file=file,append=TRUE,...) 2655 HTML(paste("\n<p>Residual Deviance: <b>", format(x$deviance, nsmall = 2), "</b>\n</p>"),file=file) 2656 HTML(paste("<p>AIC:<b>", format(x$deviance + 2 * x$edf, nsmall = 2), "</b>\n</p>"),file=file) 2657 invisible(x) 2658} 2659 2660#----------------------------------------------------------------------------------------------------# 2661 2662"HTML.qda" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2663{ 2664 cat("\n",file=file,append=append,...) 2665 if (!is.null(cl <- x$call)) { 2666 names(cl)[2] <- "" 2667 HTMLli(paste("Call: ",deparse(cl)),file=file) 2668 } 2669 HTML("\n<p>Prior probabilities of groups:\n</p>",file=file) 2670 HTML(x$prior, file=file,...) 2671 HTML("\n<p>Group means:\n</p>",file=file) 2672 HTML(x$means, file=file,append=TRUE,...) 2673 invisible(x) 2674} 2675 2676#----------------------------------------------------------------------------------------------------# 2677 2678"HTML.ridgelm" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2679{ 2680 cat("\n",file=file,append=append,...) 2681 scaledcoef <- t(as.matrix(x$coef/x$scales)) 2682 if (x$Inter) { 2683 inter <- x$ym - scaledcoef %*% x$xm 2684 scaledcoef <- cbind(Intercept = inter, scaledcoef) 2685 } 2686 HTML(drop(scaledcoef), file=file,append=TRUE,...) 2687 invisible(x) 2688} 2689 2690#----------------------------------------------------------------------------------------------------# 2691 2692"HTML.rlm" <- function (x,file=HTMLGetFile(), append=TRUE, ...) 2693{ 2694 cat("\n",file=file,append=append,...) 2695 if (!is.null(cl <- x$call)) { 2696 HTMLli(paste("Call: ",paste(deparse(cl),collapse=" ")),file=file) 2697 } 2698 if (x$converged) 2699 HTML(paste("<p>Converged in <b>", length(x$conv), "</b> iterations\n</p>"),file=file) 2700 else HTML(paste("<p>Ran <b>", length(x$conv), " </b>iterations without convergence\n</p>"),file=file) 2701 coef <- x$coef 2702 HTML("\n<p>Coefficients:\n</p>",file=file) 2703 HTML(coef, file=file,append=TRUE,...) 2704 nobs <- length(x$resid) 2705 rdf <- nobs - length(coef) 2706 HTML(paste("\n<p>Degrees of freedom: <b>", nobs, " </b>total; <b>", rdf, " </b>residual\n</p>"),file=file) 2707 HTML(paste("<p>Scale estimate:<b>", paste(format(signif(x$s, 3)),collapse=" "), "</b>\n</p>"),file=file) 2708 invisible(x) 2709} 2710 2711#----------------------------------------------------------------------------------------------------# 2712 2713"HTML.rms.curv" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2714{ 2715 cat("\n",file=file,append=append,...) 2716 HTML(paste("<p><li>Parameter effects: c^theta x sqrt(FALSE) =<b>", round(x$pe, 2717 4), "</b>\n<br><li>", "Intrinsic: c^iota x sqrt(FALSE) =<b>", round(x$ic, 2718 4), "\n</b></p>"),file=file, append=TRUE,...) 2719 invisible(x) 2720} 2721 2722#----------------------------------------------------------------------------------------------------# 2723 2724"HTML.summary.loglm" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2725{ 2726 cat("\n",file=file,append=append,...) 2727 HTML("<p>Formula:\n</p>",file=file) 2728 HTML(formula(x),file=file) 2729 HTML("\n<p>Statistics:\n</p>",file=file) 2730 HTML(x$tests,file=file) 2731 if (!is.null(x$oe)) { 2732 HTML("\n<p>Observed (Expected):\n</p>",file=file) 2733 HTML(x$oe, file=file) 2734 } 2735 invisible(x) 2736} 2737 2738 2739#----------------------------------------------------------------------------------------------------# 2740 2741"HTML.summary.negbin" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2742{ 2743 cat("\n",file=file,append=append,...) 2744 NextMethod(x,file=file) 2745 dp <- 2 - floor(log10(x$SE.theta)) 2746 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) 2747 if (!is.null(x$th.warn)) 2748 HTML(paste("<p>Warning while fitting theta:", x$th.warn, "\n</p>"),file=file) 2749 HTML(paste("\n<p><li> 2 x log-likelihood: ", format(round(x$twologlik, 3), nsmall = dp), "\n</p>"),file=file) 2750 invisible(x) 2751} 2752 2753 2754#----------------------------------------------------------------------------------------------------# 2755 2756"HTML.summary.polr" <- function (x, digits = x$digits, file=HTMLGetFile(), append=TRUE,...) 2757{ 2758 cat("\n",file=file,append=append,...) 2759 if (!is.null(cl <- x$call)) { 2760 HTMLli(paste("Call: ",deparse(cl)),file=file) 2761 } 2762 coef <- format(round(x$coef, digits = digits)) 2763 pc <- x$pc 2764 if (pc > 0) { 2765 HTML("\n<p>Coefficients:\n</p>",file=file) 2766 HTML(x$coef[seq(len = pc), ], file=file,append=TRUE, ...) 2767 } 2768 else { 2769 HTML("\n<p>No coefficients\n</p>",file=file) 2770 } 2771 HTML("\n<p>Intercepts:\n</p>",file=file) 2772 HTML(coef[(pc + 1):nrow(coef), ], file=file,append=TRUE, ...) 2773 HTML(paste("\n<p>Residual Deviance:<b>", format(x$deviance, nsmall = 2), "</b>\n</p>"),file=file) 2774 HTML(paste("\n<p>AIC:<b>", format(x$deviance + 2 * x$edf, nsmall = 2), "</b>\n</p>"),file=file) 2775 if (!is.null(correl <- x$correlation)) { 2776 cat("\n<p>Correlation of Coefficients:\n</p>",file=file) 2777 ll <- lower.tri(correl) 2778 correl[ll] <- format(round(correl[ll], digits)) 2779 correl[!ll] <- "" 2780 HTML(correl[-1, -ncol(correl)], file=file, append=TRUE,...) 2781 } 2782 invisible(x) 2783} 2784 2785#----------------------------------------------------------------------------------------------------# 2786 2787"HTML.summary.rlm" <- function (x, digits = max(3, .Options$digits - 3), file=HTMLGetFile(), append=TRUE,...) 2788{ 2789 cat("\n",file=file,append=append,...) 2790 HTMLli(paste("\nCall: ",deparse(x$call)),file=file) 2791 resid <- x$residuals 2792 df <- x$df 2793 rdf <- df[2] 2794 if (rdf > 5) { 2795 HTML("<p>Residuals:\n</p>",file=file) 2796 if (length(dim(resid)) == 2) { 2797 rq <- apply(t(resid), 1, quantile) 2798 dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", 2799 "Max"), colnames(resid)) 2800 } 2801 else { 2802 rq <- quantile(resid) 2803 names(rq) <- c("Min", "1Q", "Median", "3Q", "Max") 2804 } 2805 HTML(rq, file=file) 2806 } 2807 else if (rdf > 0) { 2808 HTML("<p>Residuals:\n</p>",file=file) 2809 HTML(resid,file=file) 2810 } 2811 if (nsingular <- df[3] - df[1]) 2812 HTML(paste("\n<p>Coefficients: (", nsingular, " not defined because of singularities)\n</p>",sep = ""),file=file) 2813 else HTML("\n<p>Coefficients:\n</p>",file=file) 2814 HTML(format(round(x$coef, digits = digits)), file=file) 2815 HTML(paste("\n<p>Residual standard error:<b>", format(signif(x$sigma, 2816 digits)), " </b>on <b> ", rdf, " </b>degrees of freedom\n</p>"),file=file) 2817 if (!is.null(correl <- x$correlation)) { 2818 p <- dim(correl)[2] 2819 if (p > 1) { 2820 HTML("\n<p>Correlation of Coefficients:\n</p>",file=file) 2821 ll <- lower.tri(correl) 2822 correl[ll] <- format(round(correl[ll], digits)) 2823 correl[!ll] <- "" 2824 HTML(correl[-1, -p, drop = FALSE], file=file) 2825 } 2826 } 2827 invisible(x) 2828} 2829 2830 2831 2832#----------------------------------------------------------------------------------------------------# 2833### PACKAGE NNET 2834#----------------------------------------------------------------------------------------------------# 2835 2836"HTML.multinom" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2837{ 2838 cat("\n",file=file,append=append,...) 2839 if (!is.null(cl <- x$call)) { 2840 HTMLli(paste("Call: ",paste(deparse(cl),collapse="")),file=file) 2841 } 2842 HTML("\n<p>Coefficients:\n</p>",file=file) 2843 HTML(coef(x), file=file) 2844 HTML(paste("\n<p>Residual Deviance: <b>", format(x$deviance), "</b>\n</p>"),file=file) 2845 HTML(paste("<p>AIC:<b>", format(x$AIC), "</b>\n</p>"),file=file) 2846 invisible(x) 2847} 2848 2849 2850#----------------------------------------------------------------------------------------------------# 2851 2852"HTML.nnet" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2853{ 2854 cat("\n",file=file,append=append,...) 2855 if (!inherits(x, "nnet")) 2856 stop("Not legitimate a neural net fit") 2857 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) 2858 2859 if (length(x$coefnames)) 2860 HTML(paste("<p>inputs:", x$coefnames, "\noutput(s):", deparse(formula(x)[[2]]), "\n</p>"),file=file) 2861 HTML("<p>options were -</p>",file=file) 2862 tconn <- diff(x$nconn) 2863 if (tconn[length(tconn)] > x$n[2] + 1) 2864 HTMLli(" skip-layer connections ",file=file) 2865 if (x$nunits > x$nsunits && !x$softmax) 2866 HTMLli(" linear output units ",file=file) 2867 if (x$entropy) 2868 HTMLli(" entropy fitting ",file=file) 2869 if (x$softmax) 2870 HTMLli(" softmax modelling ",file=file) 2871 if (x$decay[1] > 0) 2872 HTMLli(paste(" decay=", x$decay[1], sep = ""),file=file) 2873 HTMLbr(file=file) 2874 invisible(x) 2875} 2876 2877 2878#----------------------------------------------------------------------------------------------------# 2879 2880"HTML.summary.multinom" <- function (x, digits = x$digits, file=HTMLGetFile(), append=TRUE,...) 2881{ 2882 cat("\n",file=file,append=append,...) 2883 if (!is.null(cl <- x$call)) { 2884 HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file) 2885 } 2886 HTML("\n<p>Coefficients:\n</p>",file=file) 2887 if (x$is.binomial) { 2888 HTML(cbind(Values = x$coefficients, "Std. Err." = x$standard.errors, 2889 "Value/SE" = x$Wald.ratios), file=file) 2890 } 2891 else { 2892 HTML(x$coefficients, file=file) 2893 HTML("\n<p>Std. Errors:\n</p>",file=file) 2894 HTML(x$standard.errors, file=file) 2895 if (!is.null(x$Wald.ratios)) { 2896 HTML("\n<O>Value/SE (Wald statistics):\n</p>",file=file) 2897 HTML(x$coefficients/x$standard.errors, file=file) 2898 } 2899 } 2900 HTML(paste("\n<p>Residual Deviance:<b>", format(x$deviance), "</b>\n</p>"),file=file) 2901 HTML(paste("\n<p>AIC:<b>", format(x$AIC), "</b>\n</p>"),file=file) 2902 if (!is.null(correl <- x$correlation)) { 2903 p <- dim(correl)[2] 2904 if (p > 1) { 2905 HTML("\n</p>Correlation of Coefficients:\n</p>",file=file) 2906 ll <- lower.tri(correl) 2907 correl[ll] <- format(round(correl[ll], digits)) 2908 correl[!ll] <- "" 2909 HTML(correl[-1, -p], file= file) 2910 } 2911 } 2912 invisible(x) 2913} 2914 2915#----------------------------------------------------------------------------------------------------# 2916 2917"HTML.summary.nnet" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2918{ 2919 cat("\n",file=file,append=append,...) 2920 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) 2921 2922 HTML("<p>options were -</p>",file=file) 2923 tconn <- diff(x$nconn) 2924 if (tconn[length(tconn)] > x$n[2] + 1) 2925 HTMLli(" skip-layer connections ",file=file) 2926 if (x$nunits > x$nsunits && !x$softmax) 2927 HTMLli(" linear output units ",file=file) 2928 if (x$entropy) 2929 HTMLli(" entropy fitting ",file=file) 2930 if (x$softmax) 2931 HTMLli(" softmax modelling ",file=file) 2932 if (x$decay[1] > 0) 2933 HTMLli(paste(" decay=", x$decay[1], sep = ""),file=file) 2934 wts <- format(round(nnet::nnet(x), 2)) 2935 lapply(split(wts, rep(1:x$nunits, tconn)), function(x) HTML(x,file=file)) 2936 invisible(x) 2937} 2938 2939#----------------------------------------------------------------------------------------------------# 2940### PACKAGE CLUSTER 2941#----------------------------------------------------------------------------------------------------# 2942 2943 2944"HTML.agnes" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2945{ 2946 cat("\n",file=file,append=append,...) 2947 HTML("<p>Merge:\n</p>",file=file) 2948 HTML(x$merge, file=file,append=TRUE,...) 2949 HTML("<p>Order of objects:\n</p>",file=file) 2950 HTML(if (length(x$order.lab) != 0) 2951 x$order.lab 2952 else x$order, file=file,append=TRUE, ...) 2953 HTML("<p>Height:\n</p>",file=file) 2954 HTML(x$height, file=file,append=TRUE,...) 2955 HTML("<p>Agglomerative coefficient:\n</p>",file=file) 2956 HTML(x$ac, file=file,append=TRUE,...) 2957 HTML("\n<p>Available components:\n</p>",file=file) 2958 HTML(names(x), file=file,append=TRUE,...) 2959 invisible(x) 2960} 2961 2962 2963#----------------------------------------------------------------------------------------------------# 2964 2965"HTML.clara" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2966{ 2967 cat("\n",file=file,append=append,...) 2968 HTML("<p>Best sample:\n</p>",file=file) 2969 HTML(x$sample, file=file, append=TRUE,...) 2970 HTML("<p>Medoids:\n</p>",file=file) 2971 HTML(x$medoids, file=file,append=TRUE,...) 2972 HTML("<p>Clustering vector:\n</p>",file=file) 2973 HTML(x$clustering, file=file,append=TRUE,...) 2974 HTML("<p>Objective function:\n</p>",file=file) 2975 HTML(x$objective, file=file,append=TRUE,...) 2976 HTML("\n<p>Available components:\n</p>",file=file) 2977 HTML(names(x),file=file, append=TRUE,...) 2978 invisible(x) 2979} 2980 2981#----------------------------------------------------------------------------------------------------# 2982 2983"HTML.diana" <- function (x, file=HTMLGetFile(), append=TRUE,...) 2984{ 2985 cat("\n",file=file,append=append,...) 2986 HTML("<p>Merge:\n</p>",file=file) 2987 HTML(x$merge, file=file,append=TRUE,...) 2988 HTML("<p>Order of objects:\n</p>",file=file) 2989 HTML(if (length(x$order.lab) != 0) x$order.lab else x$order, file= file, append=TRUE,...) 2990 HTML("<p>Height:\n</p>",file=file) 2991 HTML(x$height, file=file,append=TRUE,...) 2992 HTML("<p>Divisive coefficient:\n</p>",file=file) 2993 HTML(x$dc,file=file, append=TRUE,...) 2994 HTML("\n<p>Available components:\n</p>",file=file) 2995 HTML(names(x),file=file,append=TRUE, ...) 2996 invisible(x) 2997} 2998 2999#----------------------------------------------------------------------------------------------------# 3000 3001"HTML.dissimilarity" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3002{ 3003 cat("\n",file=file,append=append,...) 3004 HTML("<p>Dissimilarities :\n</p>",file=file) 3005 HTML(as.vector(x),file=file,append=TRUE, ...) 3006 if (!is.null(attr(x, "na.message"))) 3007 HTML(paste("<p>Warning : ", attr(x, "NA.message"), "\n</p>"),file=file) 3008 HTML(paste("<p>Metric : ", attr(x, "Metric"), "\n</p>"),file=file) 3009 HTML(paste("<p>Number of objects : ", attr(x, "Size"), "\n</p>"),file=file) 3010 invisible(x) 3011} 3012 3013#----------------------------------------------------------------------------------------------------# 3014 3015"HTML.ellipsoid" <- function (x, digits = max(1, getOption("digits") - 2), file=HTMLGetFile(), append=TRUE,...) 3016{ 3017 3018 cat("\n",file=file,append=append,...) 3019 d <- length(x$loc) 3020 HTML(paste("<p>`ellipsoid' in <b> ", d, " </b>dimensions:<br> center = (<b>", paste(format(x$loc, 3021 digits = digits),collapse=" "), "</b>); squared ave.radius d^2 = <b>", format(x$d2, 3022 digits = digits), " </b>\n<br> and shape matrix =\n</p>"),file=file) 3023 HTML(x$cov, file=file, append=TRUE,...) 3024 HTML(paste("<p> hence,", if (d == 2) 3025 " area " 3026 else " volume ", " = <b>", format(cluster::volume(x), digits = digits), 3027 "\n</b></p>"),file=file) 3028 invisible(x) 3029} 3030 3031 3032#----------------------------------------------------------------------------------------------------# 3033 3034"HTML.fanny" <- function (x,file=HTMLGetFile(), append=TRUE,...) 3035{ 3036 cat("\n",file=file,append=append,...) 3037 HTML(x$objective, file=file,append=TRUE,...) 3038 HTML("<p>Membership coefficients:\n</p>", file=file) 3039 HTML(x$membership, file=file,append=TRUE, ...) 3040 HTML("<p>Coefficients:\n</p>", file=file) 3041 HTML(x$coeff, file=file, append=TRUE,...) 3042 HTML("<p>Closest hard clustering:\n</p>", file=file) 3043 HTML(x$clustering, file=file,append=TRUE, ...) 3044 HTML("\n<p>Available components:\n</p>", file=file) 3045 HTML(names(x), file=file, append=TRUE,...) 3046 invisible(x) 3047} 3048 3049 3050#----------------------------------------------------------------------------------------------------# 3051 3052"HTML.mona" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3053{ 3054 cat("\n",file=file,append=append,...) 3055 HTML("<p>Revised data:\n</p>",file=file) 3056 HTML(x$data,file=file, append=TRUE,...) 3057 HTML("<p>Order of objects:\n</p>",file=file) 3058 HTML(if (length(x$order.lab) != 0) x$order.lab else x$order,file=file, append=TRUE,...) 3059 HTML("<p>Variable used:\n</p>",file=file) 3060 HTML(x$variable, file=file, append=TRUE,...) 3061 HTML("<p>Separation step:\n</p>",file=file) 3062 HTML(x$step,file=file, append=TRUE,...) 3063 HTML("\n<p>Available components:\n</p>",file=file) 3064 HTML(names(x),file=file,append=TRUE, ...) 3065 invisible(x) 3066} 3067 3068#----------------------------------------------------------------------------------------------------# 3069 3070"HTML.pam" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3071{ 3072 cat("\n",file=file,append=append,...) 3073 HTML("<p>Medoids:\n</p>",file=file) 3074 HTML(x$medoids,file=file, append=TRUE,...) 3075 HTML("<p>Clustering vector:\n</p>",file=file) 3076 HTML(x$clustering,file=file, append=TRUE,...) 3077 HTML("<p>Objective function:\n</p>",file=file) 3078 HTML(x$objective,file=file, append=TRUE,...) 3079 HTML("\n<p>Available components:\n</p>",file=file) 3080 HTML(names(x),file=file, append=TRUE,...) 3081 invisible(x) 3082} 3083 3084#----------------------------------------------------------------------------------------------------# 3085 3086"HTML.summary.agnes" <- function(x,file=HTMLGetFile(), append=TRUE,...) 3087{ 3088 cat("\n",file=file,append=append,...) 3089 HTML("<p>Merge:\n</p>",file=file) 3090 HTML(x$merge, file=file, append=TRUE,...) 3091 HTML("<p>Order of objects:\n</p>",file=file) 3092 HTML(if (length(x$order.lab) != 0) 3093 x$order.lab 3094 else x$order, file=file, append=TRUE,...) 3095 HTML("<p>Height:\n</p>",file=file) 3096 HTML(x$height, file=file,append=TRUE, ...) 3097 HTML("<p>Agglomerative coefficient:\n</p>",file=file) 3098 HTML(x$ac, file=file, append=TRUE,...) 3099 HTML("<p>\n</p>",file=file) 3100 HTML(x$diss, file=file, append=TRUE,...) 3101 HTML("<p>\nAvailable components:\n</p>",file=file) 3102 HTML(names(x), file=file,append=TRUE, ...) 3103 invisible(x) 3104} 3105 3106#----------------------------------------------------------------------------------------------------# 3107 3108"HTML.summary.clara" <- function(x,file=HTMLGetFile(), append=TRUE,...) 3109{ 3110 cat("\n",file=file,append=append,...) 3111 HTML("<p>Best sample:\n</p>",file=file) 3112 HTML(x$sample, file=file, append=TRUE,...) 3113 HTML("<p>Medoids:\n</p>",file=file) 3114 HTML(x$medoids, file=file, append=TRUE,...) 3115 HTML("<p>Clustering vector:\n</p>",file=file) 3116 HTML(x$clustering, file=file,append=TRUE, ...) 3117 HTML("<p>Objective function:\n</p>",file=file) 3118 HTML(x$objective, file=file,append=TRUE, ...) 3119 HTML("<p>\nNumerical information per cluster:\n</p>",file=file) 3120 HTML(x$clusinfo, file=file, append=TRUE,...) 3121 if (length(x$silinfo) != 0) { 3122 HTML("<p>\nSilhouette plot information for best sample:\n</p>",file=file) 3123 HTML(x$silinfo[[1]], file=file,append=TRUE, ...) 3124 HTML("<p>Average silhouette width per cluster:\n</p>",file=file) 3125 HTML(x$silinfo[[2]], file=file,append=TRUE, ...) 3126 HTML("<p>Average silhouette width of best sample:\n</p>",file=file) 3127 HTML(x$silinfo[[3]], file=file,append=TRUE, ...) 3128 } 3129 HTML("<p>\n</p>",file=file) 3130 HTML(x$diss, file=file, append=TRUE,...) 3131 HTML("<p>\nAvailable components:\n</p>",file=file) 3132 HTML(names(x), file=file,append=TRUE, ...) 3133 invisible(x) 3134} 3135 3136#----------------------------------------------------------------------------------------------------# 3137 3138"HTML.summary.diana" <- function(x,file=HTMLGetFile(), append=TRUE,...) 3139{ 3140 cat("\n",file=file,append=append,...) 3141 HTML("<p>Merge:\n</p>",file=file) 3142 HTML(x$merge, file=file, append=TRUE,...) 3143 HTML("<p>Order of objects:\n</p>",file=file) 3144 HTML(if (length(x$order.lab) != 0) 3145 x$order.lab 3146 else x$order, file=file, append=TRUE,...) 3147 HTML("<p>Height:\n</p>",file=file) 3148 HTML(x$height, file=file,append=TRUE, ...) 3149 HTML("<p>Divisive coefficient:\n</p>",file=file) 3150 HTML(x$dc, file=file, append=TRUE,...) 3151 HTML("<p>\n</p>",file=file) 3152 HTML(x$diss, file=file,append=TRUE, ...) 3153 HTML("<p>\nAvailable components:\n</p>",file=file) 3154 HTML(names(x), file=file,append=TRUE, ...) 3155 invisible(x) 3156} 3157 3158#----------------------------------------------------------------------------------------------------# 3159 3160 "HTML.summary.fanny" <- function(x,file=HTMLGetFile(), append=TRUE,...) 3161{ 3162 cat("\n",file=file,append=append,...) 3163 HTML(x$objective, file=file, append=TRUE,...) 3164 HTML("<p>Membership coefficients:\n</p>",file=file) 3165 HTML(x$membership, file=file, append=TRUE, ...) 3166 HTML("<p>Coefficients:\n</p>",file=file) 3167 HTML(x$coeff, file=file, append=TRUE, ...) 3168 HTML("<p>Closest hard clustering:\n</p>",file=file) 3169 HTML(x$clustering, file=file, append=TRUE, ...) 3170 if (length(x$silinfo) != 0) { 3171 HTML("<p>\nSilhouette plot information:\n</p>",file=file) 3172 HTML(x$silinfo[[1]], file=file, append=TRUE, ...) 3173 HTML("<p>Average silhouette width per cluster:\n</p>",file=file) 3174 HTML(x$silinfo[[2]], file=file, append=TRUE, ...) 3175 HTML("<p>Average silhouette width of total data set:\n</p>",file=file) 3176 HTML(x$silinfo[[3]], file=file, append=TRUE, ...) 3177 } 3178 HTML("<p>\n</p>",file=file) 3179 HTML(x$diss, file=file, append=TRUE, ...) 3180 HTML("<p>\nAvailable components:\n</p>",file=file) 3181 HTML(names(x), file=file, append=TRUE, ...) 3182 invisible(x) 3183} 3184 3185#----------------------------------------------------------------------------------------------------# 3186 3187"HTML.summary.mona" <- function(x,file=HTMLGetFile(), append=TRUE,...) 3188{ 3189 cat("\n", file=file, append=append,...) 3190 HTML.mona(x, file=file, append=TRUE, ...) 3191 invisible(x) 3192} 3193 3194#----------------------------------------------------------------------------------------------------# 3195 3196"HTML.summary.pam" <- function(x,file=HTMLGetFile(), append=TRUE,...) 3197{ 3198 cat("\n", file=file,append=append,...) 3199 HTML("<p>Medoids:\n</p>",file=file) 3200 HTML(x$medoids, file=file, append=TRUE, ...) 3201 HTML("<p>Clustering vector:\n</p>",file=file) 3202 HTML(x$clustering, file=file, append=TRUE, ...) 3203 HTML("<p>Objective function:\n</p>",file=file) 3204 HTML(x$objective, file=file, append=TRUE, ...) 3205 HTML("<p>\nNumerical information per cluster:\n</p>",file=file) 3206 HTML(x$clusinfo, file=file, append=TRUE, ...) 3207 HTML("<p>\nIsolated clusters:\n</p>",file=file) 3208 HTML("<p>L-clusters: ") 3209 HTML(names(x$isolation[x$isolation == "L"]), 3210 ...) 3211 HTML("<p>L*-clusters: ") 3212 HTML(names(x$isolation[x$isolation == "L*"]), 3213 ...) 3214 if (length(x$silinfo) != 0) { 3215 HTML("<p>\nSilhouette plot information:\n</p>",file=file) 3216 HTML(x$silinfo[[1]], file=file, append=TRUE, ...) 3217 HTML("<p>Average silhouette width per cluster:\n</p>",file=file) 3218 HTML(x$silinfo[[2]], file=file, append=TRUE, ...) 3219 HTML("<p>Average silhouette width of total data set:\n</p>",file=file) 3220 HTML(x$silinfo[[3]], file=file, append=TRUE, ...) 3221 } 3222 HTML("<p>\n</p>",file=file) 3223 HTML(x$diss, file=file, append=TRUE, ...) 3224 HTML("<p>\nAvailable components:\n</p>",file=file) 3225 HTML(names(x), file=file, append=TRUE, ...) 3226 invisible(x) 3227} 3228 3229#----------------------------------------------------------------------------------------------------# 3230### PACKAGE MGCV 3231#----------------------------------------------------------------------------------------------------# 3232 3233"HTML.gam" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3234{ 3235 cat("\n", file=file, append=append,...) 3236 HTML(x$family,file=file) 3237 HTML("<p>Formula:\n</p>",file=file) 3238 HTML(x$formula,file=file) 3239 if (x$dim == 0) 3240 HTML(paste("<p>Total model degrees of freedom <b>", x$nsdf, " </b>\n</p>"),file=file) 3241 else HTML(paste("\n<p>Estimated degrees of freedom:<b>", paste(x$edf,collapse=" , "), "</b> total = <b>", 3242 paste(sum(x$edf) + x$nsdf,collapse=" , "), "</b>\n</p>"),file=file) 3243 gcv <- x$df.null * x$sig2/(x$df.null - sum(x$edf) - x$nsdf) 3244 HTML("\n<p>GCV score:</p> ",file=file) 3245 HTML(gcv,file=file) 3246 invisible(x) 3247} 3248 3249#----------------------------------------------------------------------------------------------------# 3250 3251"HTML.summary.gam" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3252{ 3253 cat("\n", file=file, append=append,...) 3254 HTML(x$family,file=file) 3255 HTML("<p>Formula:\n</p>",file=file) 3256 HTML(x$formula,file=file) 3257 if (length(x$p.coeff) > 0) { 3258 HTML("\n<p>Parametric coefficients:\n</p>",file=file) 3259 width <- max(nchar(names(x$p.coeff))) 3260 3261 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) 3262 3263 3264 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) 3265 3266 HTML("\n</table></td></table></center>",file=file) 3267 3268 } 3269 HTMLbr( file=file) 3270 if (x$m > 0) { 3271 HTML("<p>Approximate significance of smooth terms:\n</p>",file=file) 3272 width <- max(nchar(names(x$chi.sq))) 3273 3274 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) 3275 for (i in 1:x$m) 3276 3277 HTML(paste("<tr><td class=firstcolumn>",formatC(names(x$chi.sq)[i], width = width), 3278 "</td><td class=CellInside>", formatC(x$edf[i], width = 10, digits = 4), "</td><td class=CellInside>", 3279 formatC(x$chi.sq[i], width = 10, digits = 5),"</td><td class=CellInside>", 3280 format.pval(x$s.pv[i]), "</td></tr>\n", sep = ""),file=file) 3281 3282 HTML("\n</table></td></table></center>",file=file) 3283 3284 } 3285 HTML(paste("\n<p>Adjusted r-sq. = <b>", formatC(x$r.sq, digits = 3, width = 5), 3286 " </b> GCV score = <b>", formatC(x$gcv, digits = 5), "</b> \n<br>Scale estimate = <b>", 3287 formatC(x$scale, digits = 5, width = 8, flag = "-"), 3288 " </b> n = <b>", x$n, "</b>\n</p>", sep = ""),file=file) 3289 invisible(x) 3290} 3291 3292 3293#----------------------------------------------------------------------------------------------------# 3294### PACKAGE RPART 3295#----------------------------------------------------------------------------------------------------# 3296 3297 3298"HTML.rpart" <- function (x, minlength = 0, spaces = 2, cp, digits = getOption("digits"), 3299 file=HTMLGetFile(), append=TRUE,...) 3300{ 3301 cat("\n", file=file, append=append,...) 3302 if (!inherits(x, "rpart")) 3303 stop("Not legitimate rpart object") 3304 if (!missing(cp)) 3305 x <- rpart::prune.rpart(x, cp = cp) 3306 frame <- x$frame 3307 ylevel <- attr(x, "ylevels") 3308 node <- as.numeric(row.names(frame)) 3309 # tree.depth is not exported by rpart anymore. Defining it locally: 3310 "Inttree.depth" <- 3311 function (nodes) 3312 { 3313 depth <- floor(log(nodes, base = 2) + 1e-7) 3314 as.vector(depth - min(depth)) 3315 } 3316 depth <- Inttree.depth(node) 3317 indent <- paste(rep(" ", spaces * 32), collapse = " ") 3318 if (length(node) > 1) { 3319 indent <- substring(indent, 1, spaces * seq(depth)) 3320 indent <- paste(c("", indent[depth]), format(node), ")", 3321 sep = "") 3322 } 3323 else indent <- paste(format(node), ")", sep = "") 3324 tfun <- (x$functions)$print 3325 if (!is.null(tfun)) { 3326 if (is.null(frame$yval2)) 3327 yval <- tfun(frame$yval, ylevel, digits) 3328 else yval <- tfun(frame$yval2, ylevel, digits) 3329 } 3330 else yval <- format(signif(frame$yval, digits = digits)) 3331 term <- rep(" ", length(depth)) 3332 term[frame$var == "<leaf>"] <- "*" 3333 z <- labels(x, digits = digits, minlength = minlength, ...) 3334 n <- frame$n 3335 z <- paste(indent, z, n, format(signif(frame$dev, digits = digits)), 3336 yval, term) 3337 omit <- x$na.action 3338 if (length(omit)) 3339 HTML(paste("<p>n=<b>", n[1], "</b> (", naprint(omit), ")\n</p>\n", sep = ""),file=file) 3340 else HTML(paste("<p>n=<b>", n[1], "</b>\n</p>\n"),file=file) 3341 if (x$method == "class") 3342 HTML("<p>node), split, n, loss, yval, (yprob)\n</p>",file=file) 3343 else HTML("<p>node), split, n, deviance, yval\n</p>",file=file) 3344 HTML("<p> * denotes terminal node\n\n</p>",file=file) 3345 HTML(paste("<xmp>", paste(z, sep = "\n",collapse="\n"),"</xmp>"),file=file) 3346 invisible(x) 3347} 3348 3349#----------------------------------------------------------------------------------------------------# 3350### PACKAGE MODREG 3351#----------------------------------------------------------------------------------------------------# 3352 3353"HTML.loess" <- function (x, digits = max(3, getOption("digits") - 3),file=HTMLGetFile(), append=TRUE,...) 3354{ 3355 cat("\n", file=file, append=append,...) 3356 if (!is.null(cl <- x$call)) HTMLli(paste("Call: ",paste(deparse(cl),collapse=" ")),file=file) 3357 HTML(paste("\n<p>Number of Observations:<b>", x$n, "</b>\n</p>"),file=file) 3358 HTML(paste("<p>Equivalent Number of Parameters:<b>", format(round(x$enp, 3359 2)), "</b>\n</p>"),file=file) 3360 HTML(paste("<p>Residual", if (x$pars$family == "gaussian") 3361 " Standard Error: <b>" 3362 else " Scale Estimate:<b> ", format(signif(x$s, digits)), "</b>\n</p>"),file=file) 3363 invisible(x) 3364} 3365 3366#----------------------------------------------------------------------------------------------------# 3367 3368"HTML.ppr" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3369{ 3370 cat("\n", file=file, append=append,...) 3371 if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file) 3372 mu <- x$mu 3373 ml <- x$ml 3374 HTML("\n<p>Goodness of fit:\n</p>",file=file) 3375 gof <- x$gofn 3376 names(gof) <- paste(1:ml, "terms") 3377 HTML(format(gof[mu:ml], ...), file=file) 3378 invisible(x) 3379} 3380 3381 3382#----------------------------------------------------------------------------------------------------# 3383 3384"HTML.smooth.spline" <- function (x, digits = getOption("digits"), file=HTMLGetFile(), append=TRUE,...) 3385{ 3386 cat("\n", file=file, append=append,...) 3387 if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file) 3388 ip <- x$iparms 3389 cv <- cl$cv 3390 if (is.null(cv)) 3391 cv <- FALSE 3392 else if (is.name(cv)) 3393 cv <- eval(cv) 3394 HTML(paste("\n<p>Smoothing Parameter spar=<b>", format(x$spar, digits = digits), 3395 "</b> lambda=<b>", format(x$lambda, digits = digits),"</b>", if (ip["ispar"] != 3396 1) paste("(", ip["iter"], " iterations)", sep = ""), "\n</p>"),file=file) 3397 HTML(paste("<p>Equivalent Degrees of Freedom (Df):<b>", format(x$df, digits = digits), 3398 "</b>\n</p>"),file=file) 3399 HTML(paste("<p>Penalized Criterion:<b>", format(x$pen.crit, digits = digits), 3400 "</b>\n</p>"),file=file) 3401 HTML(paste ("<p>",if (cv) "PRESS:" 3402 else "GCV:", "<b>",format(x$cv.crit, digits = digits), "</b>\n</p>"),file=file) 3403 invisible(x) 3404} 3405 3406#----------------------------------------------------------------------------------------------------# 3407 3408"HTML.summary.loess" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 3409{ 3410 cat("\n", file=file, append=append,...) 3411 if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file) 3412 HTML(paste("\n<p>Number of Observations:<b>", x$n, "</b>\n</p>"),file=file) 3413 HTML(paste("<p>Equivalent Number of Parameters:<b>", format(round(x$enp, 2)), "</b>\n</p>"),file=file) 3414 if (x$pars$family == "gaussian") 3415 HTML("<p>Residual Standard Error:</p>",file=file) 3416 else HTML("<p>Residual Scale Estimate:</p>",file=file) 3417 HTML(format(signif(x$s, digits)),file=file) 3418 HTML("<p>Trace of smoother matrix:</p>",file=file) 3419 HTML(format(round(x$trace.hat,2)), file=file) 3420 HTML("\n<p>Control settings:\n</p><ul>",file=file) 3421 HTMLli(paste("normalize: ", x$pars$normalize, "\n"),file=file) 3422 HTMLli(paste(" span : ", format(x$pars$span), "\n"),file=file) 3423 HTMLli(paste(" degree : ", x$pars$degree, "\n"),file=file) 3424 HTMLli(paste(" family : ", x$pars$family),file=file) 3425 if (x$pars$family != "gaussian") 3426 HTMLli(paste(" iterations =", x$pars$iterations),file=file) 3427 HTML("</ul>",file=file) 3428 HTML(paste("\n<p> surface : ", x$pars$surface, if (x$pars$surface == "interpolate") paste(" cell =", format(x$pars$cell)),"</p>"),file=file) 3429 invisible(x) 3430} 3431 3432 3433#----------------------------------------------------------------------------------------------------# 3434 3435"HTML.summary.ppr" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3436{ 3437 cat("\n", file=file, append=append,...) 3438 HTML.ppr(x,file=file, ...) 3439 mu <- x$mu 3440 HTML("\n<p>Projection direction vectors:\n</p>",file=file) 3441 HTML(format(x$alpha, ...),file=file) 3442 HTML("\n<p>Coefficients of ridge terms:\n</p>",file=file) 3443 HTML(format(x$beta, ...), file=file) 3444 if (any(x$edf > 0)) { 3445 HTML("\n<p>Equivalent df for ridge terms:\n</p>") 3446 edf <- x$edf 3447 names(edf) <- paste("term", 1:mu) 3448 HTML(round(edf, 2),file=file, append=TRUE,...) 3449 } 3450 invisible(x) 3451} 3452 3453 3454#----------------------------------------------------------------------------------------------------# 3455### PACKAGE SPLINES 3456#----------------------------------------------------------------------------------------------------# 3457 3458 3459 3460"HTML.bSpline" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3461{ 3462 cat("\n", file=file, append=append,...) 3463 value <- c(rep(NA, splines::splineOrder(x)), coef(x)) 3464 names(value) <- format(splines::splineKnots(x), digits = 5) 3465 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) 3466 HTML(value, file=file,append=TRUE,...) 3467 invisible(x) 3468} 3469 3470 3471#----------------------------------------------------------------------------------------------------# 3472 3473"HTML.polySpline" <- function (x,file=HTMLGetFile(), append=TRUE,...) 3474{ 3475 cat("\n", file=file, append=append,...) 3476 coeff <- coef(x) 3477 dnames <- dimnames(coeff) 3478 if (is.null(dnames[[2]])) 3479 dimnames(coeff) <- list(format(splines::splineKnots(x)), c("constant", 3480 "linear", "quadratic", "cubic", paste(4:29, "th", 3481 sep = ""))[1:(dim(coeff)[2])]) 3482 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 ) 3483 HTML(coeff, file=file,append=TRUE,...) 3484 invisible(x) 3485} 3486 3487#----------------------------------------------------------------------------------------------------# 3488 3489"HTML.ppolySpline" <- function (x,file=HTMLGetFile(), append=TRUE,...) 3490{ 3491 cat("\n", file=file, append=append,...) 3492 HTML("<p>periodic </p>",file=file) 3493 HTML(paste("\n<p>Period:<b>", format(x[["period"]]), "</b>\n</p>"),file=file) 3494 NextMethod("HTML",file=file) 3495 invisible(x) 3496} 3497 3498 3499 3500#----------------------------------------------------------------------------------------------------# 3501### PACKAGE LSQ 3502#----------------------------------------------------------------------------------------------------# 3503 3504"HTML.lqs" <- function (x, digits = max(3, getOption("digits") - 3), file=HTMLGetFile(), append=TRUE,...) 3505{ 3506 cat("\n", file=file, append=append,...) 3507 if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file) 3508 3509 HTML("<p>Coefficients:\n</p>",file=file) 3510 HTML.default(format(coef(x), digits = digits), file=file) 3511 HTML(paste("\n<p>Scale estimates ", paste(format(x$scale, digits = digits),collapse=" "), 3512 "\n\n</p>"),file=file) 3513 invisible(x) 3514} 3515 3516 3517#----------------------------------------------------------------------------------------------------# 3518### PACKAGE NLS 3519#----------------------------------------------------------------------------------------------------# 3520 3521"HTML.nls" <- function (x, file=HTMLGetFile(), append=TRUE,...) 3522{ 3523 cat("\n", file=file, append=append,...) 3524 HTML("<p><b>Nonlinear regression model\n</b></p>",file=file) 3525 HTMLli(paste("Model: ", paste(deparse(formula(x)),collapse=" "), "\n"),file=file) 3526 HTMLli(paste("Data: ", as.character(x$data), "\n"),file=file) 3527 HTML(x$m$getAllPars(),file=file) 3528 HTMLli(paste("Residual sum-of-squares: ", format(x$m$deviance()),"\n"),file=file) 3529 invisible(x) 3530} 3531 3532 3533#----------------------------------------------------------------------------------------------------# 3534 3535"HTML.summary.nls" <- function (x, digits = max(3, getOption("digits") - 3), symbolic.cor = p > 3536 4, signif.stars = getOption("show.signif.stars"), file=HTMLGetFile(), append=TRUE,...) 3537{ 3538 cat("\n", file=file, append=append,...) 3539 HTML(paste("<p>Formula:",paste(deparse(x$formula), collapse = " "),"</p>"),file=file) 3540 df <- x$df 3541 rdf <- df[2] 3542 HTML("\n<p>Parameters:\n</p>",file=file) 3543 HTML.coefmat(x$parameters, digits = digits, signif.stars = signif.stars, 3544 file=file,append=TRUE,...) 3545 HTML(paste("\n<p>Residual standard error:<b> ", format(signif(x$sigma, 3546 digits)), " </b>on <b>", rdf, " </b>degrees of freedom\n</p>"),file=file) 3547 correl <- x$correlation 3548 if (!is.null(correl)) { 3549 p <- dim(correl)[2] 3550 if (p > 1) { 3551 HTML("\n<p>Correlation of Parameter Estimates:\n</p>",file=file) 3552 if (symbolic.cor) 3553 HTML(symnum(correl)[-1, -p],file=file) 3554 else { 3555 correl[!lower.tri(correl)] <- NA 3556 HTML(correl[-1, -p, drop = FALSE], file=file) 3557 } 3558 } 3559 } 3560 HTMLbr(file=file) 3561 invisible(x) 3562} 3563 3564 3565#----------------------------------------------------------------------------------------------------# 3566### PACKAGE STEPFUN 3567#----------------------------------------------------------------------------------------------------# 3568 3569"HTML.ecdf" <- function (x, digits = getOption("digits") - 2, file=HTMLGetFile(), append=TRUE,...) 3570{ 3571 cat("\n", file=file, append=append,...) 3572 numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ") 3573 HTML(paste("<p><b>Empirical CDF</b></p> \n<li>Call:<font class='call'> ", paste(deparse(attr(x, "call")),collapse=" "),"</font>"), file=file) 3574 n <- length(xx <- eval(expression(x), envir = environment(x))) 3575 i1 <- 1:min(3, n) 3576 i2 <- if (n >= 4) 3577 max(4, n - 1):n 3578 else integer(0) 3579 HTML(paste(" x[1:", n, "] = ", numform(xx[i1]), if (n > 3) 3580 ", ", if (n > 5) 3581 " ..., ", numform(xx[i2]), "\n<br>", sep = ""),file=file) 3582 invisible(x) 3583} 3584 3585 3586#----------------------------------------------------------------------------------------------------# 3587 3588 "HTML.stepfun" <- function (x, digits = getOption("digits") - 2, file=HTMLGetFile(), append=TRUE,...) 3589{ 3590 cat("\n", file=file, append=append,...) 3591 numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ") 3592 i1 <- function(n) 1:min(3, n) 3593 i2 <- function(n) if (n >= 4) 3594 max(4, n - 1):n 3595 else integer(0) 3596 HTML(paste("<p><b>Step function</b></p>\n<li>Call<font class='call'>: ",paste(deparse(attr(x, "call")) ,collapse=" "),"</font>"),file=file) 3597 env <- environment(x) 3598 n <- length(xx <- eval(expression(x), envir = env)) 3599 HTML(paste(" x[1:", n, "] = ", numform(xx[i1(n)]), if (n > 3) 3600 ", ", if (n > 5) 3601 " ..., ", numform(xx[i2(n)]), "\n<br>", sep = ""),file=file) 3602 y <- eval(expression(c(yleft, y)), envir = env) 3603 HTML(paste(n + 1, " step heights = ", numform(y[i1(n + 1)]), if (n + 3604 1 > 3) 3605 ", ", if (n + 1 > 5) 3606 " ..., ", numform(y[i2(n + 1)]), "\n<br>", sep = ""),file=file) 3607 invisible(x) 3608} 3609 3610#----------------------------------------------------------------------------------------------------# 3611### PACKAGE SURVIVAL 3612#----------------------------------------------------------------------------------------------------# 3613 3614"HTML.cox.zph" <- function (x, digits = max(options()$digits - 4, 3), file=HTMLGetFile(), append=TRUE,...) 3615HTML(x$table, file=file,append=append,...) 3616 3617#----------------------------------------------------------------------------------------------------# 3618 3619"HTML.coxph.null" <- function (x, digits = max(options()$digits - 4, 3), file=HTMLGetFile(), append=TRUE,...) 3620{ 3621 cat("\n", file=file, append=append,...) 3622 if (!is.null(cl <- x$call)) HTMLli(paste("Call:",paste(deparse(cl),collapse=" ")),file=file) 3623 HTML(paste("<p>Null model log likelihood=<b>", format(x$loglik), "</b>\n</p>"),file=file) 3624 omit <- x$na.action 3625 if (length(omit)) HTML(paste("<p> n=<b>", x$n, " </b>(", naprint(omit), ")\n</p>", sep = ""),file=file) 3626 else HTML(paste("<p> n=<b>", x$n, "</b>\n</p>"),file=file) 3627} 3628 3629#----------------------------------------------------------------------------------------------------# 3630### XTABLE 3631#----------------------------------------------------------------------------------------------------# 3632 3633"HTML.xtable" <- function(x,file=HTMLGetFile(), append=TRUE,...){ 3634 cat("\n", file=file, append=append,...) 3635 cat(capture.output(print(x,type="html")),file=file,append=TRUE,sep="\n") 3636} 3637 3638#----------------------------------------------------------------------------------------------------# 3639### UTILITARY FUNCTIONS 3640#----------------------------------------------------------------------------------------------------# 3641 3642#----------------------------------------------------------------------------------------------------# 3643 3644"HTML.title"<- 3645function(x, HR = 2,CSSclass=NULL,file=HTMLGetFile(), append=TRUE, ...) 3646{ 3647 cat(paste("\n <h", HR, if(!is.null(CSSclass)) paste(" class=",CSSclass,sep="") ," > ", x, "</h", HR, ">\n", sep = 3648 ""), file = file, append=append, sep = "") 3649} 3650 3651#----------------------------------------------------------------------------------------------------# 3652 3653"HTMLstem" <- function (x, file=HTMLGetFile(), append=TRUE,...) HTML(paste("<pre>",paste(capture.output(stem(x)),collapse="<br>"),"</pre>"), file=file,append=append,...) 3654 3655 3656 3657#----------------------------------------------------------------------------------------------------# 3658 3659"HTMLbr"<- function(x=1,file=HTMLGetFile(), append=TRUE) { cat(paste("\n",rep("<br> ",x),"\n",sep=""), append=append, file = file)} 3660 3661#----------------------------------------------------------------------------------------------------# 3662 3663"HTMLhr"<- function(file=HTMLGetFile(), 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 = "")} 3664 3665#----------------------------------------------------------------------------------------------------# 3666 3667"HTMLli"<- function(txt="", file=HTMLGetFile(), append=TRUE) { cat(paste("\n<br><li>", txt, sep = ""), sep = "", append=append, file = file)} 3668 3669#----------------------------------------------------------------------------------------------------# 3670 3671 3672"HTMLplot" <- function (Caption = "", file=HTMLGetFile(), append=TRUE, GraphDirectory = ".", 3673 GraphFileName = "", GraphSaveAs = "png", GraphBorder = 1, Align = "center", 3674 Width=500,Height=500,WidthHTML=NULL,HeightHTML=NULL, 3675 GraphPointSize=12,GraphBackGround="white",GraphRes=72,plotFunction=NULL,...) 3676{ 3677## New version with code submitted by James Wettenhall <wettenhall@wehi.edu.au> 3678## Change plotFunction by plotExpression... 3679 3680 if (exists(".HTMLTmpEnv", where=.HTMLEnv)) 3681 { 3682 GraphDirectory <- get(".HTML.outdir", envir=get(".HTMLTmpEnv", envir=.HTMLEnv)) 3683 } 3684 3685 cat("\n", file=file, append=append,...) 3686 if (GraphFileName == "") { 3687 nowd <- date() 3688 GraphFileName <- paste("GRAPH_", substring(nowd, 5, 7), 3689 substring(nowd, 9, 10), "_", substring(nowd, 12, 3690 13), substring(nowd, 15, 16), substring(nowd, 3691 18, 19), sep = "") 3692 } 3693 3694 GraphFileName <- paste(GraphFileName, ".", GraphSaveAs, sep = "") 3695 AbsGraphFileName <- file.path(GraphDirectory, GraphFileName) 3696 3697 if (GraphSaveAs=="png") 3698 { 3699 if (is.null(plotFunction)) 3700 dev.print(device=png, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround) 3701 else 3702 { 3703 if (exists("X11", envir =.GlobalEnv) && Sys.info()["sysname"] != "Windows" && Sys.info()["sysname"] != "Darwin") 3704 bitmap(file = AbsGraphFileName,bg=GraphBackGround,res=GraphRes) 3705 else 3706 png(filename = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround) 3707 plotFunction() 3708 dev.off() 3709 } 3710 } 3711 else if (GraphSaveAs %in% c("jpg","jpeg")) 3712 { 3713 if (is.null(plotFunction)) 3714 dev.print(device=jpeg, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround) 3715 else 3716 { 3717 if (exists("X11", envir =.GlobalEnv) && Sys.info()["sysname"] != "Windows" && Sys.info()["sysname"] != "Darwin") 3718 bitmap(filename = AbsGraphFileName,bg=GraphBackGround,res=GraphRes,type="jpeg") 3719 else 3720 jpeg(filename = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround) 3721 plotFunction() 3722 dev.off() 3723 } 3724 } 3725 else if (GraphSaveAs=="gif") 3726 { 3727 stop("Gif support was removed from base R because of patent restrictions. Use either jpg or png") 3728# 3729# if (is.null(plotFunction)) 3730# Gif support was removed from base R because of patent restrictions. 3731# see http://tolstoy.newcastle.edu.au/R/help/05/02/12809.html 3732# dev.print(device=gif, file = AbsGraphFileName, width=Width,height=Height,pointsize=GraphPointSize,bg=GraphBackGround) 3733# 3734# else 3735# { 3736# stop("When passing a plot function to HTMLplot, device must be jpg or png.") 3737# } 3738 } 3739 else stop("GraphSaveAs must be either jpg, png or gif") 3740 3741 cat(paste("<p align=", Align, "><img src='", GraphFileName, 3742 "' 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 = ""), 3743 file = file, append=TRUE, sep = "") 3744 if (Caption != "") { 3745 cat(paste("<br><font class=caption>", Caption, "</font>"), file = file, append=TRUE, sep = "") 3746 } 3747 cat("</p>", file = file, append=TRUE, sep = "\n") 3748 if (substitute(file)=="HTMLGetFile()") try(assign(".HTML.graph", TRUE, envir = .HTMLEnv)) 3749 invisible(return(TRUE)) 3750} 3751 3752#----------------------------------------------------------------------------------------------------# 3753 3754"HTMLInsertGraph" <- function(GraphFileName="",Caption="",GraphBorder=1,Align="center",WidthHTML=500,HeightHTML=NULL,file=HTMLGetFile(), append=TRUE,...) 3755{ 3756 cat("\n", file=file, append=append,...) 3757 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 = "") 3758 if (Caption != "") cat(paste("<br><i class=caption>", Caption, "</i>"), file = file, append=TRUE, sep = "") 3759 invisible(return(TRUE)) 3760} 3761 3762 3763#----------------------------------------------------------------------------------------------------# 3764 3765"HTMLCSS" <- function(file=HTMLGetFile(), append=TRUE,CSSfile="R2HTML.css") 3766{ 3767 3768 cat(paste("\n<link rel=stylesheet type=text/css href=",CSSfile,">\n",sep=""),file=file,append=append) 3769 3770} 3771 3772 3773#----------------------------------------------------------------------------------------------------# 3774"HTMLChangeCSS" <- function(newCSS="R2HTML",from=NULL){ 3775 target=getwd() 3776 if(exists(".HTMLTmpEnv", .HTMLEnv)) 3777 target=file.path(get(".HTML.outdir",envir=get(".HTMLTmpEnv", .HTMLEnv))) 3778 3779 if (is.null(from)){ 3780## from=file.path(.find.package(package = "R2HTML"),"output") 3781 from=system.file(package = "R2HTML","output") 3782 } 3783 fromfile=file.path(from,paste(newCSS,"css",sep=".")) 3784 if (!file.exists(fromfile)) stop(paste("Source CSS file",fromfile,"not found")) 3785 file.copy(fromfile,file.path(target,"R2HTML.css"),overwrite=TRUE) 3786 3787} 3788 3789 3790"HTMLCommand" <- function(x,file=HTMLGetFile(),Num="",menu=FALSE,target="index<-main.html",append=TRUE,...) 3791 { 3792 cat("\n",file=file,append=append,...) 3793 if (menu==TRUE) 3794 cat(paste("<br><li><a class=command href='./",target,"#Num",Num,"' target=main> ",paste(x,collapse=""),"</a>",sep=""),file=file,append=TRUE,sep="") 3795 else { 3796 if (Num!="") cat(paste("<a name=Num",Num,"> </a>",sep=""),file=file,append=TRUE,sep="") 3797 cat(paste("\n<p><xmp class=command>> ",x,"</xmp></p>\n",sep=""),file=file,append=TRUE,sep="") 3798 } 3799 } 3800 3801#----------------------------------------------------------------------------------------------------# 3802 3803"HTMLcode" <- function(x,...){ 3804 tmpfic=tempfile() 3805 HTML(x,file=tmpfic,...) 3806 cat("\n",file=tmpfic,append=TRUE) 3807 tmptxt=readLines(tmpfic) 3808 unlink(tmpfic) 3809 return(paste(tmptxt,collapse="\n")) 3810} 3811#----------------------------------------------------------------------------------------------------# 3812 3813 3814"HTMLReplaceNA"<- 3815function(Vec, Replace = " ") 3816{ 3817 Vec <- as.character(Vec) 3818 #Vec <- format( Vec, ... ) 3819 for(i in 1:length(Vec)) 3820 { 3821 try(if((Vec[i] == "NA") | (Vec[i] == "NaN") | is.na(Vec[i])){ Vec[i] <- Replace}) 3822 } 3823 Vec 3824} 3825 3826 3827#----------------------------------------------------------------------------------------------------# 3828"HTML.cormat" <- function(x, file=HTMLGetFile(), digits=2,append=TRUE,align="center",caption="",captionalign="bottom",classcaption="captiondataframe",classtable="cormat",useCSS=TRUE,...) 3829{ 3830 cat("\n", file=file,append=append) 3831 x<-as.matrix(x) 3832 if (is.numeric(x)) x<-round(x,digits=digits) 3833 if (is.null(dimnames(x))) x <- as.data.frame(x) 3834 txt <- paste("<p align=",align,">") 3835 txtcaption <- ifelse(is.null(caption),"",paste("<caption align=",captionalign," class=",classcaption,">",caption,"</caption>",sep="")) 3836 cormat=x 3837 abscormat=abs(cormat) 3838 backcolors=matrix(grey(1-as.matrix(abscormat)),ncol=ncol(cormat)) 3839 css = 10*round(abs(x),1) 3840 css=matrix(paste("cor",unlist(css),sep=""),ncol=ncol(x)) 3841 diag(css)="cordiag" 3842 diag(backcolors)="#FFFFFF" 3843 forecolors=matrix("#000000",ncol=ncol(cormat),nrow=nrow(cormat)) 3844 forecolors[abscormat>0.5]="#FFFFFF" 3845 forecolors[abscormat>0.8]="#F6FF6E" 3846 diag(forecolors)="#FFFFFF" 3847 forebold=matrix(FALSE,ncol=ncol(cormat),nrow=nrow(cormat)) 3848 forebold[abscormat>0.9]=TRUE 3849 txt<- paste(txt,"<table cellspacing=0 cellpading=0 border=0 >",txtcaption,"<td valign=middle class=corbody><table cellspacing=0 border=0>") 3850 txt <- paste(txt,paste("\n<tr><td align=right class=corvarname>",dimnames(x)[[2]],"</td><td width=2> </td></tr>",collapse="\n")) 3851 txt <- paste(txt,"</table></td><td valign=top class=corsep> </td><td valign=top>") 3852 txt <- paste(txt, "<table cellspacing=0 cellpadding=0 border=1 ><td><table class=",classtable," cellspacing=0>", sep = "") 3853 for(i in 1:dim(x)[1]) { 3854 VecDebut <- c(rep(paste("\n\t<td align=right", sep = ""), dim(x)[2])) 3855 if (useCSS) VecAttrib=c(paste(" class= ",css[i,],">")) else VecAttrib=c(paste(" bgcolor=",backcolors[i,],"><font color=",forecolors[i,],">",ifelse(forebold[i,],"<b>",""))) 3856 VecMilieu <- HTMLReplaceNA(as.matrix(x[i, ])) 3857 VecFin <- rep("</td>", dim(x)[2] ) 3858 txt <- paste(txt, "\n<tr>",paste(VecDebut,VecAttrib, VecMilieu, VecFin, sep = "", collapse = ""),"</tr>") 3859 } 3860 txt <- paste(txt, "</table></td></table></td></table>") 3861 cat(txt, "\n", file = file, sep = "", append=TRUE,...) 3862 invisible(return(x)) 3863 3864 } 3865 3866#----------------------------------------------------------------------------------------------------# 3867 3868"as.title"<- 3869function(x) 3870{ 3871 if (!is.character(x)) { 3872 x <- try(as.character(x)) 3873 if (!is.character(x)) stop("Input argument must be of character mode") 3874 } 3875 class(x) <- "title" 3876 return(x) 3877} 3878 3879 3880#----------------------------------------------------------------------------------------------------# 3881### R2HTML CORE 3882#----------------------------------------------------------------------------------------------------# 3883 3884"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") 3885{ 3886 if (outdir!=tempdir()) 3887 { 3888 # Copy of CSS and logo, if outdir != tempdir 3889 file.copy(file.path(tempdir(),'R2HTML.css'), file.path(outdir,'R2HTML.css')) 3890 file.copy(file.path(tempdir(),'R2HTMLlogo.gif'), file.path(outdir,'R2HTMLlogo.gif')) 3891 } 3892 .HTMLTmpEnv <- new.env(parent=.GlobalEnv) 3893 assign(".HTMLTmpEnv",.HTMLTmpEnv,envir=.HTMLEnv) 3894 assign("oldprompt",getOption("prompt"),envir=.HTMLTmpEnv) 3895 assign("HTMLframe",HTMLframe,envir=.HTMLTmpEnv) 3896 assign(".HTML.outdir",outdir,envir=.HTMLTmpEnv) 3897 assign("HTMLtorefresh",file.path(outdir,paste(filename,extension,sep=".")),envir=.HTMLTmpEnv) 3898 options(prompt=withprompt) 3899 assign(".HTML.graph",FALSE,envir =.HTMLTmpEnv) 3900 3901 # Creation of required HTML files 3902 3903 try(.HTML.file <- HTMLInitFile(outdir = outdir,filename=filename,extension=extension,HTMLframe=HTMLframe, BackGroundColor = BackGroundColor, BackGroundImg = BackGroundImg, Title = Title,CSSFile=CSSFile,useLaTeX=TRUE)) 3904 assign(".HTML.file", .HTML.file, .HTMLTmpEnv) 3905 3906 3907 ToHTML <- function(file,echo,HTMLframe,HTMLMenuFile,target,outdir) 3908 { 3909 NumCom<-0 3910 function(expr,value,ok,visible) 3911 { 3912 3913 NumCom<<- NumCom+1 3914 3915 if (NumCom>1){ 3916 3917 ToPrint<-TRUE 3918 3919 if (get(".HTML.graph",envir=.HTMLTmpEnv)==TRUE) 3920 { 3921 ToPrint <- FALSE 3922 assign(".HTML.graph",FALSE,envir=.HTMLTmpEnv) 3923 } 3924 else 3925 { 3926 if (length(expr)>1) {if ((expr[[1]]=="=")||(expr[[1]]=="<-")) ToPrint<-FALSE} 3927 3928 3929 # Print the commands and/or their number 3930 if (echo) HTMLCommand(deparse(expr),file,NumCom) else cat(paste("<a name=Num",NumCom,"> </a>",sep=""),file=file,sep="",append=TRUE) 3931 if (HTMLframe) HTMLCommand(deparse(expr),HTMLMenuFile,NumCom,menu=TRUE,target=target) 3932 if (ToPrint) HTML(value,file=file) 3933 } 3934 } 3935 3936 if (autobrowse) browseURL(url=get("HTMLtorefresh",envir=.HTMLTmpEnv)) 3937 invisible(return(TRUE)) 3938 } 3939 } 3940 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) 3941 cat("\n *** Output redirected to directory: ", outdir) 3942 cat("\n *** Use HTMLStop() to end redirection.") 3943 invisible(return(TRUE)) 3944 3945} 3946#----------------------------------------------------------------------------------------------------# 3947 3948"HTMLInitFile"<-function(outdir = tempdir(),filename="index",extension="html", 3949 HTMLframe=FALSE, BackGroundColor = "FFFFFF", BackGroundImg = "", 3950 Title = "R output",CSSFile="R2HTML.css",useLaTeX=TRUE,useGrid=TRUE) 3951{ 3952if (HTMLframe==FALSE){ 3953 file<-file.path(outdir,paste(filename,".",extension,sep="")) 3954 assign(".HTML.file",file,envir =.HTMLEnv) 3955 3956 txt <- ifelse(useLaTeX,"<html xmlns:mml=\"http://www.w3.org/1998/Math/MathML\">","<html>") 3957 #<HEAD> 3958 txt <- c(txt, "<head>") 3959 txt <- c(txt, paste("<title>",Title,"</title>")) 3960 # css 3961 txt <- c(txt, paste("<link rel=stylesheet href=\"",CSSFile,"\" type=text/css>",sep="")) 3962 # LaTeX ? 3963 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>") 3964 # Grid? 3965 if (useGrid) { 3966 txt <- c(txt, HTMLgrid_references()) 3967 txt <- c(txt, "<script>\n nequations=0;\n</script>") 3968 } 3969 # </HEAD> 3970 txt <- c(txt, "</head>") 3971 # <BODY> 3972 body <- c("<body") 3973 if(useLaTeX) body=c(body," onload=\"translate()\"") 3974 body=c(body,paste(" bgcolor=",BackGroundColor)) 3975 if (BackGroundImg!="") body = c(body, paste(" background=\"",BackGroundImg,"\"",sep="")) 3976 body <- c(body," >") 3977 body=paste(body,collapse="") 3978 txt <- c(txt, body) 3979 txt <- paste(txt, collapse="\n") 3980 cat(txt, file=file,append=FALSE) 3981 3982 } 3983else { 3984 filemenu<-paste(filename,"_menu.",extension,sep="") 3985 filemain<-paste(filename,"_main.",extension,sep="") 3986 absfilemenu<-file.path(outdir,filemenu) 3987 file<-absfilemain<-file.path(outdir,filemain) 3988 absfileindex<-file.path(outdir,paste(filename,".",extension,sep="")) 3989 assign(".HTML.file",absfilemain,envir =.HTMLEnv) 3990 3991 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) 3992 3993 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) 3994 3995 txt <- ifelse(useLaTeX,"<html xmlns:mml=\"http://www.w3.org/1998/Math/MathML\">","<html>") 3996 #<HEAD> 3997 txt <- c(txt, "<head>") 3998 txt <- c(txt, paste("<title>",Title,"</title>")) 3999 # css 4000 txt <- c(txt, paste("<link rel=stylesheet href=\"",CSSFile,"\" type=text/css>",sep="")) 4001 # LaTeX ? 4002 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>") 4003 # Grid? 4004 if (useGrid) { 4005 txt <- c(txt, HTMLgrid_references()) 4006 txt <- c(txt, "<script>\n nequations=0;\n</script>") 4007 } # </HEAD> 4008 txt <- c(txt, "</head>") 4009 # <BODY> 4010 body <- c("<body") 4011 if(useLaTeX) body=c(body," onload=\"translate()\"") 4012 body=c(body,paste(" bgcolor=",BackGroundColor)) 4013 if (!is.null(BackGroundImg)) body = c(body, paste(" background=\"",BackGroundImg,"\"",sep="")) 4014 body <- c(body," >") 4015 body=paste(body,collapse="") 4016 txt <- c(txt, body) 4017 txt <- paste(txt, collapse="\n") 4018 cat(txt, file=absfilemain,append=FALSE) 4019 4020} 4021 4022 invisible(return(file)) 4023} 4024 4025#----------------------------------------------------------------------------------------------------# 4026 4027"HTMLEndFile"<- function(file=HTMLGetFile()) 4028{ 4029 cat("\n<hr size=1>\n<font size=-1>\n\t Generated on: <i>", date(), 4030 "</i> - <b>R2HTML</b> \n<hr size=1>\n\t</body>\n</html>", 4031 sep = "", append=TRUE, file = file) 4032} 4033 4034 4035#----------------------------------------------------------------------------------------------------# 4036 4037"HTMLStop"<-function() 4038{ 4039 invisible(removeTaskCallback("HTML")) 4040 .HTMLTmpEnv <- get(".HTMLTmpEnv", envir=.HTMLEnv) 4041 options(prompt=get("oldprompt",envir=.HTMLTmpEnv)) 4042 .tmp=get(".HTML.file",envir=.HTMLTmpEnv) 4043 HTMLEndFile(file=get(".HTML.file",envir=.HTMLTmpEnv)) 4044 rm(".HTMLTmpEnv", envir=.HTMLEnv) 4045 invisible(return(.tmp)) 4046} 4047 4048#----------------------------------------------------------------------------------------------------# 4049# Function contributed by Gabor Grothendieck (ggrothendieck_at_gmail.com) 4050 4051HTML2clip <- function(x, filename = file("clipboard", ifelse(.Platform$OS == "windows","w",stop("Writing to clipboard only supported on Windows"))), append = FALSE, ...) { 4052 HTML(x, file = filename, append = append, ...) 4053} 4054 4055#----------------------------------------------------------------------------------------------------# 4056 4057 4058# "myunzip" <- function (zipname, dest) 4059# { 4060# if (file.exists(zipname)) { 4061# if (.Platform$OS.type=="unix") system(paste(getOption("unzip"), "-oq", zipname, "-d", dest)) 4062# else .Internal(int.unzip(zipname, NULL, dest)) 4063# } 4064# else stop(paste("zipfile", zipname, "not found")) 4065# } 4066 4067".onLoad" <- function(lib,pkg) 4068{ 4069 #cat("\nLoading R2HTML package...\n") 4070 #ps.options(bg="white") 4071 4072 # Copy all the content of "output" directory to tempdir() 4073 # now we use a zip file as there are subdirectories... 4074 unzip(zipfile=file.path(lib,pkg,'output','R2HTMLstuff.zip'),exdir=tempdir()) 4075 4076 options(R2HTML.CSSdir=file.path(lib,pkg,"output")) 4077 options(R2HTML.sortableDF=FALSE) 4078 options(R2HTML.format.digits=2) 4079 options(R2HTML.format.nsmall=0) 4080 options(R2HTML.format.big.mark="") 4081 options(R2HTML.format.big.interval=3) 4082 options(R2HTML.format.decimal.mark=Sys.localeconv()[["decimal_point"]]) 4083 options(R2HTML.grid.first=TRUE) 4084 options(R2HTML.grid.stuffbasepath="./") 4085 4086} 4087 4088 4089options(R2HTML.sortableDF=FALSE) 4090options(R2HTML.format.digits=2) 4091options(R2HTML.format.nsmall=0) 4092options(R2HTML.format.big.mark="") 4093options(R2HTML.format.big.interval=3) 4094options(R2HTML.format.decimal.mark=Sys.localeconv()[["decimal_point"]]) 4095options(R2HTML.grid.first=TRUE) 4096options(R2HTML.grid.stuffbasepath="./") 4097 4098