From 3a93412219b228ecc2739391d830f882e5385d8f Mon Sep 17 00:00:00 2001 From: dscott Date: Thu, 28 Jan 2016 12:49:06 +0000 Subject: [PATCH] git-svn-id: svn://scm.r-forge.r-project.org/svnroot/xtable@104 edb9625f-4e0d-4859-8d74-9fd3b1da38cb --- pkg/NAMESPACE | 7 +- pkg/R/format.ftable.R | 99 ++++++++++++++++++++++++++ pkg/R/xtable.R | 18 +++-- pkg/R/xtableFtable.R | 4 +- pkg/man/format.ftable.Rd | 66 +++++++++++++++++ pkg/man/xtable.Rd | 2 +- pkg/vignettes/OtherPackagesGallery.Rnw | 76 ++++++++++++-------- 7 files changed, 231 insertions(+), 41 deletions(-) create mode 100644 pkg/R/format.ftable.R create mode 100644 pkg/man/format.ftable.Rd diff --git a/pkg/NAMESPACE b/pkg/NAMESPACE index f5c4c69..9daba6a 100644 --- a/pkg/NAMESPACE +++ b/pkg/NAMESPACE @@ -10,7 +10,8 @@ export("caption<-", "caption", "label", "label<-", "xtableFtable", "print.xtableFtable", "toLatex.xtable", "autoformat", "xalign", "xdigits", "xdisplay", - "sanitize", "sanitize.numbers", "sanitize.final", "as.is", "as.math") + "sanitize", "sanitize.numbers", "sanitize.final", "as.is", "as.math", + "format.ftable") S3method("print", "xtable") S3method("print", "xtableMatharray") @@ -29,6 +30,8 @@ S3method("digits<-", "xtable") S3method("display<-", "xtable") S3method("display", "xtable") +S3method("format", "ftable") + S3method("xtable", "data.frame") S3method("xtable", "matrix") S3method("xtable", "table") @@ -53,7 +56,7 @@ S3method("xtable", "summary.gmsar") S3method("xtable", "stsls") S3method("xtable", "summary.stsls") S3method("xtable", "sarlm.pred") -S3method("xtable", "lagImpact") +###S3method("xtable", "lagImpact") S3method("xtable", "splm") S3method("xtable", "summary.splm") S3method("xtable", "sphet") diff --git a/pkg/R/format.ftable.R b/pkg/R/format.ftable.R new file mode 100644 index 0000000..065cd3a --- /dev/null +++ b/pkg/R/format.ftable.R @@ -0,0 +1,99 @@ +### copy of function stats:::format.ftable because unexported from stats +format.ftable <- function (x, quote = TRUE, digits = getOption("digits"), + method = c("non.compact", "row.compact", + "col.compact", "compact"), + lsep = " | ", ...) +{ + if (!inherits(x, "ftable")) + stop("'x' must be an \"ftable\" object") + charQuote <- function(s) { + if (quote && length(s)){ + paste0("\"", s, "\"") + } else { + s + } + } + makeLabels <- function(lst) { + lens <- lengths(lst) + cplensU <- c(1, cumprod(lens)) + cplensD <- rev(c(1, cumprod(rev(lens)))) + y <- NULL + for (i in rev(seq_along(lst))) { + ind <- 1 + seq.int(from = 0, to = lens[i] - 1) * + cplensD[i + 1L] + tmp <- character(length = cplensD[i]) + tmp[ind] <- charQuote(lst[[i]]) + y <- cbind(rep(tmp, times = cplensU[i]), y) + } + y + } + makeNames <- function(x) { + nmx <- names(x) + if (is.null(nmx)) { + rep_len("", length(x)) + } else { + nmx + } + } + l.xrv <- length(xrv <- attr(x, "row.vars")) + l.xcv <- length(xcv <- attr(x, "col.vars")) + method <- match.arg(method) + if (l.xrv == 0) { + if (method == "col.compact"){ + method <- "non.compact" + } else if (method == "compact") { + method <- "row.compact" + } + } + if (l.xcv == 0) { + if (method == "row.compact") { + method <- "non.compact" + } else if (method == "compact") { + method <- "col.compact" + } + } + LABS <- switch(method, + non.compact = + {cbind(rbind(matrix("", + nrow = length(xcv), + ncol = length(xrv)), + charQuote(makeNames(xrv)), + makeLabels(xrv)), + c(charQuote(makeNames(xcv)), + rep("", times = nrow(x) + 1)))}, + row.compact = + {cbind(rbind(matrix("", + nrow = length(xcv) - 1, + ncol = length(xrv)), + charQuote(makeNames(xrv)), + makeLabels(xrv)), + c(charQuote(makeNames(xcv)), + rep("", times = nrow(x))))}, + col.compact = + {cbind(rbind(cbind(matrix("", + nrow = length(xcv), + ncol = length(xrv) - 1), + charQuote(makeNames(xcv))), + charQuote(makeNames(xrv)), + makeLabels(xrv)))}, + compact = + {xrv.nms <- makeNames(xrv) + xcv.nms <- makeNames(xcv) + mat <- + cbind(rbind(cbind(matrix("", + nrow = l.xcv - 1, + ncol = l.xrv - 1), + charQuote(makeNames(xcv[-l.xcv]))), + charQuote(xrv.nms), makeLabels(xrv))) + mat[l.xcv, l.xrv] <- paste(tail(xrv.nms, 1), + tail(xcv.nms, 1), + sep = lsep) + mat}, + stop("wrong method")) + DATA <- rbind(if (length(xcv)) t(makeLabels(xcv)), + if (method %in% c("non.compact", "col.compact")) + { rep("", times = ncol(x)) }, + format(unclass(x), digits = digits, ...) ) + cbind(apply(LABS, 2L, format, justify = "left"), + apply(DATA, 2L, format, justify = "right")) +} diff --git a/pkg/R/xtable.R b/pkg/R/xtable.R index 8313808..6cf0e17 100644 --- a/pkg/R/xtable.R +++ b/pkg/R/xtable.R @@ -395,14 +395,18 @@ xtable.sarlm.pred <- function(x, caption = NULL, label = NULL, align = NULL, display = display, auto = auto, ...)) } + +### This method removed because of the need to copy code to pass CRAN checks +### lagImpactMat is neither exported nor documented in spdep + ### lagImpact objects -xtable.lagImpact <- function(x, caption = NULL, label = NULL, align = NULL, - digits = NULL, display = NULL, - auto = FALSE, ...) { - xtable(spdep:::lagImpactMat(x), caption = caption, label = label, - align = align, digits = digits, - display = display, auto = auto, ...) -} +## xtable.lagImpact <- function(x, caption = NULL, label = NULL, align = NULL, +## digits = NULL, display = NULL, +## auto = FALSE, ...) { +## xtable(spdep:::lagImpactMat(x), caption = caption, label = label, +## align = align, digits = digits, +## display = display, auto = auto, ...) +## } ### package splm ### splm objects diff --git a/pkg/R/xtableFtable.R b/pkg/R/xtableFtable.R index 34b544d..dafb6f0 100644 --- a/pkg/R/xtableFtable.R +++ b/pkg/R/xtableFtable.R @@ -110,8 +110,8 @@ print.xtableFtable <- function(x, nCharCols <- attr(x, "nChars")[2] nRowVars <- length(attr(x, "row.vars")) nColVars <- length(attr(x, "col.vars")) - fmtFtbl <- stats:::format.ftable(x, quote = quote, digits = digits, - method = method, lsep = lsep) + fmtFtbl <- format.ftable(x, quote = quote, digits = digits, + method = method, lsep = lsep) attr(fmtFtbl, "caption") <- caption attr(fmtFtbl, "label") <- label ## if method is "compact", rotate both if either requested diff --git a/pkg/man/format.ftable.Rd b/pkg/man/format.ftable.Rd new file mode 100644 index 0000000..962af8c --- /dev/null +++ b/pkg/man/format.ftable.Rd @@ -0,0 +1,66 @@ +%% File src/library/stats/man/read.ftable.Rd +%% Part of the R package, https://www.R-project.org +%% Copyright 1995-2014 R Core Team +%% Copyright 2002-2013 The R Foundation +%% Distributed under GPL 2 or later + +%% Copied to document copy of unexported function format.ftable + +\name{format.ftable} +\title{Format Flat Contingency Tables} +\alias{format.ftable} +\description{ + Format \sQuote{flat} contingency tables. +} +\usage{ +\method{format}{ftable}(x, quote = TRUE, digits = getOption("digits"), + method = c("non.compact", "row.compact", + "col.compact", "compact"), + lsep = " | ", \dots) +} +\arguments{ + \item{x}{an object of class \code{"ftable"}.} + \item{quote}{a character string giving the set of quoting characters + for \code{read.ftable}; to disable quoting altogether, use + \code{quote=""}. For \code{write.table}, a logical indicating + whether strings in the data will be surrounded by double quotes.} + \item{digits}{an integer giving the number of significant digits to + use for (the cell entries of) \code{x}.} + \item{method}{string specifying how the \code{"ftable"} object is formatted + (and printed if used as in \code{write.ftable()} or the \code{print} + method). Can be abbreviated. Available methods are (see the examples): + \describe{ + \item{"non.compact"}{the default representation of an + \code{"ftable"} object.} + \item{"row.compact"}{a row-compact version without empty cells + below the column labels.} + \item{"col.compact"}{a column-compact version without empty cells + to the right of the row labels.} + \item{"compact"}{a row- and column-compact version. This may imply + a row and a column label sharing the same cell. They are then + separated by the string \code{lsep}.} + } + } + \item{lsep}{only for \code{method = "compact"}, the separation string + for row and column labels.} + \item{\dots}{further arguments such as \code{method}, passed to + \code{format()}.} +} +\details{ + This format method is a copy of \code{format.ftable} from + \pkg{stats}, and this man page is derived from the page + \code{\link[stats]{read.ftable}}. +} +\seealso{ + \code{\link[stats]{ftable}} and + \code{\link[stats]{read.ftable}} for more information on flat + contingency tables. +} +\examples{ +ft22 <- ftable(Titanic, row.vars = 2:1, col.vars = 4:3) +write.ftable(ft22, quote = FALSE) +write.ftable(ft22, quote = FALSE, method="row.compact") +write.ftable(ft22, quote = FALSE, method="col.compact") +write.ftable(ft22, quote = FALSE, method="compact") +} +\keyword{category} diff --git a/pkg/man/xtable.Rd b/pkg/man/xtable.Rd index 29efa7c..3277d56 100644 --- a/pkg/man/xtable.Rd +++ b/pkg/man/xtable.Rd @@ -25,7 +25,7 @@ \alias{xtable.stsls} \alias{xtable.summary.stsls} \alias{xtable.sarlm.pred} -\alias{xtable.lagImpact} +%%%\alias{xtable.lagImpact} \alias{xtable.splm} \alias{xtable.summary.splm} \alias{xtable.sphet} diff --git a/pkg/vignettes/OtherPackagesGallery.Rnw b/pkg/vignettes/OtherPackagesGallery.Rnw index d23db16..fff3c40 100644 --- a/pkg/vignettes/OtherPackagesGallery.Rnw +++ b/pkg/vignettes/OtherPackagesGallery.Rnw @@ -139,25 +139,35 @@ xtable(COL.lag.stsls) xtable(p1) @ %def -This method transforms the \code{sarlm.pred} objects into data frames, allowing any number of attributes vectors which may vary according to predictor types. +This method transforms the \code{sarlm.pred} objects into data frames, +allowing any number of attributes vectors which may vary according to +predictor types. <>= xtable(p2) @ %def -\subsubsection{\code{lagImpact} objects} -\label{sec:codelagimpact-objects} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% xtable.lagImpactMat removed because of problems with unexported function +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -The \code{xtable} method returns the values of direct, indirect and total impacts for all the variables in the model. The class \code{lagImpact} have two different sets of attributes according to if simulations are used. But the \code{xtable} method always returns the three components of the non-simulation case. +%% \subsubsection{\code{lagImpact} objects} +%% \label{sec:codelagimpact-objects} -<>= -xtable(imp.exact) -@ %def +%% The \code{xtable} method returns the values of direct, indirect and +%% total impacts for all the variables in the model. The class +%% \code{lagImpact} have two different sets of attributes according to if +%% simulations are used. But the \code{xtable} method always returns the +%% three components of the non-simulation case. -\p -<>= -xtable(imp.sim) -@ %def +%% <>= +%% xtable(imp.exact) +%% @ %def + +%% \p +%% <>= +%% xtable(imp.sim) +%% @ %def \subsubsection{\code{spautolm} objects} @@ -226,11 +236,16 @@ xtable(respatlag) xtable(GM) @ %def -The \code{xtable} method works the same on impacts of \code{splm} models. -<>= -xtable(imp.spml) -@ %def +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% xtable.lagImpactMat removed because of problems with unexported function +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% The \code{xtable} method works the same on impacts of \code{splm} models. + +%% <>= +%% xtable(imp.spml) +%% @ %def \subsection{The package \pkg{sphet}} \label{sec:package-pkgsphet} @@ -265,23 +280,26 @@ xtable(res.stsls) xtable(res.gstsls) @ %def -\code{sphet} also provides a method for computing impacts. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% xtable.lagImpactMat removed because of problems with unexported function +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% \code{sphet} also provides a method for computing impacts. -<>= -xtable(imp.gstsls) -@ %def +%% <>= +%% xtable(imp.gstsls) +%% @ %def \section{The \pkg{zoo} package} \label{sec:pkgzoo-package} - + <>= library(zoo) xDate <- as.Date("2003-02-01") + c(1, 3, 7, 9, 14) - 1 as.ts(xDate) x <- zoo(rnorm(5), xDate) xtable(x) -@ %def +@ %def \p @@ -293,21 +311,21 @@ tempTable <- xtable(tempTs, digits = 0) tempTable tempZoo <- as.zoo(tempTs) xtable(tempZoo, digits = 0) -@ %def +@ %def \section{The \pkg{survival} package} \label{sec:pkgsurvival-package} - + <>= library(survival) -test1 <- list(time=c(4,3,1,1,2,2,3), - status=c(1,1,1,0,1,1,0), - x=c(0,2,1,1,1,0,0), - sex=c(0,0,0,0,1,1,1)) -coxFit <- coxph(Surv(time, status) ~ x + strata(sex), test1) +test1 <- list(time=c(4,3,1,1,2,2,3), + status=c(1,1,1,0,1,1,0), + x=c(0,2,1,1,1,0,0), + sex=c(0,0,0,0,1,1,1)) +coxFit <- coxph(Surv(time, status) ~ x + strata(sex), test1) xtable(coxFit) -@ %def +@ %def \end{document} -- 2.39.5