diff --git a/.Rbuildignore b/.Rbuildignore index 851dbf47..f96df203 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,6 +1,10 @@ \.github \.drone\.jsonnet ^data-raw$ + +tests/testthat/image/build +tests/testthat/image/*\.html + inst/demo-longtable\.log inst/demo-longtable\.tex inst/demo-pmtable\.log diff --git a/.gitignore b/.gitignore index 8a9174e8..156b0287 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,8 @@ tests/testthat/validate/validate.log + +tests/testthat/image/build +tests/testthat/image/*.html + inst/demo-longtable.log inst/demo-longtable.tex inst/demo-pmtable.log diff --git a/DESCRIPTION b/DESCRIPTION index 681368ae..d411bc2b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: pmtables Type: Package Title: Tables for Pharmacometrics -Version: 0.4.1 +Version: 0.5.0 Authors@R: c( person(given = "Kyle", @@ -32,7 +32,7 @@ License: GPL (>=2) Imports: purrr, dplyr (>= 1.0.0), forcats, tidyr, rlang, glue, tibble, assertthat, tidyselect, stringr, knitr, rmarkdown Depends: R (>= 3.5.0) -Suggests: testthat, yaml, fs, texPreview +Suggests: testthat, yaml, fs, texPreview, magick, pdftools Encoding: UTF-8 Language: en-US LazyData: true @@ -52,6 +52,7 @@ Collate: 'demographics-table.R' 'discrete_table.R' 'knit-dependencies.R' + 'preview-standalone.R' 'preview.R' 'summarize-cat-chunk.R' 'table-align.R' diff --git a/NAMESPACE b/NAMESPACE index 153be858..60405145 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,8 +16,13 @@ S3method(new_names,rowpanel) S3method(print,digits) S3method(print,stable_data) S3method(print,stobject) +S3method(st_as_image,pmtable) +S3method(st_as_image,stable) +S3method(st_as_image,stobject) S3method(st_control,default) S3method(st_control,stobject) +S3method(st_new,data.frame) +S3method(st_new,pmtable) S3method(st_wrap,default) S3method(st_wrap,stable_long) S3method(stable,data.frame) @@ -77,11 +82,16 @@ export(rowpanel) export(sig) export(st2article) export(st2doc) +export(st2pdf) +export(st2png) export(st2report) export(st2viewer) export(st_align) export(st_args) +export(st_as_image) export(st_asis) +export(st_aspdf) +export(st_aspng) export(st_blank) export(st_bold) export(st_center) @@ -93,6 +103,7 @@ export(st_drop) export(st_edit) export(st_files) export(st_hline) +export(st_image_show) export(st_it) export(st_knit_deps) export(st_latex) @@ -102,6 +113,12 @@ export(st_mutate) export(st_new) export(st_noteconf) export(st_notes) +export(st_notes_app) +export(st_notes_conf) +export(st_notes_detach) +export(st_notes_rm) +export(st_notes_str) +export(st_notes_sub) export(st_panel) export(st_preview) export(st_rename) @@ -135,6 +152,7 @@ export(triage_data) export(yaml_as_df) importFrom(assertthat,assert_that) importFrom(assertthat,validate_that) +importFrom(dplyr,across) importFrom(dplyr,arrange) importFrom(dplyr,bind_cols) importFrom(dplyr,bind_rows) @@ -203,6 +221,7 @@ importFrom(stringr,str_split) importFrom(tibble,as_tibble) importFrom(tibble,is_tibble) importFrom(tibble,tibble) +importFrom(tidyr,complete) importFrom(tidyr,fill) importFrom(tidyr,pivot_longer) importFrom(tidyr,pivot_wider) @@ -213,6 +232,7 @@ importFrom(tidyselect,all_of) importFrom(tidyselect,contains) importFrom(tidyselect,eval_rename) importFrom(tidyselect,eval_select) +importFrom(tools,file_ext) importFrom(utils,capture.output) importFrom(utils,packageVersion) importFrom(utils,str) diff --git a/NEWS.md b/NEWS.md index 3fc6311f..0eb752c9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,37 @@ +# pmtables 0.5.0 + +- New functions `st_as_image()`, `st2pdf()`, and `st2png()` to render tables with + TeX to either `pdf` or `png` format; image files may be kept on disk + or read back for display while knitting; `pdflatex` system dependency for + `pdf` images and `latex` + `dvipng` for `png` images; additional Suggested + packages include `magick` and `pdftools` (#277, #278). + +- `sig()` now returns character when integer type is passed (#272). + +- `st_new()` is now generic with dispatch for `data.frame` and objects with + class `pmtable`; most pipeline functions can now be used to customize + tables coming from `pt_cat_*`, `pt_cont_*`, `pt_demographics()` and + `pt_data_inventory()` (#274). + +- New functions `st_notes_detach()`, `st_notes_rm()`, `st_notes_app()`, + `st_notes_str()`, `st_notes_sub()` and `st_notes_conf()` to help working + with table notes in a pipe context (#274). + +- `st_span()` and `st_span_split()` accept `align` argument to push column + spanner titles to the left, right or center (default); the argument eventually + gets passed to `colgroup()` (#261). + +- `pt_cat_wide()`, `pt_cat_long()` and `pt_demographics()` gain argument + `denom` to alter the denominator when calculating percents for categorical + data summaries (#268). + +- `pt_cat_wide()` gains argument `complete` to display missing levels of + `by` and `panel` (#268). + +- Put stories in yaml format; add script to build validation docs from the + yaml file (#269, #270). + + # pmtables 0.4.1 - `colgroup()` (and `st_span()`) gains an `align` argument to position diff --git a/R/AAAA.R b/R/AAAA.R index 2ac50004..3cdb7292 100644 --- a/R/AAAA.R +++ b/R/AAAA.R @@ -3,10 +3,11 @@ #' @importFrom dplyr mutate bind_rows select ungroup summarise left_join #' @importFrom dplyr group_modify rename count vars group_by n first last #' @importFrom dplyr case_when filter arrange group_vars distinct bind_cols -#' @importFrom dplyr groups slice everything mutate_at +#' @importFrom dplyr groups slice everything mutate_at across #' @importFrom purrr map_dfr walk partial map map_chr modify flatten_chr imap #' @importFrom purrr flatten_int map_lgl modify_if map_int map2 keep flatten #' @importFrom tidyr pivot_wider pivot_longer replace_na fill separate unite +#' @importFrom tidyr complete #' @importFrom forcats fct_inorder #' @importFrom rlang sym syms quo_get_expr as_string := .data .env is_empty #' @importFrom rlang enquo enquos is_named is_atomic flatten_if have_name @@ -15,6 +16,7 @@ #' @importFrom stats median rnorm sd na.omit setNames #' @importFrom utils capture.output packageVersion str #' @importFrom stringr fixed str_split str_count str_detect str_replace +#' @importFrom tools file_ext #' #' @include summary-functions.R #' @include utils.R diff --git a/R/continuous_table.R b/R/continuous_table.R index 436a0f0a..ad41104b 100644 --- a/R/continuous_table.R +++ b/R/continuous_table.R @@ -154,8 +154,8 @@ pt_cont_wide <- function(data, cols, has_by <- !missing(by) - tst <- fun(rnorm(10)) - assert_that(identical(names(tst),"summary")) + tst <- fun(c(1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7)) + assert_that(identical(names(tst), "summary")) cols <- new_names(cols,table) by <- new_names(by,table) diff --git a/R/demographics-table.R b/R/demographics-table.R index 86f8616f..2cda008e 100644 --- a/R/demographics-table.R +++ b/R/demographics-table.R @@ -82,6 +82,8 @@ dem_cont_fun <- function(value = seq(1,5), name = "", ..., fmt = sig, #' #' This function makes a single table from both continuous and categorical data. #' +#' @inheritParams pt_cont_long +#' @inheritParams cat_data #' @param data the data frame to summarize; the user should filter or subset #' so that data contains exactly the records to be summarized; pmtables will not #' add or remove rows prior to summarizing data @@ -109,8 +111,6 @@ dem_cont_fun <- function(value = seq(1,5), name = "", ..., fmt = sig, #' column with non-repeating names cleared and separated with `hline` (see #' examples). #' -#' @inheritParams pt_cont_long -#' #' @details #' When a continuous data summary function (`fun`) is passed, the user should #' also pass a set of notes that explain the summary statistics produced @@ -183,10 +183,11 @@ pt_demographics <- function(data, cols_cont, cols_cat, stat_name = "Statistic", stat_width = 2, summarize_all = TRUE, - all_name = "All data", + all_name = "Summary", fun = dem_cont_fun, notes = pt_demographics_notes(), - paneled = TRUE) { + paneled = TRUE, + denom = c("group", "total")) { summarize_all <- isTRUE(summarize_all) summarize_span <- !is.null(span) @@ -242,14 +243,16 @@ pt_demographics <- function(data, cols_cont, cols_cat, data, cols = all_of(cols_cat), span = span, - summarize = "top" + summarize = "top", + denom = denom ) } if(summarize_all) { cat_table_all0 <- pt_cat_long( data, cols = all_of(cols_cat), - summarize = "top" + summarize = "top", + denom = denom ) cat_table_all <- rename(cat_table_all0[["data"]], value = "Summary") } diff --git a/R/discrete_table.R b/R/discrete_table.R index 95bcb900..f13bf33f 100644 --- a/R/discrete_table.R +++ b/R/discrete_table.R @@ -40,12 +40,17 @@ prep_cat_data <- function(data, cols) { #' Summarize categorical data #' #' @inheritParams pt_cont_wide +#' @inheritParams pt_cat_wide #' @param summarize_all logical indicating whether or not to include a summary -#' of the full data in the output -#' @param all_name label for full data summary -#' @param nby number of unique levels for the `by` variable +#' of the full data in the output. +#' @param all_name label for full data summary. +#' @param nby number of unique levels for the `by` variable. #' @param wide `logical`; if `TRUE`, data frame will be returned in wide format; -#' if `FALSE`, it will be returned in `long` format +#' if `FALSE`, it will be returned in `long` format. +#' @param denom the denominator to use when calculating percent for each level; +#' `group` uses the total number in the chunk being summarized; `total` uses +#' the total number in the data set; historically, `group` has been used as the +#' default. #' #' @examples #' @@ -54,7 +59,10 @@ prep_cat_data <- function(data, cols) { #' @export cat_data <- function(data, cols, by = ".total", panel = by, summarize_all = TRUE, all_name = "All", - wide = FALSE, nby = NULL) { + wide = FALSE, nby = NULL, complete = FALSE, + denom = c("group", "total")) { + + denom <- match.arg(denom) cols <- new_names(cols) @@ -64,15 +72,18 @@ cat_data <- function(data, cols, by = ".total", panel = by, if(is.null(nby)) nby <- length(unique(data[[by]])) - .groups <- unique(c(panel,by)) + .groups <- unique(c(panel, by)) data <- group_by(data, !!!syms(unname(.groups))) - ans <- group_modify(data, ~ summarize_cat_chunk(.,cols)) + ans <- group_modify( + data, + ~ summarize_cat_chunk(., cols = cols, N = nrow(data), denom = denom) + ) ans <- ungroup(ans) - ans <- mutate(ans,name=names(cols)[.data[["name"]]]) + ans <- mutate(ans, name = names(cols)[.data[["name"]]]) if(wide) { ans <- pivot_wider( @@ -81,6 +92,14 @@ cat_data <- function(data, cols, by = ".total", panel = by, values_from = "summary", names_sep = '_._' ) + if(isTRUE(complete)) { + ans <- complete(ans, !!!syms(.groups)) + nstart <- length(.groups) + nend <- ncol(ans) + ans <- mutate(ans, across(nstart+1, replace_na, 0)) + ans <- mutate(ans, across(seq(nstart+2, nend), replace_na, "0 (0.0)")) + } + ans } else { ans[["N"]] <- NULL ans <- pivot_wider( @@ -96,6 +115,7 @@ cat_data <- function(data, cols, by = ".total", panel = by, #' Discrete data summary in long format #' #' @inheritParams pt_cont_long +#' @inheritParams cat_data #' @param span variable name for column spanner #' @param all_name_span table column name to use for data summaries across #' levels of `span` if it is provided @@ -104,7 +124,14 @@ cat_data <- function(data, cols, by = ".total", panel = by, #' @param by use `span` argument instead #' #' @details -#' The data summary for all cells in the table is `count (percent)`. +#' The data summary for all cells in the table is `count (percent)`. The number +#' of data records in each column variable level is given under the column +#' title as `n`. +#' +#' When `group` is selected for `denom`, `percent` is calculated with +#' denominator set to `n`, the total for each column variable level. When +#' `total` is selected for `denom`, then `percent` is calculated by the total +#' number of records in the input data. #' #' The notes in this table are generated with [pt_cat_long_notes()]. #' @@ -120,14 +147,17 @@ cat_data <- function(data, cols, by = ".total", panel = by, #' An object with class `pmtable`; see [class-pmtable]. #' #' @export -pt_cat_long <- function(data, cols, span = ".total", +pt_cat_long <- function(data, cols, span = ".total", all_name = " ", all_name_span = "Summary", summarize = c("both", "right", "top", "none"), - table = NULL, by = NULL) { + table = NULL, by = NULL, + denom = c("group", "total")) { summarize <- match.arg(summarize) + denom <- match.arg(denom) summarize_all <- summarize != "none" + complete <- isTRUE(complete) has_span <- !missing(span) @@ -157,7 +187,8 @@ pt_cat_long <- function(data, cols, span = ".total", data = data, cols = cols, by = span, - nby = nspan + nby = nspan, + denom = denom ) if(summarize_all) { @@ -167,7 +198,7 @@ pt_cat_long <- function(data, cols, span = ".total", cols = cols, by = ".total", nby = nspan, - all_name = all_name_span + all_name = all_name_span, ) all[["N"]] <- NULL ans <- left_join(ans, all, by = c("name", "level")) @@ -225,10 +256,13 @@ pt_cat_long_notes <- function(include_n = TRUE, note_add = NULL) { #' Discrete data summary in long format #' #' @inheritParams pt_cont_wide +#' @inheritParams cat_data #' @param by a grouping variable for the summary; may be given as character -#' vector or quosure +#' vector or quosure. #' @param summarize where to put an all-data summary; choose `none` to omit the -#' summary from the table +#' summary from the table. +#' @param complete logical; if `TRUE`, then data the summary will be completed +#' for missing levels of `by`and `panel`. #' #' @details #' The data summary for this table is `count (percent)`. The number of @@ -236,6 +270,11 @@ pt_cat_long_notes <- function(include_n = TRUE, note_add = NULL) { #' of the table (either on the far left or just to the right of the `by` #' column). #' +#' When `group` is selected for `denom`, `percent` is calculated with +#' denominator set to `n`, the total for each row. When `total` is selected for +#' `denom`, then `percent` is calculated by the total number of records in the +#' input data. +#' #' The notes in this table are generated with [pt_cat_wide_notes()]. #' #' @examples @@ -256,10 +295,12 @@ pt_cat_long_notes <- function(include_n = TRUE, note_add = NULL) { #' @export pt_cat_wide <- function(data, cols, by = ".total", panel = by, table = NULL, all_name = "All data", - summarize = c("bottom", "none")) { + summarize = c("bottom", "none"), complete = FALSE, + denom = c("group", "total")) { summarize <- match.arg(summarize) summarize_all <- summarize != "none" + denom <- match.arg(denom) has_by <- !missing(by) has_panel <- !missing(panel) @@ -282,13 +323,28 @@ pt_cat_wide <- function(data, cols, by = ".total", panel = by, data <- prep_cat_data(data, cols) - ans <- cat_data(data, cols, by = by, panel = panel, wide = TRUE) - ans <- mutate(ans, !!sym(by) := as.character(!!sym(by))) + ans <- cat_data( + data, + cols, + by = by, + panel = panel, + wide = TRUE, + complete = complete, + denom = denom + ) + ans <- mutate(ans, !!sym(by) := as.character(!!sym(by))) if(summarize_all) { - all <- cat_data(data, cols, by = ".total", panel = ".total", wide = TRUE) + all <- cat_data( + data, + cols, + by = ".total", + panel = ".total", + wide = TRUE, + complete = complete + ) all_name_fmt <- paste0("\\hline \\hline {\\bf ",all_name,"}") @@ -340,7 +396,6 @@ pt_cat_wide <- function(data, cols, by = ".total", panel = by, return(out) } - #' Return table notes for pt_cat_wide #' #' See [pt_cat_wide()]. diff --git a/R/preview-standalone.R b/R/preview-standalone.R new file mode 100644 index 00000000..416a223b --- /dev/null +++ b/R/preview-standalone.R @@ -0,0 +1,438 @@ +#' Check for magick dependency +#' @noRd +require_magick <- function() { + if(!requireNamespace("magick", quietly = TRUE)) { + stop("this function requires the magick package to be installed.") + } +} + +#' Check for pdftools dependency +#' @noRd +require_pdftools <- function() { + if(!requireNamespace("pdftools", quietly = TRUE)) { + stop("this function requires the pdftools package to be installed.") + } +} + +#' Check for knitr dependency +#' @noRd +require_knitr <- function() { + if(!requireNamespace("knitr", quietly = TRUE)) { + stop("this function requires the knitr package to be installed.") + } +} + +#' If a build failed, copy an image into the output location that includes +#' text communicating that it failed. +#' @noRd +fail_png <- function(to_file) { + from_file <- system.file("image", "fail.png", package = "pmtables") + file.copy(from_file, to_file, overwrite = TRUE) +} + +fail_pdf <- function(to_file) { + from_file <- system.file("image", "fail.pdf", package = "pmtables") + file.copy(from_file, to_file, overwrite = TRUE) +} + +#' Some settings for fonts; default is a san serif font +#' @noRd +fonts <- list( + helvetica = "\\usepackage{helvet}\n\\renewcommand{\\familydefault}{\\sfdefault}", + utopia = "\\usepackage[adobe-utopia]{mathdesign}", + roboto = "\\usepackage[sfdefault]{roboto}" +) + +#' Convert stable text to a standalone snippet +#' +#' @inheritParams st_aspdf +#' @param text character vector of table text. +#' @param command pass `pdflatex` when building a `pdf` file or `latex` when +#' building `png`. +#' @param ltversion numeric version number for the longtable package; newer +#' versions have an issue that will break this code for longtables; so we are +#' requiring an older version at this point. +#' @keywords internal +st_to_standalone <- function(text, stem, dir, + font = c("helvetica","roboto", "utopia"), + command = "latex", + textwidth = 6.5, + border = "0.2cm 1cm", + ntex = 1, + ltversion = getOption("pmtables.image.ltversion" , 4.13)) { + + out_ext <- ifelse(command=="latex", ".dvi", ".pdf") + font <- match.arg(font) + assert_that(is.character(border) && length(border)==1) + assert_that(is.numeric(ntex) && length(ntex)==1) + assert_that(is.numeric(ltversion)) + + if(!dir.exists(dir)) dir.create(dir) + cwd <- getwd() + on.exit(setwd(cwd), add = TRUE) + setwd(dir) + + # INSIDE THE BUILD DIRECTORY ---------- + texfile <- paste0(stem, ".tex") + outfile <- paste0(stem, out_ext) + if(file.exists(outfile)) file.remove(outfile) + + # The standalone template + temp_file <- system.file( + "tex", + "standalone-preview.tex", + package = "pmtables" + ) + + temp_text <- readLines(temp_file) + + if(is.numeric(textwidth) && textwidth > 0) { + textw_tex <- gluet( + "\\setlength{\\textwidth}{in}" + ) + rule <- paste0("\\rule{", textwidth, "in}{0pt}") + vwidth <- paste0("=", textwidth, "in") + } else { + textw_tex <- "% textwidth not set" + rule <- "% no rule" + vwidth <- "" + } + + env <- list( + border = border, + texfile = texfile, + font = fonts[[font]], + textw_tex = as.character(textw_tex), + rule = rule, + vwidth = vwidth, + ltversion = paste0("[=v", ltversion, "]%") + ) + + temp_text <- mgluet(temp_text, .envir = env) + build_file <- basename(temp_file) + writeLines(temp_text, con = build_file) + writeLines(text, con = texfile) + + args <- c( + "-halt-on-error", + paste0("-jobname=", stem), + build_file + ) + + for(i in seq(ntex)) { + x <- system2( + command = command, + args = args, + stdout = TRUE, + stderr = TRUE + ) + } + + ans <- file.path(dir, outfile) + if(!file.exists(outfile)) { + warning("the standalone preview build didn't work.") + class(ans) <- "latex-failed" + } + + # SETWD BACK TO ORIGINAL WORKING DIRECTORY + return(ans) +} + +#' Render stable object to pdf file +#' +#' Create a "standalone" `pdf` snippet from an stable object using the +#' `pdflatex` utility. The resultant `pdf` file is saved on disk and the +#' relative path to the file is returned. `st2pdf()` is an alias to +#' `st_as_pdf()`. +#' +#' @details +#' The `pdf` file is built using `pdflatex` so this utility must be installed. +#' +#' The `textwidth` argument is set to 6.5 inches by default to mimic a 8.5 x 11 +#' page with 1 inch margins on the left and right. Setting `textwidth` sets the +#' length of the `\textwidth` latex macro to that value and also inserts an +#' invisible rule across the page with that width as well. This means for +#' skinny tables, there will be whitespace on the left and right, but the font +#' in the resultant images will be similar regardless of the width of the +#' table. To skip setting the latex `\textwidth` macro, pass `NULL`. +#' +#' The `border` argument can be one, two or four space-separated elements, each +#' formatted as `""` (e.g. "0.2cm"); pass one element to set the +#' same border on all sides; two elements to set the border on left/right +#' (first) and top/bottom (second); pass four elements to have separate borders +#' for the left, bottom, right and top (see the documentation for the +#' `standalone` latex package). +#' +#' @inheritParams st2article +#' @param x an stable object; this can be the result of calling [stable()] or +#' [stable_long()]. +#' @param stem used to build intermediate and output file names. +#' @param dir directory for building the pdf file. +#' @param font the font to use; alternative values include `roboto` and +#' `utopia`; passed to [st_to_standalone()]. +#' @param textwidth the page width (in inches) when building with `pdflatex`; +#' passed to [st_to_standalone()]; see details. +#' @param border passed as an option to `standalone` latex output type; see +#' details. +#' +#' @examples +#' +#' # check that pdflatex is installed +#' \dontrun{ +#' Sys.which("pdflatex") +#' } +#' +#' \dontrun{ +#' tab <- stable(stdata()) +#' st_aspdf(tab) +#' } +#' +#' # the template for building the image +#' temp <- system.file("tex", "standalone-preview.tex", package = "pmtables") +#' cat(temp, sep = "\n") +#' +#' @return +#' A string containing the path to the rendered `pdf` file. +#' +#' @seealso +#' [st_aspng()], [st_as_image()], [st_image_show()] +#' +#' @export +st_aspdf <- function(x, + stem = "pmt-standalone-preview", + dir = tempdir(), + font = "helvetica", + textwidth = getOption("pmtables.textwidth", 6.5), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ntex = 1) { + assert_that(inherits(x, "stable")) + ans <- st_to_standalone( + x, + stem, + dir, + command = "pdflatex", + font = font, + textwidth = textwidth, + border = border, + ntex = ntex + ) + if(inherits(ans, "latex-failed")) { + fail_pdf(unclass(ans)) + } + ans +} + +#' @rdname st_aspdf +#' @export +st2pdf <- st_aspdf + +#' Render stable object in png format +#' +#' Create a standalone png snippet using `latex` and `dvipng` from an stable +#' object; both functions are required to be installed for this to work. +#' The resultant `png` file is saved on disk and the relative path to the file +#' is returned. `st2png()` is an alias to `st_as_png()`. +#' +#' @inheritParams st_aspdf +#' @inheritParams st2article +#' @param dpi dots per inch for the resulting `png` file; used by `dvipng` when +#' converting `dvi` file to the final `png` result. +#' +#' @examples +#' \dontrun{ +#' Sys.which("latex") +#' Sys.which("dvipng") +#' +#' tab <- stable(stdata()) +#' st_aspng(tab) +#' } +#' +#' +#' @return +#' A string containing the path to the rendered `png` file. +#' +#' @seealso +#' [st_aspdf()], [st_as_image()], [st_image_show()] +#' +#' @export +st_aspng <- function(x, + stem = "pmt-standalone-preview", + dir = tempdir(), + font = "helvetica", + textwidth = getOption("pmtables.text.width", 6.5), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ntex = 1, dpi = 200) { + assert_that(inherits(x, "stable")) + outfile <- st_to_standalone( + x, + stem, + dir, + command = "latex", + font = font, + textwidth = textwidth, + border = border, + ntex = ntex + ) + png_file <- sub("dvi$", "png", outfile, perl = TRUE) + if(inherits(outfile, "latex-failed")) { + fail_png(png_file) + } else { + ans <- dvi_to_png(outfile, png_file, dpi = dpi) + if(inherits(outfile, "dvipng-failed")) { + fail_png(png_file) + } + } + png_file +} + +#' @rdname st_aspng +#' @export +st2png <- st_aspng + + +#' @keywords internal +dvi_to_png <- function(dvifile, pngfile, dpi = 200) { + + if(file.exists(pngfile)) file.remove(pngfile) + args <- c( + paste0("-D ", dpi), + paste0("-o ", pngfile), + "-q*", + dvifile + ) + ans <- system2( + "dvipng", + args, + stdout = TRUE, + stderr = TRUE + ) + if(!file.exists(pngfile)) { + pngfile <- structure(pngfile, class = "dvipng-failed") + } + return(pngfile) +} + +#' Display table from pdf image +#' +#' Use this function to turn an stable object in to a high-quality pdf file, +#' The result can be included in an Rmarkdown file rendered to `.html` or +#' other uses. +#' +#' @details +#' This function depends on the magick and pdftools packages being installed. +#' +#' 1. First, `x` is rendered with [st_aspdf()] +#' 1. Next, the pdf file is read using [magick::image_read_pdf()] +#' 2. Finally, the image is possibly resized via [st_image_show()] +#' +#' @inheritParams st_aspdf +#' @param width the relative width of the image; passed to [st_image_show()]; +#' this must be greater than 0 and less than or equal to 1. +#' @param ... arguments passed to [st_aspdf()]; please take the time to review +#' the details in that help topic. +#' +#' @return +#' A possibly resized `magick` image object (see [magick::image_read_pdf()]). +#' +#' @export +st_as_image <- function(x, ...) UseMethod("st_as_image") + +#' @rdname st_as_image +#' @export +st_as_image.stable <- function(x, + width = getOption("pmtables.image.width", 0.95), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ...) { + assert_that(inherits(x, "stable")) + pdf_file <- st_aspdf(x, border = border, ...) + st_image_show(pdf_file, width = width) +} + +#' @rdname st_as_image +#' @export +st_as_image.pmtable <- function(x, ...) { + tab <- stable(x) + st_as_image(tab, ...) +} + +#' @rdname st_as_image +#' @export +st_as_image.stobject <- function(x, ...) { + tab <- stable(x) + st_as_image(tab, ...) +} + +#' Show table output that has been saved to pdf or png format +#' +#' @details +#' This function requires the magick and pdftools packages to be installed. +#' +#' If you are not knitting an rmarkdown document, then the image is read +#' using [magick::image_read_pdf()] (pdf files) or [magick::image_read()] +#' (png files) and resized relative to the width of the current graphics +#' device (see [grDevices::dev.size()]). +#' +#' If you are knitting with pdf output, then the image is read in +#' using [magick::image_read_pdf()] and passed through +#' [knitr::include_graphics()] without resizing. If you are knitting with html +#' output, then the image is read in using [magick::image_read()] +#' and resized using [magick::image_resize()] to a certain fraction of the +#' available space (see `width` argument). +#' +#' @param path path to a png or pdf file saved on disk. +#' @param width for resizing the magick object; must be a value greater than 0 +#' and less than or equal to 1; when not knitting, the width is taken as a +#' fraction of the current graphics device width; when knitting and the image +#' is in png format, the width is taken to be a fraction of the available space; +#' this parameter is ignored when knitting pdf output. +#' @param knitting if `TRUE`, the context is assumed to be document knit (see +#' default) and the magick object is returned after resizing; if `FALSE`, then +#' interactive context is assumed and the magick object is returned after +#' resizing according to the current device width. +#' +#' @return +#' Depends the context; see details. +#' +#' @seealso +#' [st_aspng()], [st_aspdf()], [st_as_image()] +#' +#' @export +st_image_show <- function(path, + width = getOption("pmtables.image.width", 0.95), + knitting = getOption("knitr.in.progress")) { + require_magick() + require_pdftools() + + assert_that(is.numeric(width)) + assert_that(length(width)==1) + assert_that(width > 0 && width <= 2) + knitting <- isTRUE(knitting) + + format_pdf <- FALSE + if(requireNamespace("knitr")) { + format <- knitr::opts_knit$get("rmarkdown.pandoc.to") + format_pdf <- identical(format, "latex") + } else { + knitting <- FALSE + } + if(knitting && format_pdf) { + return(knitr::include_graphics(path)) + } + if(file_ext(path)=="pdf") { + img <- magick::image_read_pdf(path) + } else { + img <- magick::image_read(path) + } + if(knitting) { + ans <- magick::image_resize( + img, + magick::geometry_size_percent(width*100) + ) + return(ans) + } + ans <- magick::image_resize( + img, + magick::geometry_size_pixels(width*grDevices::dev.size("px")) + ) + return(ans) +} diff --git a/R/summarize-cat-chunk.R b/R/summarize-cat-chunk.R index 4f111385..d6c33acb 100644 --- a/R/summarize-cat-chunk.R +++ b/R/summarize-cat-chunk.R @@ -1,24 +1,48 @@ -summarize_cat_chunk <- function(data, cols) { - data$Nchunk <- nrow(data) - ans <- map_dfr(cols, summarize_cat_col, data = data) +#' Summarize a chunk of categorical data +#' +#' @param data the data frame to summarize. +#' @param cols the column names to summarize. +#' @param N the `total` number in the original data. +#' @param denom says what to use as the denominator for calculating percent. +#' @keywords internal +#' @noRd +summarize_cat_chunk <- function(data, cols, N, denom = "group") { + Nchunk <- nrow(data) + if(denom=="group") { + D <- Nchunk + } else { + D <- N + } + ans <- map_dfr(cols, summarize_cat_col, data = data, D = D, Nchunk = Nchunk) ans <- mutate(ans, name = fct_inorder(.data[["name"]])) ans <- mutate(ans, summary = paste0(n," (",.data[["Percent"]],")")) - mutate(ans,n=NULL,Percent=NULL) + mutate(ans, n = NULL, Percent = NULL) } -summarize_cat_col <- function(name, data) { - .n <- data[["Nchunk"]][1] +#' Summarize a single categorical data column +#' +#' @param name the column name to summarize. +#' @param data the data frame to summarize from. +#' @param D the denominator to use; this was set in [summarize_cat_chunk()]. +#' @param Nchunk the number of records in the chunk being summarized. +#' @return +#' - `N` is the number of records in the chunk +#' - `level` is the current level of the categorical data item +#' - `name` is the column name +#' - `n` is the number summarized +#' @keywords internal +#' @noRd +summarize_cat_col <- function(name, data, D, Nchunk) { data <- ungroup(data) pick <- select(data, .data[["ID"]], level = all_of(unname(name))) pick <- mutate(pick, name = .env[["name"]]) - pick <- group_by(pick, .data[["name"]], .data[["level"]], .drop=FALSE) + pick <- group_by(pick, .data[["name"]], .data[["level"]], .drop = FALSE) summ <- summarise(pick, n = n()) summ <- ungroup(summ) - summ <- mutate(summ, N = .n) - summ <- mutate(summ, Percent = digit1(100*.data[["n"]]/.n)) + summ <- mutate(summ, N = Nchunk) + summ <- mutate(summ, Percent = digit1(100*.data[["n"]]/D)) summ <- mutate(summ, level = as.character(.data[["level"]])) summ <- mutate(summ, name = as.character(.data[["name"]])) return(summ) } - diff --git a/R/table-object.R b/R/table-object.R index b04f14ca..932a8673 100644 --- a/R/table-object.R +++ b/R/table-object.R @@ -5,6 +5,16 @@ check_st <- function(x) { ) } +stop_if_ptobject <- function(x) { + if(is.ptobject(x)) { + caller <- as.character(sys.call(-1))[1] + stop( + glue("the {caller}() function cannot be used to operate on pmtble objects."), + call. = FALSE + ) + } +} + st_arg_names <- c( "data", "panel", "notes", "align", "r_file", "output_file", @@ -20,30 +30,67 @@ st_arg_names <- c( #' The st object will collect various configuration settings and pass those #' to [stable()] when the object is passed to [st_make()]. #' -#' @param data the data frame to pass to [stable()]; the user should filter -#' or subset so that `data` contains exactly the rows (and columns) to be -#' processed; pmtables will not add or remove rows prior to processing `data` -#' @param ... additional arguments passed to [stable()] +#' @details +#' Methods are included for `data.frame` and `pmtable`, an object that comes +#' from one of the data summary functions (e.g. [pt_cont_wide()], or +#' [pt_cat_long()] or [pt_demographics()]). +#' +#' If using the data frame method, the user should filter or subset so that +#' the data (`x`) contains exactly the rows (and columns) to be processed; +#' pmtables will not add or remove rows prior to processing `x`. +#' +#' @param x either a data frame or an object of class `pmtable`; see details. +#' @param ... additional arguments which will eventually get passed to the +#' table render function (e.g. [stable()] or [stable_long()]). +#' +#' @return +#' And object with class `stobject` which can get piped to other functions. The +#' `pmtable` method returns an object that also has class `ptobject`. #' #' @examples #' ob <- st_new(ptdata()) #' ob <- st_data(ptdata()) #' +#' ob <- st_new(pt_data_inventory(pmt_obs)) +#' +#' @export +st_new <- function(x, ...) UseMethod("st_new") +#' @rdname st_new #' @export -st_new <- function(data, ...) { - assert_that(is.data.frame(data)) - x <- new.env() - x$data <- data - x$args <- list(...) - structure(x, class = c("stobject","environment"), argnames = st_arg_names) +st_new.data.frame <- function(x, ...) { + e <- new.env() + e$data <- x + e$args <- list(...) + structure(e, class = c("stobject", "environment"), argnames = st_arg_names) } - #' @rdname st_new #' @export -st_data <- function(data,...) st_new(data,...) +st_new.pmtable <- function(x, ...) { + valid_arg_names <- c( + "data", "panel", "cols_rename", "align", "notes", "cols_extra", + "cols_blank", "span", "span_split", "units", "bold_cols" + ) + incoming <- names(x) + if(!all(incoming %in% valid_arg_names)) { + stop("internal error: invalid item in pmtable object.") + } + ans <- st_new(x$data) + foo <- lapply(incoming, function(slot) { + assign(slot, value = x[[slot]], envir = ans) + }) + structure( + ans, + class = c("stobject", "ptobject", "environment"), + argnames = st_arg_names + ) +} +#' @rdname st_new +#' @export +st_data <- function(x,...) st_new(x = x,...) is.stobject <- function(x) inherits(x, "stobject") +is.ptobject <- function(x) inherits(x, "ptobject") #' Convert st object to table output #' @@ -108,7 +155,8 @@ st_make <- function(x, ..., .preview = FALSE, .cat = FALSE, long = FALSE) { #' Add panel information to st object #' -#' See the `panel` argument to [stable()]. +#' See the `panel` argument to [stable()]. This function cannot be used to +#' operate on pmtable objects. #' #' @param x an stobject #' @param ... passed to [rowpanel()] @@ -123,6 +171,7 @@ st_make <- function(x, ..., .preview = FALSE, .cat = FALSE, long = FALSE) { #' @export st_panel <- function(x, ...) { check_st(x) + stop_if_ptobject(x) panel <- rowpanel(...) assert_that(is.rowpanel(panel)) x$panel <- panel @@ -132,25 +181,37 @@ st_panel <- function(x, ...) { #' Add note information to st object #' #' See the `notes` and `note_config` arguments passed to [stable()] and then to -#' [tab_notes()]. The function can be called multiple times and will accumulate -#' `notes` data. -#' -#' @param x an stobject -#' @param ... table notes -#' @param esc passed to [tab_escape()]; use `NULL` to bypass escaping the notes -#' @param config named list of arguments for [noteconf()] -#' @param collapse if `is.character`, then the note will be collapsed into a -#' single line separated by value of `collapse` (see [base::paste0()]) +#' [tab_notes()]. The function can be called multiple times and can accumulate +#' `notes` data in various ways. Use [st_notes_app()] as a short cut to append +#' a note to the previous line and [st_notes_str()] to convert all existing +#' notes into a single string. +#' +#' @param x an stobject. +#' @param ... character; one or more table notes. +#' @param esc passed to [tab_escape()]; use `NULL` to bypass escaping the notes. +#' @param config named list of arguments for [noteconf()]. +#' @param collapse a character string to separate notes which are pasted +#' together when flattening or appending; this should usually end in a single +#' space (see default). +#' @param append logical; if `TRUE`, then incoming notes are appended to the +#' previous, single note in the notes list. When `...` contains multiple +#' notes, then the notes are pasted together first. +#' @param to_string logical; if `TRUE`, then all notes are collapsed to a single +#' string. #' #' @examples #' library(dplyr) #' #' ob <- st_new(ptdata()) #' -#' ob %>% st_notes("ALB: albumin (g/dL)") %>% st_make() +#' ob %>% st_notes("ALB: albumin (g/dL)") %>% stable() +#' +#' @seealso +#' [st_notes_detach()], [st_notes_rm()], [st_notes_str()], [st_notes_app()] #' #' @export -st_notes <- function(x, ..., esc = NULL, config = NULL, collapse = NULL) { +st_notes <- function(x, ..., esc = NULL, config = NULL, collapse = "; ", + append = FALSE, to_string = FALSE) { check_st(x) notes <- unlist(list(...)) if(!is.null(notes)) { @@ -158,24 +219,152 @@ st_notes <- function(x, ..., esc = NULL, config = NULL, collapse = NULL) { if(is.character(esc)) { notes <- tab_escape(notes, esc = esc) } - if(is.character(collapse) && length(notes) > 1) { + append <- isTRUE(append) && length(x$notes) > 0 + tostr <- isTRUE(to_string) && length(notes) > 1 + if(tostr || append) { notes <- paste0(notes, collapse = collapse) } - x$notes <- c(x$notes, notes) + if(isTRUE(append)) { + l <- length(x$notes) + x$notes[l] <- paste0(c(x$notes[l], notes), collapse = collapse) + } else { + x$notes <- c(x$notes, notes) + } } if(is.list(config)) { - x$note_config <- do.call(noteconf,config) + x$note_config <- do.call(noteconf, config) } x } +#' Append a note to the previous position of a note vector +#' +#' @details +#' Note that the call to [st_notes()] will force in the argument +#' `append = TRUE`. +#' +#' @param ... passed to [st_notes()]. +#' +#' @export +st_notes_app <- function(...) { + st_notes(..., append = TRUE) +} + +#' Convert existing note vector into a single string +#' +#' @inheritParams st_notes +#' +#' @return +#' An updated object with class `stobject`, which can be piped to other +#' functions. +#' +#' @export +st_notes_str <- function(x, collapse = "; ") { + check_st(x) + if(length(x$notes) == 0) return(x) + x$notes <- paste0(x$notes, collapse = collapse) + x +} + +#' Remove notes from the table +#' +#' The can be useful when manipulating an object from one of the pmtable +#' functions (e.g. [pt_cont_long()] or [pt_demographics()], when notes are +#' automatically added to the table. +#' +#' @inheritParams st_notes +#' +#' @return +#' An updated object with class `stobject`, which can be piped to other +#' functions. +#' +#' @export +st_notes_rm <- function(x) { + rm("notes", envir = x) + x +} + +#' Edit lines in table notes +#' +#' This function allows the replacement of _an entire line_ in table notes. +#' The line which is replaced is matched by a regular expression or identified +#' directly with the integer position in the notes vector to replace. +#' +#' @details +#' A warning is generated if there are no notes already existing in `x`. A +#' warning is also generated if a regular expression fails to match any lines. +#' In case multiple lines are matched, only the first matching line is +#' substituted. +#' +#' @inheritParams st_notes +#' @param where a regular expression for finding a line in table notes to +#' replace; alternatively, this can be an integer specifying the line to +#' replace. +#' @param replacement the replacement text for line matching by `where`. +#' @param fixed passed to [grep()] when `where` is character. +#' +#' @return +#' An updated object with class `stobject`, which can be piped to other +#' functions. +#' +#' @export +st_notes_sub <- function(x, where, replacement, fixed = FALSE) { + check_st(x) + if(length(x$notes)==0) { + warning("did not find any notes in the object; returning.") + return(x) + } + assert_that( + inherits(where, c("character", "numeric")), + msg = "`where` must be either character or numeric." + ) + assert_that(length(where)==1) + if(is.character(where)) { + m <- grep(where, x$notes, fixed = fixed) + if(length(m)==0) { + warning("did not find any matching notes; returning.") + return(x) + } + where <- m[1] + } else { + where <- floor(where) + } + note_number <- where + assert_that(note_number >= 0 && note_number <= length(x$notes)) + x$notes[note_number] <- replacement + x +} + +#' Detach table notes from the table +#' +#' Detached notes are rendered underneath the table, in a separate minipage +#' format. By default, there is an `hline` rendered between the table and the +#' notes. It is common to adjust the width of the minipage holding the notes +#' depending on the width of the table and the extent of the notes. +#' +#' @inheritParams st_notes +#' @param width passed to [noteconf()] via [st_noteconf()]. +#' @param type passed to [noteconf()] via [st_noteconf()]; this argument should +#' not be changed if detached notes are desired. +#' @param ... other arguments passed to [noteconf()] via [st_noteconf()]. +#' +#' @return +#' An updated object with class `stobject`, which can be piped to other +#' functions. +#' +#' @export +st_notes_detach <- function(x, width = 0.8, type = "minipage", ...) { + check_st(x) + st_noteconf(x, width = width, type = type, ...) +} + #' Add note config information to st object #' #' See the `note_config` argument passed to [stable()] and then to #' [tab_notes()]. #' -#' @param x an stobject -#' @param ... named arguments passed to [noteconf()] +#' @param x an stobject. +#' @param ... named arguments passed to [noteconf()]. #' #' @examples #' library(dplyr) @@ -194,6 +383,10 @@ st_noteconf <- function(x,...) { x } +#' @rdname st_noteconf +#' @export +st_notes_conf <- st_noteconf + #' Add column alignment information to st object #' #' See the `align` argument to [stable()]. Note: these functions @@ -324,7 +517,7 @@ st_span <- function(x, ..., split = FALSE) { return(x) } if(is.list(x$span)) { - x$span <- c(x$span,list(span)) + x$span <- c(x$span, list(span)) return(x) } x @@ -358,9 +551,10 @@ st_span <- function(x, ..., split = FALSE) { st_span_split <- function(x, ..., split = TRUE) { assert_that( isTRUE(split), - msg = "the `split` argument is FALSE; use `st_span()` instead" + msg = "the `split` argument is FALSE; use `st_span()` instead." ) check_st(x) + stop_if_ptobject(x) span <- colsplit(..., split = split) if(!is.null(x$span_split)) { warning( @@ -419,7 +613,6 @@ st_rename <- function(x, ..., .list = NULL) { x } - #' Add column blank information to st object #' #' See the `cols_blank` argument passed to [stable()] and then [tab_cols()]. @@ -586,7 +779,11 @@ st_args <- function(x,...) { #' Add unit information to st object #' -#' See the `units` argument to [stable()]. Units can be passed either as +#' See the `units` argument to [stable()]. This function cannot be used to +#' work on pmtable objects. +#' +#' @details +#' Units can be passed either as #' `name=value` pairs or as a named list with [st_args()]. Units can #' alternatively be passed as an argument to [stable()] as a pre-formed, named #' list using [st_args()]. Passing as an argument this way will overwrite units @@ -602,12 +799,13 @@ st_args <- function(x,...) { #' @export st_units <- function(x, ..., parens = TRUE) { check_st(x) + stop_if_ptobject(x) units <- flatten(list(...)) units <- map(units, trimws) if(isTRUE(parens)) { - u <- unlist(units, use.names=FALSE) - w <- substr(u,1,1) != "(" & nchar(u) > 0 - units[w] <- paste0("(",units[w],")") + u <- unlist(units, use.names = FALSE) + w <- substr(u, 1, 1) != "(" & nchar(u) > 0 + units[w] <- paste0("(", units[w], ")") } if(is.list(x$units)) { x$units <- combine_list(x$units, units) @@ -628,6 +826,7 @@ st_units <- function(x, ..., parens = TRUE) { #' #' @export st_bold <- function(x, cols, pattern = "*") { + check_st(x) cols <- new_names(cols) assert_that(all(cols %in% names(x$data))) for(col in cols) { @@ -639,6 +838,7 @@ st_bold <- function(x, cols, pattern = "*") { #' @rdname st_bold #' @export st_it <- function(x, cols, pattern = "*") { + check_st(x) cols <- new_names(cols) assert_that(all(cols %in% names(x$data))) for(col in cols) { @@ -656,6 +856,7 @@ st_it <- function(x, cols, pattern = "*") { #' #' @export st_drop <- function(x, ...) { + check_st(x) dots <- new_names(enquos(...)) x$drop <- c(x$drop, dots) x @@ -671,14 +872,16 @@ st_drop <- function(x, ...) { #' #' @export st_select <- function(x, ...) { - x$data <- dplyr::select(x$data, ...) + check_st(x) + x$data <- select(x$data, ...) x } #' @rdname st_select #' @export st_mutate <- function(x, ...) { - x$data <- dplyr::mutate(x$data, ...) + check_st(x) + x$data <- mutate(x$data, ...) x } @@ -714,7 +917,6 @@ tab_edit <- function(data, pattern, replacement, cols = names(data)) { data } - #' Methods for stobject #' #' @param x an stobject diff --git a/R/utils.R b/R/utils.R index d71059cd..d1417cd2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -16,30 +16,42 @@ cvec_cs <- function(x) { #' Format digits #' #' Use [sig()] to set the number of significant digits; use [digit1()] to limit -#' to one digit. See examples. +#' to one digit. See examples. #' -#' @param x numeric, value to manipulate -#' @param digits numeric, number of significant digits Default: 3 -#' @param maxex numeric, maximum number of significant -#' digits before moving to scientific notation, Default: NULL -#' @param ... other arguments that may be passed but not used +#' @details +#' When `x` is an integer, `x` is returned after coercing to character, without +#' further processing. #' -#' @return character vector of formatted values +#' @param x `numeric`; value to manipulate. +#' @param digits `numeric`; number of significant digits. +#' @param maxex `numeric`; maximum number of significant +#' digits before moving to scientific notation. +#' @param ... other arguments that are not used. +#' +#' @return +#' A character vector of formatted values. #' #' @examples #' sig(1.123455) #' sig(0.123455) -#' sig(1.123455,digits = 5) -#' sig(1123,maxex = 3) -#' sig(1123,maxex = 4) +#' sig(1.123455, digits = 5) +#' sig(1123, maxex = 3) +#' sig(1123, maxex = 4) +#' +#' sig(1L) #' #' digit1(1.234) #' digit1(1321.123) #' +#' @md #' @rdname sig #' @export -sig <- function(x,digits=3,maxex=NULL, ...) { - if(class(x)=="integer") return(x) +sig <- function(x, digits = 3, maxex = NULL, ...) { + + if(identical(class(x), "integer")) { + return(as.character(x)) + } + namez <- names(x) x <- as.numeric(x) @@ -61,7 +73,7 @@ sig <- function(x,digits=3,maxex=NULL, ...) { #' @rdname sig #' @export -digit1 <- function(x, ...) formatC(x,digits=1,format = 'f') +digit1 <- function(x, ...) formatC(x, digits = 1,format = 'f') #' @rdname sig #' @export diff --git a/inst/WORDLIST b/inst/WORDLIST index a8f55ed8..834b626f 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -35,3 +35,13 @@ Rmd prototyped Prototyped paren +MPN +png +pdftools +mpn +metworx +https +outdented +magick +rmarkdown + diff --git a/inst/image/fail.pdf b/inst/image/fail.pdf new file mode 100644 index 00000000..133fcc65 Binary files /dev/null and b/inst/image/fail.pdf differ diff --git a/inst/image/fail.png b/inst/image/fail.png new file mode 100644 index 00000000..63e1cc89 Binary files /dev/null and b/inst/image/fail.png differ diff --git a/inst/tex/standalone-preview.tex b/inst/tex/standalone-preview.tex new file mode 100644 index 00000000..7d4806ac --- /dev/null +++ b/inst/tex/standalone-preview.tex @@ -0,0 +1,16 @@ +\documentclass[border={},varwidth]{standalone} +\usepackage{booktabs} +\usepackage{amsmath} +\usepackage{bm} +\usepackage{longtable} +\usepackage{array} +\usepackage{threeparttable} +\usepackage[T1]{fontenc} + + +\begin{document} + +\begin{center} +\input{} +\end{center} +\end{document} diff --git a/inst/validation/.gitignore b/inst/validation/.gitignore new file mode 100644 index 00000000..1a1dc4cf --- /dev/null +++ b/inst/validation/.gitignore @@ -0,0 +1,5 @@ +*.html +*.docx +*.pdf +*.md +test_results/ diff --git a/inst/validation/build-validation-docs.R b/inst/validation/build-validation-docs.R new file mode 100644 index 00000000..36be5204 --- /dev/null +++ b/inst/validation/build-validation-docs.R @@ -0,0 +1,66 @@ +####################################################### +## This script runs the test suite and builds +## the validation documents from the test outputs +## +## The script expects the following: +## * Validation stories in mrgvalprep YAML format in "inst/validation/{PKGNAME}-stories.yaml" +## * A standard testthat test suite than can be run with devtools::test() +## +## It will write the validation documents to +## "inst/validation/{PKGNAME}-{PKGVERSION}-validation-docs/") +## +####################################################### + +PKGNAME <- "pmtables" +PKGVERSION <- "0.4.1.9003" +STYLE_REF_DIR <- "docx-ref-header-image" # set to NULL if not using style ref + +# set up directories and clear existing output dirs, if they exist +val_dir <- system.file("validation", package = PKGNAME) +print(val_dir) + +style_ref_path <- NULL +if (!is.null(STYLE_REF_DIR)) { + style_ref_path <- file.path(val_dir, STYLE_REF_DIR) +} + +test_dir <- file.path(val_dir, "test_results") +if (fs::dir_exists(test_dir)) fs::dir_delete(test_dir) +fs::dir_create(test_dir) + +docs_dir <- file.path(val_dir, paste0(PKGNAME, "-", PKGVERSION, "-validation-docs")) +if (fs::dir_exists(docs_dir)) fs::dir_delete(docs_dir) +fs::dir_create(docs_dir) + +# run tests and write res to disk +test_res <- mrgvalprep::parse_testthat_list_reporter( + devtools::test(Reporter = testthat::ListReporter), + roll_up_ids = TRUE +) + +write.csv( + test_res, + file.path(test_dir, paste0(PKGNAME, "-tests.csv")) +) + +# capture commit hash and other system info +git_hash <- system("git rev-parse HEAD", intern=TRUE) +Sys.setenv("COMMIT_HASH" = git_hash) + +mrgvalprep::get_sys_info( + out_path = file.path(test_dir, paste0(PKGNAME, "-tests.json")), + env_vars = c("METWORX_VERSION", "COMMIT_HASH") +) + +# read in stories +spec <- mrgvalprep::read_spec_yaml(file.path(val_dir, paste0(PKGNAME, "-stories.yaml"))) + +# make docs +mrgvalidate::create_validation_docs( + PKGNAME, + PKGVERSION, + spec, + auto_test_dir = test_dir, + output_dir = docs_dir, + style_dir = style_ref_path +) diff --git a/inst/validation/pmtables-stories.yaml b/inst/validation/pmtables-stories.yaml new file mode 100644 index 00000000..8caa1933 --- /dev/null +++ b/inst/validation/pmtables-stories.yaml @@ -0,0 +1,610 @@ +# Please add user stories at the top of this file +PMT-S079: + name: sig returns character when passed integer + description: > + As a user, I want sig() to return a character result when passed an integer. + ProductRisk: low-risk + tests: + - PMT-UTIL-0001 + +# ----------------------------------------------------------------------------- +# The following tests were in the original import; the last story was S078 +PMT-S001: + name: Sanitize non-math columns + description: As a user, I would like non-escaped, non-math table contents sanitized + when they contain `_` or `%` + ProductRisk: low-risk + tests: PMT-TEST-0183 +PMT-S002: + name: Set table font size + description: As a user, I want to be able to set the font size for the table. + ProductRisk: low-risk + tests: PMT-TEST-0184 +PMT-S003: + name: Option to scrub column tags from column names + description: As a user, I want to issue a command to strip `tag.` from `tag.column-name`. + ProductRisk: low-risk + tests: PMT-TEST-0209 +PMT-S004: + name: longtable functionality + description: As a user, I want to be able to create long tables that span multiple + pages. + ProductRisk: low-risk + tests: PMT-TEST-0134 +PMT-S005: + name: Sanitize table notes + description: As a user, I want table notes sanitized for `_` or `%` characters. + ProductRisk: low-risk + tests: + - PMT-TEST-0180 + - PMT-TEST-0181 +PMT-S006: + name: Make longtable using pipe interface + description: As a user, I want to be able to optionally render a table as `longtable` + using the pipeable interface. + ProductRisk: low-risk + tests: PMT-TEST-0230 +PMT-S007: + name: Save table code + description: As a user, I want to be able to automatically save a file to an output + location that also appears in the table note text. + ProductRisk: low-risk + tests: PMT-TEST-0237 +PMT-S008: + name: Pipe interface + description: As a user, I want to be able to assemble tables within a pipe interface. + ProductRisk: low-risk + tests: + - PMT-TEST-0215 + - PMT-TEST-0217 + - PMT-TEST-0218 + - PMT-TEST-0219 + - PMT-TEST-0220 + - PMT-TEST-0221 + - PMT-TEST-0222 + - PMT-TEST-0223 + - PMT-TEST-0224 + - PMT-TEST-0225 + - PMT-TEST-0227 + - PMT-TEST-0228 + - PMT-TEST-0229 +PMT-S009: + name: Add hlines based on data column + description: As a user, I want to be able add horizontal lines in the table based + on non-repeating values of a data frame column. + ProductRisk: low-risk + tests: PMT-TEST-0115 +PMT-S010: + name: Add hlines anywhere + description: As a user, I want to be able to add horizontal lines in a table at + arbitrary locations. + ProductRisk: low-risk + tests: PMT-TEST-0114 +PMT-S011: + name: Summary rows + description: As a user, I want to be able to identify a row (or rows) that are summary + rows and add special styling to those rows, including a horizontal line above + that row, bold font face in certain cells of that row, and alternate text in certain + cells of that row. + ProductRisk: low-risk + tests: PMT-TEST-0199 +PMT-S012: + name: Annotate the table with user-defined notes + description: As a user, I want to be able to add notes that will get printed below + a table. + ProductRisk: low-risk + tests: + - PMT-TEST-0154 + - PMT-TEST-0153 + - PMT-TEST-0155 + - PMT-TEST-0088 + - PMT-TEST-0089 +PMT-S013: + name: Annotate the table with R file name and output file name + description: As a user, I want to be able to pass in the name of originating R script + and output latex file and add those annotations at the bottom of the table. + ProductRisk: low-risk + tests: PMT-TEST-0156 +PMT-S014: + name: Bold column names + description: As a user, I want to be able to render table column names in bold font + if I so choose. + ProductRisk: low-risk + tests: PMT-TEST-0204 +PMT-S015: + name: Replace column names + description: As a user, I want to be able to (completely) replace input data frame + column names with a new set of names. + ProductRisk: low-risk + tests: PMT-TEST-0203 +PMT-S016: + name: Continuous covariate summary table + description: As a user, I want to be able to create a table summarizing continuous + covariates in long or wide format. + ProductRisk: low-risk + tests: + - PMT-TEST-0038 + - PMT-TEST-0039 + - PMT-TEST-0040 + - PMT-TEST-0041 + - PMT-TEST-0042 +PMT-S017: + name: Categorical (discrete) covariate summary table + description: As a user, I want to be able to create a categorical covariate summary + table in either wide or long format. + ProductRisk: low-risk + tests: + - PMT-TEST-0073 + - PMT-TEST-0075 + - PMT-TEST-0065 + - PMT-TEST-0066 + - PMT-TEST-0067 + - PMT-TEST-0068 + - PMT-TEST-0109 + - PMT-TEST-0110 +PMT-S018: + name: Data inventory table + description: As a user, I want to be able to summarize a data set and create a data + disposition table summarizing the number of observations, the number of individuals, + the number of missing observations, the number of observations below the quantitation + limit, the percent of observations that are below the quantitation limit, and + the percent of observation in certain subgroups. + ProductRisk: low-risk + tests: + - PMT-TEST-0122 + - PMT-TEST-0123 + - PMT-TEST-0124 + - PMT-TEST-0125 + - PMT-TEST-0126 + - PMT-TEST-0119 + - PMT-TEST-0120 + - PMT-TEST-0121 + - PMT-TEST-0026 + - PMT-TEST-0027 + - PMT-TEST-0028 +PMT-S019: + name: Column spanner - from user + description: As a user, I want to group table columns with a horizontal line above + the table column labels and give a title to the group of columns. + ProductRisk: low-risk + tests: + - PMT-TEST-0189 + - PMT-TEST-0102 +PMT-S020: + name: Column spanner - from column names + description: As a user, I want to be able to encode column groupings in the column + names as `title.name` format; the column groupings will be implemented by stating + the separator on which to split the column name. + ProductRisk: low-risk + tests: + - PMT-TEST-0186 + - PMT-TEST-0160 + - PMT-TEST-0188 +PMT-S021: + name: Column alignment and sizing + description: As a user, I want to be able to alter the alignment of table columns + as left, center, right with the column width determined by latex or as a fixed + size. + ProductRisk: low-risk + tests: + - PMT-TEST-0001 + - PMT-TEST-0097 +PMT-S022: + name: Set table row and column padding + description: As a user, I want to be able to increase or decrease the amount of + padding between cells and / or columns in the table. + ProductRisk: low-risk + tests: + - PMT-TEST-0104 + - PMT-TEST-0105 + - PMT-TEST-0106 +PMT-S023: + name: Add units below column labels + description: As a user, I want to pass in a named list of units corresponding to + table column names and print the unit below the column name. + ProductRisk: low-risk + tests: + - PMT-TEST-0206 + - PMT-TEST-0101 + - PMT-TEST-0107 + - PMT-TEST-0108 +PMT-S024: + name: Replace repeating values with whitespace in a column + description: As a user, I want to be able to replace repeating values with whitespace + in a column. + ProductRisk: low-risk + tests: + - PMT-TEST-0010 + - PMT-TEST-0011 + - PMT-TEST-0012 +PMT-S025: + name: Write math expressions in a table + description: As a user, I want to be able to write math expressions in latex in + the table. + ProductRisk: low-risk + tests: + - PMT-TEST-0177 + - PMT-TEST-0179 +PMT-S026: + name: Tabular / three part table + description: As a user, I want to render a data frame in tabular environment within + threeparttable. + ProductRisk: low-risk + tests: PMT-TEST-0085 +PMT-S027: + name: Rename columns + description: As a user, I want to be able to have a column name appear in the latex + table that is different than the column name in the data frame. + ProductRisk: low-risk + tests: + - PMT-TEST-0202 + - PMT-TEST-0201 +PMT-S028: + name: longtable captions + description: As a user, I want to be able to specify the caption for long tables + as either text passed to the `stable_long` call or as a latex macro name. + ProductRisk: low-risk + tests: + - PMT-TEST-0135 + - PMT-TEST-0137 +PMT-S029: + name: Break column labels into multiple lines + description: As a user, I want to be able to break the table column labels into + multiple rows. + ProductRisk: low-risk + tests: PMT-TEST-0207 +PMT-S030: + name: Drop columns + description: As a user, I want to be able to optionally drop columns from the data + frame so that they do not appear in the latex output. + ProductRisk: low-risk + tests: PMT-TEST-0208 +PMT-S031: + name: 'ENHANCE: Add n column to pt_cat_wide' + description: As a user, I want to have the total number of subjects in a column + in the `pt_cat_wide` table + ProductRisk: low-risk + tests: PMT-TEST-0076 +PMT-S032: + name: 'ENHANCE: Put all data summary in pt_cat_long' + description: As a user, I want to have an all-data summary at the bottom of pt_cat_long + ProductRisk: low-risk + tests: + - PMT-TEST-0074 + - PMT-TEST-0034 + - PMT-TEST-0036 +PMT-S033: + name: 'ENHANCE: add long = TRUE to as_stable' + description: As a user, I want to be able to create long table from pmtable object. + ProductRisk: low-risk + tests: PMT-TEST-0167 +PMT-S034: + name: 'ENHANCE: invert pt_cont_long table' + description: As a user, I want to be able to make a continuous covariate summary + in long format, where the covariate summaries are paneled by the covariate name, + rather than the paneling variable name + ProductRisk: low-risk + tests: + - PMT-TEST-0018 + - PMT-TEST-0239 +PMT-S035: + name: 'BUG: passing in all_name with tex in it' + description: As a user, I want tab_panel to succeed even if `prefix_skip` or `skip` + is not a valid regular expression + ProductRisk: low-risk + tests: PMT-TEST-0243 +PMT-S036: + name: Refactor longtable and tabular row spacing + description: As a user, I want to be able to control row and column spacing in longtable + and tabular with the same parameters. + ProductRisk: low-risk + tests: + - PMT-TEST-0138 + - PMT-TEST-0185 +PMT-S037: + name: 'BUG: output file name not saved to longtable output' + description: As a user, I want longtable output object to retain output file name + as an attribute. + ProductRisk: low-risk + tests: PMT-TEST-0139 +PMT-S038: + name: Harmonize N / n in different tables + description: As a user, I want to see either N or n in table output + ProductRisk: low-risk + tests: + - PMT-TEST-0109 + - PMT-TEST-0110 + - PMT-TEST-0024 + - PMT-TEST-0079 + - PMT-TEST-0080 +PMT-S039: + name: Wrap standard table notes in function call + description: As a user, I want to be able to get the notes for a data summary table + using an R function call. + ProductRisk: low-risk + tests: + - PMT-TEST-0022 + - PMT-TEST-0023 + - PMT-TEST-0077 + - PMT-TEST-0078 + - PMT-TEST-0127 +PMT-S040: + name: Pass extra column title information as data frame + description: As a user, I want to be able to pass extra table labels to be included + in the header as a data frame + ProductRisk: low-risk + tests: PMT-TEST-0210 +PMT-S041: + name: con defaults to NULL for st_wrap in as_stable.pmtable + description: As a user, I want the table printed only once when calling `as_stable` + with `wrapw = TRUE` + ProductRisk: low-risk + tests: PMT-TEST-0002 +PMT-S042: + name: Landscape mode for st2doc and st2article + description: As a user, I want to be able to preview a table in a pdf document in + landscape mode. + ProductRisk: low-risk + tests: PMT-TEST-0169 +PMT-S043: + name: Short caption / title for longtable + description: As a user, I want to be able to specify both a short and long caption + for long table + ProductRisk: low-risk + tests: PMT-TEST-0136 +PMT-S044: + name: Error in continuous summary when all values are missing + description: As a user, I want to be able to summarize continuous data items and + have a result even if all values are missing. + ProductRisk: low-risk + tests: PMT-TEST-0025 +PMT-S045: + name: Need to accumulate hline indices in stobject + description: As a user, I want to call st_hline multiple times in a pipeline and + accumulate hline indices + ProductRisk: low-risk + tests: PMT-TEST-0118 +PMT-S046: + name: st_hline with pattern argument doesn't work when cols is used? + description: As a user, I want to place a horizontal line across a table by specifying + a pattern and a column name to in which to look + ProductRisk: low-risk + tests: PMT-TEST-0116 +PMT-S047: + name: Add nudge argument to result from pattern arguments + description: As a user, I want to move the hline resulting from `st_hline / pattern` + or `st_hline / at` up or back by a specified number of rows + ProductRisk: low-risk + tests: PMT-TEST-0117 +PMT-S048: + name: Make columns bold after sanitizing + description: As a user, I would like to have column name sanitized prior to adding + bold styling + ProductRisk: low-risk + tests: + - tests/testthat/test_tab-cols.R + - PMT-TEST-0205 +PMT-S049: + name: Break span title + description: As a user, I want to be able to break span titles over multiple lines + ProductRisk: low-risk + tests: PMT-TEST-0190 +PMT-S050: + name: Knit document with tables outside of template + description: As a user, I want to be able to include all required latex packages + when knitting a document that includes pmtables output + ProductRisk: low-risk + tests: + - PMT-TEST-0171 + - PMT-TEST-0170 +PMT-S051: + name: Option to bind yaml_as_df by column number + description: As a user, I want to write table data into a yaml file and have pmtables + read and create a data frame based on column number rather than name + ProductRisk: low-risk + tests: + - tests/testthat/test-yaml_as_df + - PMT-TEST-0246 + - PMT-TEST-0247 + - PMT-TEST-0248 +PMT-S052: + name: column spanners not showing up in longtable + description: As a user, I want column spanners to appear in long tables + ProductRisk: low-risk + tests: + - PMT-TEST-0140 + - PMT-TEST-0141 + - PMT-TEST-0142 +PMT-S053: + name: Check for missing values in categorical covariates + description: As a user, I want pmtables to tell me when there is missing values + in categorical covariate columns when creating categorical pmtable and replace + with character NA. + ProductRisk: low-risk + tests: PMT-TEST-0082 +PMT-S054: + name: col_split is changing the column names too early + description: As a user, I want to be able to specify column spanners via both `span_split` + and `span` and have `span_split` not clobber column names before calculating columns + under `span` + ProductRisk: low-risk + tests: PMT-TEST-0191 +PMT-S055: + name: Add span_split via st_span + description: As a user, I want to specify `span_split` via `st_span()` + ProductRisk: low-risk + tests: PMT-TEST-0192 +PMT-S056: + name: Make stable_long generic, add methods for pmtable and stobject + description: As a user, I want to be able to use `stable_long()` to render as long + table objects with class `pmtable` and `stobject` + ProductRisk: low-risk + tests: + - PMT-TEST-0143 + - PMT-TEST-0144 +PMT-S057: + name: Return invisible after saving or previewing + description: As a user, I want pmtables to return invisible output after previewing + a table or saving it to file. + ProductRisk: low-risk + tests: PMT-TEST-0237 +PMT-S058: + name: Bug in drop_miss implementation + description: As a user, I want `pt_data_inventory` to drop the Missing Observation + summary when I pass `drop_miss = TRUE` + ProductRisk: low-risk + tests: PMT-TEST-0128 +PMT-S059: + name: Combined demographics table + description: As a user, I pmtables to generate a table summarizing both continuous + and categorical covariates. + ProductRisk: low-risk + tests: + - PMT-TEST-0043 + - PMT-TEST-0044 + - PMT-TEST-0045 + - PMT-TEST-0046 + - PMT-TEST-0047 + - PMT-TEST-0048 + - PMT-TEST-0049 + - PMT-TEST-0050 + - PMT-TEST-0051 + - PMT-TEST-0052 + - PMT-TEST-0053 + - PMT-TEST-0054 + - PMT-TEST-0055 + - PMT-TEST-0056 + - PMT-TEST-0057 +PMT-S060: + name: Rename table columns via list + description: As a user, I want to pass a list of rename information to pmtables + in order to rename columns. + ProductRisk: low-risk + tests: PMT-TEST-0226 +PMT-S061: + name: Save a list of tables + description: As a user, I want `stable_save` to save out a list of `stable` objects + ProductRisk: low-risk + tests: PMT-TEST-0238 +PMT-S062: + name: Pipe a list of tables to st2report + description: As a user, I want to be able to pipe a list of tables to st2report + as well as passing them via dots + ProductRisk: low-risk + tests: PMT-TEST-0173 +PMT-S063: + name: Fix error message when duplicate panels are found + description: As a user, I want pmtables to name the correct argument to use to over + ride an error generated when duplicate panels are used + ProductRisk: low-risk + tests: PMT-TEST-0158 +PMT-S064: + name: Re-named cols and table arg do not rename + description: As a user, I want to used renamed cols argument or pass a table list + to `pt_cont_wide` + ProductRisk: low-risk + tests: + - PMT-TEST-0020 + - PMT-TEST-0021 + - PMT-TEST-0083 + - PMT-TEST-0084 +PMT-S065: + name: Arguments are not captured when coercing pmtable output to stable_long + description: As a user, I want to be able to convert pmtable output to long table + and pass along arguments to stable_long + ProductRisk: low-risk + tests: + - PMT-TEST-0003 + - PMT-TEST-0004 + - PMT-TEST-0005 + - PMT-TEST-0006 +PMT-S066: + name: Font size not changed for longtable + description: As a user, I want to control the base font size for longtable + ProductRisk: low-risk + tests: PMT-TEST-0145 +PMT-S067: + name: Check incoming type for st_asis + description: As a user, I want to receive an error message when the wrong type of + object is passed to `st_asis()` + ProductRisk: low-risk + tests: PMT-TEST-0175 +PMT-S068: + name: Option to omit column names totally (including hline) + description: As a user, I would like to be able to completely suppress column names + from appearing in the table. + ProductRisk: low-risk + tests: + - PMT-TEST-0211 + - PMT-TEST-0212 + - PMT-TEST-0213 + - PMT-TEST-0214 +PMT-S069: + name: Option to omit hline in panel + description: As a user, I want the option to omit the hline in the panel + ProductRisk: low-risk + tests: PMT-TEST-0164 +PMT-S070: + name: Use total non-missing obs as denom for percent bql + description: As a user, I want `pt_data_inventory` to use number of total non-missing + observations in denominator for percent bql calculation. + ProductRisk: low-risk + tests: + - PMT-TEST-0129 + - PMT-TEST-0130 + - PMT-TEST-0131 + - PMT-TEST-0132 +PMT-S071: + name: Reverse order on span_split + description: As a user, I want to be able to take the span title from the left or + right split when using `colsplit()` + ProductRisk: low-risk + tests: PMT-TEST-0187 +PMT-S072: + name: Escape names in table list for st2article + description: As a user, I want pmtables to escape names in the list of tables to + render with st2report + ProductRisk: low-risk + tests: PMT-TEST-0176 +PMT-S073: + name: Call st_asis on pmtable object + description: As a user, I want to be able to pipe a `pmtable` object to `st_asis()` + ProductRisk: low-risk + tests: all st_asis on a pmtable object +PMT-S074: + name: Jut the first column and header when panel + description: As a user, I want to be able to add small indent to the first column + when panel is used. + ProductRisk: low-risk + tests: PMT-TEST-0166 +PMT-S075: + name: Add * to panel title rows in longtable + description: As a user, I want pmtables to keep panel title rows together with the + subsequent row. + ProductRisk: low-risk + tests: PMT-TEST-0165 +PMT-S076: + name: pt_data_inventory to update colname/footer when I use BLQ + description: As a user, I want pt_data_inventory to change my colname/footer description + for BLQ if I use `bq_col = "BLQ"` + ProductRisk: low-risk + tests: PMT-TEST-0133 +PMT-S077: + name: Allow alignment of span titles + description: As a user, I want to justify span titles to the left, right or center. + ProductRisk: low-risk + tests: + - PMT-TEST-0193 + - PMT-TEST-0195 + - PMT-TEST-0194 +PMT-S078: + name: Stable() creates tabular output + description: As a user, I want to be able to create tabular output from an R data frame. + ProductRisk: low-risk + tests: + - PMT-TEST-0002 + - PMT-TEST-0003 + - PMT-TEST-0004 + - PMT-TEST-0005 + - PMT-TEST-0006 + diff --git a/man/cat_data.Rd b/man/cat_data.Rd index 49c4d332..19cc2aac 100644 --- a/man/cat_data.Rd +++ b/man/cat_data.Rd @@ -12,7 +12,9 @@ cat_data( summarize_all = TRUE, all_name = "All", wide = FALSE, - nby = NULL + nby = NULL, + complete = FALSE, + denom = c("group", "total") ) } \arguments{ @@ -27,14 +29,22 @@ not add or remove rows prior to summarizing \code{data}} \item{panel}{data set column name to stratify the summary} \item{summarize_all}{logical indicating whether or not to include a summary -of the full data in the output} +of the full data in the output.} -\item{all_name}{label for full data summary} +\item{all_name}{label for full data summary.} \item{wide}{\code{logical}; if \code{TRUE}, data frame will be returned in wide format; -if \code{FALSE}, it will be returned in \code{long} format} +if \code{FALSE}, it will be returned in \code{long} format.} -\item{nby}{number of unique levels for the \code{by} variable} +\item{nby}{number of unique levels for the \code{by} variable.} + +\item{complete}{logical; if \code{TRUE}, then data the summary will be completed +for missing levels of \code{by}and \code{panel}.} + +\item{denom}{the denominator to use when calculating percent for each level; +\code{group} uses the total number in the chunk being summarized; \code{total} uses +the total number in the data set; historically, \code{group} has been used as the +default.} } \description{ Summarize categorical data diff --git a/man/pt_cat_long.Rd b/man/pt_cat_long.Rd index 2bdd1887..3358bea6 100644 --- a/man/pt_cat_long.Rd +++ b/man/pt_cat_long.Rd @@ -12,7 +12,8 @@ pt_cat_long( all_name_span = "Summary", summarize = c("both", "right", "top", "none"), table = NULL, - by = NULL + by = NULL, + denom = c("group", "total") ) } \arguments{ @@ -36,6 +37,11 @@ use \code{none} to drop the summary from the table} examples)} \item{by}{use \code{span} argument instead} + +\item{denom}{the denominator to use when calculating percent for each level; +\code{group} uses the total number in the chunk being summarized; \code{total} uses +the total number in the data set; historically, \code{group} has been used as the +default.} } \value{ An object with class \code{pmtable}; see \link{class-pmtable}. @@ -44,7 +50,14 @@ An object with class \code{pmtable}; see \link{class-pmtable}. Discrete data summary in long format } \details{ -The data summary for all cells in the table is \code{count (percent)}. +The data summary for all cells in the table is \code{count (percent)}. The number +of data records in each column variable level is given under the column +title as \code{n}. + +When \code{group} is selected for \code{denom}, \code{percent} is calculated with +denominator set to \code{n}, the total for each column variable level. When +\code{total} is selected for \code{denom}, then \code{percent} is calculated by the total +number of records in the input data. The notes in this table are generated with \code{\link[=pt_cat_long_notes]{pt_cat_long_notes()}}. } diff --git a/man/pt_cat_wide.Rd b/man/pt_cat_wide.Rd index b188dada..f6b56498 100644 --- a/man/pt_cat_wide.Rd +++ b/man/pt_cat_wide.Rd @@ -11,7 +11,9 @@ pt_cat_wide( panel = by, table = NULL, all_name = "All data", - summarize = c("bottom", "none") + summarize = c("bottom", "none"), + complete = FALSE, + denom = c("group", "total") ) } \arguments{ @@ -22,7 +24,7 @@ not add or remove rows prior to summarizing \code{data}} \item{cols}{the columns to summarize; may be character vector or quosure} \item{by}{a grouping variable for the summary; may be given as character -vector or quosure} +vector or quosure.} \item{panel}{data set column name to stratify the summary} @@ -32,7 +34,15 @@ examples)} \item{all_name}{a name to use for the complete data summary} \item{summarize}{where to put an all-data summary; choose \code{none} to omit the -summary from the table} +summary from the table.} + +\item{complete}{logical; if \code{TRUE}, then data the summary will be completed +for missing levels of \code{by}and \code{panel}.} + +\item{denom}{the denominator to use when calculating percent for each level; +\code{group} uses the total number in the chunk being summarized; \code{total} uses +the total number in the data set; historically, \code{group} has been used as the +default.} } \value{ An object with class \code{pmtable}; see \link{class-pmtable}. @@ -46,6 +56,11 @@ data points for each row is also summarized as \code{n} on the left hand side of the table (either on the far left or just to the right of the \code{by} column). +When \code{group} is selected for \code{denom}, \code{percent} is calculated with +denominator set to \code{n}, the total for each row. When \code{total} is selected for +\code{denom}, then \code{percent} is calculated by the total number of records in the +input data. + The notes in this table are generated with \code{\link[=pt_cat_wide_notes]{pt_cat_wide_notes()}}. } \examples{ diff --git a/man/pt_demographics.Rd b/man/pt_demographics.Rd index a32de446..07b20c1b 100644 --- a/man/pt_demographics.Rd +++ b/man/pt_demographics.Rd @@ -14,10 +14,11 @@ pt_demographics( stat_name = "Statistic", stat_width = 2, summarize_all = TRUE, - all_name = "All data", + all_name = "Summary", fun = dem_cont_fun, notes = pt_demographics_notes(), - paneled = TRUE + paneled = TRUE, + denom = c("group", "total") ) } \arguments{ @@ -61,6 +62,11 @@ data; the default is \code{\link[=dem_cont_fun]{dem_cont_fun()}}. The result wil covariate names; otherwise, the covariate names will appear as the left-most column with non-repeating names cleared and separated with \code{hline} (see examples).} + +\item{denom}{the denominator to use when calculating percent for each level; +\code{group} uses the total number in the chunk being summarized; \code{total} uses +the total number in the data set; historically, \code{group} has been used as the +default.} } \value{ An object of class \code{pmtable}. diff --git a/man/sig.Rd b/man/sig.Rd index c8e59207..08f5721c 100644 --- a/man/sig.Rd +++ b/man/sig.Rd @@ -13,28 +13,34 @@ digit1(x, ...) rnd(x, digits = 0, ...) } \arguments{ -\item{x}{numeric, value to manipulate} +\item{x}{\code{numeric}; value to manipulate.} -\item{digits}{numeric, number of significant digits Default: 3} +\item{digits}{\code{numeric}; number of significant digits.} -\item{maxex}{numeric, maximum number of significant -digits before moving to scientific notation, Default: NULL} +\item{maxex}{\code{numeric}; maximum number of significant +digits before moving to scientific notation.} -\item{...}{other arguments that may be passed but not used} +\item{...}{other arguments that are not used.} } \value{ -character vector of formatted values +A character vector of formatted values. } \description{ Use \code{\link[=sig]{sig()}} to set the number of significant digits; use \code{\link[=digit1]{digit1()}} to limit -to one digit. See examples. +to one digit. See examples. +} +\details{ +When \code{x} is an integer, \code{x} is returned after coercing to character, without +further processing. } \examples{ sig(1.123455) sig(0.123455) -sig(1.123455,digits = 5) -sig(1123,maxex = 3) -sig(1123,maxex = 4) +sig(1.123455, digits = 5) +sig(1123, maxex = 3) +sig(1123, maxex = 4) + +sig(1L) digit1(1.234) digit1(1321.123) diff --git a/man/st_as_image.Rd b/man/st_as_image.Rd new file mode 100644 index 00000000..496820a6 --- /dev/null +++ b/man/st_as_image.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preview-standalone.R +\name{st_as_image} +\alias{st_as_image} +\alias{st_as_image.stable} +\alias{st_as_image.pmtable} +\alias{st_as_image.stobject} +\title{Display table from pdf image} +\usage{ +st_as_image(x, ...) + +\method{st_as_image}{stable}( + x, + width = getOption("pmtables.image.width", 0.95), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ... +) + +\method{st_as_image}{pmtable}(x, ...) + +\method{st_as_image}{stobject}(x, ...) +} +\arguments{ +\item{x}{an stable object; this can be the result of calling \code{\link[=stable]{stable()}} or +\code{\link[=stable_long]{stable_long()}}.} + +\item{...}{arguments passed to \code{\link[=st_aspdf]{st_aspdf()}}; please take the time to review +the details in that help topic.} + +\item{width}{the relative width of the image; passed to \code{\link[=st_image_show]{st_image_show()}}; +this must be greater than 0 and less than or equal to 1.} + +\item{border}{passed as an option to \code{standalone} latex output type; see +details.} +} +\value{ +A possibly resized \code{magick} image object (see \code{\link[magick:editing]{magick::image_read_pdf()}}). +} +\description{ +Use this function to turn an stable object in to a high-quality pdf file, +The result can be included in an Rmarkdown file rendered to \code{.html} or +other uses. +} +\details{ +This function depends on the magick and pdftools packages being installed. +\enumerate{ +\item First, \code{x} is rendered with \code{\link[=st_aspdf]{st_aspdf()}} +\item Next, the pdf file is read using \code{\link[magick:editing]{magick::image_read_pdf()}} +\item Finally, the image is possibly resized via \code{\link[=st_image_show]{st_image_show()}} +} +} diff --git a/man/st_aspdf.Rd b/man/st_aspdf.Rd new file mode 100644 index 00000000..ccd4f336 --- /dev/null +++ b/man/st_aspdf.Rd @@ -0,0 +1,93 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preview-standalone.R +\name{st_aspdf} +\alias{st_aspdf} +\alias{st2pdf} +\title{Render stable object to pdf file} +\usage{ +st_aspdf( + x, + stem = "pmt-standalone-preview", + dir = tempdir(), + font = "helvetica", + textwidth = getOption("pmtables.textwidth", 6.5), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ntex = 1 +) + +st2pdf( + x, + stem = "pmt-standalone-preview", + dir = tempdir(), + font = "helvetica", + textwidth = getOption("pmtables.textwidth", 6.5), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ntex = 1 +) +} +\arguments{ +\item{x}{an stable object; this can be the result of calling \code{\link[=stable]{stable()}} or +\code{\link[=stable_long]{stable_long()}}.} + +\item{stem}{used to build intermediate and output file names.} + +\item{dir}{directory for building the pdf file.} + +\item{font}{the font to use; alternative values include \code{roboto} and +\code{utopia}; passed to \code{\link[=st_to_standalone]{st_to_standalone()}}.} + +\item{textwidth}{the page width (in inches) when building with \code{pdflatex}; +passed to \code{\link[=st_to_standalone]{st_to_standalone()}}; see details.} + +\item{border}{passed as an option to \code{standalone} latex output type; see +details.} + +\item{ntex}{number of times to build the pdf file} +} +\value{ +A string containing the path to the rendered \code{pdf} file. +} +\description{ +Create a "standalone" \code{pdf} snippet from an stable object using the +\code{pdflatex} utility. The resultant \code{pdf} file is saved on disk and the +relative path to the file is returned. \code{st2pdf()} is an alias to +\code{st_as_pdf()}. +} +\details{ +The \code{pdf} file is built using \code{pdflatex} so this utility must be installed. + +The \code{textwidth} argument is set to 6.5 inches by default to mimic a 8.5 x 11 +page with 1 inch margins on the left and right. Setting \code{textwidth} sets the +length of the \verb{\\textwidth} latex macro to that value and also inserts an +invisible rule across the page with that width as well. This means for +skinny tables, there will be whitespace on the left and right, but the font +in the resultant images will be similar regardless of the width of the +table. To skip setting the latex \verb{\\textwidth} macro, pass \code{NULL}. + +The \code{border} argument can be one, two or four space-separated elements, each +formatted as \code{""} (e.g. "0.2cm"); pass one element to set the +same border on all sides; two elements to set the border on left/right +(first) and top/bottom (second); pass four elements to have separate borders +for the left, bottom, right and top (see the documentation for the +\code{standalone} latex package). +} +\examples{ + +# check that pdflatex is installed +\dontrun{ +Sys.which("pdflatex") +} + +\dontrun{ +tab <- stable(stdata()) +st_aspdf(tab) +} + +# the template for building the image +temp <- system.file("tex", "standalone-preview.tex", package = "pmtables") +cat(temp, sep = "\n") + +} +\seealso{ +\code{\link[=st_aspng]{st_aspng()}}, \code{\link[=st_as_image]{st_as_image()}}, \code{\link[=st_image_show]{st_image_show()}} +} diff --git a/man/st_aspng.Rd b/man/st_aspng.Rd new file mode 100644 index 00000000..46673ac3 --- /dev/null +++ b/man/st_aspng.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preview-standalone.R +\name{st_aspng} +\alias{st_aspng} +\alias{st2png} +\title{Render stable object in png format} +\usage{ +st_aspng( + x, + stem = "pmt-standalone-preview", + dir = tempdir(), + font = "helvetica", + textwidth = getOption("pmtables.text.width", 6.5), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ntex = 1, + dpi = 200 +) + +st2png( + x, + stem = "pmt-standalone-preview", + dir = tempdir(), + font = "helvetica", + textwidth = getOption("pmtables.text.width", 6.5), + border = getOption("pmtables.image.border", "0.2cm 0.7cm"), + ntex = 1, + dpi = 200 +) +} +\arguments{ +\item{x}{an stable object; this can be the result of calling \code{\link[=stable]{stable()}} or +\code{\link[=stable_long]{stable_long()}}.} + +\item{stem}{used to build intermediate and output file names.} + +\item{dir}{directory for building the pdf file.} + +\item{font}{the font to use; alternative values include \code{roboto} and +\code{utopia}; passed to \code{\link[=st_to_standalone]{st_to_standalone()}}.} + +\item{textwidth}{the page width (in inches) when building with \code{pdflatex}; +passed to \code{\link[=st_to_standalone]{st_to_standalone()}}; see details.} + +\item{border}{passed as an option to \code{standalone} latex output type; see +details.} + +\item{ntex}{number of times to build the pdf file} + +\item{dpi}{dots per inch for the resulting \code{png} file; used by \code{dvipng} when +converting \code{dvi} file to the final \code{png} result.} +} +\value{ +A string containing the path to the rendered \code{png} file. +} +\description{ +Create a standalone png snippet using \code{latex} and \code{dvipng} from an stable +object; both functions are required to be installed for this to work. +The resultant \code{png} file is saved on disk and the relative path to the file +is returned. \code{st2png()} is an alias to \code{st_as_png()}. +} +\examples{ +\dontrun{ +Sys.which("latex") +Sys.which("dvipng") + +tab <- stable(stdata()) +st_aspng(tab) +} + + +} +\seealso{ +\code{\link[=st_aspdf]{st_aspdf()}}, \code{\link[=st_as_image]{st_as_image()}}, \code{\link[=st_image_show]{st_image_show()}} +} diff --git a/man/st_image_show.Rd b/man/st_image_show.Rd new file mode 100644 index 00000000..ff8cb46a --- /dev/null +++ b/man/st_image_show.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preview-standalone.R +\name{st_image_show} +\alias{st_image_show} +\title{Show table output that has been saved to pdf or png format} +\usage{ +st_image_show( + path, + width = getOption("pmtables.image.width", 0.95), + knitting = getOption("knitr.in.progress") +) +} +\arguments{ +\item{path}{path to a png or pdf file saved on disk.} + +\item{width}{for resizing the magick object; must be a value greater than 0 +and less than or equal to 1; when not knitting, the width is taken as a +fraction of the current graphics device width; when knitting and the image +is in png format, the width is taken to be a fraction of the available space; +this parameter is ignored when knitting pdf output.} + +\item{knitting}{if \code{TRUE}, the context is assumed to be document knit (see +default) and the magick object is returned after resizing; if \code{FALSE}, then +interactive context is assumed and the magick object is returned after +resizing according to the current device width.} +} +\value{ +Depends the context; see details. +} +\description{ +Show table output that has been saved to pdf or png format +} +\details{ +This function requires the magick and pdftools packages to be installed. + +If you are not knitting an rmarkdown document, then the image is read +using \code{\link[magick:editing]{magick::image_read_pdf()}} (pdf files) or \code{\link[magick:editing]{magick::image_read()}} +(png files) and resized relative to the width of the current graphics +device (see \code{\link[grDevices:dev.size]{grDevices::dev.size()}}). + +If you are knitting with pdf output, then the image is read in +using \code{\link[magick:editing]{magick::image_read_pdf()}} and passed through +\code{\link[knitr:include_graphics]{knitr::include_graphics()}} without resizing. If you are knitting with html +output, then the image is read in using \code{\link[magick:editing]{magick::image_read()}} +and resized using \code{\link[magick:transform]{magick::image_resize()}} to a certain fraction of the +available space (see \code{width} argument). +} +\seealso{ +\code{\link[=st_aspng]{st_aspng()}}, \code{\link[=st_aspdf]{st_aspdf()}}, \code{\link[=st_as_image]{st_as_image()}} +} diff --git a/man/st_new.Rd b/man/st_new.Rd index 48985288..d51a2308 100644 --- a/man/st_new.Rd +++ b/man/st_new.Rd @@ -2,26 +2,46 @@ % Please edit documentation in R/table-object.R \name{st_new} \alias{st_new} +\alias{st_new.data.frame} +\alias{st_new.pmtable} \alias{st_data} \title{Create an st object} \usage{ -st_new(data, ...) +st_new(x, ...) -st_data(data, ...) +\method{st_new}{data.frame}(x, ...) + +\method{st_new}{pmtable}(x, ...) + +st_data(x, ...) } \arguments{ -\item{data}{the data frame to pass to \code{\link[=stable]{stable()}}; the user should filter -or subset so that \code{data} contains exactly the rows (and columns) to be -processed; pmtables will not add or remove rows prior to processing \code{data}} +\item{x}{either a data frame or an object of class \code{pmtable}; see details.} -\item{...}{additional arguments passed to \code{\link[=stable]{stable()}}} +\item{...}{additional arguments which will eventually get passed to the +table render function (e.g. \code{\link[=stable]{stable()}} or \code{\link[=stable_long]{stable_long()}}).} +} +\value{ +And object with class \code{stobject} which can get piped to other functions. The +\code{pmtable} method returns an object that also has class \code{ptobject}. } \description{ The st object will collect various configuration settings and pass those to \code{\link[=stable]{stable()}} when the object is passed to \code{\link[=st_make]{st_make()}}. } +\details{ +Methods are included for \code{data.frame} and \code{pmtable}, an object that comes +from one of the data summary functions (e.g. \code{\link[=pt_cont_wide]{pt_cont_wide()}}, or +\code{\link[=pt_cat_long]{pt_cat_long()}} or \code{\link[=pt_demographics]{pt_demographics()}}). + +If using the data frame method, the user should filter or subset so that +the data (\code{x}) contains exactly the rows (and columns) to be processed; +pmtables will not add or remove rows prior to processing \code{x}. +} \examples{ ob <- st_new(ptdata()) ob <- st_data(ptdata()) +ob <- st_new(pt_data_inventory(pmt_obs)) + } diff --git a/man/st_noteconf.Rd b/man/st_noteconf.Rd index 1a9412b9..49e021d3 100644 --- a/man/st_noteconf.Rd +++ b/man/st_noteconf.Rd @@ -2,14 +2,17 @@ % Please edit documentation in R/table-object.R \name{st_noteconf} \alias{st_noteconf} +\alias{st_notes_conf} \title{Add note config information to st object} \usage{ st_noteconf(x, ...) + +st_notes_conf(x, ...) } \arguments{ -\item{x}{an stobject} +\item{x}{an stobject.} -\item{...}{named arguments passed to \code{\link[=noteconf]{noteconf()}}} +\item{...}{named arguments passed to \code{\link[=noteconf]{noteconf()}}.} } \description{ See the \code{note_config} argument passed to \code{\link[=stable]{stable()}} and then to diff --git a/man/st_notes.Rd b/man/st_notes.Rd index 2cb6a021..3a72c29c 100644 --- a/man/st_notes.Rd +++ b/man/st_notes.Rd @@ -4,30 +4,51 @@ \alias{st_notes} \title{Add note information to st object} \usage{ -st_notes(x, ..., esc = NULL, config = NULL, collapse = NULL) +st_notes( + x, + ..., + esc = NULL, + config = NULL, + collapse = "; ", + append = FALSE, + to_string = FALSE +) } \arguments{ -\item{x}{an stobject} +\item{x}{an stobject.} -\item{...}{table notes} +\item{...}{character; one or more table notes.} -\item{esc}{passed to \code{\link[=tab_escape]{tab_escape()}}; use \code{NULL} to bypass escaping the notes} +\item{esc}{passed to \code{\link[=tab_escape]{tab_escape()}}; use \code{NULL} to bypass escaping the notes.} -\item{config}{named list of arguments for \code{\link[=noteconf]{noteconf()}}} +\item{config}{named list of arguments for \code{\link[=noteconf]{noteconf()}}.} -\item{collapse}{if \code{is.character}, then the note will be collapsed into a -single line separated by value of \code{collapse} (see \code{\link[base:paste]{base::paste0()}})} +\item{collapse}{a character string to separate notes which are pasted +together when flattening or appending; this should usually end in a single +space (see default).} + +\item{append}{logical; if \code{TRUE}, then incoming notes are appended to the +previous, single note in the notes list. When \code{...} contains multiple +notes, then the notes are pasted together first.} + +\item{to_string}{logical; if \code{TRUE}, then all notes are collapsed to a single +string.} } \description{ See the \code{notes} and \code{note_config} arguments passed to \code{\link[=stable]{stable()}} and then to -\code{\link[=tab_notes]{tab_notes()}}. The function can be called multiple times and will accumulate -\code{notes} data. +\code{\link[=tab_notes]{tab_notes()}}. The function can be called multiple times and can accumulate +\code{notes} data in various ways. Use \code{\link[=st_notes_app]{st_notes_app()}} as a short cut to append +a note to the previous line and \code{\link[=st_notes_str]{st_notes_str()}} to convert all existing +notes into a single string. } \examples{ library(dplyr) ob <- st_new(ptdata()) -ob \%>\% st_notes("ALB: albumin (g/dL)") \%>\% st_make() +ob \%>\% st_notes("ALB: albumin (g/dL)") \%>\% stable() } +\seealso{ +\code{\link[=st_notes_detach]{st_notes_detach()}}, \code{\link[=st_notes_rm]{st_notes_rm()}}, \code{\link[=st_notes_str]{st_notes_str()}}, \code{\link[=st_notes_app]{st_notes_app()}} +} diff --git a/man/st_notes_app.Rd b/man/st_notes_app.Rd new file mode 100644 index 00000000..fb807d12 --- /dev/null +++ b/man/st_notes_app.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/table-object.R +\name{st_notes_app} +\alias{st_notes_app} +\title{Append a note to the previous position of a note vector} +\usage{ +st_notes_app(...) +} +\arguments{ +\item{...}{passed to \code{\link[=st_notes]{st_notes()}}.} +} +\description{ +Append a note to the previous position of a note vector +} +\details{ +Note that the call to \code{\link[=st_notes]{st_notes()}} will force in the argument +\code{append = TRUE}. +} diff --git a/man/st_notes_detach.Rd b/man/st_notes_detach.Rd new file mode 100644 index 00000000..ad0d3848 --- /dev/null +++ b/man/st_notes_detach.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/table-object.R +\name{st_notes_detach} +\alias{st_notes_detach} +\title{Detach table notes from the table} +\usage{ +st_notes_detach(x, width = 0.8, type = "minipage", ...) +} +\arguments{ +\item{x}{an stobject.} + +\item{width}{passed to \code{\link[=noteconf]{noteconf()}} via \code{\link[=st_noteconf]{st_noteconf()}}.} + +\item{type}{passed to \code{\link[=noteconf]{noteconf()}} via \code{\link[=st_noteconf]{st_noteconf()}}; this argument should +not be changed if detached notes are desired.} + +\item{...}{other arguments passed to \code{\link[=noteconf]{noteconf()}} via \code{\link[=st_noteconf]{st_noteconf()}}.} +} +\value{ +An updated object with class \code{stobject}, which can be piped to other +functions. +} +\description{ +Detached notes are rendered underneath the table, in a separate minipage +format. By default, there is an \code{hline} rendered between the table and the +notes. It is common to adjust the width of the minipage holding the notes +depending on the width of the table and the extent of the notes. +} diff --git a/man/st_notes_rm.Rd b/man/st_notes_rm.Rd new file mode 100644 index 00000000..6b15bf6a --- /dev/null +++ b/man/st_notes_rm.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/table-object.R +\name{st_notes_rm} +\alias{st_notes_rm} +\title{Remove notes from the table} +\usage{ +st_notes_rm(x) +} +\arguments{ +\item{x}{an stobject.} +} +\value{ +An updated object with class \code{stobject}, which can be piped to other +functions. +} +\description{ +The can be useful when manipulating an object from one of the pmtable +functions (e.g. \code{\link[=pt_cont_long]{pt_cont_long()}} or \code{\link[=pt_demographics]{pt_demographics()}}, when notes are +automatically added to the table. +} diff --git a/man/st_notes_str.Rd b/man/st_notes_str.Rd new file mode 100644 index 00000000..86156a5e --- /dev/null +++ b/man/st_notes_str.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/table-object.R +\name{st_notes_str} +\alias{st_notes_str} +\title{Convert existing note vector into a single string} +\usage{ +st_notes_str(x, collapse = "; ") +} +\arguments{ +\item{x}{an stobject.} + +\item{collapse}{a character string to separate notes which are pasted +together when flattening or appending; this should usually end in a single +space (see default).} +} +\value{ +An updated object with class \code{stobject}, which can be piped to other +functions. +} +\description{ +Convert existing note vector into a single string +} diff --git a/man/st_notes_sub.Rd b/man/st_notes_sub.Rd new file mode 100644 index 00000000..9c3600bb --- /dev/null +++ b/man/st_notes_sub.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/table-object.R +\name{st_notes_sub} +\alias{st_notes_sub} +\title{Edit lines in table notes} +\usage{ +st_notes_sub(x, where, replacement, fixed = FALSE) +} +\arguments{ +\item{x}{an stobject.} + +\item{where}{a regular expression for finding a line in table notes to +replace; alternatively, this can be an integer specifying the line to +replace.} + +\item{replacement}{the replacement text for line matching by \code{where}.} + +\item{fixed}{passed to \code{\link[=grep]{grep()}} when \code{where} is character.} +} +\value{ +An updated object with class \code{stobject}, which can be piped to other +functions. +} +\description{ +This function allows the replacement of \emph{an entire line} in table notes. +The line which is replaced is matched by a regular expression or identified +directly with the integer position in the notes vector to replace. +} +\details{ +A warning is generated if there are no notes already existing in \code{x}. A +warning is also generated if a regular expression fails to match any lines. +In case multiple lines are matched, only the first matching line is +substituted. +} diff --git a/man/st_panel.Rd b/man/st_panel.Rd index 34669038..9dfa9933 100644 --- a/man/st_panel.Rd +++ b/man/st_panel.Rd @@ -12,7 +12,8 @@ st_panel(x, ...) \item{...}{passed to \code{\link[=rowpanel]{rowpanel()}}} } \description{ -See the \code{panel} argument to \code{\link[=stable]{stable()}}. +See the \code{panel} argument to \code{\link[=stable]{stable()}}. This function cannot be used to +operate on pmtable objects. } \examples{ library(dplyr) diff --git a/man/st_to_standalone.Rd b/man/st_to_standalone.Rd new file mode 100644 index 00000000..43c6c69f --- /dev/null +++ b/man/st_to_standalone.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preview-standalone.R +\name{st_to_standalone} +\alias{st_to_standalone} +\title{Convert stable text to a standalone snippet} +\usage{ +st_to_standalone( + text, + stem, + dir, + font = c("helvetica", "roboto", "utopia"), + command = "latex", + textwidth = 6.5, + border = "0.2cm 1cm", + ntex = 1, + ltversion = getOption("pmtables.image.ltversion", 4.13) +) +} +\arguments{ +\item{text}{character vector of table text.} + +\item{stem}{used to build intermediate and output file names.} + +\item{dir}{directory for building the pdf file.} + +\item{font}{the font to use; alternative values include \code{roboto} and +\code{utopia}; passed to \code{\link[=st_to_standalone]{st_to_standalone()}}.} + +\item{command}{pass \code{pdflatex} when building a \code{pdf} file or \code{latex} when +building \code{png}.} + +\item{textwidth}{the page width (in inches) when building with \code{pdflatex}; +passed to \code{\link[=st_to_standalone]{st_to_standalone()}}; see details.} + +\item{border}{passed as an option to \code{standalone} latex output type; see +details.} + +\item{ntex}{number of times to build the pdf file} + +\item{ltversion}{numeric version number for the longtable package; newer +versions have an issue that will break this code for longtables; so we are +requiring an older version at this point.} +} +\description{ +Convert stable text to a standalone snippet +} +\keyword{internal} diff --git a/man/st_units.Rd b/man/st_units.Rd index c87cab33..64052605 100644 --- a/man/st_units.Rd +++ b/man/st_units.Rd @@ -16,7 +16,11 @@ of units} character is not \code{(}} } \description{ -See the \code{units} argument to \code{\link[=stable]{stable()}}. Units can be passed either as +See the \code{units} argument to \code{\link[=stable]{stable()}}. This function cannot be used to +work on pmtable objects. +} +\details{ +Units can be passed either as \code{name=value} pairs or as a named list with \code{\link[=st_args]{st_args()}}. Units can alternatively be passed as an argument to \code{\link[=stable]{stable()}} as a pre-formed, named list using \code{\link[=st_args]{st_args()}}. Passing as an argument this way will overwrite units diff --git a/tests/testthat/image/as-image-test.Rmd b/tests/testthat/image/as-image-test.Rmd new file mode 100644 index 00000000..8289f692 --- /dev/null +++ b/tests/testthat/image/as-image-test.Rmd @@ -0,0 +1,138 @@ +--- +title: "Tests for stable to image" +output: + html_document: + toc: true + number_sections: true +--- + +# Setup + +```{r setup, warning = FALSE, message = FALSE} +knitr::opts_chunk$set(echo = TRUE) +library(dplyr) +library(knitr) +library(pmtables) + +dir <- "build" +``` + + +# Tables + +- stable + +```{r} +tab <- stable(stdata()) +``` + +- stable_long + +```{r} +longtab <- stable_long(stdata()) +``` + + +- stobject + +```{r} +sttab <- st_new(stdata()) +``` + +- pmtable + +```{r} +pttab <- pt_cat_long(pmt_first, span="STUDYf", cols = "SEXf") +``` + +- broken + +```{r} +brokentab <- tab +brokentab[4] <- "" +``` + + +# Tests + +## Convert from stable + +```{r} +st_as_image(tab, dir = dir, stem = "convert-stable") +``` + +## Convert from long stable + +```{r} +st_as_image(longtab, dir = dir, stem = "convert-longtable", ntex = 2) +``` + +## Convert from pmtable + +```{r} +st_as_image(pttab, dir = dir, stem = "convert-pttab") +``` + +## Convert from stobject + +```{r} +st_as_image(sttab, dir = dir, stem = "convert-sttab") +``` + + +## Include from png + +```{r} +file <- st_aspng(tab, dir = dir, stem = "include-from-png") +include_graphics(file) +``` + +## Make the page smaller + +```{r} +st_as_image(tab, dir = dir, stem = "smaller-page", textwidth = 4) +``` + +## Make display width smaller + +```{r} +st_as_image(tab, dir = dir, stem = "smaller-width", width = 0.5) +``` + +## Bigger border on the top + +```{r} +st_as_image(tab, dir = dir, stem = "bigger-border", border = "0.2cm 3cm") +``` + +## Change the font - utopia + +```{r} +st_as_image(tab, dir = dir, stem = "test-utopia", font = "utopia") +``` + +## Change the font - roboto + +```{r} +st_as_image(tab, dir = dir, stem = "test-roboto", font = "roboto") +``` + +## Broken pdf + +```{r} +st_as_image(brokentab) +``` + +## Broken png + +```{r} +st_image_show(st_aspng(brokentab)) +``` + + +# Session + +```{r} +date() +sessionInfo() +``` diff --git a/tests/testthat/test-align.R b/tests/testthat/test-align.R index 9d26143a..8e3fd988 100644 --- a/tests/testthat/test-align.R +++ b/tests/testthat/test-align.R @@ -7,7 +7,7 @@ inspect <- function(...) { context("test-align") -test_that("align helpers", { +test_that("align helpers [PMT-TEST-0001]", { expect_identical(cols_center(), cols_align(.default = 'c')) expect_identical(cols_left(), cols_align(.default = 'l')) expect_identical(cols_right(), cols_align(.default = 'r')) diff --git a/tests/testthat/test-as-image.R b/tests/testthat/test-as-image.R new file mode 100644 index 00000000..bb947561 --- /dev/null +++ b/tests/testthat/test-as-image.R @@ -0,0 +1,84 @@ + +do <- function(fn, ...) { + output_dir <- tempfile("pmtables-test-") + dir.create(output_dir) + on.exit(unlink(output_dir), add = TRUE) + old_dir <- setwd(output_dir) + on.exit(setwd(old_dir), add = TRUE, after = FALSE) + + args <- list(..., dir = output_dir) + do.call(fn, args) + + return(readLines("standalone-preview.tex")) +} + +test_that("standalone tex file looks as expected: stable", { + tab <- stable(stdata()) + x <- do(st_as_image, tab, stem = "convert-stable") + expect_match(x, "convert-stable.tex", all = FALSE, fixed = TRUE) + expect_match(x, "\\usepackage{helvet}", all = FALSE, fixed = TRUE) + expect_match(x, "\\textwidth}{6.5in}", all = FALSE, fixed = TRUE) + expect_match(x, "varwidth=6.5in", all = FALSE, fixed = TRUE) + expect_match(x, "\\usepackage{longtable}[=v4.13]", all = FALSE, fixed = TRUE) + expect_match(x, "\\rule{6.5in}{0pt}", all = FALSE, fixed = TRUE) + expect_match(x, "border={0.2cm 0.7cm}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: long stable", { + longtab <- stable_long(stdata()) + x <- do(st_as_image, longtab, stem = "convert-longtable", ntex = 2) + expect_match(x, "\\input{convert-longtable.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: pmtable", { + pttab <- pt_cat_long(pmt_first, span = "STUDYf", cols = "SEXf") + x <- do(st_as_image, pttab, stem = "convert-pttab") + expect_match(x, "\\input{convert-pttab.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: stobject", { + sttab <- st_new(stdata()) + x <- do(st_as_image, sttab, stem = "convert-sttab") + expect_match(x, "\\input{convert-sttab.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: png", { + tab <- stable(stdata()) + x <- do(st_aspng, tab, stem = "include-from-png") + expect_match(x, "\\input{include-from-png.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: smaller page", { + tab <- stable(stdata()) + x <- do(st_as_image, tab, stem = "smaller-page", textwidth = 4) + expect_match(x, "\\textwidth}{4in}", all = FALSE, fixed = TRUE) + expect_match(x, "varwidth=4in", all = FALSE, fixed = TRUE) + expect_match(x, "\\rule{4in}{0pt}", all = FALSE, fixed = TRUE) + expect_match(x, "\\input{smaller-page.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: smaller width", { + tab <- stable(stdata()) + x <- do(st_as_image, tab, stem = "smaller-width", width = 0.5) + expect_match(x, "\\textwidth}{6.5in}", all = FALSE, fixed = TRUE) + expect_match(x, "varwidth=6.5in", all = FALSE, fixed = TRUE) + expect_match(x, "\\rule{6.5in}{0pt}", all = FALSE, fixed = TRUE) + expect_match(x, "\\input{smaller-width.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: bigger border", { + tab <- stable(stdata()) + x <- do(st_as_image, tab, stem = "bigger-border", border = "0.2cm 3cm") + expect_match(x, "border={0.2cm 3cm}", all = FALSE, fixed = TRUE) + expect_match(x, "\\input{bigger-border.tex}", all = FALSE, fixed = TRUE) +}) + +test_that("standalone tex file looks as expected: change font", { + tab <- stable(stdata()) + + x <- do(st_as_image, tab, stem = "test-utopia", font = "utopia") + expect_match(x, "\\usepackage[adobe-utopia]{mathdesign}", all = FALSE, fixed = TRUE) + + x <- do(st_as_image, tab, stem = "test-roboto", font = "roboto") + expect_match(x, "\\usepackage[sfdefault]{roboto}", all = FALSE, fixed = TRUE) +}) diff --git a/tests/testthat/test-as_stable.R b/tests/testthat/test-as_stable.R index 49862060..36c4bc6a 100644 --- a/tests/testthat/test-as_stable.R +++ b/tests/testthat/test-as_stable.R @@ -7,7 +7,7 @@ inspect_long <- function(...) { get_stable_data(stable_long(..., inspect = TRUE)) } -test_that("pass con to st_wrap in as_stable", { +test_that("pass con to st_wrap in as_stable [PMT-TEST-0002]", { x <- pt_cont_long(pmt_first, cols = "WT") expect_silent(as_stable(x)) expect_output(as_stable(x, wrapw = TRUE)) @@ -17,7 +17,7 @@ test_that("pass con to st_wrap in as_stable", { expect_equal(n,1) }) -test_that("pass args to stable_long when coercing stobject", { +test_that("pass args to stable_long when coercing stobject [PMT-TEST-0003]", { x <- st_new(stdata()) y <- stable_long(x, lt_cap_text = "test pass caption") n <- grep("caption", y) @@ -25,7 +25,7 @@ test_that("pass args to stable_long when coercing stobject", { expect_match(y[n], "test pass caption") }) -test_that("pass args to stable when coercing stobject", { +test_that("pass args to stable when coercing stobject [PMT-TEST-0004]", { x <- st_new(stdata()) y <- stable(x, drop = "N", inspect = TRUE) z <- get_stable_data(y) @@ -33,7 +33,7 @@ test_that("pass args to stable when coercing stobject", { expect_identical(expect, z$cols_new) }) -test_that("pass args to stable_long when coercing pmtable", { +test_that("pass args to stable_long when coercing pmtable [PMT-TEST-0005]", { x <- pt_cont_long(pmt_first, cols = "WT,ALB,SCR") y <- stable_long(x, lt_cap_text = "test pass caption") n <- grep("caption", y) @@ -41,7 +41,7 @@ test_that("pass args to stable_long when coercing pmtable", { expect_match(y[n], "test pass caption") }) -test_that("pass args to stable when coercing pmtable", { +test_that("pass args to stable when coercing pmtable [PMT-TEST-0006]", { x <- pt_cont_wide(pmt_first, cols = "WT,ALB,SCR") y <- stable(x, notes = "test pass notes") expect_match(y, "item test pass notes", all=FALSE) diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index 1808b85c..805d665e 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -1,7 +1,7 @@ context("test-check") -test_that("continuous", { +test_that("continuous [PMT-TEST-0007]", { data <- data.frame(a = 1L, aa = 1.5, b = 'b') expect_true(pmtables:::check_continuous(data, "a")) expect_true(pmtables:::check_continuous(data, "aa")) @@ -9,14 +9,14 @@ test_that("continuous", { expect_error(pmtables:::check_continuous(data,"c")) }) -test_that("discrete", { +test_that("discrete [PMT-TEST-0008]", { data <- data.frame(a = 1L, as = 0.5, b = 'b', d = factor(11)) expect_true(pmtables:::check_discrete(data, "a")) expect_true(pmtables:::check_discrete(data,"b")) expect_error(pmtables:::check_discrete(data,"c")) }) -test_that("check exists", { +test_that("check exists [PMT-TEST-0009]", { data <- data.frame(A = 1, B = 2, C = 3) expect_true(pmtables:::check_exists(data, c("B", "C", "A"))) expect_error( diff --git a/tests/testthat/test-clear_reps.R b/tests/testthat/test-clear_reps.R index c8545f87..30be12d9 100644 --- a/tests/testthat/test-clear_reps.R +++ b/tests/testthat/test-clear_reps.R @@ -8,7 +8,7 @@ inspect <- function(...) { context("test-clear_reps") -test_that("clear replicates", { +test_that("clear replicates [PMT-TEST-0010]", { data <- data.frame(A = c(rep("a", 3), rep("b",2), rep('c', 3))) data$B <- letters[seq(nrow(data))] out <- tab_clear_reps(data, "A") @@ -16,7 +16,7 @@ test_that("clear replicates", { expect_equal(out$A,ans) }) -test_that("clear grouped replicates - 1", { +test_that("clear grouped replicates - 1 [PMT-TEST-0011]", { data <- pmt_first data <- count(data, STUDYf, FORMf, SEXf) data <- mutate(data, across(c(STUDYf,FORMf,SEXf),as.character)) @@ -35,7 +35,7 @@ test_that("clear grouped replicates - 1", { ) }) -test_that("clear grouped replicates - 2", { +test_that("clear grouped replicates - 2 [PMT-TEST-0012]", { data <- pmt_first data <- count(data,STUDYf,FORMf,SEXf) data <- mutate(data, across(STUDYf:SEXf, as.character)) diff --git a/tests/testthat/test-cont-data.R b/tests/testthat/test-cont-data.R index 1e6a1f4b..4d1be86d 100644 --- a/tests/testthat/test-cont-data.R +++ b/tests/testthat/test-cont-data.R @@ -1,7 +1,7 @@ context("test-cont-data") -test_that("continuous data summary long - simple", { +test_that("continuous data summary long - simple [PMT-TEST-0013]", { data <- pmt_first cols <- pmtables:::new_names("WT,ALB,SCR") ans <- cont_table_data(data, cols = cols) @@ -11,7 +11,7 @@ test_that("continuous data summary long - simple", { expect_equal(nrow(ans),3) }) -test_that("continuous data summary long - by", { +test_that("continuous data summary long - by [PMT-TEST-0014]", { data <- pmt_first cols <- pmtables:::new_names("WT,ALB,SCR") by <- pmtables:::new_names("STUDYf") @@ -24,7 +24,7 @@ test_that("continuous data summary long - by", { expect_true(all(ans[[2]] %in% cols)) }) -test_that("continuous data summary wide - simple", { +test_that("continuous data summary wide - simple [PMT-TEST-0015]", { data <- pmt_first cols <- pmtables:::new_names("WT,ALB,SCR") ans <- cont_table_data( @@ -36,7 +36,7 @@ test_that("continuous data summary wide - simple", { expect_equal(nrow(ans),1) }) -test_that("continuous data summary wide - by", { +test_that("continuous data summary wide - by [PMT-TEST-0016]", { data <- pmt_first cols <- pmtables:::new_names("WT,ALB,SCR") ans <- cont_table_data( diff --git a/tests/testthat/test-cont-table.R b/tests/testthat/test-cont-table.R index 0fb21156..846f2b41 100644 --- a/tests/testthat/test-cont-table.R +++ b/tests/testthat/test-cont-table.R @@ -7,14 +7,14 @@ inspect <- function(...) { context("test-cont-table") -test_that("continuous data table - long", { +test_that("continuous data table - long [PMT-TEST-0017]", { data <- pmt_first table <- list(WT = "Weight") ans <- pt_cont_long(data,cols="WT,ALB,SCR",panel="STUDYf",table=table) expect_is(ans,"pmtable") }) -test_that("invert panel and cols", { +test_that("invert panel and cols [PMT-TEST-0018]", { data <- pmt_first table <- list(WT = "weight", ALB = "albumin", SCR = "creat") ans1 <- pt_cont_long( @@ -40,13 +40,13 @@ test_that("invert panel and cols", { expect_is(ans2$sumrows, "sumrow") }) -test_that("continuous data table - wide", { +test_that("continuous data table - wide [PMT-TEST-0019]", { data <- pmt_first ans <- pt_cont_wide(data, cols = "WT,ALB,SCR", panel = "STUDYf") expect_is(ans,"pmtable") }) -test_that("cont wide with renamed cols", { +test_that("cont wide with renamed cols [PMT-TEST-0020]", { data <- pmt_first ans1 <- pt_cont_wide(data, cols = c(wt = "WT", alb = "ALB")) tb <- list(WT = "wt", ALB = "alb") @@ -57,7 +57,7 @@ test_that("cont wide with renamed cols", { expect_equal(names(ans1$data), c("WT", "ALB")) }) -test_that("cont long with renamed cols", { +test_that("cont long with renamed cols [PMT-TEST-0021]", { data <- pmt_first ans1 <- pt_cont_long(data, cols = c(`a a g` = "AAG", `b m i` = "BMI")) tb <- list(BMI = "b m i", AAG = "a a g") @@ -69,14 +69,14 @@ test_that("cont long with renamed cols", { expect_equal(variable[2], c("b m i")) }) -test_that("notes - cont-wide", { +test_that("notes - cont-wide [PMT-TEST-0022]", { ans <- pt_cont_wide(pmt_first, cols = "WT,ALB")$notes expect_is(ans, "character") expect_length(ans,1) expect_match(ans, "mean (sd) [count]", fixed = TRUE) }) -test_that("notes - cont-long", { +test_that("notes - cont-long [PMT-TEST-0023]", { ans <- pt_cont_long(pmt_first, cols = "WT,ALB")$notes expect_is(ans, "character") expect_length(ans,3) @@ -85,12 +85,12 @@ test_that("notes - cont-long", { expect_match(ans[3], "minimum", fixed = TRUE) }) -test_that("cont long table has n", { +test_that("cont long table has n [PMT-TEST-0024]", { ans <- pt_cont_long(pmt_first, cols = "WT,ALB")$data expect_true("n" %in% names(ans)) }) -test_that("cont table all missing", { +test_that("cont table all missing [PMT-TEST-0025]", { data <- dplyr::tibble(ID = 1:30,WT = runif(30,1,10), SCR = NA_real_, ALB = WT) a <- pt_cont_wide(data, cols = "WT,SCR,ALB", na_fill = NULL) b <- pt_cont_long(data, cols = "WT,SCR,ALB", na_fill = NULL) diff --git a/tests/testthat/test-demo-check.R b/tests/testthat/test-demo-check.R index 94c7009d..f10eea6a 100644 --- a/tests/testthat/test-demo-check.R +++ b/tests/testthat/test-demo-check.R @@ -50,7 +50,7 @@ j <- mutate(i, across(POBS:PBQL, pmtables:::digit1)) expected <- j test <- out$data -test_that("demo-check data inventory stacked", { +test_that("demo-check data inventory stacked [PMT-TEST-0026]", { expect_equal(test$Number.SUBJ,expected$NID) expect_equal(test$Number.OBS,expected$NOBS) expect_equal(test$Number.BQL,expected$NBQL) @@ -118,7 +118,7 @@ chk <- names(out$data)[3:10] test <- out$data[chk] expected <- k[chk] -test_that("demo-check paneled data inventory stacked", { +test_that("demo-check paneled data inventory stacked [PMT-TEST-0027]", { for(col in names(test)) { expect_identical(expected[[col]],test[[col]]) } @@ -172,7 +172,7 @@ chk <- c( test <- out$data[chk] expected <- k[chk] -test_that("demo-check grouped data inventory", { +test_that("demo-check grouped data inventory [PMT-TEST-0028]", { for(col in names(test)) { expect_identical(expected[[col]],test[[col]]) } @@ -223,7 +223,7 @@ check <- list( test <- out$list expected <- ans -test_that("demo-check wide categorical basic", { +test_that("demo-check wide categorical basic [PMT-TEST-0029]", { for(col in check) { expect_identical(test[[col[2]]], expected[[col[1]]]) } @@ -278,7 +278,7 @@ check <- list( test <- out$data expected <- z -test_that("demo-check wide categorical panel", { +test_that("demo-check wide categorical panel [PMT-TEST-0030]", { for(col in check) { expect_identical(expected[[col[2]]], test[[col[1]]]) } @@ -330,7 +330,7 @@ check <- list( test <- out$data expected <- z -test_that("demo-check wide categorical grouped", { +test_that("demo-check wide categorical grouped [PMT-TEST-0031]", { for(col in check) { expect_identical(expected[[col[1]]], test[[col[2]]]) } @@ -385,7 +385,7 @@ check <- list( test <- out$data expected <- z -test_that("demo-check wide categorical grouped paneled", { +test_that("demo-check wide categorical grouped paneled [PMT-TEST-0032]", { for(col in check) { expect_identical(expected[[col[1]]], test[[col[2]]]) } @@ -427,7 +427,7 @@ y <- mutate( expected <- y test <- out$data -test_that("demo-check long categorical", { +test_that("demo-check long categorical [PMT-TEST-0033]", { for(col in c(2,3)) { expect_identical(expected[[col]], test[[col]]) } @@ -440,7 +440,7 @@ total <- nrow(data) wide <- tibble(Summary = paste0("n = ", total)) test <- out$cols_extra expected <- wide -test_that("demo-check long categorical - n", { +test_that("demo-check long categorical - n [PMT-TEST-0034]", { for(col in names(expected)) { expect_identical(test[[col]], expected[[col]]) } @@ -490,7 +490,7 @@ expected <- z test <- out$data -test_that("demo-check long categorical grouped", { +test_that("demo-check long categorical grouped [PMT-TEST-0035]", { for(col in names(expected)) { expect_identical(test[[col]], expected[[col]]) } @@ -506,7 +506,7 @@ wide <- pivot_wider(n, names_from="FORMf", values_from="n") wide$Summary <- paste0("n = ", total) test <- out$cols_extra expected <- wide -test_that("demo-check long categorical grouped - n", { +test_that("demo-check long categorical grouped - n [PMT-TEST-0036]", { for(col in names(expected)) { expect_identical(test[[col]], expected[[col]]) } @@ -540,7 +540,7 @@ x1 <- summarise( test <- out$data expected <- x1 -test_that("demo-check wide continuous", { +test_that("demo-check wide continuous [PMT-TEST-0037]", { for(col in names(expected)) { expect_identical(test[[col]], expected[[col]]) } @@ -583,7 +583,7 @@ x <- mutate(x, STUDYf = replace_na(STUDYf, "All data")) test <- out$data expected <- x -test_that("demo-check wide continuous panel", { +test_that("demo-check wide continuous panel [PMT-TEST-0038]", { for(col in names(expected)) { expect_identical(test[[col]],expected[[col]]) } @@ -619,7 +619,7 @@ x <- rename(x, Study = STUDYf) test <- out$data expected <- x -test_that("demo-check wide continuous grouped", { +test_that("demo-check wide continuous grouped [PMT-TEST-0039]", { for(col in names(test)) { expect_identical(test[[col]], expected[[col]]) } @@ -657,7 +657,7 @@ x <- mutate(x, FORMf = replace_na(FORMf, ".panel.waiver.")) test <- out$data expected <- x -test_that("demo-check wide continuous grouped panel", { +test_that("demo-check wide continuous grouped panel [PMT-TEST-0040]", { for(col in names(test)) { expect_identical(test[[col]], expected[[col]]) } @@ -693,7 +693,7 @@ x <- mutate(x2, Variable = paste0(Variable, c(" (kg)", " (mg/dL)", " (years)"))) test <- out$data expected <- x -test_that("demo-check long continuous", { +test_that("demo-check long continuous [PMT-TEST-0041]", { for(col in names(test)) { expect_identical(test[[col]],expected[[col]]) } @@ -744,7 +744,7 @@ x <- mutate(x, STUDYf = replace_na(STUDYf, "All data")) test <- out$data expected <- x -test_that("demo-check long continuous panel", { +test_that("demo-check long continuous panel [PMT-TEST-0042]", { for(col in names(test)) { expect_identical(test[[col]],expected[[col]]) } diff --git a/tests/testthat/test-demographics-table.R b/tests/testthat/test-demographics-table.R index 974e912f..ae5e121b 100644 --- a/tests/testthat/test-demographics-table.R +++ b/tests/testthat/test-demographics-table.R @@ -6,7 +6,7 @@ context("test-demographics-table") cont <- "AGE,WT" cat <- "SEXf,ASIANf" -test_that("pt_demographics - call with span and summary", { +test_that("pt_demographics - call with span and summary [PMT-TEST-0043]", { out <- pt_demographics( data = pmt_first, cols_cont = cont, @@ -19,11 +19,11 @@ test_that("pt_demographics - call with span and summary", { ustudy <- unique(as.character(pmt_first$STUDYf)) expect_equal( names(out$data), - c("name", "Statistic", ustudy, "All data") + c("name", "Statistic", ustudy, "Summary") ) }) -test_that("pt_demographics - call with span, no summary", { +test_that("pt_demographics - call with span, no summary [PMT-TEST-0044]", { out <- pt_demographics( data = pmt_first, cols_cont = cont, @@ -39,7 +39,7 @@ test_that("pt_demographics - call with span, no summary", { ) }) -test_that("pt_demographics - call with summary, no span", { +test_that("pt_demographics - call with summary, no span [PMT-TEST-0045]", { out <- pt_demographics( data = pmt_first, cols_cont = cont, @@ -48,11 +48,11 @@ test_that("pt_demographics - call with summary, no span", { expect_is(out, "pmtable") expect_equal( names(out$data), - c("name", "Statistic", "All data") + c("name", "Statistic", "Summary") ) }) -test_that("demographics data summary - summary function", { +test_that("demographics data summary - summary function [PMT-TEST-0046]", { # With tibble new_fun <- function(value = seq(1,5), ...) { @@ -82,7 +82,7 @@ test_that("demographics data summary - summary function", { expect_true("Mean" %in% out$data$Statistic) }) -test_that("handle numeric values from cont summary function", { +test_that("handle numeric values from cont summary function [PMT-TEST-0047]", { # Values coerced to character new_fun <- function(value = seq(1,5), ...) { dplyr::tibble( @@ -98,10 +98,10 @@ test_that("handle numeric values from cont summary function", { ) expect_true("Median" %in% out$data$Statistic) cont <- dplyr::slice(out$data, 1:2) - expect_equal(cont$`All data`, c("1.32", "1.45929342")) + expect_equal(cont$Summary, c("1.32", "1.45929342")) }) -test_that("demographics data summary - summary function errors", { +test_that("demographics data summary - summary function errors [PMT-TEST-0048]", { # Wrong structure (list) new_fun <- function(value = seq(1,5), ...) { list(a = value[1], b = value[2]) @@ -133,7 +133,7 @@ test_that("demographics data summary - summary function errors", { ) }) -test_that("demographics data summary - units", { +test_that("demographics data summary - units [PMT-TEST-0049]", { out <- pt_demographics( data = pmt_first, cols_cont = c('AGE', 'WT'), @@ -145,7 +145,7 @@ test_that("demographics data summary - units", { expect_equal(unique(out$data$name), c("AGE (yr)", "WT (kg)", "SEXf", "ASIANf")) }) -test_that("demographics data summary - column renaming (no units)", { +test_that("demographics data summary - column renaming (no units) [PMT-TEST-0050]", { out <- pt_demographics( data = pmt_first, cols_cont = c('Age'='AGE', 'Weight'='WT'), @@ -159,7 +159,7 @@ test_that("demographics data summary - column renaming (no units)", { ) }) -test_that("demographics data summary - column renaming (with units)", { +test_that("demographics data summary - column renaming (with units) [PMT-TEST-0051]", { out <- pt_demographics( data = pmt_first, cols_cont = c('Age'='AGE', 'Weight'='WT'), @@ -174,7 +174,7 @@ test_that("demographics data summary - column renaming (with units)", { ) }) -test_that("demographics data summary - spot check values", { +test_that("demographics data summary - spot check values [PMT-TEST-0052]", { cols_cont <- c('AGE', 'WT') fun <- pmtables:::dem_cont_fun study1 <- dplyr::filter(pmt_first, STUDYf=="12-DEMO-001") @@ -195,19 +195,19 @@ test_that("demographics data summary - spot check values", { expect_true(out$data$`12-DEMO-002`[2] == ab2) }) -test_that("statistic column gets renamed", { +test_that("statistic column gets renamed [PMT-TEST-0053]", { out <- pt_demographics(pmt_first, cont, cat, stat_name = "Test") expect_equal(names(out$data)[2], "Test") }) -test_that("all data column gets renamed", { +test_that("all data column gets renamed [PMT-TEST-0054]", { out <- pt_demographics(pmt_first, cont, cat, all_name = "Everything") expect_equal(names(out$data)[3], "Everything") out <- pt_demographics(pmt_first, cont, cat, span="FORMf", all_name = "ALL") expect_equal(names(out$data)[6], "ALL") }) -test_that("paneled or unpaneled output", { +test_that("paneled or unpaneled output [PMT-TEST-0055]", { out <- pt_demographics(pmt_first, cont, cat, paneled = FALSE) expect_equal(out$clear_reps, "Covariate") expect_equal(out$hline_from, "Covariate") @@ -217,7 +217,7 @@ test_that("paneled or unpaneled output", { expect_equal(unname(out$data$Covariate[4]), "WT (weight)") }) -test_that("add notes to the output", { +test_that("add notes to the output [PMT-TEST-0056]", { out <- pt_demographics(pmt_first, cont, cat) expect_true("notes" %in% names(out)) expect_identical(out$notes, pmtables:::pt_demographics_notes()) @@ -225,12 +225,12 @@ test_that("add notes to the output", { expect_identical(out$notes, "mynotes") }) -test_that("set width of Statistic column", { +test_that("set width of Statistic column [PMT-TEST-0057]", { out <- pt_demographics(pmt_first, cont, cat, stat_width = 5) expect_match(out$align$update$Statistic, "5cm") }) -test_that("table argument is implemented", { +test_that("table argument is implemented [PMT-TEST-0058]", { tab <- list(WT = "Weight (kg)", SCR = "Creat", ASIANf = "Asian") out <- pt_demographics(pmt_first, "WT,AGE,SCR", cat, table = tab) expect_equal(out$data$name[1], "Weight (kg)") @@ -238,3 +238,39 @@ test_that("table argument is implemented", { expect_equal(out$data$name[7], "Creat") expect_equal(out$data$name[12], "Asian") }) + +test_that("demographics table has group argument [PMT-TEST-0059]", { + tab1a <- pt_demographics( + pmt_first, + cols_cont = "WT", + cols_cat = c("SEXf", "ASIANf"), + span = "FORMf" + )$data + tab1b <- pt_cat_long( + pmt_first, + cols = c("SEXf", "ASIANf"), + span = "FORMf" + )$data + + test1 <- select(filter(tab1a, name != "WT"), -1, -2) + ref1 <- select(tab1b, -1, -2) + expect_identical(test1, ref1) + + tab2a <- pt_demographics( + pmt_first, + cols_cont = "WT", + cols_cat = c("SEXf", "ASIANf"), + span = "FORMf", + denom = "total" + )$data + tab2b <- pt_cat_long( + pmt_first, + cols= c("SEXf", "ASIANf"), + span = "FORMf", + denom = "total" + )$data + + test2 <- select(filter(tab2a, name != "WT"), -1, -2) + ref2 <- select(tab2b, -1, -2) + expect_identical(test2, ref2) +}) diff --git a/tests/testthat/test-digits.R b/tests/testthat/test-digits.R index 18af3a25..8ecbb221 100644 --- a/tests/testthat/test-digits.R +++ b/tests/testthat/test-digits.R @@ -1,7 +1,7 @@ context("test-digits") -test_that("new digit object", { +test_that("new digit object [PMT-TEST-0060]", { x <- new_digits(.fun = pmtables:::sig) expect_is(x,"digits") expect_true(pmtables:::is.digits(x)) @@ -10,7 +10,7 @@ test_that("new digit object", { expect_is(as.list(x),"list") }) -test_that("new digit object, with defaults", { +test_that("new digit object, with defaults [PMT-TEST-0061]", { x <- new_digits(.fun = pmtables:::sig, A = 1, B = 2) expect_is(x,"digits") expect_equal(x$.default,3) @@ -20,7 +20,7 @@ test_that("new digit object, with defaults", { expect_equal(x$.digits$B,2) }) -test_that("update digit object", { +test_that("update digit object [PMT-TEST-0062]", { x <- new_digits(.fun = pmtables:::sig, A = 1, B = 1, C = 1) x <- pmtables:::update_digits(x, cols = c("B", "Z", "A")) data <- pmtables:::get_digits_list(x) @@ -32,7 +32,7 @@ test_that("update digit object", { expect_equal(data$Z,x$.default) }) -test_that("print", { +test_that("print [PMT-TEST-0063]", { x <- new_digits(.fun = pmtables:::sig, A = 1, B = 1, C = 1) ans <- capture.output(print(x)) expect_is(ans,"character") @@ -45,6 +45,6 @@ test_that("print", { expect_length(ans,2) }) -test_that("digits - invalid function", { +test_that("digits - invalid function [PMT-TEST-0064]", { expect_error(new_digits(.fun = sum), "'digits' must be included") }) diff --git a/tests/testthat/test-discrete-data.R b/tests/testthat/test-discrete-data.R index 4f84e5da..d54e574c 100644 --- a/tests/testthat/test-discrete-data.R +++ b/tests/testthat/test-discrete-data.R @@ -1,9 +1,11 @@ +library(testthat) +library(pmtables) context("test-cat-data") cols <- pmtables:::new_names(c("CPf", "SEXf", "RFf")) -test_that("discrete data summary long - simple", { +test_that("discrete data summary long - simple [PMT-TEST-0065]", { data <- pmt_first ans <- cat_data(data, cols = cols) expect_is(ans,"data.frame") @@ -18,7 +20,7 @@ test_that("discrete data summary long - simple", { expect_equal(ncol(ans),3) }) -test_that("discrete data summary long - by", { +test_that("discrete data summary long - by [PMT-TEST-0066]", { data <- pmt_first ans <- cat_data(data, cols = cols, by = "STUDY") expect_is(ans,"data.frame") @@ -34,7 +36,7 @@ test_that("discrete data summary long - by", { expect_equal(ncol(ans),nby + 2) }) -test_that("discrete data summary wide - simple", { +test_that("discrete data summary wide - simple [PMT-TEST-0067]", { data <- pmt_first ans <- cat_data(data, cols = cols, wide = TRUE) expect_is(ans,"data.frame") @@ -49,7 +51,7 @@ test_that("discrete data summary wide - simple", { expect_equal(ncol(ans),l + 1 + 1) }) -test_that("discrete data summary wide - by", { +test_that("discrete data summary wide - by [PMT-TEST-0068]", { data <- pmt_first ans <- cat_data(data, cols = cols, wide = TRUE, by = "STUDY") expect_is(ans,"data.frame") @@ -63,3 +65,105 @@ test_that("discrete data summary wide - by", { # add 1 for summary, 1 for N expect_equal(ncol(ans),l + 1 + 1) }) + +extract_pct <- function(x) { + x <- strsplit(x, "\\(|\\)") + x <- sapply(x, "[[", 2) + as.numeric(x) +} + +test_that("discrete data summary - with group denominator [PMT-TEST-0069]", { + data <- pmt_first + cols <- c("FORMf") + # The long summary sums by column + ans <- cat_data(data, cols = cols, wide = FALSE, by = "STUDYf", denom = "group") + expect_is(ans,"data.frame") + ans <- ans[,seq(3, ncol(ans))] + ans[] <- lapply(ans, extract_pct) + expect_true(all(colSums(ans)==100)) + # The wide summary sums by row + ans <- cat_data(data, cols = cols, wide = TRUE, by = "STUDYf", denom = "group") + expect_is(ans,"data.frame") + ans <- ans[,seq(3, ncol(ans))] + ans[] <- lapply(ans, extract_pct) + expect_true(all(rowSums(ans)==100)) +}) + +test_that("discrete data summary - with total denominator [PMT-TEST-0070]", { + data <- pmt_first + cols <- c("FORMf") + # The long table summs to 100% across everything + ans <- cat_data( + data, cols = cols, wide = FALSE, by = "STUDYf", denom = "total", + panel = "ASIANf" + ) + expect_is(ans,"data.frame") + ans <- ans[, seq(4, ncol(ans))] + ans[] <- lapply(ans, extract_pct) + summ <- sum(ans) + expect_true(summ > 99.5 & summ < 100.2) + # The wide table summs to 100% within column group + ans <- cat_data( + data, + cols = c(cols, "ASIANf"), panel = "SEXf", + wide = TRUE, by = "STUDYf", denom = "total", + ) + expect_is(ans,"data.frame") + ans <- ans[,grepl("ASIAN", names(ans))] + ans[] <- lapply(ans, extract_pct) + summ <- sum(ans) + expect_true(summ > 99.5 & summ < 100.2) +}) + +test_that("discrete data - wide summary is completed [PMT-TEST-0071]", { + data <- data.frame( + ID = 1, + A = as.character(c(1, 2, 3, 4)), + B = as.character(c(1, 2, 1, 2)), + C = as.character(c("a", "b", "a", "b")), + stringsAsFactors = FALSE + ) + ans1 <- pt_cat_wide( + data, + cols = "A", + by = "C", + panel = "B", + complete = FALSE, + summarize = "none" + )$data + expect_equal(nrow(ans1), 2L) + expect_equal(ans1$B, as.character(c(1,2))) + expect_equal(ans1$C, c("a", "b")) + + ans2 <- pt_cat_wide( + data, + cols = "A", + by = "C", + panel = "B", + complete = TRUE, + summarize = "none" + )$data + expect_equal(nrow(ans2), 4L) + expect_equal(ans2$B, as.character(rep(c(1,2), each = 2))) + expect_equal(ans2$C, rep(c("a", "b"), times = 2)) +}) + +test_that("discrete data - factor levels preserved in completed data [PMT-TEST-0072]", { + data <- data.frame( + ID = 1, + A = as.character(c(1, 2, 3, 4)), + B = factor(c(1, 2, 1, 2), levels = c(2,1)), + C = as.character(c("a", "b", "a", "b")), + stringsAsFactors = FALSE + ) + ans <- pt_cat_wide( + data, + cols = "A", + by = "C", + panel = "B", + complete = TRUE, + summarize = "none" + )$data + expect_equal(as.character(ans$B), as.character(rep(c(2,1), each = 2))) + expect_equal(ans$C, rep(c("a", "b"), times = 2)) +}) diff --git a/tests/testthat/test-discrete-table.R b/tests/testthat/test-discrete-table.R index 338a2d17..e61b48e6 100644 --- a/tests/testthat/test-discrete-table.R +++ b/tests/testthat/test-discrete-table.R @@ -6,13 +6,13 @@ inspect <- function(...) { get_stable_data(stable(..., inspect = TRUE)) } -test_that("discrete data table - long", { +test_that("discrete data table - long [PMT-TEST-0073]", { data <- pmt_first ans <- pt_cat_long(data, cols = "SEXf,RFf,CPf", span = "STUDYf") expect_is(ans,"pmtable") }) -test_that("discrete - long, summaries", { +test_that("discrete - long, summaries [PMT-TEST-0074]", { data <- pmt_first ans <- pt_cat_long(data, cols = "SEXf,RFf,CPf", span = "STUDYf") expect_is(ans,"pmtable") @@ -38,13 +38,13 @@ test_that("discrete - long, summaries", { expect_equal(ncol(ans$data), nc-1) }) -test_that("discrete data table - wide", { +test_that("discrete data table - wide [PMT-TEST-0075]", { data <- pmt_first ans <- pt_cat_wide(data, cols = "SEXf,RFf,CPf", by = "STUDYf") expect_is(ans,"pmtable") }) -test_that("discrete - wide, summaries", { +test_that("discrete - wide, summaries [PMT-TEST-0076]", { data <- pmt_first ans <- pt_cat_wide(data, cols = "SEXf,RFf,CPf", by = "STUDYf") nr <- length(unique(data$STUDYf)) @@ -57,7 +57,7 @@ test_that("discrete - wide, summaries", { expect_equal(nrow(ans$data), nr) }) -test_that("notes - cat-wide", { +test_that("notes - cat-wide [PMT-TEST-0077]", { ans <- pt_cat_wide(pmt_first, cols = "FORMf,SEXf")$notes expect_is(ans, "character") expect_length(ans,2) @@ -65,7 +65,7 @@ test_that("notes - cat-wide", { expect_match(ans[2], "number of records summarized", fixed = TRUE) }) -test_that("notes - cat-long", { +test_that("notes - cat-long [PMT-TEST-0078]", { ans <- pt_cat_long(pmt_first, cols = "STUDYf")$notes expect_is(ans, "character") expect_length(ans,2) @@ -73,12 +73,12 @@ test_that("notes - cat-long", { expect_match(ans[2], "number of records summarized", fixed = TRUE) }) -test_that("cat wide table has n", { +test_that("cat wide table has n [PMT-TEST-0079]", { ans <- pt_cat_wide(pmt_first, cols = "FORMf,STUDYf")$data expect_true("n" %in% names(ans)) }) -test_that("cat long table has cols_extra", { +test_that("cat long table has cols_extra [PMT-TEST-0080]", { ans <- pt_cat_long(pmt_first, cols = "FORMf,STUDYf", span = "SEXf")$cols_extra expect_is(ans,"data.frame") expect_equal(ans$Summary ,"n = 160") @@ -86,7 +86,7 @@ test_that("cat long table has cols_extra", { expect_equal(ans$female ,"n = 80") }) -test_that("cat wide with spanner breaks", { +test_that("cat wide with spanner breaks [PMT-TEST-0081]", { ans <- pt_cat_wide( pmt_first, cols = c("Formulation ... type" = "FORMf", "SEX" = "SEXf") @@ -100,7 +100,7 @@ test_that("cat wide with spanner breaks", { expect_equal(out$span_data$cols, c("n", lvls)) }) -test_that("cat table with missing value", { +test_that("cat table with missing value [PMT-TEST-0082]", { data <- pmt_first data$SEXf[20] <- NA_character_ expect_warning( @@ -110,7 +110,7 @@ test_that("cat table with missing value", { expect_is(ans, "pmtable") }) -test_that("cat wide with renamed cols", { +test_that("cat wide with renamed cols [PMT-TEST-0083]", { data <- pmt_first ans1 <- pt_cat_wide(data, cols = c(Form = "FORMf", Sex = "SEXf")) tb <- list(FORMf = "Form", SEXf = "Sex") @@ -126,7 +126,7 @@ test_that("cat wide with renamed cols", { expect_equal(sp$title, c("", rep("Form", an), rep("Sex", bn))) }) -test_that("cat long with renamed cols", { +test_that("cat long with renamed cols [PMT-TEST-0084]", { data <- pmt_first ans1 <- pt_cat_long(data, cols = c(Form = "FORMf", Sex = "SEXf")) tb <- list(FORMf = "Form", SEXf = "Sex") diff --git a/tests/testthat/test-expected.R b/tests/testthat/test-expected.R index 4c2575e3..1a87c1dd 100644 --- a/tests/testthat/test-expected.R +++ b/tests/testthat/test-expected.R @@ -9,19 +9,19 @@ read_tex <- function(file) { readLines(file.path("validate", file)) } -test_that("basic-table", { +test_that("basic-table [PMT-TEST-0085]", { expect <- read_tex("basic-table.tex") ans <- stable(pmt_summarized) expect_identical(expect, as.character(ans)) }) -test_that("basic-table-bold", { +test_that("basic-table-bold [PMT-TEST-0086]", { expect <- read_tex("basic-table-bold.tex") ans <- stable(pmt_summarized, cols_bold = TRUE) expect_identical(expect, as.character(ans)) }) -test_that("file-names", { +test_that("file-names [PMT-TEST-0087]", { expect <- read_tex("file-names.tex") ans <- stable( pmt_summarized, @@ -31,7 +31,7 @@ test_that("file-names", { expect_identical(expect, as.character(ans)) }) -test_that("notes-tpt", { +test_that("notes-tpt [PMT-TEST-0088]", { expect <- read_tex("notes-tpt.tex") ans <- stable( pmt_summarized, @@ -40,7 +40,7 @@ test_that("notes-tpt", { expect_identical(expect, as.character(ans)) }) -test_that("notes-mini", { +test_that("notes-mini [PMT-TEST-0089]", { expect <- read_tex("notes-mini.tex") conf <- noteconf(type = "minipage") ans <- stable( @@ -51,7 +51,7 @@ test_that("notes-mini", { expect_identical(expect, as.character(ans)) }) -test_that("panel-basic", { +test_that("panel-basic [PMT-TEST-0090]", { expect <- read_tex("panel-basic.tex") ans <- stable( pmt_summarized, @@ -60,7 +60,7 @@ test_that("panel-basic", { expect_identical(expect, as.character(ans)) }) -test_that("panel-prefix", { +test_that("panel-prefix [PMT-TEST-0091]", { expect <- read_tex("panel-prefix.tex") ans <- stable( pmt_summarized, @@ -69,7 +69,7 @@ test_that("panel-prefix", { expect_identical(expect, as.character(ans)) }) -test_that("clear-reps", { +test_that("clear-reps [PMT-TEST-0092]", { expect <- read_tex("clear-reps.tex") ans <- stable( pmt_summarized, @@ -78,7 +78,7 @@ test_that("clear-reps", { expect_identical(expect, as.character(ans)) }) -test_that("clear-grouped-reps", { +test_that("clear-grouped-reps [PMT-TEST-0093]", { expect <- read_tex("clear-grouped-reps.tex") ans <- stable( pmt_summarized, @@ -87,7 +87,7 @@ test_that("clear-grouped-reps", { expect_identical(expect, as.character(ans)) }) -test_that("hline-at", { +test_that("hline-at [PMT-TEST-0094]", { expect <- read_tex("hline-at.tex") ans <- stable( pmt_summarized, @@ -96,7 +96,7 @@ test_that("hline-at", { expect_identical(expect, as.character(ans)) }) -test_that("hline-from", { +test_that("hline-from [PMT-TEST-0095]", { expect <- read_tex("hline-from.tex") ans <- stable( pmt_summarized, @@ -105,7 +105,7 @@ test_that("hline-from", { expect_identical(expect, as.character(ans)) }) -test_that("hline-from-clear", { +test_that("hline-from-clear [PMT-TEST-0096]", { expect <- read_tex("hline-from-clear.tex") ans <- stable( pmt_summarized, @@ -115,7 +115,7 @@ test_that("hline-from-clear", { expect_identical(expect, as.character(ans)) }) -test_that("align", { +test_that("align [PMT-TEST-0097]", { expect <- read_tex("align.tex") ans <- stable( pmt_summarized, @@ -124,7 +124,7 @@ test_that("align", { expect_identical(expect, as.character(ans)) }) -test_that("cols-rename", { +test_that("cols-rename [PMT-TEST-0098]", { expect <- read_tex("col-rename.tex") ans <- stable( pmt_summarized, @@ -133,7 +133,7 @@ test_that("cols-rename", { expect_identical(expect, as.character(ans)) }) -test_that("cols-blank", { +test_that("cols-blank [PMT-TEST-0099]", { expect <- read_tex("col-blank.tex") ans <- stable( pmt_summarized, @@ -142,7 +142,7 @@ test_that("cols-blank", { expect_identical(expect, as.character(ans)) }) -test_that("col-multi-line", { +test_that("col-multi-line [PMT-TEST-0100]", { expect <- read_tex("col-multi-line.tex") ans <- stable( pmt_summarized, @@ -151,7 +151,7 @@ test_that("col-multi-line", { expect_identical(expect, as.character(ans)) }) -test_that("col-multi-line-units", { +test_that("col-multi-line-units [PMT-TEST-0101]", { expect <- read_tex("col-multi-line-units.tex") ans <- stable( pmt_summarized, @@ -162,7 +162,7 @@ test_that("col-multi-line-units", { expect_identical(expect, as.character(ans)) }) -test_that("span", { +test_that("span [PMT-TEST-0102]", { expect <- read_tex("span.tex") ans <- stable( pmt_summarized, @@ -171,7 +171,7 @@ test_that("span", { expect_identical(expect, as.character(ans)) }) -test_that("span-levels", { +test_that("span-levels [PMT-TEST-0103]", { expect <- read_tex("span-levels.tex") ans <- stable( pmt_summarized, @@ -183,7 +183,7 @@ test_that("span-levels", { expect_identical(expect, as.character(ans)) }) -test_that("row-space", { +test_that("row-space [PMT-TEST-0104]", { expect <- read_tex("row-space.tex") ans <- stable( pmt_summarized, @@ -192,7 +192,7 @@ test_that("row-space", { expect_identical(expect, as.character(ans)) }) -test_that("col-space", { +test_that("col-space [PMT-TEST-0105]", { expect <- read_tex("col-space.tex") ans <- stable( pmt_summarized, @@ -201,7 +201,7 @@ test_that("col-space", { expect_identical(expect, as.character(ans)) }) -test_that("header-space", { +test_that("header-space [PMT-TEST-0106]", { expect <- read_tex("header-space.tex") ans <- stable( pmt_summarized, @@ -211,7 +211,7 @@ test_that("header-space", { expect_identical(expect, as.character(ans)) }) -test_that("continuous-long-panel", { +test_that("continuous-long-panel [PMT-TEST-0107]", { expect <- read_tex("continuous-long-panel.tex") ans <- pt_cont_long( pmt_first, cols = "WT,CRCL,ALB", panel = "STUDYf", @@ -220,7 +220,7 @@ test_that("continuous-long-panel", { expect_identical(expect, as.character(ans)) }) -test_that("continuous-wide-by", { +test_that("continuous-wide-by [PMT-TEST-0108]", { expect <- read_tex("continuous-wide-by.tex") ans <- pt_cont_wide( pmt_first, @@ -231,7 +231,7 @@ test_that("continuous-wide-by", { expect_identical(expect, as.character(ans)) }) -test_that("cat-long-span", { +test_that("cat-long-span [PMT-TEST-0109]", { expect <- read_tex("cat-long-span.tex") ans <- pt_cat_long( pmt_first, @@ -241,7 +241,7 @@ test_that("cat-long-span", { expect_identical(expect, as.character(ans)) }) -test_that("cat-wide-by-panel", { +test_that("cat-wide-by-panel [PMT-TEST-0110]", { expect <- read_tex("cat-wide-by-panel.tex") ans <- pt_cat_wide( pmt_first, @@ -251,7 +251,7 @@ test_that("cat-wide-by-panel", { expect_identical(expect, as.character(ans)) }) -test_that("inventory-by", { +test_that("inventory-by [PMT-TEST-0111]", { expect <- read_tex("inventory-by.tex") ans <- pt_data_inventory( pmt_pk, @@ -261,7 +261,7 @@ test_that("inventory-by", { expect_identical(expect, as.character(ans)) }) -test_that("inventory-panel-by", { +test_that("inventory-panel-by [PMT-TEST-0112]", { expect <- read_tex("inventory-panel-by.tex") ans <- pt_data_inventory( pmt_pk, @@ -271,7 +271,7 @@ test_that("inventory-panel-by", { expect_identical(expect, as.character(ans)) }) -test_that("inventory-stacked", { +test_that("inventory-stacked [PMT-TEST-0113]", { expect <- read_tex("inventory-stacked.tex") ans <- pt_data_inventory( pmt_obs, diff --git a/tests/testthat/test-hline.R b/tests/testthat/test-hline.R index c4aabfa0..dd6c0402 100644 --- a/tests/testthat/test-hline.R +++ b/tests/testthat/test-hline.R @@ -15,26 +15,26 @@ data <- tibble( d = c("a", "a", "b", "a", "b") ) -test_that("test-hline-hline-at", { +test_that("test-hline-hline-at [PMT-TEST-0114]", { x <- inspect(data = data, hline_at = c(2,4)) ans <- grep("hline", x$tab) expect_equal(c(2,4)-1, ans) }) -test_that("test-hline-hline-from", { +test_that("test-hline-hline-from [PMT-TEST-0115]", { x <- inspect(data = data, hline_from = "d") ans <- grep("hline", x$tab) expect_equal(c(3,4,5)-1, ans) expect_error(inspect(data = data, hline_from = "kyle")) }) -test_that("test-hline st_hline pattern", { +test_that("test-hline st_hline pattern [PMT-TEST-0116]", { x <- st_new(stdata()) %>% st_hline(pattern = "cap", col = "FORM") %>% st_make() y <- st_new(stdata()) %>% st_hline(pattern = "cap") %>% st_make() expect_identical(x,y) }) -test_that("test-hline st_hline nudge", { +test_that("test-hline st_hline nudge [PMT-TEST-0117]", { data <- tibble(a = letters[1:10]) x <- st_new(data) %>% st_hline(pattern = 'd') %>% @@ -54,7 +54,7 @@ test_that("test-hline st_hline nudge", { expect_false(grepl("hline", z$tab[3])) }) -test_that("test-hline st_hline accumulate", { +test_that("test-hline st_hline accumulate [PMT-TEST-0118]", { x <- st_new(tibble(a = letters)) %>% st_hline(at = c(1,2,3)) %>% diff --git a/tests/testthat/test-inventory-data.R b/tests/testthat/test-inventory-data.R index 961c8bd5..474fd036 100644 --- a/tests/testthat/test-inventory-data.R +++ b/tests/testthat/test-inventory-data.R @@ -1,7 +1,7 @@ context("test-inventory-data") -test_that("inventory data summary", { +test_that("inventory data summary [PMT-TEST-0119]", { data <- pmt_first ans <- data_inventory_data(data, by = ".total") expect_equal(nrow(ans),1) @@ -15,7 +15,7 @@ test_that("inventory data summary", { expect_identical(ans,ans2) }) -test_that("stacked inventory data summary", { +test_that("stacked inventory data summary [PMT-TEST-0120]", { data <- pmt_first ans <- pmtables:::data_inventory_data_split(data, by = "STUDYf") nstudy <- length(unique(data[["STUDY"]])) @@ -28,7 +28,7 @@ test_that("stacked inventory data summary", { ) }) -test_that("missing columns", { +test_that("missing columns [PMT-TEST-0121]", { data <- data.frame(DV = 1, ID = 2, BQL = 3, by = 'a') expect_silent(data_inventory_data(data, by = "by")) bad <- select(data, -DV) diff --git a/tests/testthat/test-inventory-table.R b/tests/testthat/test-inventory-table.R index 323d7425..54797281 100644 --- a/tests/testthat/test-inventory-table.R +++ b/tests/testthat/test-inventory-table.R @@ -2,7 +2,7 @@ library(testthat) context("test-inventory-table") -test_that("inventory table", { +test_that("inventory table [PMT-TEST-0122]", { data <- pmt_first ans <- pt_data_inventory(data, by = "STUDYf") expect_is(ans,"pmtable") @@ -18,7 +18,7 @@ test_that("inventory table", { expect_equal(names(tab)[7], "Percent.BQL") }) -test_that("inventory table grouped paneled", { +test_that("inventory table grouped paneled [PMT-TEST-0123]", { data <- pmt_first ans <- pt_data_inventory(data, by = "STUDYf", panel = "FORMf") expect_is(ans,"pmtable") @@ -39,7 +39,7 @@ test_that("inventory table grouped paneled", { }) -test_that("inventory table - stacked", { +test_that("inventory table - stacked [PMT-TEST-0124]", { data <- pmt_obs ans <- pt_data_inventory(data, panel = "SEQf", by = "STUDYf",stacked = TRUE) expect_is(ans,"pmtable") @@ -57,7 +57,7 @@ test_that("inventory table - stacked", { expect_equal(names(tab)[8], "Percent.BQL") }) -test_that("inventory table - different BQL cols", { +test_that("inventory table - different BQL cols [PMT-TEST-0125]", { data1 <- pmt_pk data2 <- rename(data1, BLQ = BQL) ans1 <- pt_data_inventory(data1) @@ -65,13 +65,13 @@ test_that("inventory table - different BQL cols", { expect_false(identical(ans1,ans2)) }) -test_that("inventory table - no bq col", { +test_that("inventory table - no bq col [PMT-TEST-0126]", { data <- select(pmt_pk, -BQL) ans <- pt_data_inventory(data) expect_false(any(grepl("BQL", names(ans$data), fixed = TRUE))) }) -test_that("notes - inventory", { +test_that("notes - inventory [PMT-TEST-0127]", { ans <- pt_data_inventory(pmt_pk)$notes expect_is(ans, "character") expect_length(ans,4) @@ -81,14 +81,14 @@ test_that("notes - inventory", { expect_match(ans[4], "OBS: observations", fixed = TRUE) }) -test_that("drop MISS column", { +test_that("drop MISS column [PMT-TEST-0128]", { ans1 <- pt_data_inventory(pmt_pk)$data expect_equal(names(ans1)[2], "Number.MISS") ans2 <- pt_data_inventory(pmt_pk, drop_miss = TRUE)$data expect_equal(names(ans2)[2], "Number.OBS") }) -test_that("inventory table - denominator", { +test_that("inventory table - denominator [PMT-TEST-0129]", { non_miss <- filter(pmt_pk, !(is.na(DV) & BQL==0)) ans <- pt_data_inventory(pmt_pk)$data miss <- ans$Number.MISS @@ -103,20 +103,20 @@ test_that("inventory table - denominator", { expect_equal(pmtables:::digit1(100*bql/den), pbq) }) -test_that("inventory table - bql", { +test_that("inventory table - bql [PMT-TEST-0130]", { x <- c(rep(0,10), rep(1,2), rep(3,5)) expect_equal(pmtables:::n_bql(x), 7) expect_equal(sum(pmtables:::is_bql(x)), 7) }) -test_that("inventory table - obs", { +test_that("inventory table - obs [PMT-TEST-0131]", { dv <- c(1,2,3,4,5,6,7,8) bql <- c(0,0,1,0,0,2,0,0) ans <- pmtables:::n_obs(dv, bql) expect_equal(ans, 6) }) -test_that("inventory table - missing / non-missing", { +test_that("inventory table - missing / non-missing [PMT-TEST-0132]", { x <- NA_real_ dv <- c(0,1,x,3,4,5,x,7,8,x) bql <- c(0,0,0,1,0,0,2,0,0,0) @@ -126,7 +126,7 @@ test_that("inventory table - missing / non-missing", { expect_equal(ans, 8) }) -test_that("handle BQL and BLQ inventory table", { +test_that("handle BQL and BLQ inventory table [PMT-TEST-0133]", { data1 <- pmt_first data2 <- dplyr::rename(data1, BLQ = BQL) diff --git a/tests/testthat/test-longtable.R b/tests/testthat/test-longtable.R index 4833a6f4..b24d5a36 100644 --- a/tests/testthat/test-longtable.R +++ b/tests/testthat/test-longtable.R @@ -7,19 +7,19 @@ inspect_long <- function(...) { context("test-longtable") -test_that("test-longtable stable_long", { +test_that("test-longtable stable_long [PMT-TEST-0134]", { notes <- letters[1:3] out <- inspect_long(data = mtcars, notes = notes) expect_match(out$output, "\\begin{longtable}", fixed = TRUE, all=FALSE) }) -test_that("longtable - caption text", { +test_that("longtable - caption text [PMT-TEST-0135]", { out <- inspect_long(data = mtcars, lt_cap_text = "Text caption") test <- "\\caption{Text caption}" expect_match(out$output, test, fixed = TRUE, all=FALSE) }) -test_that("longtable - caption with short", { +test_that("longtable - caption with short [PMT-TEST-0136]", { out <- inspect_long( data = mtcars, lt_cap_text = "Text caption", @@ -29,7 +29,7 @@ test_that("longtable - caption with short", { expect_match(out$output, test, fixed = TRUE, all=FALSE) }) -test_that("longtable - caption macro", { +test_that("longtable - caption macro [PMT-TEST-0137]", { out <- inspect_long(data = mtcars, lt_cap_macro = "mylongtable") test <- "\\caption{\\mylongtable}" expect_match(out$output, test, fixed = TRUE, all = FALSE) @@ -39,7 +39,7 @@ test_that("longtable - caption macro", { "invalid for use in latex")) }) -test_that("longtable - row spacing is set", { +test_that("longtable - row spacing is set [PMT-TEST-0138]", { out <- inspect_long(data = mtcars, sizes = tab_size(lt_row = 0.15)) expect_match(out$tab,"extrarowheight}{0.15em}", all = FALSE, fixed = TRUE) out <- inspect_long(data = mtcars, sizes = tab_size(lt_row = -0.11, row = 1.3)) @@ -47,12 +47,12 @@ test_that("longtable - row spacing is set", { expect_match(out$tab,"renewcommand{\\arraystretch}{1.3}", all = FALSE, fixed = TRUE) }) -test_that("longtable - output file is saved", { +test_that("longtable - output file is saved [PMT-TEST-0139]", { out <- stable_long(ptdata(), output_file = "../path/foo.tex") expect_equal(attributes(out)$stable_file, "../path/foo.tex") }) -test_that("longtable - with span", { +test_that("longtable - with span [PMT-TEST-0140]", { data <- stdata() span <- colgroup("a group of cols", 4:9) out <- inspect_long(data, span = span) @@ -64,7 +64,7 @@ test_that("longtable - with span", { ) }) -test_that("longtable - with units", { +test_that("longtable - with units [PMT-TEST-0141]", { data <- stdata() units <- list(WT = "(kg)", AGE = "(years)") out <- inspect_long(data, units = units ) @@ -82,7 +82,7 @@ test_that("longtable - with units", { ) }) -test_that("longtable - with span and units", { +test_that("longtable - with span and units [PMT-TEST-0142]", { data <- stdata() units <- list(WT = "(kg)", AGE = "(years)") span <- colgroup("a group of cols", 4:9) @@ -101,19 +101,19 @@ test_that("longtable - with span and units", { ) }) -test_that("render long table from pmtable", { +test_that("render long table from pmtable [PMT-TEST-0143]", { a <- stable_long(pt_cont_long(pmt_first, cols = "WT,ALB,SCR")) expect_is(a, "stable_long") expect_is(a, "stable") }) -test_that("render long table from stobject", { +test_that("render long table from stobject [PMT-TEST-0144]", { a <- st_new(stdata()) %>% stable_long() expect_is(a, "stable_long") expect_is(a, "stable") }) -test_that("set font size in longtable", { +test_that("set font size in longtable [PMT-TEST-0145]", { a <- stable_long(stdata(), inspect = TRUE) expect_match(a[1], "\\arraystretch", fixed = TRUE) sz <- tab_size(font = "scriptsize") diff --git a/tests/testthat/test-new_names.R b/tests/testthat/test-new_names.R index dd91a701..0c18aeb4 100644 --- a/tests/testthat/test-new_names.R +++ b/tests/testthat/test-new_names.R @@ -2,7 +2,7 @@ context("test-new_names") -test_that("new names - character", { +test_that("new names - character [PMT-TEST-0146]", { x <- pmtables:::new_names("a,b,c") expect_identical(unname(x),names(x)) expect_is(x,"character") @@ -13,14 +13,14 @@ test_that("new names - character", { expect_equal(x, c(a = "a", B = "b", c = "c", zz = "z")) }) -test_that("new names - quosure, unnamed", { +test_that("new names - quosure, unnamed [PMT-TEST-0147]", { x <- pmtables:::new_names(dplyr::vars(a,b,c)) expect_identical(unname(x),names(x)) expect_is(x,"character") expect_length(x,3) }) -test_that("new names - quosure, named", { +test_that("new names - quosure, named [PMT-TEST-0148]", { x <- pmtables:::new_names(dplyr::vars(j = a, k = b, c)) expect_is(x,"character") expect_length(x,3) @@ -28,7 +28,7 @@ test_that("new names - quosure, named", { expect_identical(names(x), c("j", "k", "c")) }) -test_that("new names - quosure, table", { +test_that("new names - quosure, table [PMT-TEST-0149]", { table <- list(c = "d") x <- pmtables:::new_names(dplyr::vars(a,b,c),table) expect_identical(names(x),c("a", "b", "d")) @@ -36,7 +36,7 @@ test_that("new names - quosure, table", { expect_length(x,3) }) -test_that("new names - panel", { +test_that("new names - panel [PMT-TEST-0150]", { x <- rowpanel("a") x <- pmtables:::new_names(x) expect_identical(names(x),c("a")) @@ -45,7 +45,7 @@ test_that("new names - panel", { expect_length(x,1) }) -test_that("new names - list", { +test_that("new names - list [PMT-TEST-0151]", { x <- list(a = "A", z = "Z") x <- pmtables:::new_names(x) expect_identical(names(x),c("a", "z")) @@ -54,7 +54,7 @@ test_that("new names - list", { expect_length(x,2) }) -test_that("duplicated values is error", { +test_that("duplicated values is error [PMT-TEST-0152]", { expect_error(pmtables:::new_names("a,b,c,a")) expect_error(pmtables:::new_names(dplyr::vars(a,b,c,a))) }) diff --git a/tests/testthat/test-notes.R b/tests/testthat/test-notes.R index 419c8aeb..3b8f3a2f 100644 --- a/tests/testthat/test-notes.R +++ b/tests/testthat/test-notes.R @@ -8,7 +8,7 @@ inspect <- function(...) { context("test-notes") -test_that("tpt notes", { +test_that("tpt notes [PMT-TEST-0153]", { data <- tibble(a = 1) x <- inspect(data = data, notes = c("abcd", "xyz")) expect_equal(x$notes, c("abcd", "xyz")) @@ -18,7 +18,7 @@ test_that("tpt notes", { expect_match(x$tpt_notes,"item xyz", fixed = TRUE, all = FALSE) }) -test_that("mini notes", { +test_that("mini notes [PMT-TEST-0154]", { data <- tibble(a = 1) conf <- noteconf( type = "minipage", table_skip = 0.6, note_skip = 0.1, @@ -38,13 +38,13 @@ test_that("mini notes", { expect_match(x$mini_notes, "\\vskip 0.1cm", fixed = TRUE, all = FALSE) }) -test_that("notes escape", { +test_that("notes escape [PMT-TEST-0155]", { data <- tibble(a = 1) x <- inspect(data = data, notes = "abc_def") expect_equal(x$notes, c("abc\\_def")) }) -test_that("test-notes-files", { +test_that("test-notes-files [PMT-TEST-0156]", { data <- tibble(a = 1) x <- inspect( data = data, @@ -76,7 +76,7 @@ test_that("test-notes-files", { ) }) -test_that("test-notes-basename-only", { +test_that("test-notes-basename-only [PMT-TEST-0157]", { data <- tibble(a = 1) x <- inspect( data = data, diff --git a/tests/testthat/test-panel.R b/tests/testthat/test-panel.R index 98d9a7c5..897f97cb 100644 --- a/tests/testthat/test-panel.R +++ b/tests/testthat/test-panel.R @@ -9,7 +9,7 @@ inspect <- function(...) { context("test-panel") -test_that("panel duplicates", { +test_that("panel duplicates [PMT-TEST-0158]", { data <- data.frame(A = c(1,1,2,2,1,1), B = 3) expect_error( stable(data, panel = as.panel("A")), @@ -19,14 +19,14 @@ test_that("panel duplicates", { expect_equal(ncol(out$data),1L) }) -test_that("can't panel with one column", { +test_that("can't panel with one column [PMT-TEST-0159]", { expect_error( stable(data.frame(A = 1), panel = as.panel("A")), "must have more than one column" ) }) -test_that("span split with title", { +test_that("span split with title [PMT-TEST-0160]", { data <- data.frame(a.A = 1, a.B = 2, C = 3, z.Y = 4, z.Z = 5) title <- list(a = "First Split", z = "Last Split") out <- inspect(data, span_split = colsplit(sep = '.', title = title)) @@ -35,7 +35,7 @@ test_that("span split with title", { expect_equal(utitle, c("First Split", "", "Last Split")) }) -test_that("panel with sumrow", { +test_that("panel with sumrow [PMT-TEST-0161]", { data <- ptdata() data$STUDY[6] <- "Summary" data$STUDY[13] <- "Summary" @@ -51,7 +51,7 @@ test_that("panel with sumrow", { expect_equal(sum(all),2) }) -test_that("panel with drop", { +test_that("panel with drop [PMT-TEST-0162]", { data <- ptdata() out <- inspect(data, panel = "STUDY", drop = "N,WT,DOSE") n <- ncol(data) - 3 - 1 @@ -62,7 +62,7 @@ test_that("panel with drop", { expect_equal(ans,length(unique(data[["STUDY"]]))) }) -test_that("panel invalid regex in panel_skip", { +test_that("panel invalid regex in panel_skip [PMT-TEST-0163]", { x <- "\\textbf{c}" data <- data.frame(A = c("a", "b", x), B = "B", C = "C") out <- inspect(data, panel = as.panel("A",skip = x)) @@ -74,7 +74,7 @@ test_that("panel invalid regex in panel_skip", { expect_match(out$tab, "\\textbf{c}", all = FALSE, fixed = TRUE) }) -test_that("omit hline from panel", { +test_that("omit hline from panel [PMT-TEST-0164]", { data <- stdata() tab1 <- stable(data, panel = as.panel("STUDY")) tab2 <- stable(data, panel = as.panel("STUDY", hline = FALSE)) @@ -83,7 +83,7 @@ test_that("omit hline from panel", { expect_false(grepl("\\hline", tab2[where], fixed = TRUE)) }) -test_that("nopagebreak for panels in longtable", { +test_that("nopagebreak for panels in longtable [PMT-TEST-0165]", { ans <- stable_long(stdata(), panel = "STUDY") inserted <- grep(pmtables:::.internal$marker.panel, ans, fixed = TRUE) check <- grep("DEMO", ans, fixed = TRUE) @@ -102,7 +102,7 @@ test_that("nopagebreak for panels in longtable", { ) }) -test_that("jut de-indents panel rows", { +test_that("jut de-indents panel rows [PMT-TEST-0166]", { u <- list(WT = "kg") ans <- inspect(stdata(), panel = rowpanel("STUDY", jut = 1), units = u) code <- ans$output diff --git a/tests/testthat/test-pmtable.R b/tests/testthat/test-pmtable.R index 59ac1a72..01eeb510 100644 --- a/tests/testthat/test-pmtable.R +++ b/tests/testthat/test-pmtable.R @@ -3,7 +3,7 @@ library(dplyr) context("test-pmtable") -test_that("test-pmtable as_stable long", { +test_that("test-pmtable as_stable long [PMT-TEST-0167]", { out <- pt_cont_wide(pmt_first, cols = "WT") expect_is(out, "pmtable") expect_is(out, "list") @@ -11,7 +11,7 @@ test_that("test-pmtable as_stable long", { expect_is(ans, "stable_long") }) -test_that("test-pmtable as_stable", { +test_that("test-pmtable as_stable [PMT-TEST-0168]", { out <- pt_cont_wide(pmt_first, cols = "WT") expect_is(out, "pmtable") expect_is(out, "list") diff --git a/tests/testthat/test-preview.R b/tests/testthat/test-preview.R index d03c7a94..b0b64b81 100644 --- a/tests/testthat/test-preview.R +++ b/tests/testthat/test-preview.R @@ -4,7 +4,7 @@ library(pmtables) context("test-preview.R") -test_that("wrap stable output in landscape", { +test_that("wrap stable output in landscape [PMT-TEST-0169]", { out <- stable(stdata()) out.ls <- as_lscape(out) expect_true(is_lscape(out.ls)) @@ -13,7 +13,7 @@ test_that("wrap stable output in landscape", { expect_match(tex[2], "begin{landscape}", fixed = TRUE) }) -test_that("use latex dependencies for knit", { +test_that("use latex dependencies for knit [PMT-TEST-0170]", { expect_identical(st_using_knit_deps(), FALSE) st_use_knit_deps() expect_identical(st_using_knit_deps(), FALSE) @@ -26,7 +26,7 @@ test_that("use latex dependencies for knit", { pmtables:::st_reset_knit_deps() }) -test_that("st-wrap table placement H", { +test_that("st-wrap table placement H [PMT-TEST-0171]", { tab <- stable(stdata()) out1 <- st_wrap(tab, con = NULL, float = "!ht") expect_match(out1[2], "{table}[!ht]", fixed = TRUE) @@ -36,11 +36,11 @@ test_that("st-wrap table placement H", { pmtables:::st_reset_knit_deps() }) -test_that("error to try to view long table", { +test_that("error to try to view long table [PMT-TEST-0172]", { expect_error(st2viewer(stable_long(stdata))) }) -test_that("pass a list of tables to st2report", { +test_that("pass a list of tables to st2report [PMT-TEST-0173]", { tab <- stable(stdata()) tabs <- list(tab,tab,tab) ans1 <- st2report(tabs, dry_run = TRUE) @@ -51,20 +51,20 @@ test_that("pass a list of tables to st2report", { expect_length(ans2, 3) }) -test_that("call st_asis on a pmtable object", { +test_that("call st_asis on a pmtable object [PMT-TEST-0174]", { x <- pt_cont_long(pmt_first, cols = "WT") ans <- st_asis(x) expect_is(ans, "knit_asis") }) -test_that("error to call st_asis on non-stable object", { +test_that("error to call st_asis on non-stable object [PMT-TEST-0175]", { expect_error( st_asis(stdata()), msg = "x does not inherit from class stable" ) }) -test_that("st2report - list names are escaped", { +test_that("st2report - list names are escaped [PMT-TEST-0176]", { l <- list(a = stable(stdata()), `a_b` = stable(stdata())) a <- st2report(l, dry_run = TRUE) expect_equal(names(a), c("a", "a\\_b")) diff --git a/tests/testthat/test-sanitize.R b/tests/testthat/test-sanitize.R index a1be577c..b4cbae45 100644 --- a/tests/testthat/test-sanitize.R +++ b/tests/testthat/test-sanitize.R @@ -8,33 +8,33 @@ inspect <- function(...) { context("test-sanitize") -test_that("tab-escape", { +test_that("tab-escape [PMT-TEST-0177]", { x <- c("a", "a_b", "a $\\Sigma$ b") ans <- pmtables:::tab_escape(x) expect_equal(ans, c(x[1], "a\\_b", x[3])) }) -test_that("col names are sanitized", { +test_that("col names are sanitized [PMT-TEST-0178]", { data <- tibble(A = 1, "B %" = 2, "C_3" = 3) x <- inspect(data) expect_equal(x$cols_tex, "A & B \\% & C\\_3 \\\\") }) -test_that("units are sanitized", { +test_that("units are sanitized [PMT-TEST-0179]", { data <- tibble(A = 1, "B %" = 2, "C_3" = 3) x <- inspect(data, units = list(C_3 = "$\\mu$g")) expect_match(x$cols_tex[1], " & & C\\_3", fixed = TRUE) expect_match(x$cols_tex[2], "A & B \\% & $\\mu$g", fixed = TRUE) }) -test_that("files are sanitized", { +test_that("files are sanitized [PMT-TEST-0180]", { data <- tibble(A = 1, "B %" = 2, "C_3" = 3) x <- inspect(data, r_file = "foo_bar.R", output_file = "foo\\_bar.tex") expect_match(x$notes[1], "foo\\_bar.R", fixed = TRUE) expect_match(x$notes[2], "foo\\_bar.tex", fixed = TRUE) }) -test_that("notes are sanitized", { +test_that("notes are sanitized [PMT-TEST-0181]", { data <- tibble(A = 1, "B %" = 2, "C_3" = 3) notes <- c("foo_bar note", "foo_bar %", "$\\mu$ %") x <- inspect(data, notes = notes) @@ -43,7 +43,7 @@ test_that("notes are sanitized", { expect_match(x$notes[3], notes[3], fixed = TRUE) }) -test_that("span titles are sanitized", { +test_that("span titles are sanitized [PMT-TEST-0182]", { data <- ptdata() sp <- list( colgroup("Percent_true (%)", CRCL:AGE), @@ -55,7 +55,7 @@ test_that("span titles are sanitized", { expect_match(ans[3], "Percent\\_true (\\%)", fixed = TRUE) }) -test_that("table contents are sanitized", { +test_that("table contents are sanitized [PMT-TEST-0183]", { data <- as.data.frame(matrix(letters[1:16], ncol = 4), stringsAsFactors=FALSE) data[2,3] <- "foo_bar" data[4,3] <- "percent (%)" diff --git a/tests/testthat/test-sizes.R b/tests/testthat/test-sizes.R index aa17a5d7..1b2007a9 100644 --- a/tests/testthat/test-sizes.R +++ b/tests/testthat/test-sizes.R @@ -7,12 +7,12 @@ inspect <- function(...) { context("test-sizes") -test_that("test-sizes-fontsize", { +test_that("test-sizes-fontsize [PMT-TEST-0184]", { out <- inspect(ptdata(), sizes = tab_size(font = "tiny")) expect_match(out$output[1], "\\tiny", fixed = TRUE) }) -test_that("test-sizes-rowspace", { +test_that("test-sizes-rowspace [PMT-TEST-0185]", { out <- inspect(ptdata(), sizes = tab_size(row = 1.6)) expect_match(out$output, "renewcommand{\\arraystretch}{1.6}", fixed = TRUE, all=FALSE) }) diff --git a/tests/testthat/test-span.R b/tests/testthat/test-span.R index a5c6126d..6010308c 100644 --- a/tests/testthat/test-span.R +++ b/tests/testthat/test-span.R @@ -7,14 +7,14 @@ inspect <- function(...) { context("test-span") -test_that("span split", { +test_that("span split [PMT-TEST-0186]", { data <- data.frame(a.A = 1, a.B = 2, C = 3, z.Y = 4, z.Z = 5) out <- inspect(data, span_split = colsplit(sep = '.')) expect_equal(out$cols_new, c("A", "B", "C", "Y", "Z")) expect_equal(out$span_data$span[[1]]$title, c("a", "a", "", "z", "z")) }) -test_that("span split with reversed title / col", { +test_that("span split with reversed title / col [PMT-TEST-0187]", { data1 <- data.frame(a.A = 1, a.B = 2, C = 3, z.Y = 4, z.Z = 5) data2 <- data.frame(A.a = 1, B.a = 2, C = 3, Y.z = 4, Z.z = 5) out1 <- inspect(data1, span_split = colsplit(sep = '.')) @@ -24,7 +24,7 @@ test_that("span split with reversed title / col", { expect_equal(out2$span_data$span[[1]]$title, c("a", "a", "", "z", "z")) }) -test_that("span split with title", { +test_that("span split with title [PMT-TEST-0160]", { data <- data.frame(a.A = 1, a.B = 2, C = 3, z.Y = 4, z.Z = 5) title <- list(a = "First Split", z = "Last Split") out <- inspect(data, span_split = colsplit(sep = '.', title = title)) @@ -33,14 +33,14 @@ test_that("span split with title", { expect_equal(utitle, c("First Split", "", "Last Split")) }) -test_that("span from user", { +test_that("span from user [PMT-TEST-0189]", { out <- inspect(ptdata(), span = colgroup("from us_er", FORM:WT)) span <- out$span_data$span[[1]] expect_equal(nrow(span), ncol(ptdata())) expect_true(all(span$title[3:5] == "from us_er")) }) -test_that("span with breaks in title", { +test_that("span with breaks in title [PMT-TEST-0190]", { data <- ptdata() span <- colgroup("line 1 ~~~ line 2", WT:ALB) out <- inspect(data, span = span, span_title_break = "~~~") @@ -54,7 +54,7 @@ test_that("span with breaks in title", { expect_match(sp[[3]], "cmidrule(lr)", fixed = TRUE) }) -test_that("names are not clobbered with span plus span_split", { +test_that("names are not clobbered with span plus span_split [PMT-TEST-0191]", { data <- tibble(A = 2, B_A = 2, B_B = 3, B_C = 4) ans <- inspect( data, span_split = colsplit(sep = "_"), @@ -65,7 +65,7 @@ test_that("names are not clobbered with span plus span_split", { expect_equal(ans$span_data$span[[2]]$title, c("", "", "foo", "foo")) }) -test_that("add span_split via st_span", { +test_that("add span_split via st_span [PMT-TEST-0192]", { data <- tibble(A = 2, B_A = 2, B_B = 3, B_C = 4) x <- st_new(data) %>% st_span(sep = "_", split = TRUE) %>% inspect() expect_equal(x$span_data$cols, c("A", "A", "B", "C")) @@ -81,7 +81,7 @@ test_that("add span_split via st_span", { ) }) -test_that("align spanner - standard", { +test_that("align spanner - standard [PMT-TEST-0193]", { data <- stdata() ans1 <- stable(stdata(), span = colgroup("FOO", AGE:SCR)) ans2 <- stable(stdata(), span = colgroup("FOO", AGE:SCR, align = 'l')) @@ -104,7 +104,7 @@ test_that("align spanner - standard", { ) }) -test_that("align spanner - multiple", { +test_that("align spanner - multiple [PMT-TEST-0194]", { sp <- list( colgroup("LEFT", DOSE:FORM, align = 'l'), colgroup("CENTER", WT:CRCL), @@ -129,7 +129,7 @@ test_that("align spanner - multiple", { ) }) -test_that("align spanner - via colsplit", { +test_that("align spanner - via colsplit [PMT-TEST-0195]", { data <- rename(stdata(), AAA.CRCL= CRCL, AAA.WT = WT) ans1 <- stable(data, span_split = colsplit(sep = ".", align = 'r')) check <- which(grepl("AAA", ans1)) diff --git a/tests/testthat/test-summary-functions.R b/tests/testthat/test-summary-functions.R index 405f6629..7a24b6a5 100644 --- a/tests/testthat/test-summary-functions.R +++ b/tests/testthat/test-summary-functions.R @@ -4,7 +4,7 @@ library(dplyr) context("test-summary-functions.R") -test_that("summary cont_long_fun", { +test_that("summary cont_long_fun [PMT-TEST-0196]", { x <- rnorm(1000) ans <- pmtables:::cont_long_fun(x) expect_is(ans,"data.frame") @@ -17,7 +17,7 @@ test_that("summary cont_long_fun", { expect_equal(ans$`Min / Max`, rng) }) -test_that("summary cont_wide_fun", { +test_that("summary cont_wide_fun [PMT-TEST-0197]", { x <- rnorm(1000) ans <- pmtables:::cont_wide_fun(x) expect_is(ans,"data.frame") @@ -30,7 +30,7 @@ test_that("summary cont_wide_fun", { expect_equal(txt[3], "[1000]") }) -test_that("summary n missing", { +test_that("summary n missing [PMT-TEST-0198]", { x <- rnorm(1000) miss <- sample(seq_len(1000), 10) bq <- sample(miss, 5) diff --git a/tests/testthat/test-sumrow.R b/tests/testthat/test-sumrow.R index 4f79fb8c..8593b571 100644 --- a/tests/testthat/test-sumrow.R +++ b/tests/testthat/test-sumrow.R @@ -7,7 +7,7 @@ inspect <- function(...) { context("test-sumrow") -test_that("summary row", { +test_that("summary row [PMT-TEST-0199]", { file <- system.file("datasets", "with-total.RDS", package = "pmtables") data <- readRDS(file) n <- nrow(data) diff --git a/tests/testthat/test-tab_cols.R b/tests/testthat/test-tab_cols.R index b1ab0638..50f77de3 100644 --- a/tests/testthat/test-tab_cols.R +++ b/tests/testthat/test-tab_cols.R @@ -9,14 +9,14 @@ inspect <- function(...) { context("test-tab_cols") # issue-62 -test_that("underscore doesn't get escaped in rename", { +test_that("underscore doesn't get escaped in rename [PMT-TEST-0200]", { cols <- c("A", "B", "C_f", "D") renam <- c(X = "C_f") out <- tab_cols(cols, cols_rename = renam) expect_identical(out$new[3], "X") }) -test_that("cols are not renamed when no match", { +test_that("cols are not renamed when no match [PMT-TEST-0201]", { cols <- letters[1:5] re_label <- LETTERS[1:5] out <- pmtables:::rename_cols(cols, re_label) @@ -26,21 +26,21 @@ test_that("cols are not renamed when no match", { expect_identical(out, cols) }) -test_that("cols are renamed", { +test_that("cols are renamed [PMT-TEST-0202]", { cols <- letters[1:5] re_label <- c("A" = "a", "DD" = "d") out <- pmtables:::rename_cols(cols, re_label) expect_identical(out, c("A", "b", "c", "DD", "e")) }) -test_that("cols are replaced", { +test_that("cols are replaced [PMT-TEST-0203]", { data <- data.frame(A = 1, B = 2, C = 3) out <- inspect(data, cols_replace = c("X", "Y", "Z")) expect_equal(out$cols_new, c("X", "Y", "Z")) expect_error(stable(data, cols_replace = c("X", "Y"))) }) -test_that("cols are bold", { +test_that("cols are bold [PMT-TEST-0204]", { data <- tibble(a = 1, b = 2, c = 3) x <- inspect(data, cols_bold = TRUE) expect_true(grepl("textbf", x$cols_tex)) @@ -48,14 +48,14 @@ test_that("cols are bold", { expect_false(grepl("textbf", x$cols_tex)) }) -test_that("cols are bold after sanitizing", { +test_that("cols are bold after sanitizing [PMT-TEST-0205]", { data <- tibble(a_z = 1, b = 2, c = 3) x <- inspect(data, cols_bold = TRUE) cols <- str_split(x$cols_tex, " *& *") expect_equal(cols[[1]][1], "\\textbf{a\\_z}") }) -test_that("units", { +test_that("units [PMT-TEST-0206]", { u <- list(b = "in",kyle = "baron", dd = 5, a = "mg") data <- tibble(a = 1, b = 2, c = 3) x <- inspect(data,units = u) @@ -66,7 +66,7 @@ test_that("units", { ) }) -test_that("col title breaks", { +test_that("col title breaks [PMT-TEST-0207]", { data <- tibble(a = 1, b = 2, c = 3) x <- inspect( data, @@ -86,19 +86,19 @@ test_that("col title breaks", { expect_match(x$cols_tex[4], "A & B & c") }) -test_that("column is dropped", { +test_that("column is dropped [PMT-TEST-0208]", { data <- tibble(a = 1, b = 2, z = 25, c = 3) x <- inspect(data, drop = "z") expect_identical(x$cols, c("a", "b", "c")) }) -test_that("de-tag column labels", { +test_that("de-tag column labels [PMT-TEST-0209]", { data <- tibble(x.a = 1, x.b = 2, y.a = 25, z.a = 3) x <- inspect(data, cols_split = '.') expect_identical(x$cols_new, c("a", "b", "a", "a")) }) -test_that("tab-cols cols_extra", { +test_that("tab-cols cols_extra [PMT-TEST-0210]", { x <- letters[1:10] data <- tibble(a = x, b = x, c = x) xtra <- data[1,] @@ -114,7 +114,7 @@ test_that("tab-cols cols_extra", { ) }) -test_that("cols_omit drops column names - stable", { +test_that("cols_omit drops column names - stable [PMT-TEST-0211]", { a <- stable(stdata(), cols_omit = FALSE) b <- stable(stdata(), cols_omit = TRUE) expect_equal(length(a) - length(b), 2) @@ -124,7 +124,7 @@ test_that("cols_omit drops column names - stable", { expect_false(any(grepl("CRCL", b))) }) -test_that("cols_omit drops column names - longtable", { +test_that("cols_omit drops column names - longtable [PMT-TEST-0212]", { a <- stable_long(stdata(), cols_omit = FALSE) b <- stable_long(stdata(), cols_omit = TRUE) expect_match(a[1:20], "STUDY &", all = FALSE, fixed = TRUE) @@ -133,7 +133,7 @@ test_that("cols_omit drops column names - longtable", { expect_false(any(grepl("CRCL", b))) }) -test_that("cols_omit drops units", { +test_that("cols_omit drops units [PMT-TEST-0213]", { u <- list(WT = "kg") a <- stable(stdata(), units = u) b <- stable(stdata(), cols_omit = TRUE, units = u) @@ -141,7 +141,7 @@ test_that("cols_omit drops units", { expect_false(any(grepl("kg", b))) }) -test_that("cols_omit keeps span data", { +test_that("cols_omit keeps span data [PMT-TEST-0214]", { sp <- as.span("title", WT:SCR) a <- stable(stdata(), span = sp) b <- stable(stdata(), cols_omit = TRUE, span = sp) diff --git a/tests/testthat/test-table-object.R b/tests/testthat/test-table-object.R index 04ea4c40..f6468437 100644 --- a/tests/testthat/test-table-object.R +++ b/tests/testthat/test-table-object.R @@ -13,7 +13,7 @@ inspect2 <- function(x) { x %>% st_make(inspect=TRUE) %>% get_stable_data() } -test_that("stobject equivalent hline", { +test_that("stobject equivalent hline [PMT-TEST-0215]", { mt <- mtcars[1:20,] x <- inspect(mt, hline_at = c(1,5,8)) y <- st_new(mt) %>% st_hline(at = c(1,5,8)) %>% @@ -27,7 +27,7 @@ test_that("stobject equivalent hline", { expect_identical(x$tab, y$tab) }) -test_that("hine re", { +test_that("hine re [PMT-TEST-0216]", { data <- data.frame( Study = c("A", "B", "C", "All Studies"), Result = c(1,2,3,123), @@ -41,7 +41,7 @@ test_that("hine re", { expect_identical(where, nrow(data)-1L) }) -test_that("stobject equivalent cols_bold", { +test_that("stobject equivalent cols_bold [PMT-TEST-0217]", { mt <- mtcars[1:20,] x <- inspect(mt, cols_bold = TRUE) y <- st_new(mt, cols_bold = TRUE) %>% @@ -50,7 +50,7 @@ test_that("stobject equivalent cols_bold", { expect_identical(x$cols_tex, y$cols_tex) }) -test_that("stobject equivalent panel", { +test_that("stobject equivalent panel [PMT-TEST-0218]", { mt <- arrange(mtcars[1:20,], cyl) x <- inspect(mt, panel = "cyl") y <- st_new(mt) %>% @@ -60,7 +60,7 @@ test_that("stobject equivalent panel", { expect_identical(x$cols_tex, y$cols_tex) }) -test_that("stobject equivalent sumrow", { +test_that("stobject equivalent sumrow [PMT-TEST-0219]", { file <- system.file("datasets", "with-total.RDS", package = "pmtables") data <- readRDS(file) sumr <- sumrow(rows = data$STUDY=="all", bold = TRUE, label = "All data") @@ -71,7 +71,7 @@ test_that("stobject equivalent sumrow", { expect_identical(out1,out2) }) -test_that("stobject equivalent span", { +test_that("stobject equivalent span [PMT-TEST-0220]", { data <- tibble(a = 1, b = 2, c = 3, d = 4, e = 5, f = 6) sp <- list( colgroup("first", a:c), @@ -84,7 +84,7 @@ test_that("stobject equivalent span", { expect_identical(x,y) }) -test_that("stobject equivalent files", { +test_that("stobject equivalent files [PMT-TEST-0221]", { mt <- arrange(mtcars[1:20,], cyl) x <- inspect(mt, r_file = "a.R", output_file = "b.tex") y <- st_new(mt) %>% @@ -95,7 +95,7 @@ test_that("stobject equivalent files", { }) -test_that("stobject equivalent drop", { +test_that("stobject equivalent drop [PMT-TEST-0222]", { mt <- mtcars[1:3,] x <- inspect(mt, drop = "cyl") y <- st_new(mt) %>% st_drop(cyl) %>% @@ -103,7 +103,7 @@ test_that("stobject equivalent drop", { expect_identical(x$output, y$output) }) -test_that("stobject equivalent align", { +test_that("stobject equivalent align [PMT-TEST-0223]", { mt <- mtcars[1:3,] ali <- cols_center(cyl = 'r', hp = 'l', qsec = col_ragged(3)) x <- inspect(mt, align = ali) @@ -114,7 +114,7 @@ test_that("stobject equivalent align", { expect_identical(x$output, y$output) }) -test_that("stobject equivalent notes", { +test_that("stobject equivalent notes [PMT-TEST-0224]", { mt <- mtcars[1:3,] notes <- letters[1:3] x <- inspect( @@ -143,7 +143,7 @@ test_that("stobject equivalent notes", { expect_identical(a$output, b$output) }) -test_that("stobject equivalent rename", { +test_that("stobject equivalent rename [PMT-TEST-0225]", { mt <- mtcars[1:3,] notes <- letters[1:3] x <- inspect( @@ -157,7 +157,7 @@ test_that("stobject equivalent rename", { expect_identical(x$output, y$output) }) -test_that("rename by named list", { +test_that("rename by named list [PMT-TEST-0226]", { mt <- mtcars[1:3,] y1 <- st_new(mt) %>% @@ -183,7 +183,7 @@ test_that("rename by named list", { }) -test_that("stobject equivalent blank", { +test_that("stobject equivalent blank [PMT-TEST-0227]", { mt <- mtcars[1:3,] notes <- letters[1:3] x <- inspect( @@ -197,28 +197,28 @@ test_that("stobject equivalent blank", { expect_identical(x$output, y$output) }) -test_that("stobject equivalent clear_reps", { +test_that("stobject equivalent clear_reps [PMT-TEST-0228]", { data <- ptdata() x <- inspect(data, clear_reps = "FORM") y <- st_new(data) %>% st_clear_reps(FORM) %>% inspect2() expect_identical(x$output, y$output) }) -test_that("stobject equivalent clear_grouped_reps", { +test_that("stobject equivalent clear_grouped_reps [PMT-TEST-0229]", { data <- ptdata() x <- inspect(data, clear_grouped_reps = "STUDY,DOSE") y <- st_new(data) %>% st_clear_grouped(STUDY,DOSE) %>% inspect2() expect_identical(x$output, y$output) }) -test_that("stobject equivalent longtable", { +test_that("stobject equivalent longtable [PMT-TEST-0230]", { data <- ptdata() x <- stable_long(data) y <- st_new(data) %>% st_make(long=TRUE) expect_identical(x, y) }) -test_that("tab edit", { +test_that("tab edit [PMT-TEST-0231]", { data <- tibble(a = c(1,2,3), b = c(4,2,6)) ans <- tab_edit(data, "2", "222") expect_equal(ans$a, c("1", "222", "3")) @@ -228,7 +228,7 @@ test_that("tab edit", { expect_equal(ans$b, c("4", "222", "6")) }) -test_that("st_units", { +test_that("st_units [PMT-TEST-0232]", { data <- ptdata() x <- st_new(data) %>% st_units(WT = "kg", ALB = "foo") expect_identical(x$units, list(WT = "(kg)", ALB = "(foo)")) @@ -237,7 +237,7 @@ test_that("st_units", { expect_identical(x$units, list(WT = "(kg)", ALB = "(foo)")) }) -test_that("st_bold and st_it", { +test_that("st_bold and st_it [PMT-TEST-0233]", { data <- data.frame(A = 1, B =2 , C = 3) x <- st_new(data) %>% st_bold("B") expect_equal(x$data$B, "\\textbf{2}") @@ -245,7 +245,7 @@ test_that("st_bold and st_it", { expect_equal(x$data$A, "\\textit{1}") }) -test_that("st_args overwrites any arg", { +test_that("st_args overwrites any arg [PMT-TEST-0234]", { x <- st_new(stdata()) x <- st_notes(x, "the original note") y <- get_stable_data(stable(x, inspect = TRUE)) @@ -255,10 +255,160 @@ test_that("st_args overwrites any arg", { expect_identical(z$notes, "a new note") }) -test_that("arguments to st_args must be named", { +test_that("arguments to st_args must be named [PMT-TEST-0235]", { x <- st_new(stdata()) expect_error( st_args(x, "the original note"), regexp = "must be named" ) }) + +test_that("pipe pt_cat_wide to stobject", { + x <- pt_cat_wide( + pmt_first, + cols = c("SEXf", "ASIANf") + ) + a <- st_new(x) %>% st_notes("a,b,c") %>% stable() + b <- stable(x, notes = c(x$notes, "a,b,c")) + expect_identical(a, b) +}) + +test_that("pipe pt_cat_long to stobject", { + x <- pt_cat_long( + pmt_first, + cols = c("SEXf", "ASIANf") + ) + a <- st_new(x) %>% st_notes("a,b,c") %>% stable() + b <- stable(x, notes = c(x$notes, "a,b,c")) + expect_identical(a, b) +}) + +test_that("pipe pt_cont_wide to stobject", { + x <- pt_cont_long( + pmt_first, + cols = c("AGE", "WT") + ) + a <- st_new(x) %>% st_notes("a,b,c") %>% stable() + b <- stable(x, notes = c(x$notes, "a,b,c")) + expect_identical(a, b) +}) + +test_that("pipe pt_cont_long to stobject", { + x <- pt_cont_wide( + pmt_first, + cols = c("AGE", "WT") + ) + a <- st_new(x) %>% st_notes("a,b,c") %>% stable() + b <- stable(x, notes = c(x$notes, "a,b,c")) + expect_identical(a, b) +}) + +test_that("pipe pt_demographics to stobject", { + x <- pt_demographics( + pmt_first, + cols_cont = c("AGE", "WT"), + cols_cat = c("SEXf", "ASIANf") + ) + a <- st_new(x) %>% st_notes("a,b,c") %>% stable() + b <- stable(x, notes = c(x$notes, "a,b,c")) + expect_identical(a, b) +}) + +test_that("call st_col_split() on pmtable", { + expect_error( + pt_cat_wide(pmt_first, cols = c("SEXf")) %>% + st_new() %>% st_span_split(), + regexp = "the st_span_split() function cannot be used", + fixed = TRUE + ) +}) + +test_that("call st_panel() on pmtable", { + expect_error( + pt_cat_wide(pmt_first, cols = c("SEXf")) %>% + st_new() %>% st_panel(), + regexp = "the st_panel() function cannot be used", + fixed = TRUE + ) +}) + +test_that("call st_units() on pmtable", { + expect_error( + pt_cat_wide(pmt_first, cols = c("SEXf")) %>% + st_new() %>% st_units(), + regexp = "the st_units() function cannot be used", + fixed = TRUE + ) +}) + + +test_that("remove notes from a st object", { + x <- pt_data_inventory(pmt_obs) + expect_true(is.character(x$notes)) + expect_true(length(x$notes) > 0) + x <- st_new(x) + x <- st_notes_rm(x) + expect_null(x$notes) +}) + +test_that("append a note in a st object", { + x <- pt_data_inventory(pmt_obs) + x <- st_new(x) + nn <- x$notes + x <- st_notes_app(x, "more notes") + mm <- x$notes + l <- length(nn) + ans <- paste0(nn[l], "; more notes") + expect_equal(ans, mm[l]) +}) + +test_that("collapse notes to a single string in st object", { + x <- pt_data_inventory(pmt_obs) + nn <- x$notes + x <- st_new(x) + x <- st_notes_str(x) + mm <- x$notes + ans <- paste0(nn, collapse = "; ") + expect_identical(ans, mm) +}) + +test_that("detach the notes in a st object", { + x <- st_new(pt_data_inventory(pmt_obs)) + x <- st_notes_detach(x, 0.95) + conf <- x$note_config + expect_equal(conf$width, 0.95) + expect_equal(conf$type, "minipage") +}) + +test_that("substitute lines in table notes", { + x <- pt_data_inventory(pmt_obs) + not <- x$notes + x <- st_new(x) + + a <- st_notes_sub(x, "^MISS", "missing stuff") + expect_equal(a$notes[3], "missing stuff") + + b <- st_notes_sub(x, 2, "below ql") + expect_equal(b$notes[2], "below ql") + + expect_warning( + st_notes_sub(x, "kyle", "abc"), + regexp = "did not find any matching notes" + ) + + expect_error( + st_notes_sub(x, TRUE, "abc"), + regexp = "must be either character or numeric" + ) + + expect_error( + st_notes_sub(x, 100, "abc"), + regexp = "not less than or equal to" + ) + + xx <- st_notes_rm(x) + expect_warning( + st_notes_sub(xx, "kyle", "abc"), + regexp = "did not find any notes" + ) +}) diff --git a/tests/testthat/test-table-utils.R b/tests/testthat/test-table-utils.R index b4d3d9e0..f7fbcd5f 100644 --- a/tests/testthat/test-table-utils.R +++ b/tests/testthat/test-table-utils.R @@ -4,7 +4,7 @@ library(pmtables) context("test-utils-table.R") -test_that("tex_bold and tex_it", { +test_that("tex_bold and tex_it [PMT-TEST-0236]", { expect_error(tex_bold(1)) expect_error(tex_it(1)) ans <- tex_bold("a") @@ -21,7 +21,7 @@ test_that("tex_bold and tex_it", { expect_identical(ans[3], "\\textbf{c}") }) -test_that("test-table-utils-stable_save", { +test_that("test-table-utils-stable_save [PMT-TEST-0237]", { tmp <- tempfile() x <- stable(data.frame(a = 1), output_file = tmp) expect_invisible(ans <- stable_save(x)) @@ -35,7 +35,7 @@ test_that("test-table-utils-stable_save", { expect_error(stable_save(x), "and the 'file' argument is missing") }) -test_that("save a list of tables", { +test_that("save a list of tables [PMT-TEST-0238]", { a <- stable(stdata(), output_file = "a.tex") b <- stable(stdata(), output_file = "b.tex") l <- list(a,b) @@ -43,7 +43,7 @@ test_that("save a list of tables", { expect_is(ans, "list") }) -test_that("table-utils paste units", { +test_that("table-utils paste units [PMT-TEST-0239]", { cols <- LETTERS[c(2,5,4,3,1)] units <- list(C = "pounds", X = "none", B = "mg", D = "kg", Z = "liters") cols_new <- pmtables:::paste_units(cols, units) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index f38814f1..d2c52a0b 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,7 +1,7 @@ context("test-utils") -test_that("Update_List", { +test_that("Update_List [PMT-TEST-0240]", { a <- list(a = 1, b = 2, c = 3) b <- list(c = 4, a = 3, z = 500) x <- pmtables:::Update_List(a,b) @@ -13,19 +13,19 @@ test_that("Update_List", { expect_equal(x$b,a$b) }) -test_that("digit1", { +test_that("digit1 [PMT-TEST-0241]", { expect_equal(digit1(1.2345), "1.2") expect_equal(digit1(100202.2345), "100202.2") }) -test_that("rnd is a very simple wrapper for round", { +test_that("rnd is a very simple wrapper for round [PMT-TEST-0242]", { x <- rnorm(1000) a <- round(x, 5) b <- rnd(x, 5, foo = "bar") expect_identical(a,b) }) -test_that("check if regular expression is valid", { +test_that("check if regular expression is valid [PMT-TEST-0243]", { expect_true(pmtables:::is_regex("^abc$")) expect_false(pmtables:::is_regex("\\textbf{foo}")) expect_true(pmtables:::is_str_regex(fixed("\\textbf{foo}"))) @@ -36,7 +36,7 @@ test_that("check if regular expression is valid", { expect_match(x, "invalid-regex-") }) -test_that("repattern data frame", { +test_that("repattern data frame [PMT-TEST-0244]", { a <- data.frame(a = 1, b = 2, c = 3) b <- data.frame(a = 4, d = 5, z = 5, c = 4) c <- data.frame(j = 5, m = 2) @@ -52,7 +52,7 @@ test_that("repattern data frame", { }) -test_that("add parens to vector if not there", { +test_that("add parens to vector if not there [PMT-TEST-0245]", { a <- letters[1:3] ans <- ensure_parens(a) expect_equal(ans, c("(a)", "(b)", "(c)")) @@ -83,3 +83,7 @@ test_that("add parens to vector if not there", { ans <- ensure_parens(d) expect_equal(ans, c("(1)", "(2)", "(3)")) }) + +test_that("sig returns character when passed int [PMT-UTIL-0001]", { + expect_is(sig(1L), "character") +}) diff --git a/tests/testthat/test-yaml_as_df.R b/tests/testthat/test-yaml_as_df.R index d42ce9fa..9015e947 100644 --- a/tests/testthat/test-yaml_as_df.R +++ b/tests/testthat/test-yaml_as_df.R @@ -11,7 +11,7 @@ sysfile <- function(x) { ) } -test_that("read simple table", { +test_that("read simple table [PMT-TEST-0246]", { file <- sysfile("table.yml") expect_is(yaml_as_df(file), "data.frame") file <- sysfile("prototype-error-2.yml") @@ -19,12 +19,12 @@ test_that("read simple table", { expect_message(try(yaml_as_df(file), silent = TRUE), msg = "row data in yaml") }) -test_that("read study summary table", { +test_that("read study summary table [PMT-TEST-0247]", { file <- sysfile("studySummary.yaml") expect_is(yaml_as_df(file), "data.frame") }) -test_that("read prototyped table", { +test_that("read prototyped table [PMT-TEST-0248]", { file <- sysfile("prototype.yaml") expect_is(yaml_as_df(file), "data.frame") file <- sysfile("prototype-error.yaml")