diff --git a/DESCRIPTION b/DESCRIPTION index 7e99aa4..f497bdb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: table1 Type: Package -Version: 1.5 +Version: 1.5.9000 Date: 2025-04-25 Title: Tables of Descriptive Statistics in HTML Authors@R: person("Benjamin", "Rich", role=c("aut", "cre", "cph"), email="mail@benjaminrich.net") @@ -14,8 +14,19 @@ Description: Create HTML tables of descriptive statistics, as one would expect License: GPL-3 Depends: R (>= 3.5.0) Imports: stats,Formula,knitr,htmltools,yaml,methods -Suggests: boot,MatchIt,rmarkdown,printr,kableExtra,flextable,officer,Hmisc,survey +Suggests: + boot, + MatchIt, + rmarkdown, + printr, + kableExtra, + flextable, + officer, + Hmisc, + survey, + testthat (>= 3.0.0) VignetteBuilder: knitr Language: en-US Encoding: UTF-8 RoxygenNote: 7.3.2 +Config/testthat/edition: 3 diff --git a/NEWS.md b/NEWS.md index 6a41e26..75e1b42 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# table1 development version + +* Add `label_colspan` to `t1flex()` to allow variable labels to span all cells + (fix #133) + # table1 1.5 * Improvements to `kableExtra` output generated by `t1kable()`. diff --git a/R/t1flex.R b/R/t1flex.R new file mode 100644 index 0000000..865651b --- /dev/null +++ b/R/t1flex.R @@ -0,0 +1,74 @@ +#' Convert a \code{table1} object to \code{flextable}. +#' +#' @param x An object returned by \code{\link{table1}}. +#' @param tablefn Choose a function from the \code{flextable} package to use as +#' the basis for the table. +#' @param ... Further options passed to \code{tablefn}. +#' @param label_colspan Have variable labels span all columns in the table +#' @return A \code{flextable} object. +#' @note The \code{flextable} package needs to be installed for this to work. +#' @importFrom utils getFromNamespace +#' @export +t1flex <- function(x, tablefn=c("qflextable", "flextable", "regulartable"), ..., label_colspan = FALSE) { + if (!requireNamespace("flextable", quietly = TRUE)) { + stop("This function requires package 'flextable'. Please install it and try again.", call. = FALSE) # nocov + } + tablefn <- match.arg(tablefn) + tablefn <- getFromNamespace(tablefn, "flextable") + obj <- attr(x, "obj", exact = TRUE) + rlh <- if (is.null(obj$rowlabelhead) || obj$rowlabelhead=="") "\U{00A0}" else obj$rowlabelhead + i <- vapply(X = obj$contents, FUN = nrow, FUN.VALUE = 1) + i <- cumsum(c(1, i[-length(i)])) + each_group_df <- lapply(obj$contents, function(y) { + y <- as.data.frame(y, stringsAsFactors = FALSE) + y2 <- data.frame(x=paste0(c("", rep("\U{00A0}\U{00A0}", nrow(y) - 1)), rownames(y)), stringsAsFactors = FALSE) + y <- cbind(setNames(y2, rlh), y) + if (label_colspan) { + y[1,] <- y[1,1] + } + y + }) + all_group_df <- do.call(rbind, each_group_df) + + header_df <- data.frame( + labels = c(rlh, obj$headings), + keys = LETTERS[1:ncol(all_group_df)] + ) + + if (!is.null(obj$groupspan)) { + zzz <- ncol(all_group_df) - sum(obj$groupspan) - 1 + label2 <- c("", rep(obj$labels$groups, times=obj$groupspan), rep("", zzz)) + header_df <- cbind(data.frame(label2=label2), header_df) + } + + colnames(all_group_df) <- header_df$keys + rownames(all_group_df) <- NULL + out <- tablefn(all_group_df, ...) + out <- flextable::set_header_df(out, header_df, key="keys") + out <- flextable::merge_h(out, part = "header", i = 1) + #out <- flextable::merge_v(out, part = "header", j = 1) + #out <- flextable::theme_booktabs(out, bold_header = TRUE) + + # Add line above the top of the table + out <- flextable::hline_top(out, border = officer::fp_border(width=1.5), part = "header") + # Add line below the bottom of the header + out <- flextable::hline_bottom(out, border = officer::fp_border(width=1.5), part = "header") + # Center both data and header cells, except for the first column + out <- flextable::align(out, j=2:(obj$ncolumns+1), align="center", part="body") + out <- flextable::align(out, j=2:(obj$ncolumns+1), align="center", part="header") + # Make the top header bold + out <- flextable::bold(out, part="header") + # Make the category headers bold + out <- flextable::bold(out, i=i, j=1) + if (label_colspan) { + out <- flextable::merge_h(out, i = i) + } + + if (!is.null(obj$caption)) { + out <- flextable::set_caption(out, caption=obj$caption) + } + if (!is.null(obj$footnote)) { + out <- flextable::add_footer_lines(out, values=obj$footnote) + } + out +} diff --git a/R/table1.R b/R/table1.R index fa212cc..8d8c8ac 100644 --- a/R/table1.R +++ b/R/table1.R @@ -33,20 +33,20 @@ #' x <- c(0.9001, 12345, 1.2, 1., 0.1, 0.00001 , 1e5) #' signif_pad(x, digits=3) #' signif_pad(x, digits=3, round.integers=TRUE) -#' +#' #' # Compare: #' as.character(signif(x, digits=3)) #' format(x, digits=3, nsmall=3) #' prettyNum(x, digits=3, drop0trailing=TRUE) #' prettyNum(x, digits=3, drop0trailing=FALSE) -#' +#' #' # This is very close. -#' formatC(x, format="fg", flag="#", digits=3) +#' formatC(x, format="fg", flag="#", digits=3) #' formatC(signif(x, 3), format="fg", flag="#", digits=3) -#' +#' #' # Could always remove the trailing "." #' sub("[.]$", "", formatC(x, format="fg", flag="#", digits=3)) -#' +#' #' @keywords utilities #' @export signif_pad <- function(x, digits=3, round.integers=TRUE, round5up=TRUE, dec, ...) { @@ -152,7 +152,7 @@ format_n <- function (x, ...) { #' @examples #' x <- exp(rnorm(100, 1, 1)) #' stats.default(x) -#' +#' #' y <- factor(sample(0:1, 99, replace=TRUE), labels=c("Female", "Male")) #' y[1:10] <- NA #' stats.default(y) @@ -217,9 +217,9 @@ stats.default <- function(x, quantile.type=7, ...) { T1=NA, T2=NA) } else if (is.numeric(x)) { - p <- c(0.01, 0.025, 0.05, 0.1, 0.25, 1/3, 0.5, 2/3, 0.75, 0.9, 0.95, 0.975, 0.99) + p <- c(0.01, 0.025, 0.05, 0.1, 0.25, 1/3, 0.5, 2/3, 0.75, 0.9, 0.95, 0.975, 0.99) q <- quantile(x, probs=p, na.rm=TRUE, type=quantile.type) - names(q) <- c("0.01", "0.025", "0.05", "0.1", "0.25", "1/3", "0.5", "2/3", "0.75", "0.9", "0.95", "0.975", "0.99") + names(q) <- c("0.01", "0.025", "0.05", "0.1", "0.25", "1/3", "0.5", "2/3", "0.75", "0.9", "0.95", "0.975", "0.99") list( N=sum(!is.na(x)), NMISS=sum(is.na(x)), @@ -283,7 +283,7 @@ stats.default <- function(x, quantile.type=7, ...) { #' #' @return A list with the same number of elements as \code{x}. The rounded #' values will be \code{character} (not \code{numeric}) and will have 0 padding -#' to ensure consistent number of significant digits. +#' to ensure consistent number of significant digits. #' #' @seealso #' \code{\link{signif_pad}} @@ -344,7 +344,7 @@ stats.apply.rounding <- function(x, digits=3, digits.pct=1, round.median.min.max #' the table output. #' #' @param x A vector or numeric, factor, character or logical values. -#' @param name Name of the variable to be rendered (ignored). +#' @param name Name of the variable to be rendered (ignored). #' @param missing Should missing values be included? #' @param transpose Logical indicating whether on not the table is transposed. #' @param render.empty A \code{character} to return when \code{x} is empty. @@ -371,7 +371,7 @@ stats.apply.rounding <- function(x, digits=3, digits.pct=1, round.median.min.max #' x <- exp(rnorm(100, 1, 1)) #' render.default(x) #' render.default(x, TRUE) -#' +#' #' y <- factor(sample(0:1, 99, replace=TRUE), labels=c("Female", "Male")) #' y[1:10] <- NA #' render.default(y) @@ -427,7 +427,7 @@ render.default <- function(x, name, missing=any(is.na(x)), transpose=F, #' Parse abbreviated code for rendering table output. #' #' @param code A \code{character} vector specifying the statistics to display -#' in abbreviated code. See Details. +#' in abbreviated code. See Details. #' @param ... Further arguments, passed to \code{\link{stats.apply.rounding}}. #' #' @return A function that takes a single argument and returns a @@ -456,7 +456,7 @@ render.default <- function(x, name, missing=any(is.na(x)), transpose=F, #' f2(x) #' f3 <- parse.abbrev.render.code(c("Mean (SD)"), 3) #' f3(x) -#' +#' #' x <- sample(c("Male", "Female"), 30, replace=T) #' stats.default(x) #' f <- parse.abbrev.render.code("Freq (Pct%)") @@ -490,7 +490,7 @@ function(code, ...) { nm <- ifelse(sapply(res, seq_along)==1, "1", "") nm[nm=="1"] <- names(s) res <- unlist(res) - names(res) <- nm + names(res) <- nm c("", res) } else { if (length(codestr) == 1 && is.null(names(codestr))) { @@ -519,7 +519,7 @@ function(code, ...) { #' @examples #' x <- exp(rnorm(100, 1, 1)) #' render.continuous.default(x) -#' +#' #' @keywords utilities #' @export render.continuous.default <- function(x, ...) { @@ -658,7 +658,7 @@ render.strat <- function(strata, ..., transpose=F) { l <- ifelse(is.na(stratn), names(strata), sprintf("%s\n(N=%s)", names(strata), stratn)) attr(l, "html") <- { - ifelse(is.na(stratn), + ifelse(is.na(stratn), names(strata), sprintf("%s
(N=%s)", names(strata), stratn) ) @@ -674,11 +674,11 @@ render.strat <- function(strata, ..., transpose=F) { #' label the rows of the table. Row labels, if specified, can have a special #' HTML \code{class} designated, which can be useful as a hook to customize #' their appearance using CSS. The same is true for the the first and last row -#' of cells. +#' of cells. #' #' @param x A vector or table-like structure (e.g. a \code{\link{data.frame}} or \code{\link{matrix}}). #' @param row.labels Values for the first column, typically used to label the row, or \code{NULL} to omit. -#' @param th A logical. Should \code{th} tags be used rather than \code{td}? +#' @param th A logical. Should \code{th} tags be used rather than \code{td}? #' @param class HTML class attribute. Can be a single \code{character}, a vector or a matrix. #' @param rowlabelclass HTML class attribute for the row labels (i.e. first column). #' @param firstrowclass HTML class attribute for the first row of cells. @@ -800,7 +800,7 @@ has.label <- function(x) { #' @describeIn units Set units attribute. #' @export 'units<-' <- function(x, value) { - attr(x, "units") <- value + attr(x, "units") <- value x } @@ -826,7 +826,7 @@ has.units <- function(x) { #' deliberately not attempted, as this is best accomplished with CSS. To #' facilitate this, some tags (such as row labels) are given specific classes #' for easy CSS selection. -#' +#' #' For the formula version, the formula is expected to be a one-sided formula, #' optionally with a vertical bar separating the variables that are to appear #' as data in the table (as rows) from those used for stratification (i.e. @@ -901,53 +901,53 @@ has.units <- function(x) { #' dat$age <- runif(nrow(dat), 10, 50) #' dat$age[3] <- NA # Add a missing value #' dat$wt <- exp(rnorm(nrow(dat), log(70), 0.2)) -#' +#' #' label(dat$sex) <- "Sex" #' label(dat$age) <- "Age" #' label(dat$treat) <- "Treatment Group" #' label(dat$wt) <- "Weight" -#' +#' #' units(dat$age) <- "years" #' units(dat$wt) <- "kg" -#' +#' #' # One level of stratification #' table1(~ sex + age + wt | treat, data=dat) -#' +#' #' # Two levels of stratification (nesting) #' table1(~ age + wt | treat*sex, data=dat) -#' +#' #' # Switch the order or nesting #' table1(~ age + wt | sex*treat, data=dat) -#' +#' #' # No stratification #' table1(~ treat + sex + age + wt, data=dat) -#' +#' #' # Something more complicated -#' +#' #' dat$dose <- ifelse(dat$treat=="Placebo", "Placebo", #' sample(c("5 mg", "10 mg"), nrow(dat), replace=TRUE)) #' dat$dose <- factor(dat$dose, levels=c("Placebo", "5 mg", "10 mg")) -#' +#' #' strata <- c(split(dat, dat$dose), #' list("All treated"=subset(dat, treat=="Treated")), #' list(Overall=dat)) -#' +#' #' labels <- list( #' variables=list(sex=render.varlabel(dat$sex), #' age=render.varlabel(dat$age), #' wt=render.varlabel(dat$wt)), #' groups=list("", "Treated", "")) -#' +#' #' my.render.cont <- function(x) { -#' with(stats.default(x), +#' with(stats.default(x), #' sprintf("%0.2f (%0.1f)", MEAN, SD)) #' } -#' +#' #' table1(strata, labels, groupspan=c(1, 3, 1), render.continuous=my.render.cont) #' #' # Transposed table #' table1(~ age + wt | treat, data=dat, transpose=TRUE) -#' +#' #' @keywords utilities #' @export table1 <- function(x, ...) { @@ -1218,73 +1218,6 @@ as.data.frame.table1 <- function(x, ...) { }) } -#' Convert a \code{table1} object to \code{flextable}. -#' -#' @param x An object returned by \code{\link{table1}}. -#' @param tablefn Choose a function from the \code{flextable} package to use as -#' the basis for the table. -#' @param ... Further options passed to \code{tablefn}. -#' @return A \code{flextable} object. -#' @note The \code{flextable} package needs to be installed for this to work. -#' @importFrom utils getFromNamespace -#' @export -t1flex <- function(x, tablefn=c("qflextable", "flextable", "regulartable"), ...) { - if (!requireNamespace("flextable", quietly = TRUE)) { - stop("This function requires package 'flextable'. Please install it and try again.", call.=F) - } - tablefn <- match.arg(tablefn) - tablefn <- getFromNamespace(tablefn, "flextable") - obj <- attr(x, "obj", exact=TRUE) - with(obj, { - rlh <- if (is.null(rowlabelhead) || rowlabelhead=="") "\U{00A0}" else rowlabelhead - i <- lapply(contents, function(y) { - nrow(y) - }) - i <- cumsum(c(1, i[-length(i)])) - z <- lapply(contents, function(y) { - y <- as.data.frame(y, stringsAsFactors=F) - y2 <- data.frame(x=paste0(c("", rep("\U{00A0}\U{00A0}", nrow(y) - 1)), rownames(y)), stringsAsFactors=F) - y <- cbind(setNames(y2, rlh), y) - y - }) - df <- do.call(rbind, z) - - header_df <- data.frame( - labels = c(rlh, headings), - keys = LETTERS[1:ncol(df)] - ) - - if (!is.null(groupspan)) { - zzz <- ncol(df) - sum(groupspan) - 1 - label2 <- c("", rep(labels$groups, times=groupspan), rep("", zzz)) - header_df <- cbind(data.frame(label2=label2), header_df) - } - - colnames(df) <- header_df$keys - rownames(df) <- NULL - - out <- tablefn(df, ...) - out <- flextable::set_header_df(out, header_df, key="keys") - out <- flextable::merge_h(out, part = "header", i = 1) - #out <- flextable::merge_v(out, part = "header", j = 1) - #out <- flextable::theme_booktabs(out, bold_header = TRUE) - out <- flextable::hline_top(out, border = officer::fp_border(width=1.5), part = "header") - out <- flextable::hline_bottom(out, border = officer::fp_border(width=1.5), part = "header") - out <- flextable::align(out, j=2:(ncolumns+1), align="center", part="body") - out <- flextable::align(out, j=2:(ncolumns+1), align="center", part="header") - out <- flextable::bold(out, part="header") - out <- flextable::bold(out, i=i, j=1) - - if (!is.null(caption)) { - out <- flextable::set_caption(out, caption=caption) - } - if (!is.null(footnote)) { - out <- flextable::add_footer_lines(out, values=footnote) - } - out - }) -} - #' Convert a \code{table1} object to \code{kabelExtra}. #' #' @param x An object returned by \code{\link{table1}}. @@ -1539,7 +1472,7 @@ table1.formula <- function(x, data, overall="Overall", rowlabelhead="", transpos if (is.null(overall) || (is.logical(overall) && overall == FALSE)) { stop("Table has no columns?!") } - stratlabel <- overall + stratlabel <- overall } for (i in 1:ncol(m1)) { if (!has.label(m1[[i]])) { @@ -1679,11 +1612,11 @@ factorp <- function(x, ...) { #' x <- c(3.7, 3.3, 3.5, 2.8) #' y <- c(1, 2, 1, 2) #' w <- c(5, 3, 4, 1) -#' +#' #' z <- weighted(x=x, w=w) #' weights(z) #' weights(z[2:3]) # Weights are preserved -#' +#' #' d <- weighted( #' data.frame( #' x=x, @@ -1691,7 +1624,7 @@ factorp <- function(x, ...) { #' ), #' w #' ) -#' +#' #' weights(d) #' weights(d[[1]]) #' weights(d$x) @@ -1769,18 +1702,18 @@ weights.weighted <- function(object, ...) { #' @examples #' x <- c(3.7, 3.3, 3.5, 2.8) #' y <- c(1, 2, 1, 2) -#' +#' #' z <- indexed(x=x) #' indices(z) #' indices(z[2:3]) # Indices are preserved -#' +#' #' d <- indexed( #' data.frame( #' x=x, #' y=y #' ) #' ) -#' +#' #' indices(d) #' indices(d[[1]]) #' indices(d$x) diff --git a/man/signif_pad.Rd b/man/signif_pad.Rd index ba60e1b..21a4f98 100644 --- a/man/signif_pad.Rd +++ b/man/signif_pad.Rd @@ -51,7 +51,7 @@ prettyNum(x, digits=3, drop0trailing=TRUE) prettyNum(x, digits=3, drop0trailing=FALSE) # This is very close. -formatC(x, format="fg", flag="#", digits=3) +formatC(x, format="fg", flag="#", digits=3) formatC(signif(x, 3), format="fg", flag="#", digits=3) # Could always remove the trailing "." diff --git a/man/t1flex.Rd b/man/t1flex.Rd index 0231ea2..645c419 100644 --- a/man/t1flex.Rd +++ b/man/t1flex.Rd @@ -1,10 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/table1.R +% Please edit documentation in R/t1flex.R \name{t1flex} \alias{t1flex} \title{Convert a \code{table1} object to \code{flextable}.} \usage{ -t1flex(x, tablefn = c("qflextable", "flextable", "regulartable"), ...) +t1flex( + x, + tablefn = c("qflextable", "flextable", "regulartable"), + ..., + label_colspan = FALSE +) } \arguments{ \item{x}{An object returned by \code{\link{table1}}.} @@ -13,6 +18,8 @@ t1flex(x, tablefn = c("qflextable", "flextable", "regulartable"), ...) the basis for the table.} \item{...}{Further options passed to \code{tablefn}.} + +\item{label_colspan}{Have variable labels span all columns in the table} } \value{ A \code{flextable} object. diff --git a/man/table1.Rd b/man/table1.Rd index 9366d8a..47defcc 100644 --- a/man/table1.Rd +++ b/man/table1.Rd @@ -195,7 +195,7 @@ labels <- list( groups=list("", "Treated", "")) my.render.cont <- function(x) { - with(stats.default(x), + with(stats.default(x), sprintf("\%0.2f (\%0.1f)", MEAN, SD)) } diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..7c55199 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(table1) + +test_check("table1") diff --git a/tests/testthat/test-t1flex.R b/tests/testthat/test-t1flex.R new file mode 100644 index 0000000..f91ce2b --- /dev/null +++ b/tests/testthat/test-t1flex.R @@ -0,0 +1,15 @@ +test_that("t1flex", { + skip_if_not_installed("flextable") + d <- data.frame(A = 1:10, B = 11:20) + expect_error( + t1flex(d, tablefn = "foo") + ) + + label(d$A) <- "Anything really long will illustrate the point here" + t1 <- table1(~A+B, data = d) + non_span <- t1flex(t1) + spanning <- t1flex(t1, label_colspan = TRUE) + + expect_equal(non_span$body$spans$rows[1,1], 1) + expect_equal(spanning$body$spans$rows[1,1], 2) +})