├── .Rbuildignore ├── .gitignore ├── inst ├── tests │ ├── ssafety.rda │ └── test.Rnw ├── feh.bib └── greport.sty ├── R ├── todo │ ├── baselineReport.R │ ├── complianceReport.R │ ├── makeNA.R │ ├── subjectList.R │ ├── dropoutReport.R │ ├── rreport-package.R │ ├── rangeCheck.R │ ├── repVarclus.R │ ├── refManager.R │ ├── completenessReport.R │ ├── survReport.R │ ├── Misc.firsttry.r │ └── listTable.R ├── greport-package.r ├── nriskReport.r ├── eReport.r ├── survReport.r └── accrualReport.r ├── man ├── latticeInit.Rd ├── greport.Rd ├── getgreportOption.Rd ├── maskDframe.Rd ├── mfrowSuggest.Rd ├── dNeedle.Rd ├── startPlot.Rd ├── sampleFrac.Rd ├── appsection.Rd ├── maskVal.Rd ├── putFig.Rd ├── setgreportOption.Rd ├── Merge.Rd ├── eReport.Rd ├── nriskReport.Rd ├── accrualReport.Rd ├── exReport.Rd ├── survReport.Rd └── dReport.Rd ├── DESCRIPTION ├── INDEX ├── NAMESPACE ├── README.md └── NEWS /.Rbuildignore: -------------------------------------------------------------------------------- 1 | /home/harrelfe/R/Hmisc/.Rbuildignore -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | publish 6 | greport.Rproj 7 | -------------------------------------------------------------------------------- /inst/tests/ssafety.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/harrelfe/greport/HEAD/inst/tests/ssafety.rda -------------------------------------------------------------------------------- /R/todo/baselineReport.R: -------------------------------------------------------------------------------- 1 | #' @rdname mixedvarReport 2 | #' @export 3 | 4 | baselineReport <- function(...) 5 | mixedvarReport(..., panel='baseline', bpPrototype=TRUE) 6 | -------------------------------------------------------------------------------- /man/latticeInit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{latticeInit} 4 | \alias{latticeInit} 5 | \title{Setup lattice plots using greport options} 6 | \usage{ 7 | latticeInit() 8 | } 9 | \description{ 10 | Initializes colors and other graphical attributes based on 11 | what is stored in system option \code{greport}. 12 | } 13 | -------------------------------------------------------------------------------- /man/greport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/greport-package.r 3 | \docType{package} 4 | \name{greport} 5 | \alias{greport} 6 | \alias{.noGenerics} 7 | \alias{greport-package} 8 | \title{Graphical Reporting for Clinical Trials} 9 | \format{ 10 | An object of class \code{logical} of length 1. 11 | } 12 | \usage{ 13 | .noGenerics 14 | } 15 | \description{ 16 | Graphical clinical trial reporting based on Rmarkdown, LaTeX, and pdf 17 | } 18 | \author{ 19 | Frank E Harrell Jr \email{fh@fharrell.com} 20 | } 21 | \keyword{datasets} 22 | -------------------------------------------------------------------------------- /man/getgreportOption.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{getgreportOption} 4 | \alias{getgreportOption} 5 | \title{Get greport Options} 6 | \usage{ 7 | getgreportOption(opts = NULL) 8 | } 9 | \arguments{ 10 | \item{opts}{character vector containing list of option names to retrieve. If only one element, the result is a scalar, otherwise a list. If \code{opts} is not specified, a list with all current option settings is returned.} 11 | } 12 | \description{ 13 | Get greport options, assigning default values of unspecified optios. 14 | } 15 | -------------------------------------------------------------------------------- /man/maskDframe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{maskDframe} 4 | \alias{maskDframe} 5 | \title{Mask Variables in a Data Frame} 6 | \usage{ 7 | maskDframe(x, formula, ...) 8 | } 9 | \arguments{ 10 | \item{x}{an input data frame or data table} 11 | 12 | \item{formula}{a formula specifying the variables to perturb} 13 | 14 | \item{\dots}{parameters to pass to \code{maskVal}} 15 | } 16 | \description{ 17 | Given a list of applicable variable names in a formula, runs \code{maskVal} on any variables in a data frame \code{x} whose name is found in \code{formula}. 18 | } 19 | -------------------------------------------------------------------------------- /man/mfrowSuggest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{mfrowSuggest} 4 | \alias{mfrowSuggest} 5 | \title{Compute mfrow Parameter} 6 | \usage{ 7 | mfrowSuggest(n, small = FALSE) 8 | } 9 | \arguments{ 10 | \item{n}{numeric. Total number of figures to place in layout.} 11 | 12 | \item{small}{logical. Set to \sQuote{TRUE} if the plot area should be 13 | smaller to accomodate many plots.} 14 | } 15 | \value{ 16 | return numeric vector. 17 | oldmfrow <- mfrowSet(8) 18 | } 19 | \description{ 20 | Compute a good \code{par("mfrow")} given the 21 | number of figures to plot. 22 | } 23 | -------------------------------------------------------------------------------- /man/dNeedle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{dNeedle} 4 | \alias{dNeedle} 5 | \title{Draw Needles} 6 | \usage{ 7 | dNeedle(sf, name, file = "", append = TRUE) 8 | } 9 | \arguments{ 10 | \item{sf}{output of \code{sampleFrac}} 11 | 12 | \item{name}{character string name of LaTeX variable to create} 13 | 14 | \item{file}{output file name (character string)} 15 | 16 | \item{append}{set to \code{FALSE} to start a new \code{file}} 17 | } 18 | \description{ 19 | Create a LaTeX \code{picture} to draw needles for current sample sizes. Uses colors set by call to \code{setgreportOptions}. 20 | } 21 | -------------------------------------------------------------------------------- /man/startPlot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{startPlot} 4 | \alias{startPlot} 5 | \alias{endPlot} 6 | \title{Plot Initialization} 7 | \usage{ 8 | startPlot(file, h = 7, w = 7, lattice = TRUE, ...) 9 | 10 | endPlot() 11 | } 12 | \arguments{ 13 | \item{file}{character. Character string specifying file prefix.} 14 | 15 | \item{h}{numeric. Height of plot in inches, default=7.} 16 | 17 | \item{w}{numeric. Width of plot in inches, default=7.} 18 | 19 | \item{lattice}{logical. Set to \code{FALSE} to prevent \code{latticeInit} from being called.} 20 | 21 | \item{\dots}{Arguments to be passed to \code{spar}.} 22 | } 23 | \description{ 24 | Toggle plotting. Sets options by examining \code{setgreportOption(gtype=)}. 25 | } 26 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: greport 2 | Version: 0.7-4 3 | Date: 2023-09-02 4 | Title: Graphical Reporting for Clinical Trials 5 | Author: Frank E Harrell Jr 6 | Maintainer: Frank E Harrell Jr 7 | Depends: 8 | Hmisc (>= 4.0-0), 9 | Imports: 10 | rms (>= 5.0-0), 11 | lattice, 12 | latticeExtra, 13 | ggplot2, 14 | Formula, 15 | survival, 16 | methods, 17 | data.table 18 | Description: Contains many functions useful for 19 | monitoring and reporting the results of clinical trials and other 20 | experiments in which treatments are compared. LaTeX is 21 | used to typeset the resulting reports, recommended to be in the 22 | context of 'knitr'. The 'Hmisc', 'ggplot2', and 'lattice' packages are used 23 | by 'greport' for high-level graphics. 24 | License: GPL (>= 2) 25 | URL: http://hbiostat.org/R/greport/, 26 | https://github.com/harrelfe/greport/ 27 | RoxygenNote: 7.2.3 28 | -------------------------------------------------------------------------------- /man/sampleFrac.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{sampleFrac} 4 | \alias{sampleFrac} 5 | \title{Compute Sample Fractions} 6 | \usage{ 7 | sampleFrac(n, nobsY = NULL, table = TRUE) 8 | } 9 | \arguments{ 10 | \item{n}{integer vector, named with \code{"enrolled","randomized"} and optionally also including treatment levels.} 11 | 12 | \item{nobsY}{a result of the the \code{nobsY} Hmisc function} 13 | 14 | \item{table}{set to \code{TRUE} to return as an attribute \code{"table"} a character string containing a LaTeX tabular showing the pertinent frequencies created from \code{n} and the \code{denom} option, and if \code{nobsY} is present, adding another table with response variable-specific counts.} 15 | } 16 | \description{ 17 | Uses denominators stored with \code{setgreportOption} along with counts specified to \code{SampleFrac} to compute fractions of subjects in current analysis 18 | } 19 | -------------------------------------------------------------------------------- /INDEX: -------------------------------------------------------------------------------- 1 | accrualReport Accrual Report 2 | appsection Issue LaTeX section and/or subsection in 3 | appendix 4 | dNeedle Draw Needles 5 | dReport Descriptive Statistics Report 6 | eReport Event Report 7 | exReport Exclusion Report 8 | getgreportOption Get greport Options 9 | greport Graphical Reporting for Clinical Trials 10 | latticeInit Setup lattice plots using greport options 11 | maskDframe Mask Variables in a Data Frame 12 | maskVal Mask Values of a Vector 13 | Merge Merge Multiple Data Frames or Data Tables 14 | mfrowSuggest Compute mfrow Parameter 15 | nriskReport Number at Risk Report 16 | putFig Put Figure 17 | sampleFrac Compute Sample Fractions 18 | setgreportOption Set greport Options 19 | startPlot Plot Initialization 20 | survReport Survival Report 21 | -------------------------------------------------------------------------------- /R/greport-package.r: -------------------------------------------------------------------------------- 1 | #' Graphical Reporting for Clinical Trials 2 | #' 3 | #' Graphical clinical trial reporting based on Rmarkdown, LaTeX, and pdf 4 | #' 5 | #' @author Frank E Harrell Jr \email{fh@fharrell.com} 6 | #' 7 | #' @export Merge accrualReport dNeedle dReport eReport endPlot exReport getgreportOption nriskReport putFig sampleFrac setgreportOption startPlot survReport 8 | #' @import Hmisc ggplot2 lattice data.table methods 9 | #' @importFrom latticeExtra useOuterStrips 10 | #' @importFrom rms npsurv survplot 11 | #' @importFrom survival Surv survfit 12 | #' @importFrom Formula Formula model.part 13 | #' @importFrom grDevices adjustcolor dev.off gray pdf 14 | #' @importFrom graphics abline axis box grconvertX grconvertY lines par plot plot.new points text 15 | #' @importFrom stats as.formula median model.frame qnorm reshape sd terms runif 16 | #' @docType package 17 | #' @aliases greport-package 18 | #' @name greport 19 | 20 | # The caching and check for conflicts require looking for a pattern of objects; the search may be avoided by defining an object .noGenerics 21 | # see ?library 22 | .noGenerics <- TRUE 23 | -------------------------------------------------------------------------------- /man/appsection.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{appsection} 4 | \alias{appsection} 5 | \title{Issue LaTeX section and/or subsection in appendix} 6 | \usage{ 7 | appsection(section = NULL, subsection = NULL, main = FALSE, panel = "") 8 | } 9 | \arguments{ 10 | \item{section}{a character string that will cause a section command to be added to app.tex} 11 | 12 | \item{subsection}{a character string that will cause a subsection command to be added to app.tex} 13 | 14 | \item{main}{set to \code{TRUE} to also write a section or subsection command to the console to be used in building the main report body (graphical section), in which case you should also specify \code{panel} if option \code{texdir} is not an empty string} 15 | 16 | \item{panel}{panel string; must be given if \code{main=TRUE} and option \code{texdir} is not \code{""}} 17 | } 18 | \description{ 19 | This is useful for copying section and subsection titles in the main body of the report to the appendix, to help in navigating supporting tables. LaTeX backslash characters need to be doubled. 20 | } 21 | -------------------------------------------------------------------------------- /R/todo/complianceReport.R: -------------------------------------------------------------------------------- 1 | #' Compliance Report 2 | #' 3 | #' Generate compliance report by time across treatment groups. 4 | #' 5 | #' @param comply numeric or character vector. Indicator variable for compliance. 6 | #' Should be 1/0 or yes/no. 7 | #' @param treat factor vector. Treatment group for each record. 8 | #' @param time numeric vector. Time for each record. 9 | #' @param times numeric vector. Subset of times to use. 10 | #' @export 11 | #' @examples 12 | #' \dontrun{ 13 | #' complianceReport(rbinom(200, 1, 0.8), as.factor(sample(c('A','B'), 200, replace=TRUE)), sample(10, 200, replace=TRUE)) 14 | #' } 15 | 16 | complianceReport <- function(comply, treat, time, times=NULL) { 17 | if(!is.numeric(comply)) 18 | comply <- 1*(comply %in% c('Y','Yes','yes','YES')) 19 | if(length(times)) { 20 | s <- time %in% times 21 | comply <- comply[s] 22 | treat <- treat[s] 23 | time <- time[s] 24 | } 25 | Compliance <- comply 26 | latex(summary(Compliance ~ time+stratify(treat)), 27 | file=file.path(TexDirName(), 'compliance.tex'), where='hbp!', ncaption=FALSE, ctable=TRUE) 28 | latex(summary(Compliance ~ time), 29 | file=file.path(TexDirName(), 'Ocompliance.tex'), where='hbp!', ncaption=FALSE, ctable=TRUE) 30 | invisible() 31 | } 32 | -------------------------------------------------------------------------------- /man/maskVal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{maskVal} 4 | \alias{maskVal} 5 | \title{Mask Values of a Vector} 6 | \usage{ 7 | maskVal(x, prev = 0.5, NAs = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{an input vector} 11 | 12 | \item{prev}{a numeric scalar specifying the prevalence for binary variables} 13 | 14 | \item{NAs}{if the variable contains \code{NA}s, keep the same expected proportion of \code{NA}s but distribute them randomly. Otherwise, the new vector will have no missing values.} 15 | } 16 | \description{ 17 | Modifies the value of a vector so as to mask the information by generating random data subject to constraints and keeping the length, type, label, and units attributes of the original variable. For a binary numeric or logical variable a random vector with prevalence (by default) of 0.5 replaces the original. For a factor variable, a random multinomial sample is drawn, with equal expected frequencies of all levels. For a numeric variable, the range is preserved but the distribution is uniform over that range, and generated values are rounded by an amount equal to the minimum spacing between distinct values. Character variables are just randomly reordered. In the special case where the input vector contains only one unique non-NA value, the variable is assumed to be the type of variable where NA represents FALSE or "no", and the variable is replaced by a logical vector with the specified prevalence. 18 | } 19 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(Merge) 4 | export(accrualReport) 5 | export(appsection) 6 | export(dNeedle) 7 | export(dReport) 8 | export(eReport) 9 | export(endPlot) 10 | export(exReport) 11 | export(getgreportOption) 12 | export(maskDframe) 13 | export(maskVal) 14 | export(nriskReport) 15 | export(putFig) 16 | export(sampleFrac) 17 | export(setgreportOption) 18 | export(startPlot) 19 | export(survReport) 20 | import(Hmisc) 21 | import(data.table) 22 | import(ggplot2) 23 | import(lattice) 24 | import(methods) 25 | importFrom(Formula,Formula) 26 | importFrom(Formula,model.part) 27 | importFrom(grDevices,adjustcolor) 28 | importFrom(grDevices,dev.off) 29 | importFrom(grDevices,gray) 30 | importFrom(grDevices,pdf) 31 | importFrom(graphics,abline) 32 | importFrom(graphics,axis) 33 | importFrom(graphics,box) 34 | importFrom(graphics,grconvertX) 35 | importFrom(graphics,grconvertY) 36 | importFrom(graphics,lines) 37 | importFrom(graphics,par) 38 | importFrom(graphics,plot) 39 | importFrom(graphics,plot.new) 40 | importFrom(graphics,points) 41 | importFrom(graphics,text) 42 | importFrom(latticeExtra,useOuterStrips) 43 | importFrom(rms,npsurv) 44 | importFrom(rms,survplot) 45 | importFrom(stats,as.formula) 46 | importFrom(stats,median) 47 | importFrom(stats,model.frame) 48 | importFrom(stats,qnorm) 49 | importFrom(stats,reshape) 50 | importFrom(stats,runif) 51 | importFrom(stats,sd) 52 | importFrom(stats,terms) 53 | importFrom(survival,Surv) 54 | importFrom(survival,survfit) 55 | -------------------------------------------------------------------------------- /inst/feh.bib: -------------------------------------------------------------------------------- 1 | @Manual{Rsystem, 2 | title = {R: A Language and Environment for Statistical Computing}, 3 | author = {{R Development Core Team}}, 4 | organization = {R Foundation for Statistical Computing}, 5 | address = {Vienna, Austria}, 6 | year = {2013}, 7 | note = {Available from \url{http://www.R-project.org}} 8 | } 9 | 10 | @MISC{greport, 11 | author = {Harrell, Frank E.}, 12 | year = 2014, 13 | title = {\texttt{greport}: {R} functions for graphical reporting of clinical trials.}, 14 | howpublished = {Available from \url{hbiostat.org/R/greport}} 15 | } 16 | 17 | @MISC{Hmisc, 18 | author = {Harrell, Frank E.}, 19 | year = 2014, 20 | title = {{\tt Hmisc}: {A} package of miscellaneous \textsc{R} functions}, 21 | howpublished = {Available from 22 | \url{hbiostat.org/R/Hmisc}} 23 | } 24 | 25 | @MISC{rrms, 26 | author = {Harrell, Frank E.}, 27 | year = 2013, 28 | title = {\texttt{rms}: {S} functions for biostatistical/epidemiologic 29 | modeling, testing, estimation, validation, graphics, prediction, and 30 | typesetting by storing enhanced model design attributes in the fit}, 31 | note = {Implements methods in \emph{Regression Modeling Strategies}, New York:Springer, 2001}, 32 | howpublished = {Available from \url{hbiostat.org/R/rms}} 33 | } 34 | 35 | @Book{knitrbook, 36 | author = {Yihui Xie}, 37 | title = {Dynamic Documents with R and \texttt{knitr}}, 38 | publisher = {Chapman and Hall}, 39 | year = 2013, 40 | note = {ISBN 978-1482203530}} 41 | -------------------------------------------------------------------------------- /R/todo/makeNA.R: -------------------------------------------------------------------------------- 1 | #' Make NA 2 | #' 3 | #' Examine a dataset for numeric values outside of a desired range. 4 | #' Bad values will be replaced with NAs. 5 | #' 6 | #' \code{mins} and \code{maxs} should be named vectors, where the names 7 | #' are columns found in \code{data}. They should contain the same names 8 | #' and have the same length. 9 | #' 10 | #' @param data data.frame. Dataset with numerical values to range check. 11 | #' @param mins named numeric vector. Minimum value for each named column. 12 | #' @param maxs named numeric vector. Maximum value for each named column. 13 | #' @return Returns modified data.frame invisibly. 14 | #' @export 15 | #' @examples 16 | #' set.seed(100) 17 | #' df <- data.frame(x=rnorm(100), y=rnorm(100, sd=0.5)) 18 | #' na.df <- makeNA(df, c(x=-2,y=-1), c(x=2,y=1)) 19 | 20 | makeNA <- function(data, mins, maxs) { 21 | 22 | # Make sure length(mins) = length(maxs) 23 | if(length(mins) != length(maxs)) stop('Min and max not specified for every variable') 24 | 25 | # If length(mins) = length(maxs), make sure names(mins) = names(maxs) 26 | if(any(sort(names(mins)) != sort(names(maxs)))) { 27 | stop(paste('Variable names specified in', sQuote('mins'), 28 | 'and', sQuote('maxs'), 'do not match')) 29 | } 30 | 31 | # Make sure valid column names were specified in mins and maxs for the data frame data 32 | if(any(names(mins) %nin% names(data))) { 33 | stop(paste('Illegal variable names specified in', 34 | sQuote('mins'), 'and', sQuote('maxs'))) 35 | } 36 | 37 | n <- names(mins) 38 | for(i in 1:length(n)) { 39 | x <- data[[n[i]]] 40 | check <- paste('datta <', mins[i], '| datta >', maxs[i]) 41 | checkfn <- eval(parse(text = paste('function(datta) {', check, '}'))) 42 | bad <- checkfn(x) 43 | nbad <- sum(bad, na.rm = TRUE) 44 | if(nbad) { 45 | data[bad & !is.na(x), n[i]] <- NA 46 | } 47 | } 48 | invisible(data) 49 | } 50 | -------------------------------------------------------------------------------- /man/putFig.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{putFig} 4 | \alias{putFig} 5 | \title{Put Figure} 6 | \usage{ 7 | putFig( 8 | panel, 9 | name, 10 | caption = NULL, 11 | longcaption = NULL, 12 | tcaption = caption, 13 | tlongcaption = NULL, 14 | poptable = NULL, 15 | popfull = FALSE, 16 | sidecap = FALSE, 17 | outtable = FALSE, 18 | append = TRUE 19 | ) 20 | } 21 | \arguments{ 22 | \item{panel}{character. Panel name.} 23 | 24 | \item{name}{character. Name for figure.} 25 | 26 | \item{caption}{character. Short caption for figure.} 27 | 28 | \item{longcaption}{character. Long caption for figure.} 29 | 30 | \item{tcaption}{character. Short caption for supporting table.} 31 | 32 | \item{tlongcaption}{character. Long caption for supporting table.} 33 | 34 | \item{poptable}{an optional character string containing LaTeX code that will be used as a pop-up tool tip for the figure (typically a tabular). Set to \code{NULL} to suppress supplemental tables that back up figures.} 35 | 36 | \item{popfull}{set to \code{TRUE} to make the pop-up be full-page} 37 | 38 | \item{sidecap}{set to \code{TRUE} (only applies if \code{greportOption(figenv="SCfigure")}) to assume the figure is narrow and to use side captions} 39 | 40 | \item{outtable}{set to \code{TRUE} to only have the caption and hyperlink to graphics in a LaTeX table environment and to leave the tabulars to free-standing LaTeX markup. This is useful when the table is long, to prevent hyperlinking from making the table run outside the visable area. Instead of the hyperlink area being the whole table, it will be the caption. A \code{clearpage} is issued after the tabular.} 41 | 42 | \item{append}{logical. If \sQuote{TRUE} output will be appended instead of overwritten.} 43 | } 44 | \description{ 45 | Included a generated figure within LaTex document. \code{tcaption} and \code{tlongcaption} only apply if \code{setgreportOption(tablelink="hyperref")}. 46 | } 47 | -------------------------------------------------------------------------------- /R/todo/subjectList.R: -------------------------------------------------------------------------------- 1 | #' Subject List 2 | #' 3 | #' Generate a LaTeX table from a dataset. 4 | #' 5 | #' @param data data.frame. Data used for report. 6 | #' @param panel character. Name of panel. 7 | #' @param caption character. See \code{\link[Hmisc]{latex}}. 8 | #' @param vname character. Specifies how to generate column headings, 9 | #' either through variable \sQuote{labels} or \sQuote{names}. 10 | #' @param colheads character vector. Column headings for each variable. 11 | #' @param size character. Set LaTeX table font size, see \code{\link[Hmisc]{latex}}. 12 | #' @param longtable logical. See \code{\link[Hmisc]{latex}}. 13 | #' @param landscape logical. See \code{\link[Hmisc]{latex}}. 14 | #' @export 15 | #' @examples 16 | #' \dontrun{ 17 | #' load(url('http://biostat.mc.vanderbilt.edu/wiki/pub/Main/Rreport/ssafety.rda')) 18 | #' subjectList(ssafety[1:10,1:10], "datalist", vname='names') 19 | #' } 20 | 21 | subjectList <- function(data, panel, caption=NULL, 22 | vname=c('labels','names'), 23 | colheads=NULL, 24 | size='smaller', 25 | longtable=TRUE, landscape=TRUE) { 26 | 27 | vname <- match.arg(vname) 28 | if(length(colheads)) lab <- colheads else { 29 | lab <- names(data) 30 | if(vname == 'labels') { 31 | lab <- sapply(data,label) 32 | lab <- ifelse(lab=='', names(data), lab) 33 | } 34 | } 35 | ## For chron date-time variables remove surrounding ( ) and seconds 36 | for(i in 1:length(data)) { 37 | x <- data[[i]] 38 | if(all(c('chron','dates','times') %in% class(x))) { 39 | x <- format(x) 40 | x <- substring(x, 2, nchar(x)-4) 41 | data[[i]] <- x 42 | } 43 | } 44 | 45 | w <- latex(data, file=file.path(TexDirName(), sprintf("%s.tex", panel)), 46 | title=panel, colheads=lab, 47 | longtable=longtable, size=size, caption=caption, 48 | landscape=landscape, rowname=NULL) 49 | invisible() 50 | } 51 | -------------------------------------------------------------------------------- /man/setgreportOption.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{setgreportOption} 4 | \alias{setgreportOption} 5 | \title{Set greport Options} 6 | \usage{ 7 | setgreportOption(...) 8 | } 9 | \arguments{ 10 | \item{\dots}{a series of options for which non-default values are desired: 11 | \itemize{ 12 | \item{\code{tx.pch}:}{symbols corresponding to treatments} 13 | \item{\code{tx.col}:}{colors corresponding to treatments} 14 | \item{\code{tx.linecol}:}{colors for lines in line plots} 15 | \item{\code{nontx.col}:}{colors for categories other than treatments} 16 | \item{\code{tx.lty}:}{line types corresponding to treatments} 17 | \item{\code{tx.lwd}:}{line widths corresponding to treatments} 18 | \item{\code{tx.var}:}{character string name of treatment variable} 19 | \item{\code{er.col}:}{2-vector with names \code{"enrolled","randomized"} containing colors to use for enrolled and randomized in needle displays} 20 | \item{\code{alpha.f}:}{single numeric specifying alpha adjustment to be applied to all colors. Default is 0.7} 21 | \item{\code{denom}:}{named vector with overall sample sizes} 22 | \item{\code{tablelink}:}{a character string, either \code{"tooltip"} or \code{"hyperref"} (the default); use the latter to make supporting data tables be hyperlinked to tables in the appendix rather than using a pop-up tooltip} 23 | \item{\code{figenv}:}{LaTeX figure environment to use, default is \code{"figure"}. Use \code{figenv="SCfigure"} if using the LaTeX \code{sidecap} package. \code{SCfigure} is only used for narrow images, by calling \code{putFig} with \code{sidecap=TRUE}.} 24 | \item{code{figpos}:}{LaTeX figure environment position; default is \code{"htb!"}} 25 | \item{\code{gtype}:}{graphics type, \code{"pdf"} or \code{"interactive"}} 26 | \item{\code{pdfdir}:}{name of subdirectory in which to write \code{pdf} graphics} 27 | \item{\code{texdir}:}{name of subdirectory in which to write \code{LaTeX} code} 28 | \item{\code{texwhere}:}{default is \code{"texdir"} to use location specified by \code{texdir}. Set to \code{""} to write generated non-appendix LaTeX code to the console as expected by \code{knitr}} 29 | \item{\code{defs}:}{fully qualified file name to which to write LaTeX macro definitions such as poptables} 30 | }} 31 | } 32 | \description{ 33 | Set greport Options 34 | } 35 | -------------------------------------------------------------------------------- /man/Merge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Misc.r 3 | \name{Merge} 4 | \alias{Merge} 5 | \title{Merge Multiple Data Frames or Data Tables} 6 | \usage{ 7 | Merge(..., id, all = TRUE, verbose = TRUE) 8 | } 9 | \arguments{ 10 | \item{\dots}{two or more dataframes or data tables} 11 | 12 | \item{id}{a formula containing all the identification variables such that the combination of these variables uniquely identifies subjects or records of interest. May be omitted for data tables; in that case the \code{key} function retrieves the id variables.} 13 | 14 | \item{all}{set to \code{FALSE} to drop observations not found in second and later data frames (only applies if not using \code{data.table})} 15 | 16 | \item{verbose}{set to \code{FALSE} to not print information about observations} 17 | } 18 | \description{ 19 | Merges an arbitrarily large series of data frames or data tables containing common \code{id} variables (keys for data tables). Information about number of observations and number of unique \code{id}s in individual and final merged datasets is printed. The first data frame has special meaning in that all of its observations are kept whether they match \code{id}s in other data frames or not. For all other data frames, by default non-matching observations are dropped. The first data frame is also the one against which counts of unique \code{id}s are compared. Sometimes \code{merge} drops variable attributes such as \code{labels} and \code{units}. These are restored by \code{Merge}. If all objects are of class \code{data.table}, faster merging will be done using the \code{data.table} package's join operation. This assumes that all objects have identical key variables and those of the variables on which to merge. 20 | } 21 | \examples{ 22 | a <- data.frame(sid=1:3, age=c(20,30,40)) 23 | b <- data.frame(sid=c(1,2,2), bp=c(120,130,140)) 24 | d <- data.frame(sid=c(1,3,4), wt=c(170,180,190)) 25 | all <- Merge(a, b, d, id = ~ sid) 26 | # For data.table, first file must be the master file and must 27 | # contain all ids that ever occur. ids not in the master will 28 | # not be merged from other datasets. 29 | require(data.table) 30 | a <- data.table(a); setkey(a, sid) 31 | # data.table also does not allow duplicates without allow.cartesian=TRUE 32 | b <- data.table(sid=1:2, bp=c(120,130)); setkey(b, sid) 33 | d <- data.table(d); setkey(d, sid) 34 | all <- Merge(a, b, d) 35 | } 36 | -------------------------------------------------------------------------------- /R/todo/dropoutReport.R: -------------------------------------------------------------------------------- 1 | #' Dropout Report 2 | #' 3 | #' Generate a survival plot for subjects remaining in the study. 4 | #' 5 | #' @param d.dropout numeric vector. Dropout date. 6 | #' @param dropout numeric vector. Indicator variable for dropout. 7 | #' @param treat factor vector. Vector of treatment group for each record. 8 | #' @param time.inc numeric. See \code{\link[rms]{survplot}}. 9 | #' @param ylim numeric vector. See \code{\link[rms]{survplot}}. 10 | #' @param panel character. Name for panel, defaults to \sQuote{dropout}. 11 | #' @param what character. Name of study, defaults to \sQuote{study}. 12 | #' @param \dots additional arguments, passed to \code{\link[rms]{survplot}}. 13 | #' @export 14 | #' @examples 15 | #' \dontrun{ 16 | #' d.d <- sample(1:10, 200, replace=TRUE, prob=c(rep(0.03,9), 0.73)) 17 | #' dropout <- as.numeric(d.d < 10) 18 | #' dropoutReport(d.d, dropout, as.factor(sample(c('A','B'), 200, replace=TRUE)), time.inc=2) 19 | #' } 20 | 21 | dropoutReport <- function(d.dropout, dropout, treat, 22 | time.inc=NULL, ylim=c(0,1), panel="dropout", what="study", ...) { 23 | ### function for capitalizing the first letter of each word 24 | ### borrowed from function "toupper" help 25 | .simpleCap <- function(x) { 26 | s <- strsplit(x, " ")[[1]] 27 | paste(toupper(substring(s, 1,1)), substring(s, 2), sep="", collapse=" ") 28 | } 29 | S <- if(length(dropout)) Surv(d.dropout, dropout) else 30 | Surv(d.dropout) 31 | openPanel <- paste("O", panel, sep="") 32 | startPlot(openPanel, h=4) 33 | f <- survfit.formula(S ~ treat) 34 | d <- data.frame(treat) 35 | d$S <- S 36 | yl <- paste("Fraction Remaining in",.simpleCap(what)) 37 | lwd <- c(1,2); lty=c(1,1); col=gray(c(0,.7)) 38 | if(length(time.inc)) 39 | survplot.survfit(f, time.inc=time.inc, n.risk=TRUE, conf='none', ylab=yl, 40 | lwd=lwd, lty=lty, col=col, ylim=ylim, ...) else 41 | survplot.survfit(f, conf='none', ylab=yl, lwd=lwd, lty=lty, col=col, 42 | ylim=ylim, n.risk=TRUE, ...) 43 | 44 | endPlot() 45 | startPlot(panel, h=4) 46 | f <- survfit.formula(S ~ treat, data=d) 47 | if(length(time.inc)) 48 | survplot.survfit(f, time.inc=time.inc, n.risk=TRUE, conf='none', ylab=yl, 49 | lwd=lwd, lty=lty, col=col, label.curves=FALSE, ylim=ylim, ...) 50 | else survplot.survfit(f, conf='none', ylab=yl, n.risk=TRUE, 51 | lwd=lwd, lty=lty, col=col, label.curves=FALSE, 52 | ylim=ylim, ...) 53 | endPlot() 54 | for(w in c(panel,openPanel)){ 55 | figureCaption = paste("Distribution of time until dropout from",what) 56 | putFig(w, w, figureCaption, 57 | if(w==panel) paste(figureCaption,". \\protect\\treatkey", sep="") 58 | else figureCaption, append=FALSE) 59 | } 60 | invisible() 61 | } 62 | -------------------------------------------------------------------------------- /man/eReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/eReport.r 3 | \name{eReport} 4 | \alias{eReport} 5 | \title{Event Report} 6 | \usage{ 7 | eReport( 8 | formula, 9 | data = NULL, 10 | subset = NULL, 11 | na.action = na.retain, 12 | minincidence = 0, 13 | conf.int = 0.95, 14 | etype = "adverse events", 15 | panel = "events", 16 | subpanel = NULL, 17 | head = NULL, 18 | tail = NULL, 19 | h = 6, 20 | w = 7, 21 | append = FALSE, 22 | popts = NULL 23 | ) 24 | } 25 | \arguments{ 26 | \item{formula}{a formula with one or two left hand variables (the first representing major categorization and the second minor), and 1-2 right hand variables. One of these may be enclosed in \code{id()} to indicate the presence of a unique subject ID, and the other is treatment.} 27 | 28 | \item{data}{input data frame} 29 | 30 | \item{subset}{subsetting criteria} 31 | 32 | \item{na.action}{function for handling \code{NA}s when creating analysis frame} 33 | 34 | \item{minincidence}{a number between 0 and 1 specifying the minimum incidence in any stratum that must hold before an event is included in the summary} 35 | 36 | \item{conf.int}{confidence level for difference in proportions} 37 | 38 | \item{etype}{a character string describing the nature of the events, for example \code{"adverse events"}, \code{"serious adverse events"}. Used in figure captions.} 39 | 40 | \item{panel}{panel string} 41 | 42 | \item{subpanel}{a subpanel designation to add to \code{panel}} 43 | 44 | \item{head}{character string. Specifies initial text in the figure caption, otherwise a default is used.} 45 | 46 | \item{tail}{a character string to add to end of automatic caption} 47 | 48 | \item{h}{height of graph} 49 | 50 | \item{w}{width of graph} 51 | 52 | \item{append}{set to \code{TRUE} if adding to an existing sub-report} 53 | 54 | \item{popts}{a list of options to pass to graphing functions} 55 | } 56 | \description{ 57 | Generates graphics for binary event proportions 58 | } 59 | \details{ 60 | Generates dot charts showing proportions on left and risk difference with confidence intervals on the right, if there is only one level of event categorization. Input data must contain one record per event, with this record containing the event name. If there is more than one event of a given type per subject, unique subject ID must be provided. Denominators come from \code{greport} options and it is assumed that only randomized subjects have records. Some of the graphics functions are modifications of those found in the HH package. The data are expected to have one record per event, and non-events are inferred from \code{setgreportOption('denom')}. It is also assumed that only randomized subjects are included in the dataset. 61 | } 62 | \examples{ 63 | # See test.Rnw in tests directory 64 | } 65 | \author{ 66 | Frank Harrell 67 | } 68 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | R greport package: Graphical Reporting of Clinical Trials 2 | ======= 3 | Statisticians and statistical programmers spend a great deal of time analyzing data and producing reports for clinical trials, both for final trial reports and for interim reports for data monitoring committees. Point and Click interfaces and copy-and-paste are now believed to be bad models for reproducible research. Instead, there are advantages to developing a high-level language for producing common elements of reports related to accrual, exclusions, descriptive statistics, adverse events, time to event, and longitudinal data. 4 | 5 | It is well appreciated in the statistical and graphics design communities that graphics are much better than tables for conveying numeric information. There are thus advantages for having statistical reports for clinical trials that are almost completely graphical. For those reviewers of clinical trial reports who insist on seeing tables, and for those who occasionally like to have tables to see "exact" figures for certain data elements, supporting tables can be placed in an appendix. These tables are hyperlinked to the main graphics. Small tables can also pop-up when one hovers the mouse over a graphic. These two approaches are facilitated by features of Adobe Acrobat Reader. Reviewers who prefer printed reports can print the appendix in order to have a complete document. 6 | 7 | greport marries R, the R Hmisc and lattice packages, knitr, and LaTeX 8 | to produce reproducible clinical trial reports with a minimum of 9 | coding. greport composes all figure captions and makes heavy use of 10 | analysis file annotations such as variable labels and units of 11 | measurement. Some new graphical elements are introduced such as 12 | special dot charts that replace tables, extended box plots, split 13 | violin plots for longitudinal continuous variables, half confidence 14 | intervals for differences, new charts for representing patient flow, 15 | and pop-up tooltips. Supporting tables are hyperlinked to graphics, 16 | and the graphics are hyperlinked back from the tables. Figure 17 | captions contain supporting table numbers, and tables contain figure 18 | numbers. 19 | 20 | Current Goals 21 | ============= 22 | * In accrual report cumulative randomized plots add text for deficit at last recorded randomized subject 23 | * Add Svetlana Eden's function in rreport package for graphically summarizing adverse events by major and minor categories (e.g., body system and preferred term) 24 | * Add function similar to that in rreport for group sequential monitoring boundary presentation 25 | * Need executable tests in tests/ 26 | * See if current tests should become vignettes 27 | 28 | 29 | Web Sites 30 | ============= 31 | * Overall: http://hbiostat.org/R/greport 32 | * CRAN: http://cran.r-project.org/web/packages/greport 33 | * Changelog: https://github.com/harrelfe/greport/commits/master 34 | -------------------------------------------------------------------------------- /man/nriskReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nriskReport.r 3 | \name{nriskReport} 4 | \alias{nriskReport} 5 | \title{Number at Risk Report} 6 | \usage{ 7 | nriskReport( 8 | formula, 9 | groups = NULL, 10 | time0 = "randomization", 11 | data = NULL, 12 | subset = NULL, 13 | na.action = na.retain, 14 | ylab = "Number Followed", 15 | panel = "nrisk", 16 | head = NULL, 17 | tail = NULL, 18 | h = 5.5, 19 | w = 5.5, 20 | outerlabels = TRUE, 21 | append = FALSE, 22 | popts = NULL 23 | ) 24 | } 25 | \arguments{ 26 | \item{formula}{a formula with time and the left hand side, and with variables on the right side being possible stratification variables. If no stratification put \code{1} as the right hand side. Specify unique subject IDs by including a term \code{id()} if subjects have more than one observation.} 27 | 28 | \item{groups}{a character string naming a superpositioning variable. Must also be included in \code{formula}.} 29 | 30 | \item{time0}{a character string defining the meaning of time zero in follow-up. Default is \code{"randomization"}.} 31 | 32 | \item{data}{data frame} 33 | 34 | \item{subset}{a subsetting epression for the entire analysis} 35 | 36 | \item{na.action}{a NA handling function for data frames, default is \code{na.retain}} 37 | 38 | \item{ylab}{character string if you want to override \code{"Number Followed"}} 39 | 40 | \item{panel}{character string. Name of panel, which goes into file base names and figure labels for cross-referencing. The default is \code{'nrisk'}.} 41 | 42 | \item{head}{character string. Specifies initial text in the figure caption, otherwise a default is used} 43 | 44 | \item{tail}{optional character string. Specifies final text in the figure caption, e.g., what might have been put in a footnote in an ordinary text page. This appears just before any needles.} 45 | 46 | \item{h}{numeric. Height of plot, in inches} 47 | 48 | \item{w}{numeric. Width of plot} 49 | 50 | \item{outerlabels}{logical that if \code{TRUE}, pass \code{lattice} graphics through the \code{latticeExtra} package's \code{useOuterStrips}function if there are two conditioning (paneling) variables, to put panel labels in outer margins.} 51 | 52 | \item{append}{logical. Set to \code{FALSE} to start a new panel} 53 | 54 | \item{popts}{list specifying extra arguments to pass to \code{Ecdf}. A common use is for example \code{popts=list(layout=c(columns,rows))} to be used in rendering \code{lattice} plots. \code{key} and \code{panel} are also frequently used.} 55 | } 56 | \description{ 57 | Graph number of subjects at risk 58 | } 59 | \details{ 60 | \code{nriskReport} generates multi-panel charts, separately for categorical analysis variables. Each panel depicts the number at risk as a function of follow-up time. The Hmisc \code{Ecdf} function is used. Stratification is by treatment or other variables. It is assumed that this function is only run on randomized subjects. If an \code{id} variable is present but \code{groups} and stratification variables are not, other plots are also produced: a histogram of the number of visits per subject, a histogram of times at which subjects have visits, the average number of contacts as a function of elapsed time, and a histogram showing the distribution of the longest gap between visits over subjects. 61 | } 62 | \examples{ 63 | # See test.Rnw in tests directory 64 | } 65 | -------------------------------------------------------------------------------- /man/accrualReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/accrualReport.r 3 | \name{accrualReport} 4 | \alias{accrualReport} 5 | \title{Accrual Report} 6 | \usage{ 7 | accrualReport( 8 | formula, 9 | data = NULL, 10 | subset = NULL, 11 | na.action = na.retain, 12 | dateRange = NULL, 13 | zoom = NULL, 14 | targetN = NULL, 15 | targetDate = NULL, 16 | closeDate = NULL, 17 | enrollmax = NULL, 18 | studynos = TRUE, 19 | minrand = 10, 20 | panel = "accrual", 21 | h = 2.5, 22 | w = 3.75, 23 | hb = 5, 24 | wb = 5, 25 | hdot = 3.5 26 | ) 27 | } 28 | \arguments{ 29 | \item{formula}{formula object, with time variables on the left (separated by +) and grouping variables on the right. Enrollment date, randomization date, region, country, and site when present must have the variables in parenthesis preceeded by the key words \code{enrollment, randomize, region, country, site}.} 30 | 31 | \item{data}{data frame.} 32 | 33 | \item{subset}{a subsetting epression for the entire analysis.} 34 | 35 | \item{na.action}{a NA handling function for data frames, default is \code{na.retain}.} 36 | 37 | \item{dateRange}{\code{Date} or character 2-vector formatted as \code{yyyy-mm-dd}. Provides the range on the \code{x}-axis (before any zooming).} 38 | 39 | \item{zoom}{\code{Date} or character 2-vector for an option zoomed-in look at accrual.} 40 | 41 | \item{targetN}{integer vector with target sample sizes over time, same length as \code{targetDate}} 42 | 43 | \item{targetDate}{\code{Date} or character vector corresponding to \code{targetN}} 44 | 45 | \item{closeDate}{\code{Date} or characterstring. Used for randomizations per month and per site-month - contains the dataset closing date to be able to compute the number of dates that a group (country, site, etc.) has been online since randomizating its first subject.} 46 | 47 | \item{enrollmax}{numeric specifying the upper y-axis limit for cumulative enrollment when not zoomed} 48 | 49 | \item{studynos}{logical. Set to \code{FALSE} to suppress summary study numbers table.} 50 | 51 | \item{minrand}{integer. Minimum number of randomized subjects a country must have before a box plot of time to randomization is included.} 52 | 53 | \item{panel}{character string. Name of panel, which goes into file base names and figure labels for cross-referencing.} 54 | 55 | \item{h}{numeric. Height of ordinary plots, in inches.} 56 | 57 | \item{w}{numeric. Width of ordinary plots.} 58 | 59 | \item{hb}{numeric. Height of extended box plots.} 60 | 61 | \item{wb}{numeric. Weight of extended box plots.} 62 | 63 | \item{hdot}{numeric. Height of dot charts in inches.} 64 | } 65 | \description{ 66 | Generate graphics and LaTeX to analyze subject accrual 67 | } 68 | \details{ 69 | Typically the left-hand-side variables of the formula, in order, are date of enrollment and date of randomization, with subjects enrolled but not randomized having missing date of randomization. Given such date variables, this function generates cumulative frequencies optionally with target enrollment/randomization numbers and with time-zooming. Makes a variety of dot charts by right-hand-side variables: number of subjects, number of sites, number of subjects per site, fraction of enrolled subjects randomized, number per month, number per site-month. 70 | } 71 | \examples{ 72 | \dontrun{ 73 | # See test.Rnw in tests directory 74 | } 75 | } 76 | -------------------------------------------------------------------------------- /R/todo/rreport-package.R: -------------------------------------------------------------------------------- 1 | #' This package creates reports. 2 | #' 3 | #' @author Frank E Harrell Jr \email{f.harrell@@vanderbilt.edu} 4 | #' 5 | #' Maintainer: Charles Dupont \email{charles.dupont@@vanderbilt.edu} 6 | #' 7 | #' @importFrom chron as.chron dates seq.dates chron years days hours minutes seconds 8 | #' @importFrom lattice bwplot 9 | #' @importFrom rms Surv survfit.formula survplot.survfit 10 | #' @import Hmisc 11 | #' @docType package 12 | #' @aliases rreport package-rreport 13 | #' @name rreport 14 | NULL 15 | 16 | # The caching and check for conflicts require looking for a pattern of objects; the search may be avoided by defining an object ‘.noGenerics’ 17 | # see ?library 18 | .noGenerics <- TRUE 19 | 20 | #' RReport Package Options 21 | #' 22 | #' @aliases rreport.options 23 | #' @section Options used in rreport: 24 | #' \describe{ 25 | #' \item{\code{rreport.gtype}:}{graphing device (ps, pdf, interactive)} 26 | #' \item{\code{rreport.appendix.file.name}:}{filename for appendix} 27 | #' \item{\code{rreport.generated.tex.dir}:}{directory name for report tex files} 28 | #' \item{\code{rreport.graphics.dir}:}{directory name for report graphic files} 29 | #' \item{\code{rreport.closed.filename.mask}:}{mask for closed report filenames} 30 | #' \item{\code{rreport.open.filename.mask}:}{mask for open report filenames} 31 | #' } 32 | #' @name pkgOptions 33 | #' @seealso \code{\link[base]{options}} 34 | NULL 35 | 36 | .defaultRreportOptions <- function() { 37 | list( 38 | rreport.gtype = 'pdf', 39 | rreport.appendix.file.name = 'app.tex', 40 | rreport.generated.tex.dir = 'gentex', 41 | rreport.graphics.dir = 'pdf', 42 | rreport.closed.filename.mask = NULL, 43 | rreport.open.filename.mask = 'O%s' 44 | ) 45 | } 46 | 47 | .onLoad <- function(libname, pkgname) { 48 | options(.defaultRreportOptions()) 49 | } 50 | 51 | .onAttach <- function(libname, pkgname) { 52 | packageStartupMessage("rreport library by Frank E Harrell Jr\n\nType library(help='rreport') to see overall documentation.\n\n") 53 | } 54 | 55 | # remove rreport options 56 | .onUnload <- function(libpath) { 57 | ropts <- grep("^rreport", names(options()), value=TRUE) 58 | nulls <- vector('list', length(ropts)) 59 | names(nulls) <- ropts 60 | options(nulls) 61 | } 62 | 63 | # questions? 64 | # accrualReport: no visible binding for global variable ‘code.infig’ 65 | # aeReport: no visible binding for global variable ‘weeks’ 66 | # completenessReport: no visible binding for global variable ‘compFullCaptionDone’ 67 | # freqReport: no visible binding for global variable ‘name’ 68 | # rangeCheck: no visible binding for global variable ‘dataframe’ 69 | # there is no "gtype" (interactive/pdf/ps) 70 | # endPlot 71 | # putFig 72 | # startPlot 73 | 74 | # mixedvarReport: no visible global function definition for ‘Key’ 75 | 76 | # S3 methods shown with full name in documentation object 'getReferenceObject': 77 | # ‘print.latexReference’ 78 | # 79 | # S3 methods shown with full name in documentation object 'floor.chron': 80 | # ‘floor.chron’ ‘ceiling.chron’ 81 | # 82 | # The \usage entries for S3 methods should use the \method markup and not their full name. 83 | # See the chapter ‘Writing R documentation files’ in the ‘Writing R Extensions’ manual. 84 | # * checking Rd contents ... WARNING 85 | # Argument items with no description in Rd object 'getReferenceObject': 86 | # ‘refD’ ‘newMarker’ ‘keyword’ ‘label’ 87 | # 88 | # regarding survReport 89 | #' This report assumes units are in days. 90 | #' I can use this, but the output looks dumb. 91 | #' valueUnit(mydata$time) <- "Month" 92 | -------------------------------------------------------------------------------- /inst/greport.sty: -------------------------------------------------------------------------------- 1 | % Usage: \def\poptype{0:no popup tooltips 1:ocgtools 2:movable popups 2 | % 3:tiny inline popups} 3 | % \usepackage{greport} 4 | 5 | \NeedsTeXFormat{LaTeX2e} 6 | \ProvidesPackage{greport}[2016/04/07 Support for R greport reports] 7 | 8 | % User must define LaTeX macros \tooltipn, \tooltipm, and \tooltipw 9 | % for narrow, medium, and wide LaTeX objects to pop up 10 | % Must also define macro \hsepline as \hrule doesn't work in a parbox 11 | \ifnum\poptype=0 12 | \newcommand{\tooltipn}[2]{#1}{#2} 13 | \newcommand{\tooltipm}[2]{#1}{#2} 14 | \newcommand{\tooltipw}[2]{#1}{#2} 15 | \def\hsepline{\hrule} 16 | \def\popnotation{} 17 | \fi 18 | \ifnum\poptype=1 19 | \usepackage{ocg-p} % keeps ocgtools from loading ocg package 20 | \usepackage[mouseover]{ocgtools} 21 | \usepackage{xcolor,pbox} 22 | % Needs this package the user must install using e.g.: 23 | % getlatex ocgtools 24 | % Use |-> symbol for popup rather than coloring object blue 25 | \def\ocgtextstart{} 26 | \def\ocgtextend{~\textcolor[gray]{0.5}{$\mapsto$}} 27 | \def\defaultocgpapercolor{yellow!20} 28 | \newcommand{\tooltipn}[2]{\ocgminitext{#1}{\pbox{7in}{#2}}} 29 | \newcommand{\tooltipm}[2]{\ocgminitext{#1}{\pbox{7in}{#2}}} 30 | \newcommand{\tooltipw}[2]{\ocgtext{#1}{\pbox{7in}{#2}}} 31 | % If want to have more control, use the following: 32 | % \newcommand{\tooltipn}[2]{\ocgminitext[width=3.5in]{#1}{#2}} 33 | % \newcommand{\tooltipm}[2]{\ocgminitext[width=5in]{#1}{#2}} 34 | % \newcommand{\tooltipw}[2]{\ocgtext[width=6.5in]{#1}{#2}} 35 | \def\hsepline{} 36 | %\def\hsepline{\hrule} % use if not using \parbox or \pbox 37 | \fi 38 | 39 | \ifnum\poptype=2 40 | \usepackage{tooltip,pbox} 41 | % For movable tooltips, download tooltip.sty, move to ~/texmf/tex 42 | % Note: tooltip expands width pretty well for non-wide objects 43 | \newcommand{\tooltipn}[2]{\tooltip{#1~\textcolor[gray]{0.5}{$\mapsto$}}{% 44 | \pbox{7in}{#2}}} 45 | % For stricter control of layout for narrow popups use 46 | % \newcommand{tooltipn}[2]{\tooltip{#1~\textcolor[gray]{0.5}{$\mapsto$}}{% 47 | % \parbox[c]{3.5in}{#2}} 48 | \newcommand{\tooltipm}[2]{\tooltip{#1~\textcolor[gray]{0.5}{$\mapsto$}}{% 49 | \pbox{7in}{#2}}} 50 | % \parbox[c]{5in}{#2}}} 51 | \newcommand{\tooltipw}[2]{\tooltip{#1-\textcolor[gray]{0.5}{$\mapsto$}}{% 52 | \pbox{7in}{#2}}} 53 | % \parbox[c]{6.5in}{#2}}} 54 | \def\hsepline{} 55 | \fi 56 | 57 | \ifnum\poptype=3 58 | \newcommand{\tooltipn}[2]{{\\\tiny #2}\hfill #1} 59 | \newcommand{\tooltipm}[2]{{\\\tiny #2}\hfill #1} 60 | \newcommand{\tooltipw}[2]{{\\\tiny #2}\hfill #1} 61 | \def\hsepline{} %{\hrule} 62 | \def\popnotation{} 63 | \fi 64 | 65 | \typeout{Using poptype=\poptype} 66 | 67 | %------------begin Float Adjustment 68 | %two column float page must be 90% full 69 | \renewcommand\dblfloatpagefraction{.90} 70 | %two column top float can cover up to 80% of page 71 | \renewcommand\dbltopfraction{.80} 72 | %float page must be x% full 73 | \renewcommand\floatpagefraction{.9} 74 | %top float can cover up to x% of page 75 | \renewcommand\topfraction{.90} 76 | %bottom float can cover up to x% of page 77 | \renewcommand\bottomfraction{.80} 78 | %at least x% of a normal page must contain text 79 | \renewcommand\textfraction{.07} 80 | %separation between floats and text 81 | \setlength\dbltextfloatsep{9pt plus 5pt minus 3pt } 82 | %separation between two column floats and text 83 | \setlength\textfloatsep{4pt plus 2pt minus 1.5pt} 84 | \endinput 85 | 86 | % To install: 87 | sudo cp greport.sty ~/texmf/tex/ 88 | -------------------------------------------------------------------------------- /R/todo/rangeCheck.R: -------------------------------------------------------------------------------- 1 | #' Out-of-Range Report 2 | #' 3 | #' Generate a report on the frequency of variables found outside 4 | #' the user-defined range. 5 | #' 6 | #' @param data data.frame. Contains information required to perform checks. 7 | #' \sQuote{dataframe} should be the name of the data.frame to check. 8 | #' \sQuote{variable} is the name of the variable to check. 9 | #' \sQuote{label} is the variable label. 10 | #' \sQuote{min} is the minimum value. 11 | #' \sQuote{max} is the maximum value. 12 | #' \sQuote{units} is the unit of measurement. 13 | #' @param colheader character. Column header for table. 14 | #' @param panel character. Name for panel. 15 | #' @param append append logical. If \sQuote{TRUE} output will be appended instead of overwritten. 16 | #' @export 17 | #' @examples 18 | #' \dontrun{ 19 | #' load(url('http://biostat.mc.vanderbilt.edu/wiki/pub/Main/Rreport/ssafety.rda')) 20 | #' rules <- data.frame( 21 | #' dataframe = rep('ssafety', 4), 22 | #' variable = c('age', 'height', 'weight', 'bmi'), 23 | #' label = c('age', 'height', 'weight', 'bmi'), 24 | #' min = c(45, 145, 50, 15), 25 | #' max = c(80, 180, 140, 40), 26 | #' units = c('years', 'cms', 'kgs', 'cm/kg') 27 | #' ) 28 | #' rangeCheck(rules, panel='check') 29 | #' } 30 | 31 | rangeCheck <- function(data, colheader = 'Variable', 32 | panel, append=FALSE) { 33 | 34 | x <- data 35 | # Make sure valid column names were specified for each dataframe specified in data 36 | illnames <- NULL 37 | for(i in as.character(unique(x$dataframe))) { 38 | if(any(subset(x, dataframe == i)$variable %nin% names(get(i)))) illnames <- c(illnames, i) 39 | } 40 | if(length(illnames)) stop(paste('Illegal variable names specified for', paste(illnames, collapse = ', '))) 41 | 42 | # Build a table which specifies the variable, its defined range (including units), and the frequency 43 | # of values outside the defined range (% and raw frequency) 44 | Table <- data.frame(column = NA, min = NA, max = NA, out1 = NA, out2 = NA) 45 | for(i in 1:nrow(x)) { 46 | vec <- get(as.character(x[i, 'dataframe']))[ as.character(x[i, 'variable']) ] 47 | n <- length(vec[!is.na(vec)]) 48 | check <- paste('datta <', x[i, 'min'], '| datta >', x[i, 'max']) 49 | checkfn <- eval(parse(text = paste('function(datta) {', check, '}'))) 50 | bad <- checkfn(vec) 51 | nbad <- sum(bad, na.rm = TRUE) 52 | # Split 'pctbad' by the decimal point so can align the column by the decimal --> see col.just 53 | pctbad <- unlist(strsplit(format(round((nbad/n)*100, 2), nsmall = 2), '\\.')) 54 | Table[i, 'column'] <- as.character(x[i, 'label']) 55 | Table[i, 'min'] <- format(x[i, 'min'], big.mark = ',') 56 | Table[i, 'max'] <- paste(format(x[i, 'max'], big.mark = ','), 57 | latexTranslate(as.character(x[i, 'units']), greek = TRUE)) 58 | Table[i, 'out1'] <- pctbad[1] 59 | Table[i, 'out2'] <- paste(pctbad[2], '\\% \\scriptsize $\\frac{', nbad, '}{', n, '}$', sep = '') 60 | } 61 | 62 | invisible(latex(Table, 63 | file = file.path(TexDirName(), sprintf("%s.tex", panel)), 64 | where = '!htbp', ctable = TRUE, append = FALSE, rowname = NULL, 65 | cgroup = c(paste('\\textbf{', colheader, '}'), '\\textbf{Defined Range}', '\\textbf{Out of Range}'), 66 | n.cgroup = c(1, 2, 2), colheads = NULL, 67 | # Align the range column by the '-' and the percent bad column by the '.' 68 | # --> NOTE: col.just must have the same number of elements as ncol(Table) --> have to combine the justifications 69 | # to align by the '-' and '.' 70 | col.just = Cs('l', 'r@{~-~}', 'l', 'r@{.}', 'l'), 71 | caption = paste('Frequency of', casefold(colheader), 72 | 'values outside of defined ranges.')) 73 | ) 74 | } 75 | -------------------------------------------------------------------------------- /R/todo/repVarclus.R: -------------------------------------------------------------------------------- 1 | #' Variable Clustering Diagrams 2 | #' 3 | #' Generate variable clustering diagrams for each time period. 4 | #' 5 | #' Variables are grouped according to how they are 6 | #' correlated with one another, as measured by the square of the 7 | #' Spearman \eqn{\rho} rank correlation coefficient computed on all 8 | #' pairs of variables. Variables connected on 9 | #' lower branches are more highly correlated with one another. 10 | #' Variables missing in more than 75% of the observations or 11 | #' categorical variables having more than 20 levels are ignored. 12 | #' Categories less than 0.1 prevalent are pooled with other rare categories. 13 | #' 14 | #' @param data data.frame. Data used for report. 15 | #' @param time numeric vector. Time for each record. 16 | #' @param times numeric vector. Subset of times to use. 17 | #' @param nmin numeric. Variables must have four responses or at least 18 | # 'two responses with more than \code{nmin} counts to be included. 19 | #' @export 20 | #' @examples 21 | #' \dontrun{ 22 | #' dat <- data.frame(age=sample(41:80, replace=TRUE, 1000), height=round(rnorm(1000, 68, 4))) 23 | #' dat$weight <- sample(140:200, replace=TRUE, 1000)+(dat$height-60)*3 24 | #' repVarclus(dat, numeric(1000)) 25 | #' } 26 | 27 | repVarclus <- function(data, time, times=sort(unique(time)), nmin=10) { 28 | g <- function(y, nmin) { 29 | y <- table(oldUnclass(y)) 30 | length(y) > 3 || (length(y) > 1 && sort(y)[length(y)-1] > nmin) 31 | } 32 | 33 | if(any(times==0)) { 34 | cat('A variable clustering diagram is shown in the figure', 35 | 'which follows. Variables are grouped according to how they', 36 | 'are correlated with one another, as measured by the square', 37 | 'of the Spearman $\\rho$ rank correlation coefficient', 38 | 'computed on all pairs of variables. Variables connected on', 39 | 'lower branches are more highly correlated with one another.', 40 | 'Variables missing in more than 0.75 of the observations or', 41 | 'categorical variables having more than 20 levels are ignored.', 42 | 'Categories less than 0.1 prevalent are pooled with other rare categories.\n', 43 | file=file.path(TexDirName(), 'Ovarclus.tex')) 44 | startPlot('Ovarclus', h=4) 45 | d <- data[time==0,] 46 | r <- sapply(d, g, nmin=nmin) 47 | d <- d[r] 48 | v <- varclus(~., data=d, fracmiss=.75, maxlevels=20, minprev=.1) 49 | plot(v) 50 | putFig('Ovarclus', 'Ovarclus', 'Clustering of variables at baseline', append=TRUE) 51 | endPlot() 52 | } 53 | cat('Variable clustering diagrams are shown in the', 54 | if(length(times) > 1)'figures that follow.' else 'figure that follows.', 55 | 'Variables are grouped according to how they are', 56 | 'correlated with one another, as measured by the square of the', 57 | 'Spearman $\\rho$ rank correlation coefficient computed on all', 58 | 'pairs of variables. Variables connected on', 59 | 'lower branches are more highly correlated with one another.', 60 | 'Variables missing in more than 0.75 of the observations or', 61 | 'categorical variables having more than 20 levels are ignored.', 62 | 'Categories less than 0.1 prevalent are pooled with other rare categories.\n', 63 | file=file.path(TexDirName(), 'varclus.tex')) 64 | startPlot('varclus%d', h=4) 65 | i <- 0 66 | for(x in times) { 67 | i <- i + 1 68 | d <- data[time==x,] 69 | r <- sapply(d, g, nmin=nmin) 70 | d <- d[r] 71 | v <- varclus(~., data=d, fracmiss=.75, maxlevels=20, minprev=.1) 72 | plot(v) 73 | title(paste(label(time), x)) 74 | putFig('varclus', paste('varclus',i,sep=''), 75 | paste('Clustering of variables at',label(time),x), 76 | append=TRUE) 77 | } 78 | endPlot() 79 | invisible() 80 | } 81 | -------------------------------------------------------------------------------- /R/todo/refManager.R: -------------------------------------------------------------------------------- 1 | ## $Id: 2 | 3 | if (FALSE){ 4 | source("rreport.s") 5 | #source("refManager.s") 6 | #newMarker="mar1";label="label1"; keyword="sae1" 7 | getReference("sae", "ser.adv withdr") 8 | getReference("Osae", "ser.advWITHDR") 9 | getReference("Osae", "ser.advCARDIO") 10 | getReference("sae", "ser.adv cardio") 11 | 12 | getRefsByKey("sae") 13 | getLabelsByKey("sae") 14 | 15 | getReferenceString("Osae") 16 | 17 | getReferenceObject() 18 | } 19 | 20 | #' Reference Objects 21 | #' 22 | #' summary 23 | #' 24 | #' details 25 | #' 26 | #' @rdname references 27 | #' @export 28 | #' @examples 29 | #' 1 30 | 31 | getReferenceObject <- function(){ 32 | refD <- options("rreport.reference.list")[[1]] 33 | if (is.null(refD)){ 34 | refD <- data.frame(marker=c(), keyword=c(), label=c()) 35 | } 36 | refD 37 | } 38 | 39 | #' @rdname references 40 | #' @param refD 41 | #' @export 42 | #' @examples 43 | #' 1 44 | 45 | putReferenceObject <- function(refD){ 46 | options(rreport.reference.list=refD) 47 | } 48 | 49 | #' @rdname references 50 | #' @export 51 | #' @examples 52 | #' 1 53 | 54 | print.latexReference <- function(refD){ 55 | if (is.null(refD)){ 56 | cat("The list of markers has not been created. Use function getReferenceObject() to create it\n") 57 | }else{ 58 | print(refD) 59 | } 60 | } 61 | 62 | #' @rdname references 63 | #' @param newMarker 64 | #' @param keyword 65 | #' @param label 66 | #' @export 67 | #' @examples 68 | #' 1 69 | 70 | updateMarkers <- function(newMarker, keyword="", label=""){ 71 | ### puts a new marker into the dataframe of the existing ones 72 | ### checks if it is different from the existing ones 73 | ### returns updated latexReference 74 | refD = getReferenceObject() 75 | if (newMarker %in% refD$marker){ 76 | stop(paste("Duplicated marker", newMarker)) 77 | } 78 | newM <-data.frame(marker=newMarker, keyword=keyword, label=label) 79 | newM$marker <- as.character(newM$marker) 80 | newM$keyword <- as.character(newM$keyword) 81 | newM$label <- as.character(newM$label) 82 | refD = rbind(refD, newM) 83 | for (n in names(refD)) refD[[n]] <- as.character(refD[[n]]) 84 | putReferenceObject(refD) 85 | } 86 | 87 | #' @rdname references 88 | #' @export 89 | #' @examples 90 | #' 1 91 | 92 | generateRef <- function(){ 93 | generate <- function(){paste("marker",abs(round(rnorm(1)*(10^8))), sep="")} 94 | existingMarkers <- getRefsByKey() 95 | newMarker <- generate() 96 | while (newMarker %in% existingMarkers){ 97 | newMarker <- generate() 98 | } 99 | newMarker 100 | } 101 | 102 | #' @rdname references 103 | #' @export 104 | #' @examples 105 | #' 1 106 | 107 | getReference <- function(keyword="", label=""){ 108 | newMarker <- generateRef() 109 | updateMarkers(newMarker = newMarker, keyword=keyword, label=label) 110 | newMarker 111 | } 112 | 113 | #' @rdname references 114 | #' @export 115 | #' @examples 116 | #' 1 117 | 118 | getRefsByKey <- function(keyword=NULL){ 119 | ### returns all markers with a given keyword 120 | ### if keyword==NULL returns all markers 121 | refD = getReferenceObject() 122 | if (!is.null(keyword)){ 123 | refD$marker[refD$keyword==keyword] 124 | }else{ 125 | refD$marker 126 | } 127 | } 128 | 129 | #' @rdname references 130 | #' @export 131 | #' @examples 132 | #' 1 133 | 134 | getLabelsByKey <- function(keyword=NULL){ 135 | ### returns all labels with a given keyword 136 | ### if keyword==NULL returns all labels 137 | refD = getReferenceObject() 138 | if (!is.null(keyword)){ 139 | refD$label[refD$keyword==keyword] 140 | }else{ 141 | refD$label 142 | } 143 | } 144 | 145 | #' @rdname references 146 | #' @export 147 | #' @examples 148 | #' 1 149 | 150 | getReferenceString <- function(keyword){ 151 | ### returns a vector of strings "see section \\ref{m1} (page\\pageref{m1})" 152 | ### for all markers with a given keyword 153 | markers <- getRefsByKey(keyword) 154 | labels <- getLabelsByKey(keyword) 155 | keys <- paste(labels," in section ", "\\ref{", markers, "}", " (page ", "\\pageref{",markers,"}",")", sep="") 156 | paste("See", paste(keys, collapse=", ")) 157 | } 158 | 159 | -------------------------------------------------------------------------------- /R/todo/completenessReport.R: -------------------------------------------------------------------------------- 1 | #' Completeness Report 2 | #' 3 | #' Generate report with information about the completeness of the data. 4 | #' 5 | #' details 6 | #' 7 | #' @param data data.frame. Data to report. 8 | #' @param vars character vector. Column names to use. 9 | #' @param panel character. Name of panel. 10 | #' @param Time numeric vector. Times for each record. 11 | #' @param times numeric vector. Subset of times to use. 12 | #' @param longPanel character. Long name of panel. 13 | #' @param frac numeric. Ratio used to determine if a dotplot for completeness 14 | #' should be generated for each variable. Defaults to 0.95, that is, if the variable 15 | #' with the most missing data has 5% more missing than the variable with the least 16 | #' missing data, generate the dotplot. 17 | #' @param h numeric. Height of plot, passed to \code{\link{startPlot}}. 18 | #' @param cex numeric. Text size within plot, passed to \code{\link[Hmisc]{Dotplot}}. 19 | #' @param fullCaption logical. THIS PARAMETER IS NOT USED. 20 | #' @param append logical. If \sQuote{TRUE} output will be appended instead of overwritten. 21 | #' @export 22 | 23 | completenessReport <- function(data, vars, 24 | panel, Time, times, 25 | longPanel=panel, frac=0.95, 26 | h=4 * (nv < 15) + 5 * (nv >= 15), cex=1, 27 | fullCaption=FALSE, append=TRUE) 28 | { 29 | if(!exists('compFullCaptionDone')) 30 | storeTemp(FALSE, 'compFullCaptionDone') 31 | 32 | if(!append) cat('', file='gentex/completeness-key.tex') 33 | 34 | needkey <- TRUE 35 | 36 | vars <- unlist(vars) 37 | xlab <- 'Number of Non-Missing Values' 38 | timeUsed <- !missing(Time) 39 | if(timeUsed && !missing(times)) { 40 | s <- Time %in% times 41 | data <- data[s,] 42 | Time <- Time[s] 43 | } 44 | fn <- paste('complete', panel, sep='-') 45 | nv <- length(vars) 46 | pl <- TRUE 47 | 48 | lcap <- paste('Completeness of ', longPanel, '.', sep='') 49 | if(!timeUsed) { 50 | n <- sapply(data[vars], function(y)sum(!is.na(y))) 51 | ce <- combineEqual(n) 52 | n <- ce$x 53 | r <- range(n) 54 | if(r[1] / r[2] < frac) 55 | { 56 | variable <- factor(names(n),names(n)) 57 | variable <- reorder(variable, n) 58 | # variable <- reorder.factor(variable, n) 59 | startPlot(fn, h=h) 60 | print(Dotplot(variable ~ n, xlab=xlab, cex=cex)) 61 | } 62 | else pl <- FALSE 63 | } else { 64 | n <- rowsum(1 - is.na(data[vars]), Time) 65 | ce <- combineEqual(n) 66 | n <- ce$x 67 | nvarpl <- ncol(n) 68 | if(nvarpl < 2) { 69 | startPlot(fn, h=3) 70 | plot(as.numeric(dimnames(n)[[1]]), n[,1], 71 | xlab=label(Time), 72 | ylab='Number of Values', type='b') 73 | lcap <- paste(lcap, 74 | ' The $y$-axis displays the number of values measured for', 75 | ' \\texttt{', 76 | if(length(ce$defs)) ce$defs else vars[1], 77 | '}. ', sep='') 78 | needkey <- FALSE 79 | } else { 80 | m <- reShape(n) 81 | variable <- reorder(factor(m$colvar), m$n) 82 | times <- sort(unique(Time)) 83 | Time <- factor(m$rowvar, times, paste(label(Time),times)) 84 | n <- m$n 85 | startPlot(fn, h=h) 86 | print(Dotplot(variable ~ n | Time, 87 | xlab=xlab, cex=cex)) 88 | if(length(ce$codes)) 89 | lcap <- 90 | paste(lcap, 91 | ' Letters in parentheses indicate groups of variables ', 92 | 'having the same number of values measured, ', 93 | 'defined elsewhere.\n', sep='') 94 | if(!compFullCaptionDone) { 95 | lcap <- paste(lcap, 96 | 'Variables are sorted by the average number of', 97 | 'non-missing values over time.') 98 | storeTemp(TRUE, 'compFullCaptionDone') 99 | } 100 | } 101 | } 102 | if(pl) { 103 | endPlot() 104 | putFig('completeness', fn, 105 | paste('Completeness of', longPanel), 106 | lcap, append=append) 107 | if(length(ce$codes) & needkey) { 108 | cat('\nCodes used in Figure~\\ref{fig:',fn,'} are as follows:', 109 | '{\\smaller[2]', 110 | paste(paste('\\textbf{',ce$codes,'}:', 111 | '\\texttt{\\textbf{',ce$defs,'}}',sep=''), 112 | collapse='; '), 113 | '.}\n\n', sep='', 114 | file=file.path(TexDirName(), 'completeness-key.tex'), append=TRUE) 115 | } 116 | } else { 117 | cat('For the',length(vars),longPanel, 118 | 'variables, the number of subjects having values entered', 119 | if(r[1]==r[2])paste('was ', r[1],'.\n', sep='') else 120 | paste('ranged from ',r[1],' to ', r[2],'.\n', sep=''), 121 | file=file.path(TexDirName(), 'completeness.tex'), append=append) 122 | } 123 | invisible() 124 | } 125 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | Changes in version 0.7-4 (2023-09-02) 2 | * greport-package.r: change @aliases greport package-greport to greport-package 3 | 4 | Changes in version 0.7-3 (2022-10-17) 5 | * changed email address for maintainer 6 | 7 | Changes in version 0.7-2 (2020-02-09) 8 | * dReport: added exclude1 argument, default to TRUE (see Hmisc::ggplot.summaryP) 9 | * Require Hmisc >= 4.0-0, rms >= 5.0-0 10 | * accrualReport: changed target enrollment/randomization curves to thick grayscale lines 11 | * nriskReport: added more plots when id is present but groups is not 12 | * maskVal, maskDframe: new functions for masking variables for test reports 13 | * accrualReport: added number sites randomizing, number subjects randomized per randomizing size, mean and median days to randomization from enrollment 14 | * dReport help file: removed unused dots argument 15 | 16 | Changes in version 0.7-1 (2016-04-08) 17 | * dReport: added stable argument for suppressing backup tables 18 | * startPlot: stopped suppressing arguments for spar that are not in par 19 | * survReport: added opts argument, mylim argument 20 | * survReport: reduced font size of ylab when long, added markevent argument 21 | * accrualReport: added studynos argument 22 | * greport.sty: attach ocg-p LaTeX package so that ocgtools no longer needs ocg, asymptote, acrotex 23 | * greport.sty: added poptype=3 to use tiny tables and no actual pop-ups 24 | * survReport: changed default markevent to TRUE 25 | * dReport: passed continuous argument to summaryM 26 | 27 | Changes in version 0.7-0 (2015-12-02) 28 | * survReport: plot cumulative incidence estimates when left hand side of formula contains Surv objects for competing risks 29 | * upFirst: removed function; added to Hmisc 30 | 31 | Changes in version 0.6-0 (2015-08-30) 32 | * accrualReport: put zoomed cumulative distribution on same graph as regular 33 | * exReport: added option plotExRemain to suppress 2-panel dot chart, solved problem with collisions of labels on vertical cumulative exclusion plot 34 | * NAMESPACE: import base functions used 35 | * exReport: avoided collisions in vertical dot chart, excluded actually randomized subjects from exclusion frequencies 36 | * exReport: fixed exclusion table so that even though exclusion counts for numerators exclude any randomized subjects, special conditions (indented) use all enrolled subjects in the denominator 37 | 38 | Changes in version 0.5-3 (2015-04-20) 39 | * putFig: add \clearpage after every appendix table 40 | * exReport: fine-tuned vertical dot plot 41 | * dReport: rotated strip labels 42 | * Added new greport option nontx.col and use that in other functions, for non-treatment groups 43 | * dReport: changed strip label font size 44 | * dReport: run ggplot.summaryP output through colorFacet (new in Hmisc) 45 | * upFirst: leave all words with > 1 upper case letter unchanged (for acronyms) 46 | * accrualReport: changed denominator to randomized subjects for table corresponding to box plots of days to randomization 47 | * all reporting functions: use upFirst(lower=TRUE) for captions 48 | * appsection: new function 49 | * sampleFrac: capped fraction at 1.0, issued warning if > 1 and assumes this indicates that analysis is to compare randomized with non-randomized subjects 50 | * test.Rnw, report.Rnw: switch to using changepage style instead of chngpage 51 | * Misc: use gsub instead of translate() 52 | * survReport: added aehaz argument, fixed caption for when differences don't apply (no strata) 53 | * startPlot: ignored non-par parameters in ... 54 | * survReport: changed default y.n.risk to 0 (used if what='1-S') 55 | * exReport: added short caption when using app 56 | * survReport: added times argument 57 | * nriskReport: changed any(duplicated()) to anyDuplicated() 58 | 59 | 60 | Changes in version 0.5-2 (2014-11-21) 61 | * accrualReport: axis.Date was not positioning axis labels containing only 4-digit years at Jan 1 so wrote customized axisDate function 62 | * Better escaping of special characters 63 | * dReport: handle special characters in table captions 64 | * dReport: added append=TRUE in call to latex() for proportions 65 | * exReport: added apptail argument for appendix table of IDs 66 | * All functions: checked that panel and subpanel containing only legal LaTeX macro name characters (A-Z a-z -); . are auto-removed 67 | 68 | Changes in version 0.5-1 (2014-04-15) 69 | * survReport: changed to use npsurv instead of survfit.formula 70 | * exReport: changed order of output so that analysis of randomized patients marked for exclusions appears last; use LaTeX chngpage package to allow detailed table to go into left margin so as to be centered on page 71 | * exReport: added adjustwidth argument 72 | * accrualReport: allowed enrollment target N to be omitted 73 | * exReport: fine tuning 74 | * nriskReport: new report to show number of subjects still being followed at each day 75 | * Merge: added support for data.table 76 | * nriskReport: added id() variable 77 | * exReport: fixed bug when there is an exclusion with 0 frequency 78 | * accrualReport: improved graphics formatting, added minrand argument 79 | * accrualReport: added enrollmax argument, clarified notation 80 | * exReport: added ignoreExcl, ignoreRand arguments 81 | * all: added greportOption texwhere; default is 'gentex'; can specify texwhere='' to write non-appendix LaTeX code to console as for knitr 82 | * dReport: for byx for discrete Y, sense when Y is binary and use Wilson interval instead of bootstrap; adjust SE using confidence interval if proportion is 0 or 1 83 | * dReport: changed discreteness non-binary classification to use maximum number of unique values or Y instead of minimum 84 | * add globalVariables call to nriskReport 85 | -------------------------------------------------------------------------------- /man/exReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/exReport.r 3 | \name{exReport} 4 | \alias{exReport} 5 | \title{Exclusion Report} 6 | \usage{ 7 | exReport( 8 | formula, 9 | data = NULL, 10 | subset = NULL, 11 | na.action = na.retain, 12 | ignoreExcl = NULL, 13 | ignoreRand = NULL, 14 | plotExRemain = TRUE, 15 | autoother = FALSE, 16 | sort = TRUE, 17 | whenapp = NULL, 18 | erdata = NULL, 19 | panel = "excl", 20 | subpanel = NULL, 21 | head = NULL, 22 | tail = NULL, 23 | apptail = NULL, 24 | h = 5.5, 25 | w = 6.5, 26 | hc = 4.5, 27 | wc = 5, 28 | adjustwidth = "-0.75in", 29 | append = FALSE, 30 | popts = NULL, 31 | app = TRUE 32 | ) 33 | } 34 | \arguments{ 35 | \item{formula}{a formula with only a right-hand side, possibly containing a term of the form \code{pending(x)} to inform the function of which subjects have incomplete randomization ("randomization pending"). The \code{pending} variable is ignored if a subject has an exclusion marked. A \code{randomized} variable is an optional \code{logical} vector specifying which subjects are considered to have been randomized. The presence of this variable causes consistency checking against exclusions. One or more \code{cond} variables provide binary/logical vectors used to define subsets of subjects for which denominators are used to compute additional fractions of exclusions that are reported in a detailed table. The arguments of the \code{cond} function are the name of the original variable (assumed to be provided as a regular variable in \code{formula}, a single character string giving the label for the condition, and the vector of essentially binary values that specify the condition.} 36 | 37 | \item{data}{input data frame} 38 | 39 | \item{subset}{subsetting criteria} 40 | 41 | \item{na.action}{function for handling \code{NA}s when creating analysis frame} 42 | 43 | \item{ignoreExcl}{a formula with only a right-hand side, specifying the names of exclusion variable names that are to be ignored when counting exclusions (screen failures)} 44 | 45 | \item{ignoreRand}{a formula with only a right-hand side, specifying the names of exclusion variable names that are to be ignored when counting randomized subjects marked as exclusions} 46 | 47 | \item{plotExRemain}{set to \code{FALSE} to suppress plotting a 2-panel dot plot showing the number of subjects excluded and the fraction of enrolled subjects remaining} 48 | 49 | \item{autoother}{set to \code{TRUE} to add another exclusion \code{Unspecified} that is set to \code{TRUE} for non-pending subjects that have no other exclusions} 50 | 51 | \item{sort}{set to \code{FALSE} to not sort variables by descending exclusion frequency} 52 | 53 | \item{whenapp}{a named character vector (with names equal to names of variables in formula). For each variable that is only assessed (i.e., is not \code{NA}) under certain conditions, add an element to this vector naming the condition} 54 | 55 | \item{erdata}{a data frame that is subsetted on the combination of \code{id} variables when \code{randomized} is present, to print auxiliary information about randomized subjects who have exclusion criteria} 56 | 57 | \item{panel}{panel string} 58 | 59 | \item{subpanel}{If calling \code{exReport} more than once (e.g., for different values of \code{sort}), specify \code{subpanel} to distinguish the multiple calls. In that case, \code{-subpanel} will be appended to \code{panel} when creating figure labels and cross-references.} 60 | 61 | \item{head}{character string. Specifies initial text in the figure caption, otherwise a default is used.} 62 | 63 | \item{tail}{a character string to add to end of automatic caption} 64 | 65 | \item{apptail}{a character string to add to end of automatic caption for appendix table with listing of subject IDs} 66 | 67 | \item{h}{height of 2-panel graph} 68 | 69 | \item{w}{width of 2-panel graph} 70 | 71 | \item{hc}{height of cumulative exclusion 1-panel graph} 72 | 73 | \item{wc}{width of this 1-panel graph} 74 | 75 | \item{adjustwidth}{used to allow wide detailed exclusion table to go into left margin in order to be centered on the physical page. The default is \code{'-0.75in'}, which works well when using article document class with default page width. To use the geometry package in LaTeX with margin=.45in specify \code{adjustwidth='+.90in'}.} 76 | 77 | \item{append}{set to \code{TRUE} if adding to an existing sub-report} 78 | 79 | \item{popts}{a list of options to pass to graphing functions} 80 | 81 | \item{app}{set to \code{FALSE} to prevent writing appendix information} 82 | } 83 | \description{ 84 | Generates graphics for sequential exclusion criteria 85 | } 86 | \details{ 87 | With input being a series of essentially binary variables with positive indicating that a subject is excluded for a specific reason, orders the reasons so that the first excludes the highest number of subjects, the second excludes the highest number of remaining subjects, and so on. If a randomization status variable is present, actually randomized (properly or not) subjects are excluded from counts of exclusions. First draws a single vertical axis graph showing cumulative exclusions, then creates a 2-panel dot chart with the first panel showing that information, along with the marginal frequencies of exclusions and the second showing the number of subjects remaining in the study after the sequential exclusions. A pop-up table is created showing those quantities plus fractions. There is an option to not sort by descending exclusion frequencies but instead to use the original variable order. Assumes that any factor variable exclusions that have only one level and that level indicates a positive finding, that variable has a denominator equal to the overall number of subjects. 88 | } 89 | \examples{ 90 | # See test.Rnw in tests directory 91 | } 92 | \author{ 93 | Frank Harrell 94 | } 95 | -------------------------------------------------------------------------------- /man/survReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/survReport.r 3 | \name{survReport} 4 | \alias{survReport} 5 | \title{Survival Report} 6 | \usage{ 7 | survReport( 8 | formula, 9 | data = NULL, 10 | subset = NULL, 11 | na.action = na.retain, 12 | ylab = NULL, 13 | what = c("S", "1-S"), 14 | conf = c("diffbands", "bands", "bars", "none"), 15 | cause = NULL, 16 | panel = "surv", 17 | subpanel = NULL, 18 | head = NULL, 19 | tail = NULL, 20 | h = 3, 21 | w = 4.5, 22 | multi = FALSE, 23 | markevent = TRUE, 24 | mfrow = NULL, 25 | y.n.risk = 0, 26 | mylim = NULL, 27 | bot = 2, 28 | aehaz = TRUE, 29 | times = NULL, 30 | append = FALSE, 31 | opts = NULL, 32 | ... 33 | ) 34 | } 35 | \arguments{ 36 | \item{formula}{a formula with survival (\code{Surv}) objects on the left hand side and an optional stratification factor on the right (or \code{1} if none). The survival object component variables should be labeled; these labels are used for graph annotation. If any of the \code{Surv} objects are competing risk objects (see \code{\link[survival]{Surv}}), event labels come from the factor levels in the variable that was the second argument to \code{Surv}, and the first factor level must correspond to right-censored observations.} 37 | 38 | \item{data}{data.frame} 39 | 40 | \item{subset}{optional subsetting criteria} 41 | 42 | \item{na.action}{function for handling \code{NA}s while creating a data frame} 43 | 44 | \item{ylab}{character. Passed to \code{\link[rms]{survplot.npsurv}} as the \code{ylab} argument. Constructed by default.} 45 | 46 | \item{what}{\code{"S"} (the default) to plot survival functions or \code{"1-S"} to plot cumulative incidence functions. If any of the survival time objects on the left hand side are competing risk objects, the default is \code{"1-S"} and you may not change it.} 47 | 48 | \item{conf}{character. See \code{\link[rms]{survplot.npsurv}}.} 49 | 50 | \item{cause}{character vector or list. If a vector, every \code{Surv} term on the left hand side of \code{formula} will have cumulative incidence plotted for all causes that appear in \code{cause}. If a list, the list elements must correspond to the \code{Surv} terms in order, and specify which causes to display from the corresponding \code{Surv} object. When \code{cause} is a list and one of its elements contains more than one character string, or when \code{cause} is a vector and for one \code{Surv} object it matches multiple causes, \code{survReport} produces more plots than there are \code{Surv} objects.} 51 | 52 | \item{panel}{character string. Name of panel, which goes into file base names and figure labels for cross-referencing.} 53 | 54 | \item{subpanel}{character string. If calling \code{dReport} more than once for the same type of chart (categorical or continuous), specify \code{subpanel} to distinguish the multiple calls. In that case, \code{-subpanel} will be appended to \code{panel} when creating figure labels and cross-references.} 55 | 56 | \item{head}{character string. Specifies initial text in the figure caption, otherwise a default is used.} 57 | 58 | \item{tail}{optional character string. Specifies final text in the figure caption, e.g., what might have been put in a footnote in an ordinary text page. This appears just before any needles.} 59 | 60 | \item{h}{numeric. Height of plots.} 61 | 62 | \item{w}{numeric. Width of plots in inches.} 63 | 64 | \item{multi}{logical. If \code{TRUE}, multiple figures are produced, otherwise a single figure with a matrix of survival plots is made.} 65 | 66 | \item{markevent}{logical. Applies only if \code{multi=TRUE}. Specify \code{FALSE} to not put the event label in the extreme upper left of the plot.} 67 | 68 | \item{mfrow}{numeric 2-vector, used if \code{multi=FALSE}. If not specified, default plot matrix layout will be figured.} 69 | 70 | \item{y.n.risk}{used if \code{what="1-S"}, to specify \code{y} coordinate for putting numbers at risk, typically below the \code{x}-axis label} 71 | 72 | \item{mylim}{numeric 2-vector. Used to force expansion of computed y-axis limits. See \code{survplot}.} 73 | 74 | \item{bot}{number of spaces to reserve at bottom of plot for numbers at risk, if \code{what="1-S"}} 75 | 76 | \item{aehaz}{logical. Set to \code{FALSE} to not print number of events and hazard rate on plots.} 77 | 78 | \item{times}{numeric vector. If specified, prints cumulative incidence probabilities at those times on the plots.} 79 | 80 | \item{append}{logical. If \code{TRUE} output will be appended instead of overwritten.} 81 | 82 | \item{opts}{list. A list specifying arguments to \code{survReport} and \code{startPlot} that override any other arguments. This is useful when making a long series of \code{survReport} calls with the same options, as the options can be defined up front in a list.} 83 | 84 | \item{\dots}{ignored} 85 | } 86 | \description{ 87 | Generate a Survival Report with Kaplan-Meier Estimates 88 | } 89 | \examples{ 90 | ## See tests directory test.Rnw for a live example 91 | \dontrun{ 92 | set.seed(1) 93 | n <- 400 94 | dat <- data.frame(t1=runif(n, 2, 5), t2=runif(n, 2, 5), 95 | e1=rbinom(n, 1, .5), e2=rbinom(n, 1, .5), 96 | treat=sample(c('a','b'), n, TRUE)) 97 | dat <- upData(dat, 98 | labels=c(t1='Time to operation', 99 | t2='Time to rehospitalization', 100 | e1='Operation', e2='Hospitalization', 101 | treat='Treatment') 102 | units=c(t1='year', t2='year')) 103 | survReport(Surv(t1, e1) + Surv(t2, e2) ~ treat, data=dat) 104 | 105 | dat <- upData(dat, labels=c(t1='Follow-up Time', t2='Time'), 106 | cause=factor(sample(c('death','MI','censor'), n, TRUE), 107 | c('censor', 'MI', 'death'))) 108 | survReport(Surv(t1, cause) ~ treat, cause='death', data=dat) 109 | survReport(Surv(t1, cause) + Surv(t2, cause) ~ treat, 110 | cause=list(c('death', 'MI'), 'death'), data=dat) 111 | # Two plots for t1, one plot for t2 112 | } 113 | } 114 | -------------------------------------------------------------------------------- /man/dReport.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dReport.r 3 | \name{dReport} 4 | \alias{dReport} 5 | \title{Descriptive Statistics Report} 6 | \usage{ 7 | dReport( 8 | formula, 9 | groups = NULL, 10 | what = c("box", "proportions", "xy", "byx"), 11 | byx.type = c("violin", "quantiles"), 12 | violinbox = TRUE, 13 | violinbox.opts = list(col = adjustcolor("blue", alpha.f = 0.25), border = FALSE), 14 | summaryPsort = FALSE, 15 | exclude1 = TRUE, 16 | stable = TRUE, 17 | fun = NULL, 18 | data = NULL, 19 | subset = NULL, 20 | na.action = na.retain, 21 | panel = "desc", 22 | subpanel = NULL, 23 | head = NULL, 24 | tail = NULL, 25 | continuous = 10, 26 | h = 5.5, 27 | w = 5.5, 28 | outerlabels = TRUE, 29 | append = FALSE, 30 | sopts = NULL, 31 | popts = NULL, 32 | lattice = FALSE 33 | ) 34 | } 35 | \arguments{ 36 | \item{formula}{a formula accepted by the \code{bpplotM} or \code{summaryP} functions. \code{formula} must have an \code{id(subjectidvariable)} term if there are repeated measures, in order to get correct subject counts as \code{nobs}.} 37 | 38 | \item{groups}{a superpositioning variable, usually treatment, for categorical charts. For continuous analysis variables, \code{groups} becomes the \code{y}-axis stratification variable. This is a single character string.} 39 | 40 | \item{what}{\code{"box"} (the default) or \code{"xy"} for continuous analysis variables, or \code{"proportions"} (or shorter) for categorical ones. Instead, specifying \code{what="byx"} results in an array of quantile intervals for continuous \code{y}, Wilson confidence intervals for proportions when \code{y} is binary, or means and parametric confidence limits when \code{y} is not continuous but is not binary. If \code{what} is omitted or \code{what="byx"}, actions will be inferred from the most continuous variable listed in \code{formula}. When \code{fun} is given, different behavior results (see below).} 41 | 42 | \item{byx.type}{set to \code{"quantiles"} to show vertical quantile intervals of \code{y} at each \code{x} for when \code{what="byx"} and the \code{y} variable is continuous numeric, or set \code{byx.type="violin"} (the default) to plot half-violin plots at each \code{x}.} 43 | 44 | \item{violinbox}{set to \code{TRUE} to add violin plots to box plots} 45 | 46 | \item{violinbox.opts}{a list to pass to \code{panel.violin}} 47 | 48 | \item{summaryPsort}{set to \code{TRUE} to sort categories in descending order of frequencies} 49 | 50 | \item{exclude1}{logical used for \code{latex} methods when \code{summaryM} or \code{summaryP} are called by \code{dReport}, or for plot methods for \code{summaryP}. The default is \code{TRUE} to cause the most frequent level of any two-level categorical variable to not be used as a separate category in the graphic or table. See \code{\link[Hmisc]{summaryM}}.} 51 | 52 | \item{stable}{set to \code{FALSE} to suppress creation of backup supplemental tables for graphics} 53 | 54 | \item{fun}{a function that takes individual response variables (which may be matrices, as in \code{\link[survival]{Surv}} objects) and creates one or more summary statistics that will be computed while the resulting data frame is being collapsed to one row per condition. Dot charts are drawn when \code{fun} is given.} 55 | 56 | \item{data}{data frame} 57 | 58 | \item{subset}{a subsetting epression for the entire analysis} 59 | 60 | \item{na.action}{a NA handling function for data frames, default is \code{na.retain}} 61 | 62 | \item{panel}{character string. Name of panel, which goes into file base names and figure labels for cross-referencing} 63 | 64 | \item{subpanel}{If calling \code{dReport} more than once for the same type of chart (by different values of \code{what}), specify \code{subpanel} to distinguish the multiple calls. In that case, \code{-subpanel} will be appended to \code{panel} when creating figure labels and cross-references.} 65 | 66 | \item{head}{character string. Specifies initial text in the figure caption, otherwise a default is used} 67 | 68 | \item{tail}{optional character string. Specifies final text in the figure caption, e.g., what might have been put in a footnote in an ordinary text page. This appears just before any needles.} 69 | 70 | \item{continuous}{the minimum number of numeric values a variable must have in order to be considered continuous. Also passed to \code{summaryM}.} 71 | 72 | \item{h}{numeric. Height of plot, in inches} 73 | 74 | \item{w}{numeric. Width of plot} 75 | 76 | \item{outerlabels}{logical that if \code{TRUE}, pass \code{lattice} graphics through the \code{latticeExtra} package's \code{useOuterStrips}function if there are two conditioning (paneling) variables, to put panel labels in outer margins.} 77 | 78 | \item{append}{logical. Set to \code{FALSE} to start a new panel} 79 | 80 | \item{sopts}{list specifying extra arguments to pass to \code{bpplotM}, \code{summaryP}, or \code{summaryS}} 81 | 82 | \item{popts}{list specifying extra arguments to pass to a plot method. One example is \code{text.at} to specify some number beyond \code{xlim[2]} to leave extra space for numerators and denominators when using \code{summaryP} for categorical analysis variables. Another common use is for example \code{popts=list(layout=c(columns,rows))} to be used in rendering \code{lattice} plots. \code{key} and \code{panel} are also frequently used.} 83 | 84 | \item{lattice}{set to \code{TRUE} to use \code{lattice} instead of \code{ggplot2} for proportions. When this option is in effect, numerators and denominators are shown.} 85 | } 86 | \description{ 87 | Generate graphics and LaTeX with descriptive statistics 88 | } 89 | \details{ 90 | \code{dReport} generates multi-panel charts, separately for categorical analysis variables and continuous ones. The Hmisc \code{summaryP} function and its plot method are used for categorical variables, and \code{bpplotM} is used to make extended box plots for continuous ones unless \code{what='byx'}. Stratification is by treatment or other variables. The user must have defined a LaTeX macro \code{\\eboxpopup} (which may be defined to do nothing) with one argument. This macro is called with argument \code{extended box plot} whenever that phrase appears in the legend, so that a \code{PDF} popup may be generated to show the prototype. See the example in \code{report.Rnw} in the \code{tests} directory. Similarly a popup macro \code{\\qintpopup} must be defined, which generates a tooltip for the phrase \code{quantile intervals}. 91 | } 92 | \examples{ 93 | # See test.Rnw in tests directory 94 | } 95 | -------------------------------------------------------------------------------- /R/todo/survReport.R: -------------------------------------------------------------------------------- 1 | #' Survival Report 2 | #' 3 | #' Generate a survival report with Kaplan-Meier estimates, 4 | #' 5 | #' If both \code{group} and \code{treat.group} are present, plots will be 6 | #' generated for each level of group. 7 | #' 8 | #' @param etime character. Name of column with event time data. 9 | #' @param event character. Name of column with event status data. 10 | #' @param treat character. Name of column with treatment data. 11 | #' @param group character. Name of column with group data. 12 | #' @param treat.group character. Name of column with treatment group data. 13 | #' @param data data.frame. Data used for report. 14 | #' @param ylabel character. Passed to \code{\link[rms]{survplot.survfit}} as 15 | #' the \code{ylab} argument. 16 | #' @param conf character. See \code{\link[rms]{survplot.survfit}}. 17 | #' @param n numeric. See \code{\link[Hmisc]{ldBands}}. 18 | #' @param labels character vector. See \code{\link[Hmisc]{plot.ldBands}}. 19 | #' @param previousActual Passed as the second component to the 20 | #' \code{actual} argument in the \code{\link[Hmisc]{plot.ldBands}} function. 21 | #' @param h numeric. Height of plot. Default is 4in. See \code{\link[Hmisc]{setps}}. 22 | #' @param append logical. If \sQuote{TRUE} output will be appended instead of overwritten. 23 | #' @param fileName character. File name suffix. 24 | #' @param descrip character. Used in caption to describe the predictor of interest. 25 | #' The default is \sQuote{treatment}. 26 | #' @param ndescrip character. Used in longcaption to provide further detail. 27 | #' @param \dots additional arguments, passed to \code{\link[rms]{survplot}} 28 | #' and \code{\link[Hmisc]{ldBands}}. 29 | #' @export 30 | #' @examples 31 | #' \dontrun{ 32 | #' set.seed(47) 33 | #' mydata <- data.frame(time=sapply(round(rnorm(1000, 36, 5)), min, 36), treat=rep(0:1, each=500)) 34 | #' mydata$event <- ifelse(mydata$time < 36, 1, 0) 35 | #' survReport("time", "event", "treat", data=mydata) 36 | #' } 37 | 38 | survReport <- function(etime, event, treat, group=NULL, treat.group=NULL, data, 39 | ylabel='Survival Probability', 40 | conf=c('bars','bands','none'), 41 | n=NULL, labels=NULL, previousActual=NULL, h=4, 42 | append=FALSE, fileName="trt", descrip="treatment", ndescrip = "", ...) { 43 | plotName <- paste('surv-km', fileName, sep=".") 44 | conf <- match.arg(conf) 45 | 46 | if(length(group) & length(treat.group)) { 47 | # Base K-M plot on treat.group 48 | lty = rep(c(1,3), 2); col = rep(gray(c(0,.7)), each = 2); lwd = 1 49 | S <- Surv(data[[etime]], data[[event]]) 50 | treat.group <- as.factor(data[[treat.group]]) 51 | startPlot(plotName, h=h) 52 | survplot.survfit(survfit.formula(S ~ treat.group), n.risk=TRUE, conf=conf, lwd=lwd, 53 | lty=lty, col=col, ylab=ylabel, ...) 54 | endPlot() 55 | # Calculate the corresponding z for each level of group 56 | for(i in levels(as.factor(data[[group]]))) { 57 | assign(paste("S", i, sep="."), Surv(data[data[[group]]==i, etime], data[data[[group]]==i, event])) 58 | assign(paste("treat", i, sep="."), data[data[[group]]==i, treat]) 59 | j <- is.na(get(paste("S", i, sep="."))) | is.na(get(paste("treat", i, sep="."))) 60 | if(any(j)) { 61 | assign(paste("S", i, sep="."), get(paste("S", i, sep="."))[!j,]) 62 | assign(paste("treat", i, sep="."), get(paste("treat", i, sep="."))[!j]) 63 | } 64 | assign(paste("z", i, sep="."), round(sqrt(logrank(get(paste("S", i, sep=".")), as.integer(get(paste("treat", i, sep="."))))), 2)) 65 | } 66 | putFig(panel = 'surv', name = plotName, 67 | caption = paste('Kaplan-Meier estimates by ', descrip, '.', sep=''), 68 | longcaption = paste('Kaplan-Meier cumulative event-free probability estimates by ', paste(descrip, ndescrip, sep = " "), '.', 69 | ' Based on these data, the unadjusted Cox-logrank $z$ values for ', levels(as.factor(data[[group]]))[1], ' and ', levels(as.factor(data[[group]]))[2], 70 | ' across treatment were calculated to be ', get(paste("z", levels(as.factor(data[[group]]))[1], sep=".")), ' and ', 71 | get(paste("z", levels(as.factor(data[[group]]))[2], sep=".")), 72 | ', respectively. ', 73 | # Inset treatment key 74 | levels(treat.group)[1], ' = solid black; ', levels(treat.group)[2], ' = dotted black; ', levels(treat.group)[3], ' = solid gray; ', 75 | levels(treat.group)[4],' = dotted gray.', sep=""), append = append) 76 | } 77 | else { 78 | # Base everything on treat 79 | lwd = c(1,2); lty = c(1,1); col = gray(c(0,.7)) 80 | S <- Surv(data[[etime]], data[[event]]) 81 | treat <- as.factor(data[[treat]]) 82 | if(attributes(survfit.formula(S ~ treat)$strata)$names[1]=="B") { 83 | col=gray(c(0.7, 0)) 84 | } 85 | startPlot(plotName, h=h) 86 | survplot.survfit(survfit.formula(S ~ treat), n.risk=TRUE, conf=conf, lwd=lwd, 87 | lty=lty, col=col, ylab=ylabel, ...) 88 | endPlot() 89 | # Calculate the corresponding z 90 | i <- is.na(S) | is.na(treat) 91 | if(any(i)) { 92 | S <- S[!i,] 93 | treat <- treat[!i] 94 | } 95 | z <- round(sqrt(logrank(S, as.integer(treat))), 2) 96 | putFig(panel = 'surv', name = plotName, 97 | caption = paste('Kaplan-Meier estimates by ', descrip, '.', sep=''), 98 | longcaption = paste('Kaplan-Meier cumulative event-free probability estimates by ', paste(descrip, ndescrip, sep = " "), ".", 99 | ' Based on these data, an unadjusted Cox-logrank $z$ value was calculated to be ', z, ". ", 100 | # Inset treatment key 101 | levels(treat)[1], ':\\rule[.05in]{.25in}{.5pt}; ', levels(treat)[2], ':\\textcolor[gray]{0.7}{\\rule[.05in]{.25in}{1.25pt}}.', sep=""), 102 | append = append) 103 | } 104 | 105 | # LEAVE AS IS IN survReport.s 106 | if(length(n)) { 107 | p <- ldBands(n=n, ...) 108 | i <- is.na(S) | is.na(treat) 109 | if(any(is.na(i))) { 110 | S <- S[!i,] 111 | treat <- treat[!i] 112 | } 113 | z <- logrank(S, as.integer(treat)) 114 | startPlot('surv-monitor', h=h) 115 | plot(p, labels=labels, actual=c(z, previousActual)) 116 | endPlot() 117 | putFig('surv','surv-monitor', 118 | 'Group-sequential monitoring boundaries', 119 | paste('Lan-DeMets group-sequential monitoring boundaries using the Obrien-Fleming alpha-spending function with',n,'looks equally spaced in time. Points indicate observed Cox-logrank Z statistics.'), append=append) 120 | } 121 | } 122 | -------------------------------------------------------------------------------- /R/nriskReport.r: -------------------------------------------------------------------------------- 1 | #' Number at Risk Report 2 | #' 3 | #' Graph number of subjects at risk 4 | #' 5 | #' \code{nriskReport} generates multi-panel charts, separately for categorical analysis variables. Each panel depicts the number at risk as a function of follow-up time. The Hmisc \code{Ecdf} function is used. Stratification is by treatment or other variables. It is assumed that this function is only run on randomized subjects. If an \code{id} variable is present but \code{groups} and stratification variables are not, other plots are also produced: a histogram of the number of visits per subject, a histogram of times at which subjects have visits, the average number of contacts as a function of elapsed time, and a histogram showing the distribution of the longest gap between visits over subjects. 6 | #' @param formula a formula with time and the left hand side, and with variables on the right side being possible stratification variables. If no stratification put \code{1} as the right hand side. Specify unique subject IDs by including a term \code{id()} if subjects have more than one observation. 7 | #' @param groups a character string naming a superpositioning variable. Must also be included in \code{formula}. 8 | #' @param time0 a character string defining the meaning of time zero in follow-up. Default is \code{"randomization"}. 9 | #' @param data data frame 10 | #' @param subset a subsetting epression for the entire analysis 11 | #' @param na.action a NA handling function for data frames, default is \code{na.retain} 12 | #' @param ylab character string if you want to override \code{"Number Followed"} 13 | #' @param panel character string. Name of panel, which goes into file base names and figure labels for cross-referencing. The default is \code{'nrisk'}. 14 | #' @param head character string. Specifies initial text in the figure caption, otherwise a default is used 15 | #' @param tail optional character string. Specifies final text in the figure caption, e.g., what might have been put in a footnote in an ordinary text page. This appears just before any needles. 16 | #' @param h numeric. Height of plot, in inches 17 | #' @param w numeric. Width of plot 18 | #' @param outerlabels logical that if \code{TRUE}, pass \code{lattice} graphics through the \code{latticeExtra} package's \code{useOuterStrips}function if there are two conditioning (paneling) variables, to put panel labels in outer margins. 19 | #' @param append logical. Set to \code{FALSE} to start a new panel 20 | #' @param popts list specifying extra arguments to pass to \code{Ecdf}. A common use is for example \code{popts=list(layout=c(columns,rows))} to be used in rendering \code{lattice} plots. \code{key} and \code{panel} are also frequently used. 21 | #' @export 22 | #' @examples 23 | #' # See test.Rnw in tests directory 24 | 25 | nriskReport <- 26 | function(formula, groups=NULL, time0='randomization', 27 | data=NULL, subset=NULL, na.action=na.retain, 28 | ylab='Number Followed', panel = 'nrisk', head=NULL, tail=NULL, 29 | h=5.5, w=5.5, outerlabels=TRUE, append=FALSE, 30 | popts=NULL) 31 | { 32 | if(grepl('[^a-zA-Z-]', panel)) 33 | stop('panel must contain only A-Z a-z -') 34 | 35 | ohead <- head 36 | 37 | gro <- getgreportOption() 38 | tvar <- gro$tx.var 39 | Nobs <- nobsY(formula, group=tvar, 40 | data=data, subset=subset, na.action=na.action) 41 | formula <- Nobs$formula # removes id() 42 | 43 | X <- if(length(subset)) model.frame(formula, data=data, subset=subset, 44 | na.action=na.action) 45 | else model.frame(formula, data=data, na.action=na.action) 46 | xnam <- names(X) 47 | tx.used <- tvar %in% xnam 48 | tx <- if(tx.used) X[[tvar]] 49 | labs <- sapply(X, label) 50 | labs <- ifelse(labs == '', xnam, labs) 51 | id <- Nobs$id 52 | sl <- if(ncol(X) > 1) upFirst(labs[-1], lower=TRUE) 53 | 54 | if(length(id) && anyDuplicated(id)) { 55 | ## Reduce data matrix to one row per subject per stratum with 56 | ## maximum follow-up time 57 | X <- data.table(X, .id.=id) 58 | setnames(X, xnam[1], '.y.') 59 | X <- subset(X, ! is.na(.y.)) 60 | by <- if(length(xnam) > 1) paste(xnam[-1], '.id.', sep=',') else '.id.' 61 | mx <- function(w) as.double(if(any(! is.na(w))) max(w, na.rm=TRUE) else NA) 62 | X <- X[, list(.maxy.= max(.y.), 63 | .n. = length(.y.), 64 | .gap. = max(diff(sort(c(0, .y.))))), by=by] 65 | X <- X[, c('.maxy.', '.n.', '.gap.', xnam[-1]), with=FALSE] 66 | setnames(X, '.maxy.', xnam[1]) 67 | } 68 | 69 | x1 <- X[[1]] 70 | xunits <- units(x1) 71 | if(xunits == '') xunits <- 'days' 72 | 73 | file <- sprintf('%s/%s.tex', getgreportOption('texdir'), panel) 74 | if(getgreportOption('texwhere') == '') file <- '' 75 | else if(!append) cat('', file=file) 76 | lb <- gsub('\\.', '', gsub('-', '', panel)) 77 | lbt <- lb 78 | if(! grepl('nrisk', lb)) { 79 | lb <- paste(lb, 'nrisk', sep='-') 80 | lbt <- paste(lbt, 'nrisk', sep='') 81 | } 82 | lttpop <- paste('ltt', lbt, sep='') 83 | 84 | if(! length(head)) 85 | head <- sprintf('Number of subjects followed at least $x$ %s from %s', 86 | xunits, time0) 87 | cap <- if(! length(sl)) head 88 | else sprintf('%s stratified by %s', head, sl) 89 | 90 | shortcap <- cap 91 | 92 | form <- paste('~', xnam[1]) 93 | cvar <- xnam %nin% c(xnam[1], groups) 94 | if(any(cvar)) 95 | form <- paste(form, '|', paste(xnam[cvar], collapse='*')) 96 | form <- as.formula(form) 97 | if(tx.used) { 98 | col <- gro$tx.linecol 99 | lwd <- gro$tx.lwd 100 | } else { 101 | col <- rep(c(gray(c(0, .7)), 'blue', 'red', 'green'), 10) 102 | lwd <- rep(c(1, 3), length=10) 103 | } 104 | dl <- list(x=form, 105 | data=X, na.action=na.action, 106 | what='1-f', col=col, lwd=lwd) 107 | if(length(subset)) dl$subset <- subset 108 | if(length(ylab)) dl$ylab <- ylab 109 | 110 | key <- popts$key 111 | if(! length(key) && length(groups)) { 112 | glevels <- levels(X[[groups]]) 113 | popts$key <- list(x=.6, y=-.07, cex=.8, 114 | columns=length(glevels), lines=TRUE, points=FALSE) 115 | } 116 | 117 | www <- c(dl, popts) 118 | p <- if(! length(groups)) do.call('Ecdf', c(dl, popts)) 119 | else { 120 | a <- sprintf("Ecdf(form, groups=%s, data=X, na.action=na.action, what='1-f', col=col, lwd=lwd", groups) 121 | if(length(subset)) a <- paste(a, ', subset=subset') 122 | if(length(ylab)) a <- paste(a, ', ylab=ylab') 123 | a <- paste(a, ')') 124 | p <- eval(parse(text=a)) 125 | } 126 | if(outerlabels && length(dim(p)) == 2) { 127 | # strip <- function(which.given, which.panel, var.name, 128 | # factor.levels, ...) { 129 | # current.var <- var.name[which.given] 130 | # levs <- if(current.var == 'time') lev else factor.levels 131 | # strip.default(which.given, which.panel, var.name, factor.levels=levs, ...#) 132 | # } 133 | p <- latticeExtra::useOuterStrips(p) #, strip=strip, strip.left=strip) 134 | } 135 | 136 | startPlot(lb, h=h, w=w) 137 | print(p) 138 | 139 | if(length(tail)) cap <- paste(cap, tail, sep='. ') 140 | no <- c(Nobs$nobs, Nobs$nobs, Nobs$nobsg) 141 | names(no) <- c('enrolled', 'randomized', rownames(Nobs$nobsg)) 142 | dNeedle(sampleFrac(no, Nobs), name=lttpop, file=file) 143 | cap <- sprintf('%s~\\hfill\\%s', cap, lttpop) 144 | endPlot() 145 | 146 | putFig(panel = panel, name = lb, caption = shortcap, 147 | longcaption = cap) 148 | 149 | if(length(id) && anyDuplicated(id) && ! length(groups) && 150 | length(xnam) == 1) { 151 | lb <- paste0(lb, '-details') 152 | lbt <- paste0(lbt, 'details') 153 | head <- ohead 154 | if(! length(head)) 155 | head <- sprintf('Distributions of follow-up visits, with times in %s', xunits) 156 | cap <- head 157 | shortcap <- cap 158 | 159 | startPlot(lb, h=5, w=6, mfrow=c(2,2), ps=7) 160 | cap <- paste0(cap, '. Top left panel is a histogram showing the distribution of the number of contacts per participant. Top right panel is a histogram showing the distribution of time from ', time0, ' to all contacts. Bottom left panel is a histogram showing the distribution of the longest time gap between visits per participant. Bottom right panel shows the relationship between the time of last contact per subject and the average number of contacts per subject.') 161 | if(length(tail)) cap <- paste(cap, tail, sep='. ') 162 | cap <- sprintf('%s\\hfill\\%s', cap, lttpop, longcaption=cap) 163 | x1 <- X[[xnam[1]]] 164 | with(X, { 165 | hist(.n., nclass=15, main='', 166 | xlab='Number of Contacts Per Participant', 167 | ylab='Number of Participants') 168 | hist(x1, nclass=40, main='', 169 | xlab=paste0(upFirst(xunits), ' From ', time0, ', All Contacts'), 170 | ylab='Number of Contacts') 171 | hist(.gap., nclass=40, main='', 172 | xlab=labelPlotmath('Longest Gap Between Visits Per Participant', 173 | xunits), 174 | ylab='Number of Participants') 175 | plot(supsmu(x1, .n.), type='l', 176 | xlab=paste(upFirst(xunits), 'From', time0, 'to Last Contact'), 177 | ylab='Number of Contacts Per Participant') 178 | }) 179 | 180 | endPlot() 181 | putFig(panel=panel, name=lb, caption=shortcap, longcaption=cap) 182 | } 183 | invisible() 184 | } 185 | 186 | utils::globalVariables('.y.') 187 | -------------------------------------------------------------------------------- /R/eReport.r: -------------------------------------------------------------------------------- 1 | #' Event Report 2 | #' 3 | #' Generates graphics for binary event proportions 4 | #' 5 | #' Generates dot charts showing proportions on left and risk difference with confidence intervals on the right, if there is only one level of event categorization. Input data must contain one record per event, with this record containing the event name. If there is more than one event of a given type per subject, unique subject ID must be provided. Denominators come from \code{greport} options and it is assumed that only randomized subjects have records. Some of the graphics functions are modifications of those found in the HH package. The data are expected to have one record per event, and non-events are inferred from \code{setgreportOption('denom')}. It is also assumed that only randomized subjects are included in the dataset. 6 | #' 7 | #' @param formula a formula with one or two left hand variables (the first representing major categorization and the second minor), and 1-2 right hand variables. One of these may be enclosed in \code{id()} to indicate the presence of a unique subject ID, and the other is treatment. 8 | #' @param data input data frame 9 | #' @param subset subsetting criteria 10 | #' @param na.action function for handling \code{NA}s when creating analysis frame 11 | #' @param minincidence a number between 0 and 1 specifying the minimum incidence in any stratum that must hold before an event is included in the summary 12 | #' @param conf.int confidence level for difference in proportions 13 | #' @param etype a character string describing the nature of the events, for example \code{"adverse events"}, \code{"serious adverse events"}. Used in figure captions. 14 | #' @param panel panel string 15 | #' @param subpanel a subpanel designation to add to \code{panel} 16 | #' @param head character string. Specifies initial text in the figure caption, otherwise a default is used. 17 | #' @param tail a character string to add to end of automatic caption 18 | #' @param h height of graph 19 | #' @param w width of graph 20 | #' @param append set to \code{TRUE} if adding to an existing sub-report 21 | #' @param popts a list of options to pass to graphing functions 22 | #' @author Frank Harrell 23 | #' @export 24 | #' @examples 25 | #' # See test.Rnw in tests directory 26 | 27 | eReport <- function(formula, data=NULL, subset=NULL, na.action=na.retain, 28 | minincidence=0, conf.int=0.95, 29 | etype='adverse events', 30 | panel='events', subpanel=NULL, head=NULL, tail=NULL, 31 | h=6, w=7, append=FALSE, popts=NULL) { 32 | 33 | if(grepl('[^a-zA-Z-]', panel)) 34 | stop('panel must contain only A-Z a-z -') 35 | if(length(subpanel) && grepl('[^a-zA-Z-]', subpanel)) 36 | stop('subpanel must contain only A-Z a-z -') 37 | 38 | Nobs <- nobsY(formula, group=getgreportOption('tx.var'), 39 | data=data, subset=subset, na.action=na.action) 40 | form <- Formula(formula) 41 | environment(form) <- new.env(parent = environment(form)) 42 | en <- environment(form) 43 | assign(envir = en, 'id', function(x) x) 44 | 45 | Y <- if(length(subset)) model.frame(form, data=data, subset=subset, 46 | na.action=na.action) 47 | else model.frame(form, data=data, na.action=na.action) 48 | X <- model.part(form, data=Y, rhs=1) 49 | Y <- model.part(form, data=Y, lhs=1) 50 | rhs <- terms(form, rhs=1, specials='id') 51 | sr <- attr(rhs, 'specials') 52 | ## specials counts from lhs variables 53 | wid <- sr$id 54 | if(length(wid)) wid <- wid - ncol(Y) 55 | 56 | nY <- ncol(Y) 57 | major <- NULL 58 | if(nY > 1) major <- Y[[1]] 59 | event <- Y[[nY]] 60 | id <- 1 : length(event) 61 | nX <- ncol(X) 62 | gname <- glabel <- '' 63 | if(nX > 1 + (length(wid) > 0)) 64 | stop('cannot have more than one right hand variable other than id variable') 65 | if(length(wid)) { 66 | id <- X[[wid]] 67 | j <- setdiff(1 : nX, wid) 68 | } else if(nX == 1) j <- 1 69 | else j <- 0 70 | if(j == 0) { 71 | group <- factor(rep('', length(event))) 72 | gname <- glabel <- '' 73 | } 74 | else { 75 | group <- X[[j]] 76 | gname <- names(X)[j] 77 | glabel <- label(group, default=gname) 78 | } 79 | 80 | event <- as.factor(event) 81 | levels(event) <- upFirst(levels(event)) 82 | # event <- as.character(event) 83 | uevent <- levels(event) 84 | nue <- length(uevent) 85 | N <- getgreportOption('denom') 86 | n <- N[setdiff(names(N), c('enrolled', 'randomized'))] 87 | groups <- names(n) 88 | if(length(groups) != 2) stop('currently only implemented for 2 treatments') 89 | group <- as.character(group) 90 | 91 | if(! length(major)) { 92 | ## The following functions are in the HH package 93 | panel.ae.dotplot <- 94 | function (x, y, groups, ..., col.AB, pch.AB, lower, upper) { 95 | pn <- panel.number() 96 | if (pn == 1) 97 | panel.ae.leftplot(x, y, groups = groups, 98 | col = col.AB, pch = pch.AB, ...) 99 | if (pn == 2) 100 | panel.ae.rightplot(x, y, ..., lwd = 6, pch = 16, 101 | lower = lower, upper = upper) 102 | } 103 | 104 | panel.ae.leftplot <- function(x, y, groups, col.AB, ...) { 105 | panel.abline(h = y, lty = 2, lwd = .4, col = gray(.7)) 106 | panel.superpose(x, y, groups = groups, 107 | col = col.AB, ...) 108 | } 109 | 110 | panel.ae.rightplot <- 111 | function(x, y, ..., lwd = 6, lower, upper) { 112 | panel.abline(v = 0, lty = 1, lwd = .6, col = gray(.7)) 113 | panel.abline(h = y, lty = 2, lwd = .4, col = gray(.7)) 114 | panel.segments(lower, y, upper, y, lwd = 2) 115 | panel.xyplot(x, y, ..., col = 1, cex = 0.7) 116 | panel.points(lower, y, pch = 3, col = 1, cex = 0.4) 117 | panel.points(upper, y, pch = 3, col = 1, cex = 0.4) 118 | } 119 | 120 | ## Modification of HH's ae.dotplot that uses risk difference and 121 | ## uses proportions instead of percents 122 | 123 | zcrit <- qnorm( (1 + conf.int) / 2) 124 | f <- function(i) { 125 | idi <- id[i] 126 | grp <- group[i] 127 | n1 <- length(unique(idi[grp == groups[1]])) 128 | n2 <- length(unique(idi[grp == groups[2]])) 129 | p1 <- n1 / n[1] 130 | p2 <- n2 / n[2] 131 | se <- sqrt(p1 * (1 - p1) / n[1] + p2 * (1 - p2) / n[2]) 132 | diff <- p1 - p2 133 | lower <- diff - zcrit * se 134 | upper <- diff + zcrit * se 135 | r <- c(p1, p2, diff, lower, upper) 136 | names(r) <- c('p1', 'p2', 'diff', 'lower', 'upper') 137 | r 138 | } 139 | z <- tapply(1 : length(event), event, f) 140 | z <- t(sapply(z, function(x) x)) 141 | if(minincidence > 0) { 142 | small <- pmax(z[, 'p1'], z[, 'p2'], na.rm=TRUE) < minincidence 143 | z <- z[! small, ] 144 | } 145 | zr <- round(z, 3) 146 | z <- data.frame(event=row.names(z ), z ) 147 | zr <- data.frame(event=upFirst(row.names(zr)), zr) 148 | 149 | file <- sprintf('%s/%s.tex', getgreportOption('texdir'), panel) 150 | if(getgreportOption('texwhere') == '') file <- '' 151 | else if(! append) cat('', file=file) 152 | lb <- if(length(subpanel)) sprintf('%s-%s', panel, subpanel) else panel 153 | lbn <- gsub('\\.', '', gsub('-', '', lb)) 154 | 155 | popname <- sprintf('\\pop%s', lbn) 156 | names(zr) <- c('Event', groups, 'Difference', 'Lower', 'Upper') 157 | pop <- latexTabular(zr, align='lrrrrr', hline=1) 158 | cat('\\def', popname, '{', pop, '}%\n', sep='', file=file, append=TRUE) 159 | 160 | ## Duplicate diff and CI so that lattice can have separate records 161 | ## for 2 treatments 162 | z <- rbind(cbind(.group.=groups[1], proportion=z$p1, z), 163 | cbind(.group.=groups[2], proportion=z$p2, z)) 164 | 165 | txcol <- getgreportOption('tx.col') 166 | txpch <- getgreportOption('tx.pch') 167 | z$event <- with(z, reorder(event, diff)) 168 | 169 | r <- dotplot(event ~ proportion + diff, 170 | groups = .group., 171 | data = z, outer = TRUE, 172 | lower = z$lower, 173 | upper = z$upper, 174 | panel = panel.ae.dotplot, 175 | scales = list(x = list(relation = "free", 176 | limits = list(range(z$proportion), 177 | range(z$lower, z$upper, 178 | na.rm=TRUE))), 179 | y = list(cex = 0.6)), 180 | A.name = groups[1], B.name = groups[2], 181 | col.AB = txcol, 182 | pch.AB = txpch, 183 | cex.AB.points = NULL, 184 | cex.AB.y.scale = 0.6, 185 | ## main = list(main.title, cex = main.cex), 186 | xlab = NULL, between = list(x = 1), 187 | key = list(y = -0.2, x = 0.15, 188 | points = list(col = txcol, pch = txpch), 189 | text = list(groups, col = txcol, cex = 0.9), 190 | columns = 2, between = 0.5, space = "bottom")) 191 | r$condlevels[[1]] <- c("Proportion", 192 | paste("Risk Difference with", 193 | conf.int, "CI")) 194 | } 195 | else { 196 | stop('major event grouping not yet implemented') 197 | } 198 | 199 | lttpop <- paste('ltt', lbn, sep='') 200 | if(! length(head)) 201 | head <- paste('Proportion of', etype, 202 | 'and risk differences by', upFirst(glabel, lower=TRUE), 203 | 'sorted by risk difference') 204 | if(minincidence > 0 && any(small)) 205 | head <- paste(head, '. ', sum(small), ' events with less than ', 206 | minincidence, 207 | ' incidence in at least one group are not shown.', 208 | sep='') 209 | shortcap <- paste('Proportion of', etype, 'and risk differences by', 210 | upFirst(glabel, lower=TRUE)) 211 | startPlot(lb, h=h, w=w) 212 | print(r) 213 | endPlot() 214 | N[1] <- N[2] # assume only analyze randomized subjects 215 | dNeedle(sampleFrac(N, nobsY=Nobs), name=lttpop, file=file) 216 | head <- paste(head, '~\\hfill\\', lttpop, sep='') 217 | putFig(panel=panel, name=lb, caption=shortcap, longcaption=head, 218 | poptable=popname, popfull=TRUE) 219 | invisible() 220 | } 221 | -------------------------------------------------------------------------------- /R/todo/Misc.firsttry.r: -------------------------------------------------------------------------------- 1 | #' Call a \sQuote{knitr} Macro from \sQuote{creport} 2 | #' 3 | #' Takes an unquoted macro name, appends ".Rnw" to it and prepends with 4 | #' system location of the macros, then calls \sQuote{knit_expand} with 5 | #' the full file name along with arguments. 6 | #' 7 | #' details 8 | #' 9 | #' @param macname unquoted macro name. 10 | #' @param ... arguments to pass to \link[knitr]{knit_expand} 11 | #' @export 12 | #' @examples 13 | #' callmac(accrualReport, entryDate1="rdate") 14 | 15 | callmac <- function(macname, ...) { 16 | file <- paste('Rnw/', deparse(substitute(macname)), '.Rnw', sep='') 17 | file <- system.file(file, package='creport') 18 | knit(text = knit_expand(file, ...)) 19 | } 20 | 21 | #' Check if knitr Macro Variable is Present in Macro Invocation 22 | # Written by Yihui Xie 23 | mvarthere <- function(x) 24 | exists(deparse(substitute(x)), envir=parent.frame(), inherits = FALSE) 25 | # The key is inherits=FALSE, which stops R from looking for objects in 26 | # parent frames successively. 27 | 28 | #' Kaplan-Meier Estimates 29 | #' 30 | #' For two strata, estimates the standard error of the difference in two 31 | #' Kaplan-Meier estimates at each value of times, and plots half-width 32 | #' of confidence level for the difference, centered at the midpoint 33 | #' of the survival estimates. 34 | #' 35 | #' details 36 | #' 37 | #' @param fit survfit object. See \code{\link[rms]{survfit.formula}}. 38 | #' @param times numeric vector. Time value for each record. 39 | #' @param fun function. Function to plot estimates. 40 | #' @param offset numeric. Offset value to apply to \sQuote{x} coordinate points. 41 | #' @param lwd numeric. The line width, passed to \code{lines}. 42 | #' @param lty numeric. The line type, passed to \code{lines}. 43 | #' @export 44 | #' @examples 45 | #' set.seed(20) 46 | #' time <- rep(365, 50) 47 | #' event <- rbinom(50, 1, 1/3) 48 | #' time[event == 1] <- sample(365, sum(event == 1), replace=TRUE) 49 | #' trt <- sample(1:2, 50, replace=TRUE) 50 | #' require('rms') 51 | #' fit <- survfit.formula(Surv(time, event) ~ trt) 52 | #' survplot.survfit(fit) 53 | #' plotKmHalfCL(fit, time) 54 | 55 | plotKmHalfCL <- function(fit, times, fun=function(x) x, 56 | offset=0, lwd=0.5, lty=1) { 57 | s <- summary(fit, times=times) 58 | st <- s$strata 59 | lev <- levels(st) 60 | 61 | if(length(lev) != 2) { 62 | stop('only handles 2 strata') 63 | } 64 | 65 | s1 <- s$surv[st == lev[1]] 66 | s2 <- s$surv[st == lev[2]] 67 | se1 <- s$std.err[st == lev[1]] 68 | se2 <- s$std.err[st == lev[2]] 69 | se.diff <- sqrt(se1^2 + se2^2) 70 | clhalf <- 1.96 * se.diff 71 | midpt <- (s1 + s2) / 2 72 | for(i in 1 : length(times)) { 73 | lines(offset + c(times[i], times[i]), 74 | fun(c(midpt[i] - clhalf[i] / 2, midpt[i] + clhalf[i] / 2)), 75 | lwd=lwd, lty=lty, col=gray(0.7)) 76 | } 77 | } 78 | 79 | #' Set mfrow Parameter 80 | #' 81 | #' Compute and set a good \code{par("mfrow")} given the 82 | #' number of figures to plot. 83 | #' 84 | #' \code{trellis} and \code{small} may not both be specified as \sQuote{TRUE}. 85 | #' 86 | #' @param n numeric. Total number of figures to place in layout. 87 | #' @param trellis logical. Set to \sQuote{TRUE} when a \sQuote{trellis} plot 88 | #' is requested. 89 | #' @param small logical. Set to \sQuote{TRUE} if the plot area should be 90 | #' smaller to accomodate many plots. 91 | #' @return return numeric vector. 92 | #' If \code{trellis = TRUE} the suggested \sQuote{mfrow} is returned. 93 | #' Otherwise the original \sQuote{mfrow} is returned invisibly. 94 | #' @export 95 | #' @examples 96 | #' oldmfrow <- mfrowSet(8) 97 | 98 | mfrowSet <- function(n, trellis=FALSE, small=FALSE) { 99 | if(small && trellis) stop('may not specify small=T when trellis=T') 100 | 101 | omf <- mf <- if(trellis)NULL else par('mfrow') 102 | if(length(mf)==0) mf <- c(1,1) 103 | if(n > 1 & max(mf)==1) { 104 | if(small) { 105 | mf <- if(n <= 4) { 106 | c(2,2) 107 | } else if(n <= 6) { 108 | c(2,3) 109 | } else if(n <= 12) { 110 | c(3,4) 111 | } else if(n <= 16) { 112 | c(4,4) 113 | } else if(n <= 20) { 114 | c(4,5) 115 | } else if(n <= 24) { 116 | c(4,6) 117 | } else if(n <= 25) { 118 | c(5,5) 119 | } else if(n <= 30) { 120 | c(5,6) 121 | } else if(n <= 36) { 122 | c(6,6) 123 | } else if(n <= 42) { 124 | c(6,7) 125 | } else { 126 | c(6,8) 127 | } 128 | } else { 129 | mf <- if(n <= 4) { 130 | c(2,2) 131 | } else if(n <= 6) { 132 | c(2,3) 133 | 134 | } else if(n <= 9) { 135 | c(3,3) 136 | } else { 137 | c(4,3) 138 | } 139 | 140 | if(n > 12 & n <= 16) { 141 | mf <- c(4,4) 142 | } 143 | } 144 | if(!trellis) { 145 | par(mfrow=mf) 146 | } 147 | } 148 | if(trellis) { 149 | mf 150 | } else { 151 | invisible(omf) 152 | } 153 | } 154 | 155 | #' Combine Equal 156 | #' 157 | #' Given a contingency table of counts, combine factors with equal counts. 158 | #' 159 | #' Factor names will be pasted together to make new names. A code and definition will be generated 160 | #' if the new name should exceed \code{maxChar}. 161 | #' 162 | #' @param x numeric. Contingency table or matrix of names and counts, see \code{\link[base]{table}}. 163 | #' @param maxChar numeric. Maximum length of character string. Names exceeding this will be replaced with a letter-code. 164 | #' @return a list with three elements 165 | #' \item{x}{Named vector of code frequencies. The name corresponds to the code.} 166 | #' 167 | #' \item{codes}{Character vector of alpha-code labels.} 168 | #' 169 | #' \item{defs}{Character vector of code definitions.} 170 | #' 171 | #' @export 172 | #' @examples 173 | #' combineEqual(table(rep(991:1010, times=rep(1:4, each=5)))) 174 | #' combineEqual(table(rep(991:1010, times=rep(1:4, each=5))), maxChar=10) 175 | 176 | combineEqual <- function(x, maxChar=24) { 177 | xorig <- x 178 | if(is.matrix(x)) { 179 | x <- apply(x, 2, paste, collapse=',') 180 | } 181 | 182 | if(!any(duplicated(x))) { 183 | return(xorig) 184 | } 185 | 186 | z <- split(names(x), x) 187 | 188 | v <- if(is.matrix(xorig)) { 189 | names(z) 190 | } else { 191 | as.numeric(names(z)) 192 | } 193 | 194 | nam <- codes <- defs <- character(0) 195 | j <- 0 196 | 197 | all.letters <- c(letters,LETTERS) 198 | for(i in 1:length(z)) { 199 | a <- z[[i]] 200 | ac <- paste(a, collapse=', ') 201 | if(nchar(ac) <= maxChar) { 202 | nam <- c(nam,ac) 203 | } else { 204 | j <- j + 1 205 | k <- paste('(',all.letters[j],')',sep='') 206 | nam <- c(nam, k) 207 | codes <- c(codes, k) 208 | defs <- c(defs, ac) 209 | } 210 | } 211 | names(v) <- nam 212 | if(is.matrix(xorig)) { 213 | v <- matrix(as.numeric(unlist(strsplit(v,','))),ncol=length(v), 214 | dimnames=list(dimnames(xorig)[[1]], nam)) 215 | } 216 | 217 | list(x=v, codes=codes, defs=defs) 218 | } 219 | 220 | #' Make Treatment Key 221 | #' 222 | #' Use treatment levels to generate treatment key in LaTeX. 223 | #' 224 | #' @param tlevels vector. unique treatment levels, expected to have length two 225 | #' @export 226 | #' @examples 227 | #' makeTreatKey(c('A', 'B')) # prints to standard output 228 | 229 | makeTreatKey <- function(tlevels) { 230 | if(length(tlevels) != 2) { 231 | stop('expected two levels of treatment') 232 | } 233 | cat('\\def\\treatkey{', tlevels[1], ':\\rule[.05in]{.25in}{.5pt}; ', 234 | tlevels[2], ':\\textcolor[gray]{0.7}{\\rule[.05in]{.25in}{1.25pt}}.}\n') 235 | invisible() 236 | } 237 | 238 | #' Put Params 239 | #' 240 | #' Define parameters and provide LaTeX formatting. 241 | #' 242 | #' Parameters will be saved to the parameter LaTeX file. 243 | #' 244 | #' @param \dots list of name-value pairs. parameter names and their associated formats 245 | #' @export 246 | #' @examples 247 | #' putparams(go=1, fish='blue') #prints to standard output 248 | 249 | putparams <- function(...) { 250 | x <- list(...) 251 | if(!length(x)) return(invisible()) 252 | for(n in names(x)) 253 | cat('\\def\\', n, '{', format(x[[n]]), '}\n', sep='') 254 | invisible() 255 | } 256 | 257 | #' Publish PDF 258 | #' 259 | #' summary 260 | #' 261 | #' details 262 | #' 263 | #' @param reports NEEDDOC 264 | #' @param minutes NEEDDOC 265 | #' @param title NEEDDOC 266 | #' @param server NEEDDOC 267 | #' @param path NEEDDOC 268 | #' @param extension NEEDDOC 269 | #' @param upload NEEDDOC 270 | #' @param email NEEDDOC 271 | #' @param uid NEEDDOC 272 | #' @param passwd NEEDDOC 273 | #' @param to NEEDDOC 274 | #' @param cc NEEDDOC 275 | #' @param bcc NEEDDOC 276 | #' @param sig NEEDDOC 277 | #' @param hardcopies NEEDDOC 278 | #' @param verbose NEEDDOC 279 | #' @param mailer NEEDDOC 280 | #' @param extra NEEDDOC 281 | #' @return return something 282 | #' @export 283 | #' @examples 284 | #' 1 285 | 286 | # Don't remember how configured mail to work 287 | # Consider R package mail - can send up to 20 notification messages 288 | # per day using only http:. sendmailR does not work with smtpauth 289 | # Also consider mutt. You can use Thunderbird command line arguments 290 | # but still have to open a window and hit Send 291 | 292 | publishPdf <- function(reports, minutes=NULL, title, server, path, extension="pdf", 293 | upload=TRUE, email=FALSE, uid=NULL, passwd=NULL, 294 | to=NULL, cc=NULL, bcc=NULL, sig=NULL, 295 | hardcopies=TRUE, verbose=TRUE, 296 | mailer=c('mail','kmail'), extra=NULL) { 297 | 298 | ## E.g. publishPdf(c(report='Closed Meeting Report', 299 | ## Oreport='Open Meeting Report'),title='My Project', 300 | ## server='myserver.edu', path='/home/www/html/myproject') 301 | ## Be sure to put something like export REPLYTO=foo@place.edu in ~/.bashrc 302 | ## if using mailer='mail' 303 | 304 | mailer <- match.arg(mailer) 305 | nl <- ifelse(mailer=='kmail','\n','\\n') 306 | 307 | if(upload) { 308 | f <- tempfile() 309 | 310 | if(file.exists(f) && !file.info(f)$isdir) { 311 | file.remove(f) 312 | } 313 | 314 | dir.create(f, recursive=TRUE) 315 | if (extension=="") {sep=""} else {sep="."} 316 | rn <- paste(names(c(reports,minutes)), extension, sep=sep) 317 | paths <- file.path(f, c('index.html', basename(rn))) 318 | 319 | info <- file.info(rn)[,c('size','mtime')] 320 | cat('', 321 | paste('

', title, '

', sep=''), 322 | sep='\n', file=paths[1]) 323 | i <- with(info, data.frame(Bytes=size, 'Date Created'=mtime, 324 | Description=c(reports,minutes), 325 | row.names=basename(row.names(info)), 326 | check.names=FALSE)) 327 | z <- html(i, file=paths[1], append=TRUE, link=basename(rn), linkCol='Name', 328 | linkType='href') 329 | 330 | file.copy(rn, paths[-1], overwrite=TRUE) 331 | 332 | system(paste('chmod u=rw,g=rw,o=', paste(shQuote(paths), collapse=' '))) 333 | system(paste('scp ', paste(shQuote(paths), collapse=' '), ' ', server, ':', path, sep='')) 334 | 335 | #file.remove(paths, f) 336 | } 337 | if(email) { 338 | url <- strsplit(path, '/')[[1]] 339 | url <- url[length(url)] 340 | url <- paste('http://', server, '/', url, sep='') 341 | cmd <- paste( 342 | if(length(c(reports,minutes)) ==1) { 343 | 'The following document has' 344 | } else { 345 | 'The following documents have' 346 | }, 347 | ' been placed or updated on a secure web page:',nl,#nl, 348 | paste(c(reports,minutes), collapse=nl), nl, nl, 349 | 'Point your browser to ', url, #nl, 350 | ' and use the username ', uid, 351 | ' and the password that will be in the next email. ', 352 | 'For accuracy, copy the password from the e-mail and', 353 | ' paste it in the proper field in your browser.',nl,nl, 354 | 'Please confirm your ability to open the pdf files within 24 hours by replying to this message.',nl,nl, 355 | if(hardcopies) { 356 | 'I will bring final hard copies to the meeting.' 357 | }, 358 | if(length(extra)) { 359 | paste(nl,nl, extra,sep='') 360 | }, 361 | sep='') 362 | 363 | if(length(sig)) { 364 | sig <- paste(sig, collapse=nl) 365 | cmd <- paste(cmd, nl, '----------', nl, sig, sep='') 366 | } 367 | 368 | if(mailer=='kmail') { 369 | tf <- tempfile() 370 | cat(cmd, file=tf) 371 | to <- paste('"', paste(to, collapse=','), '"', sep='') 372 | if(length(cc)) { 373 | cc <- paste(' -c "', paste(cc, collapse=','),'"',sep='') 374 | } 375 | 376 | if(length(bcc)) { 377 | bcc <- paste(' -b "', paste(bcc, collapse=','),'"',sep='') 378 | } 379 | } else { 380 | to <- paste(to, collapse=' ') 381 | if(length(cc)) { 382 | cc <- paste(paste(' -c', cc), collapse='') 383 | } 384 | 385 | if(length(bcc)) { 386 | bcc <- paste(paste(' -b', bcc),collapse='') 387 | } 388 | } 389 | cmd <- if(mailer=='kmail') { 390 | paste('kmail -s "', title, '"', cc, 391 | bcc, ' --msg ', tf, ' ', to, sep='') 392 | } else { 393 | paste('echo "', cmd, '" | mail -s "', 394 | title, ' Reports"', cc, bcc, ' ', to, sep='') 395 | } 396 | 397 | system(cmd) 398 | if(verbose) { 399 | cat('\n\nMail command sent:\n', cmd, '\n') 400 | } 401 | 402 | prn(passwd) 403 | 404 | if(length(passwd)) { 405 | cmd <- if(mailer=='kmail') { 406 | paste('kmail -s "Additional information"', cc, bcc, 407 | ' --body "', passwd, '" ', to, sep='') 408 | } else { 409 | paste('echo ', passwd, ' | mail -s "Additional information"', 410 | cc, bcc, ' ', to, sep='') 411 | } 412 | 413 | system(cmd) 414 | if(verbose) { 415 | cat('\n\nMail command sent:\n', cmd, '\n') 416 | } 417 | } 418 | } 419 | invisible() 420 | } 421 | -------------------------------------------------------------------------------- /R/survReport.r: -------------------------------------------------------------------------------- 1 | #' Survival Report 2 | #' 3 | #' Generate a Survival Report with Kaplan-Meier Estimates 4 | #' 5 | #' @param formula a formula with survival (\code{Surv}) objects on the left hand side and an optional stratification factor on the right (or \code{1} if none). The survival object component variables should be labeled; these labels are used for graph annotation. If any of the \code{Surv} objects are competing risk objects (see \code{\link[survival]{Surv}}), event labels come from the factor levels in the variable that was the second argument to \code{Surv}, and the first factor level must correspond to right-censored observations. 6 | #' @param data data.frame 7 | #' @param subset optional subsetting criteria 8 | #' @param na.action function for handling \code{NA}s while creating a data frame 9 | #' @param ylab character. Passed to \code{\link[rms]{survplot.npsurv}} as the \code{ylab} argument. Constructed by default. 10 | #' @param what \code{"S"} (the default) to plot survival functions or \code{"1-S"} to plot cumulative incidence functions. If any of the survival time objects on the left hand side are competing risk objects, the default is \code{"1-S"} and you may not change it. 11 | #' @param conf character. See \code{\link[rms]{survplot.npsurv}}. 12 | #' @param cause character vector or list. If a vector, every \code{Surv} term on the left hand side of \code{formula} will have cumulative incidence plotted for all causes that appear in \code{cause}. If a list, the list elements must correspond to the \code{Surv} terms in order, and specify which causes to display from the corresponding \code{Surv} object. When \code{cause} is a list and one of its elements contains more than one character string, or when \code{cause} is a vector and for one \code{Surv} object it matches multiple causes, \code{survReport} produces more plots than there are \code{Surv} objects. 13 | #' @param panel character string. Name of panel, which goes into file base names and figure labels for cross-referencing. 14 | #' @param subpanel character string. If calling \code{dReport} more than once for the same type of chart (categorical or continuous), specify \code{subpanel} to distinguish the multiple calls. In that case, \code{-subpanel} will be appended to \code{panel} when creating figure labels and cross-references. 15 | #' @param head character string. Specifies initial text in the figure caption, otherwise a default is used. 16 | #' @param tail optional character string. Specifies final text in the figure caption, e.g., what might have been put in a footnote in an ordinary text page. This appears just before any needles. 17 | #' @param h numeric. Height of plots. 18 | #' @param w numeric. Width of plots in inches. 19 | #' @param multi logical. If \code{TRUE}, multiple figures are produced, otherwise a single figure with a matrix of survival plots is made. 20 | #' @param markevent logical. Applies only if \code{multi=TRUE}. Specify \code{FALSE} to not put the event label in the extreme upper left of the plot. 21 | #' @param mfrow numeric 2-vector, used if \code{multi=FALSE}. If not specified, default plot matrix layout will be figured. 22 | #' @param y.n.risk used if \code{what="1-S"}, to specify \code{y} coordinate for putting numbers at risk, typically below the \code{x}-axis label 23 | #' @param mylim numeric 2-vector. Used to force expansion of computed y-axis limits. See \code{survplot}. 24 | #' @param bot number of spaces to reserve at bottom of plot for numbers at risk, if \code{what="1-S"} 25 | #' @param aehaz logical. Set to \code{FALSE} to not print number of events and hazard rate on plots. 26 | #' @param times numeric vector. If specified, prints cumulative incidence probabilities at those times on the plots. 27 | #' @param append logical. If \code{TRUE} output will be appended instead of overwritten. 28 | #' @param opts list. A list specifying arguments to \code{survReport} and \code{startPlot} that override any other arguments. This is useful when making a long series of \code{survReport} calls with the same options, as the options can be defined up front in a list. 29 | #' @param \dots ignored 30 | #' @export 31 | #' @examples 32 | #' ## See tests directory test.Rnw for a live example 33 | #' \dontrun{ 34 | #' set.seed(1) 35 | #' n <- 400 36 | #' dat <- data.frame(t1=runif(n, 2, 5), t2=runif(n, 2, 5), 37 | #' e1=rbinom(n, 1, .5), e2=rbinom(n, 1, .5), 38 | #' treat=sample(c('a','b'), n, TRUE)) 39 | #' dat <- upData(dat, 40 | #' labels=c(t1='Time to operation', 41 | #' t2='Time to rehospitalization', 42 | #' e1='Operation', e2='Hospitalization', 43 | #' treat='Treatment') 44 | #' units=c(t1='year', t2='year')) 45 | #' survReport(Surv(t1, e1) + Surv(t2, e2) ~ treat, data=dat) 46 | #' 47 | #' dat <- upData(dat, labels=c(t1='Follow-up Time', t2='Time'), 48 | #' cause=factor(sample(c('death','MI','censor'), n, TRUE), 49 | #' c('censor', 'MI', 'death'))) 50 | #' survReport(Surv(t1, cause) ~ treat, cause='death', data=dat) 51 | #' survReport(Surv(t1, cause) + Surv(t2, cause) ~ treat, 52 | #' cause=list(c('death', 'MI'), 'death'), data=dat) 53 | #' # Two plots for t1, one plot for t2 54 | #' } 55 | 56 | survReport <- function(formula, data=NULL, subset=NULL, na.action=na.retain, 57 | ylab=NULL, what=c('S', '1-S'), 58 | conf=c('diffbands', 'bands', 'bars', 'none'), 59 | cause=NULL, 60 | panel='surv', subpanel=NULL, head=NULL, tail=NULL, 61 | h=3, w=4.5, multi=FALSE, markevent=TRUE, mfrow=NULL, y.n.risk=0, 62 | mylim=NULL, bot=2, aehaz=TRUE, times=NULL, 63 | append=FALSE, opts=NULL, ...) 64 | { 65 | if(grepl('[^a-zA-Z-]', panel)) 66 | stop('panel must contain only A-Z a-z -') 67 | if(length(subpanel) && grepl('[^a-zA-Z-]', subpanel)) 68 | stop('subpanel must contain only A-Z a-z -') 69 | 70 | what <- match.arg(what) 71 | if(length(cause)) what <- '1-S' 72 | conf <- match.arg(conf) 73 | 74 | ## Bring arguments from opts as if they were listed outside opts 75 | if(length(opts) && is.list(opts)) 76 | for(j in 1 : length(opts)) 77 | assign(names(opts)[j], opts[[j]], immediate=TRUE) 78 | ## Add other startPlot and spar arguments into opts 79 | w <- c(list(h=h, w=w, multi=multi, mfrow=mfrow, bot=bot), list(...)) 80 | if(! length(opts) || any(names(w) %nin% names(opts))) { 81 | if(! length(opts)) opts <- list(junk='junk') 82 | for(x in names(w)) if(x %nin% names(opts)) opts[[x]] <- w[[x]] 83 | opts$junk <- NULL 84 | } 85 | 86 | kmlab <- if(what == 'S') 'Kaplan-Meier estimates' 87 | else 'Kaplan-Meier cumulative incidence estimates' 88 | 89 | past <- function(x) { 90 | l <- length(x) 91 | y <- if(l < 2) x 92 | else if(l == 2) paste(x, collapse=' and ') 93 | else paste(paste(x[1 : (l - 1)], collapse=', '), x[l], sep=', and ') 94 | upFirst(y, alllower=TRUE) 95 | } 96 | 97 | stamp <- function(w) 98 | text(grconvertX(0, 'ndc', 'user'), grconvertY(1, 'ndc', 'user'), 99 | w, adj=c(0, 1), xpd=NA, col='blue') 100 | 101 | 102 | form <- Formula(formula) 103 | Y <- if(length(subset)) model.frame(form, data=data, subset=subset, 104 | na.action=na.action) 105 | else model.frame(form, data=data, na.action=na.action) 106 | X <- model.part(form, data=Y, rhs=1) 107 | Y <- model.part(form, data=Y, lhs=1) 108 | 109 | texdir <- getgreportOption('texdir') 110 | file <- if(getgreportOption('texwhere') == 'gentex') 111 | sprintf('%s/%s.tex', texdir, panel) else '' 112 | if(file != '' && ! append) cat('', file=file) 113 | lb <- if(length(subpanel)) sprintf('%s-%s', panel, subpanel) else panel 114 | 115 | if(length(cause) && is.list(cause) && length(cause) != length(Y)) 116 | stop('when cause is a list it must have length = number of Surv objects on left side of model') 117 | 118 | 119 | namx <- labx <- NULL 120 | if(length(X)) { 121 | x <- X[[1]] 122 | namx <- names(X)[1] 123 | labx <- upFirst(ifelse(label(x) == '', namx, label(x)), alllower=TRUE) 124 | } 125 | 126 | Nobs <- nobsY(formula, group=getgreportOption('tx.var'), 127 | data=data, subset=subset, na.action=na.action) 128 | 129 | ny <- nycause <- ncol(Y) 130 | ## nycause is the total number of plots counting any separate plots for 131 | ## multiple causes 132 | 133 | if(length(cause)) { 134 | Cause <- list() 135 | for(i in 1 : ny) { 136 | y <- Y[[i]] 137 | states <- attr(y, 'states') 138 | usecause <- '' 139 | if(length(states)) { 140 | selectedCauses <- if(is.list(cause)) cause[[i]] else cause 141 | if(! length(selectedCauses)) 142 | stop(paste('cause not specified for Surv object #', i)) 143 | if(is.list(cause) && any(selectedCauses %nin% states)) 144 | stop(paste('a selected cause is not in the list of states for Surv object #', 145 | i, '\nstates:', paste(states, collapse=','), 146 | '\ncause:', paste(selectedCauses, collapse=','))) 147 | usecause <- intersect(states, selectedCauses) 148 | } 149 | Cause[[i]] <- usecause 150 | } 151 | nycause <- length(unlist(Cause)) 152 | } 153 | 154 | if(nycause == 1) multi <- FALSE 155 | if(! multi) { 156 | if(! length(opts$mfrow)) opts$mfrow <- mfrowSuggest(nycause) 157 | if(what == 'S') opts$bot <- 0 158 | do.call('startPlot', c(list(file=lb, lattice=FALSE), opts)) 159 | } 160 | 161 | gro <- getgreportOption() 162 | x.is.tx <- FALSE; ng <- 0 163 | if(length(X)) { 164 | x <- X[[1]] 165 | ng <- if(is.factor(x)) length(levels(x)) else 166 | length(unique(x[!is.na(x)])) 167 | if(namx == gro$tx.var) { 168 | x.is.tx <- TRUE 169 | col <- gro$tx.linecol 170 | lwd <- gro$tx.lwd 171 | } 172 | else { 173 | col <- rep(gro$nontx.col, length=ng) 174 | lwd <- rep(c(1, 3), length=ng) 175 | } 176 | } else { 177 | x <- rep('', nrow(Y)) 178 | col <- 1 179 | lwd <- 2 180 | } 181 | 182 | nobs <- rep(0, 1 + x.is.tx * ng) 183 | evlab <- character(nycause) 184 | icause <- 0 185 | for(i in 1 : ny) { 186 | y <- Y[[i]] 187 | 188 | states <- attr(y, 'states') 189 | usecause <- '' 190 | if(length(attr(y, 'states'))) { 191 | if(! length(cause)) 192 | stop('cause must be specified if any Surv objects on the left side are for competing risks') 193 | usecause <- Cause[[i]] 194 | } 195 | 196 | no <- c(randomized = nrow(y[! is.na(y)])) 197 | s <- npsurv(y ~ x) 198 | if(conf == 'diffbands' && length(s$strata) < 2) conf <- 'bands' 199 | if(x.is.tx) { 200 | no <- c(no, s$n) 201 | names(no) <- c('randomized', levels(x)) 202 | } 203 | 204 | for(cau in usecause) { 205 | icause <- icause + 1 206 | evlab[icause] <- if(cau == '') label(y) else cau 207 | if(multi) { 208 | lbi <- paste(lb, icause, sep='-') 209 | if(what == 'S') opts$bot <- 0 210 | do.call('startPlot', c(list(file=lbi, lattice=FALSE), opts)) 211 | } 212 | yl <- ylb <- if(length(ylab)) ylab else upFirst(evlab[icause]) 213 | yl <- if(what == 'S') paste(yl, '-Free Probability', sep='') 214 | else paste('Cumulative Incidence of', yl) 215 | 216 | cex.ylab <- par('cex.lab') * ifelse(nchar(yl) > 33, .8, 1) 217 | if(what == 'S') 218 | survplot(s, 219 | n.risk=TRUE, conf=conf, lwd=lwd, 220 | lty=1, col=col, ylab=yl, mylim=mylim, 221 | label.curves=list(keys='lines', key.opts=list(bty='n')), 222 | levels.only=TRUE, aehaz=aehaz, times=times, 223 | cex.ylab=cex.ylab, ...) 224 | else 225 | survplot(s, state=if(length(cause)) cau, 226 | fun=function(y) 1 - y, 227 | n.risk=TRUE, y.n.risk=y.n.risk, conf=conf, lwd=lwd, 228 | lty=1, col=col, ylab=yl, mylim=mylim, 229 | label.curves=list(keys='lines', key.opts=list(bty='n')), 230 | levels.only=TRUE, aehaz=aehaz, times=times, 231 | cex.ylab=cex.ylab, ...) 232 | 233 | capconf <- if(conf == 'diffbands') ', along with half-height of 0.95 confidence limits centered at estimate midpoints. $N$=' else 234 | ', along with 0.95 confidence bands. $N$=' 235 | 236 | if(multi) { 237 | if(markevent) stamp(ylb) 238 | endPlot() 239 | shortcap <- if(length(head)) head 240 | else if(cau == '') paste(kmlab, 'for', 241 | upFirst(evlab[icause], alllower=TRUE)) 242 | else paste('Cumulative incidence of', 243 | upFirst(cau, alllower=TRUE), 244 | if(length(states) > 2) 'with competing events' 245 | else 'with competing event', 246 | past(setdiff(states, cau))) 247 | if(length(labx)) 248 | shortcap <- paste(shortcap, 'stratified by', labx) 249 | cap <- paste(shortcap, capconf, no[1], '. ', tail, sep='') 250 | dNeedle(sampleFrac(no, Nobs), name='lttsurv', file=file) 251 | cap <- sprintf('%s~\\hfill\\lttsurv', cap) 252 | putFig(panel=panel, name=lbi, caption=shortcap, longcaption=cap) 253 | } 254 | if(! multi) for(j in 1:length(nobs)) nobs[j] <- max(nobs[j], no[j]) 255 | names(nobs) <- names(no) 256 | } 257 | } 258 | 259 | if(! multi) { 260 | endPlot() 261 | shortcap <- if(length(head)) head else 262 | if(! length(cause)) kmlab else 263 | 'Cumulative incidence estimates under competing risks' 264 | shortcap <- paste(shortcap, 'for', past(evlab)) 265 | if(length(labx)) 266 | shortcap <- paste(shortcap, 'stratified by', labx) 267 | cap <- paste(shortcap, capconf, nobs[1], '. ', tail, sep='') 268 | dNeedle(sampleFrac(nobs, Nobs), name='lttsurv', file=file) 269 | cap <- sprintf('%s~\\hfill\\lttsurv', cap) 270 | putFig(panel=panel, name=lb, caption=shortcap, longcaption=cap) 271 | } 272 | invisible() 273 | } 274 | -------------------------------------------------------------------------------- /R/todo/listTable.R: -------------------------------------------------------------------------------- 1 | #' List Table 2 | #' 3 | #' Convert a data.frame object into a LaTeX table. 4 | #' 5 | #' @param fileName character. A description of the file connection. 6 | #' @param longtable logical. Toggle \sQuote{longtable} or \sQuote{table} environment. Defaults to \sQuote{TRUE}. 7 | #' @param landscape logical. Use \sQuote{landscape} environment. Defaults to \sQuote{FALSE}. 8 | #' @param caption character. Main table caption. 9 | #' @param fontSize character. Define font size from one of the following: \sQuote{tiny}, 10 | #' \sQuote{scriptsize}, \sQuote{footnotesize}, \sQuote{small}, \sQuote{normalsize}, 11 | #' \sQuote{large}, \sQuote{Large}, \sQuote{LARGE}, \sQuote{huge}, \sQuote{Huge}. Default is \sQuote{small}. 12 | #' @param dataframe data.frame. Provides content for list table. 13 | #' @param zebraPattern character. Defaults to \sQuote{none}, other options are \sQuote{plain}, \sQuote{group} and \sQuote{plaingroup.} 14 | #' \sQuote{plaingroup} is only recommended for large groups (more than four objects in a group). 15 | #' @param by character. Column used to generate zebra pattern, defaulting to the first column in \sQuote{dataframe}. 16 | #' @param orderGroups logical. If \sQuote{TRUE} order the data by \sQuote{by}. This is recommened 17 | #' when \sQuote{zebraPattern} is set to \sQuote{group} or \sQuote{plaingroup}. 18 | #' @param colNames character vector. Define column name headers for \sQuote{dataframe}. 19 | #' @param vars character vector. Column names to select from \sQuote{dataframe}. 20 | #' @param fixedColVars character vector. Column variables. 21 | #' @param fixedColWdths character vector. Fixed width for each column. 22 | #' @param markVar character vector. Marker variable. 23 | #' @param markVarVal character vector. Value for each marker variable. 24 | #' @param toLatexChar logical. If \sQuote{TRUE} text will be checked and escaped should they contain special LaTeX characters. 25 | #' @param appendix logical. If \sQuote{TRUE} the function will require the \code{subsection} and \code{marker} 26 | #' arguments since it will have to reference the tables in the future. 27 | #' @param subsection character. Name of document subsection that refers to this table. 28 | #' @param marker character. Marker for document subsection that refers to this table. 29 | #' @param append logical. If \sQuote{TRUE} output will be appended instead of overwritten. 30 | #' @export 31 | #' @examples 32 | #' listTable(fileName='', caption="\\label{table:listtable}Table of groupings", zebraPattern='group', 33 | #' dataframe=data.frame(code=c('(a)', '(b)', '(c)'), def=c("apple, orange", "dog, cat, horse", "windows, linux, mac")), 34 | #' appendix=FALSE) # print generated table to standard out 35 | 36 | listTable <- function(fileName, 37 | longtable=TRUE, landscape=FALSE, 38 | caption = "", fontSize="small", 39 | dataframe, zebraPattern="none", by=names(dataframe)[1], orderGroups=FALSE, 40 | colNames = names(dataframe), 41 | vars =names(dataframe), fixedColVars=c(), fixedColWdths=c(), 42 | markVar="", markVarVal="", 43 | toLatexChar=TRUE, 44 | appendix=TRUE, subsection=NULL, marker=NULL, append=FALSE){ 45 | ### appendix: if TRUE the function will require the subsection and marker arguments 46 | ### since it will have to reference the tables in the future. 47 | ### append: if TRUE all the out put will be appended to a file specified in fileName 48 | 49 | #internal constants and functions definitions 50 | fontSizes <- c("tiny","scriptsize","footnotesize","small", 51 | "normalsize","large","Large","LARGE","huge","Huge") 52 | zebraPatterns <- c("none", "plain", "group", "plaingroup") 53 | #NOTE: pattern "plaingroup" is recommended only for large groups (more than 4 objects in a group) 54 | 55 | #!!! not to remove: adjusted pallet white&gray 56 | pallet1 <- list(lightwhite=c(0,0,0,0), darkwhite=c(0,0,0,0.07), 57 | lightgray =c(0,0,0,0.2), darkgray=c(0,0,0,0.27), 58 | middlegray=c(0,0,0,0.18), red=c(0,0.9,0.3,0)) 59 | #!!! not to remove: adjusted pallet: orange&blue1 60 | pallet2 <- list(lightwhite=c(0,0.05,0.15,0), darkwhite=c(0,0.1,0.3,0), 61 | lightgray=c(0.3,0.15,0.075,0), darkgray=c(.4,0.2,0.1,0), 62 | middlegray=c(0.3,0.15,0.075,0), red=c(0,0.7,1,0)) 63 | #!!! not to remove: adjusted pallet: orange&blue2 64 | pallet3 <- list(lightwhite=c(0,0.04,0.12,0), darkwhite=c(0,0.08,0.24,0), 65 | lightgray=c(0.22,0.11,0.055,0), darkgray=c(0.3,0.15,0.075,0), 66 | middlegray=c(0.22,0.11,0.055,0), red=c(0,0.7,1,0)) 67 | #!!! not to remove: adjusted pallet: purple&yellow 68 | pallet4 <- list(lightwhite=c(0.0025,0.05,0.2,0), darkwhite=c(0.05,0.1,0.4,0), 69 | lightgray=c(.235,0.235,0.1125,0), darkgray=c(.3,0.3,0.15,0), 70 | middlegray=c(.235,0.235,0.1125,0), red=c(0,0.9,0.3,0)) 71 | pallet <- pallet1 72 | 73 | latexTextMode <- function(str) { 74 | #internal constants and functions definitions 75 | latexTextModeSpec <- function(char){ 76 | if (char == "\\"){ 77 | retStr <- "$\\backslash$" 78 | }else{ 79 | if (char == "^" | char == "~"){ 80 | retStr <- paste("\\verb*+",char,"+",sep="") 81 | }else{ 82 | retStr <- paste("\\",char,sep="") 83 | } 84 | } 85 | retStr 86 | } 87 | latexTextModeMath <- function(char){ 88 | retStr <- paste("$",char,"$",sep="") 89 | retStr 90 | } 91 | charToLatexTextChar <- function(char){ 92 | if (is.na(latexCharText[char])){ 93 | char 94 | }else{ 95 | latexCharText[char] 96 | } 97 | } 98 | 99 | latexTextModeText <- function(char){ 100 | if (char %in% latexSpecialChar){ 101 | retStr <- latexTextModeSpec(char) 102 | }else{ 103 | if (char %in% latexMathChar){ 104 | retStr <- latexTextModeMath(char) 105 | }else{ 106 | retStr <- NULL 107 | } 108 | } 109 | retStr 110 | } 111 | 112 | latexSpecialChar <- c("#","$","%","^","_","{","}","~","&","\\") 113 | latexMathChar <- c("<", ">", "|") 114 | latexSpecAndMath <- c(latexSpecialChar,latexMathChar) 115 | latexCharText <- sapply(X = latexSpecAndMath, FUN=latexTextModeText) 116 | 117 | #beginning of the function latexTextMode 118 | spl <- unlist(strsplit(str,"")) 119 | paste(sapply(X = spl, FUN=charToLatexTextChar),collapse="") 120 | } 121 | 122 | processBeginCommand <- function(beginCom=c(), outFile, 123 | caption = "", fontSize="small", colNames = c(), 124 | dataframe, zebraPattern, 125 | fixedColVars=c(), fixedColWdths=c(), 126 | markVar="", markVarVal="") { 127 | #internal constants and functions definitions 128 | commandBegin <- function(command, outFile){ 129 | if (command %in% fontSizes){ 130 | cat("\n{\\",command,"\n",sep="", file=outFile) 131 | }else{ 132 | cat("\n\\begin{",command,"}",sep="", file=outFile) 133 | } 134 | } 135 | commandEnd <- function(command, outFile){ 136 | if (command %in% fontSizes){ 137 | cat("}\n", file=outFile) 138 | }else{ 139 | cat("\\end{",command,"}\n",sep="", file=outFile) 140 | } 141 | } 142 | latexCaption <- function(captionFill, longtable, outFile){ 143 | cap <- paste("\n\\caption{",captionFill,"}",sep="") 144 | if (longtable){ 145 | cat(cap,"\\\\\n", sep="", file=outFile) 146 | }else{ 147 | cat(cap,"\n", sep="", file=outFile) 148 | } 149 | } 150 | processColsFormat <- function(data, fixedColVars=c(), fixedColWdths=c(), outFile){ 151 | colFormat <- c() 152 | for (n in names(data)){ 153 | if (n %in% fixedColVars){ 154 | colFormat <- c(colFormat,paste("p{",fixedColWdths[fixedColVars==n],"pt}", sep="")) 155 | }else{ 156 | colFormat <- c(colFormat,"l") 157 | } 158 | } 159 | cat(" {",paste(colFormat, collapse=""),"}", sep="", file=outFile) 160 | } 161 | hline <- function(outFile, number=1){ 162 | cat(paste(rep("\\hline",number),collapse=""),"\n", file=outFile) 163 | } 164 | 165 | processColsHead <- function(colNames, longtable, caption="", outFile){ 166 | processColNames <- function(colNames, style, outFile){ 167 | hline(outFile,2) 168 | cat(style, colNames[1], file=outFile) 169 | for (i in 2:length(colNames)){ 170 | cat("&", style, colNames[i], file=outFile) 171 | } 172 | cat("\\\\\n", file=outFile) 173 | hline(outFile) 174 | } 175 | headStyle <- "\\bfseries" 176 | otherStyle <- "\\bfseries\\em" 177 | colNum <- length(colNames) 178 | processColNames(colNames, headStyle, outFile) 179 | hline(outFile) 180 | if (longtable){ 181 | cat("\\endfirsthead\n", file=outFile) 182 | cat("\\caption[]{",caption,"{",otherStyle," (continued)}} \\\\\n", file=outFile) 183 | processColNames(colNames, headStyle, outFile) 184 | cat("\\endhead\n", file=outFile) 185 | hline(outFile) 186 | cat("\\multicolumn{",colNum,"}{r}{",otherStyle," Continued on next page}\\\\\n", 187 | sep="", file=outFile) 188 | cat("\\endfoot\n", file=outFile) 189 | hline(outFile) 190 | cat("\\multicolumn{",colNum,"}{r}{",otherStyle," End}\\\\\n", 191 | sep="", file=outFile) 192 | cat("\\endlastfoot\n", file=outFile) 193 | } 194 | } 195 | 196 | processRows <- function(data, zebraPattern, outFile, markVar, markVarVal){ 197 | #internal constants and functions definitions 198 | if(FALSE) { 199 | processRow <- function(row, color, outFile, markVarIndex){ 200 | if (!is.na(color)){ 201 | cat("\\rowcolor{",color,"}\n",sep="", file=outFile) 202 | } 203 | cat(row[[1]], file=outFile) 204 | for (i in c(2:length(row))){ 205 | if (i==markVarIndex){ 206 | cat(" &", "\\color{red}{\\bfseries\\em ", row[[i]],"}", file=outFile) 207 | }else{ 208 | cat(" &", row[[i]], file=outFile) 209 | } 210 | } 211 | cat("\\\\\n", file=outFile) 212 | } 213 | } 214 | if(TRUE) { 215 | processRow <- function(row, color, outFile, markVarIndex){ 216 | rowStr <- "" 217 | if (!is.na(color)){ 218 | rowStr <- paste(rowStr,"\\rowcolor{",color,"}\n",sep="") 219 | } 220 | rowStr <- paste(rowStr,row[[1]],sep="") 221 | for (i in c(2:length(row))){ 222 | if (i==markVarIndex){ 223 | rowStr <- paste(rowStr," &", "\\color{red}{\\bfseries\\em ", row[[i]],"}",sep="") 224 | }else{ 225 | rowStr <- paste(rowStr," &", row[[i]],sep="") 226 | } 227 | } 228 | rowStr <- paste(rowStr,"\\\\\n", sep="") 229 | cat(rowStr, file=outFile) 230 | } 231 | } 232 | #beginning of the function processRows 233 | markVarIndex <- match(markVar, names(data)) 234 | if (markVar!="" & is.na(markVarIndex)) stop("Error: Variable to mark is not in dataframe names\n") 235 | if (length(data[[1]]) != 0){ 236 | for (i in c(1:length(data[[1]]))){ 237 | if (!is.na(markVarIndex)){ 238 | if (data[i,markVarIndex]==markVarVal){ 239 | processRow(data[i,], zebraPattern[i], outFile, markVarIndex) 240 | }else{ 241 | processRow(data[i,], zebraPattern[i], outFile, -1) 242 | } 243 | }else{ 244 | processRow(data[i,], zebraPattern[i], outFile, -1) 245 | } 246 | } 247 | } 248 | hline(outFile) 249 | } 250 | 251 | #beginning of the function processBeginCommand 252 | if (length(beginCom[!is.na(beginCom)])>0) { 253 | commandBegin(beginCom[1],outFile) 254 | if (beginCom[1] == "table"){ 255 | latexCaption(caption, beginCom[1] == "longtable",outFile) 256 | } 257 | if (beginCom[1] == "tabular"){ 258 | processColsFormat(data=dataframe, fixedColVars, fixedColWdths, outFile) 259 | processColsHead(colNames = colNames, beginCom[1] == "longtable", outFile=outFile) 260 | processRows(data=dataframe, zebraPattern=zebraPattern, outFile, 261 | markVar, markVarVal) 262 | } 263 | if (beginCom[1] == "longtable"){ 264 | processColsFormat(data=dataframe, fixedColVars, fixedColWdths, outFile) 265 | latexCaption(caption, beginCom[1] == "longtable",outFile) 266 | processColsHead(colNames = colNames, beginCom[1] == "longtable", caption, outFile) 267 | processRows(data=dataframe, zebraPattern=zebraPattern, outFile, 268 | markVar, markVarVal) 269 | } 270 | processBeginCommand(beginCom[2:(length(beginCom)+1)], outFile, 271 | caption, fontSize, colNames, 272 | dataframe, zebraPattern, 273 | fixedColVars, fixedColWdths, 274 | markVar, markVarVal) 275 | commandEnd(beginCom[1], outFile) 276 | } 277 | } 278 | 279 | makePattern <- function(zebraPattern, by){ 280 | #internal constants and functions definitions 281 | plain <- function(col1, col2, len){ 282 | pattern <- rep(c(col1,col2), len) 283 | pattern <- pattern[1:len] 284 | pattern 285 | } 286 | group <- function(by){ 287 | col <- 1 288 | pattern <- rep(col, length(by)) 289 | current <- by[1] 290 | for (i in 2:length(by)){ 291 | nextg <- by[i] 292 | if (current==nextg) { 293 | pattern[i] <- col 294 | }else{ 295 | col <- col*(-1) 296 | pattern[i] <- col 297 | } 298 | current <- nextg 299 | } 300 | pattern 301 | } 302 | 303 | #beginning of the function makePattern 304 | if (zebraPattern != "none") { 305 | if (!(zebraPattern %in% zebraPatterns)) stop("Error: Illigal Zebra Pattern\n") 306 | if (zebraPattern=="plain"){ 307 | pattern <- plain("lightwhite","middlegray",length(by)) 308 | } 309 | if (zebraPattern=="group"){ 310 | pattern <- group(by) 311 | pattern <- ifelse(pattern>0,"middlegray","lightwhite") 312 | } 313 | if (zebraPattern=="plaingroup"){ 314 | pattern <- group(by) 315 | light <- plain("darkwhite","lightwhite",length(by)) 316 | dark <- plain("lightgray","darkgray",length(by)) 317 | pattern <- ifelse(pattern>0,dark,light) 318 | } 319 | pattern 320 | } else { 321 | rep(NA, length(by)) 322 | } 323 | } 324 | 325 | defineColors <- function(outFile){ 326 | for (n in names(pallet)){ 327 | cat("\\definecolor{",n,"}{cmyk}{",pallet[[n]][1],",", 328 | pallet[[n]][2],",", 329 | pallet[[n]][3],",", 330 | pallet[[n]][4],"}\n",sep="",file=outFile) 331 | } 332 | } 333 | 334 | #beginning of the function listTable 335 | if (appendix && is.null(marker)) { 336 | stop("Argument 'marker' has to be provided\n") 337 | } 338 | 339 | if(append) { 340 | openMode <- "at" 341 | } else { 342 | openMode <- "wt" 343 | } 344 | # allow file to be standard out 345 | if(fileName == "") { 346 | outFile <- "" 347 | } else { 348 | outFile <- file(fileName, open=openMode) 349 | on.exit(close(outFile)) 350 | } 351 | if(appendix) { 352 | if (!is.null(subsection)){ 353 | cat(paste("\\subsection{", subsection, "}\n", sep="") , file=outFile) 354 | } 355 | cat(paste("\\label{", marker, "}\n", sep=""), file=outFile) 356 | } 357 | 358 | dataframe <- dataframe[,vars] 359 | if (orderGroups){ 360 | dataframe <- dataframe[order(dataframe[[by]]),] 361 | } 362 | if (zebraPattern %in% c("group","plaingroup")){ 363 | ordered <- dataframe[[by]][order(dataframe[[by]])] 364 | if (!all(dataframe[[by]]==ordered) && !all(dataframe[[by]]==ordered[length(ordered):1])){ 365 | cat("\nWARNING: It is recommended to order the data by", by, "\n", 366 | " when argument 'zebraPattern' is set to 'group' or 'plaingroup'.\n", 367 | " It can be done by setting argument 'orderGroups' to TRUE.\n") 368 | } 369 | } 370 | for (n in names(dataframe)){ 371 | dataframe[[n]] <- as.character(as.character(dataframe[[n]])) 372 | if (toLatexChar) 373 | dataframe[[n]] <- sapply(X = dataframe[[n]], FUN=latexTextMode) 374 | } 375 | pattern <- makePattern(zebraPattern, dataframe[[by]]) 376 | beginCommands <- c() 377 | if (landscape) beginCommands <- c(beginCommands,"landscape") 378 | beginCommands <- c(beginCommands, fontSize) 379 | if (!landscape) beginCommands <- c(beginCommands,"center") 380 | if (longtable) beginCommands <- c(beginCommands,"longtable") 381 | else beginCommands <- c(beginCommands,c("table","tabular")) 382 | defineColors(outFile) 383 | processBeginCommand(beginCommands, outFile, 384 | caption, fontSize, colNames, 385 | dataframe, pattern, 386 | fixedColVars, fixedColWdths, 387 | markVar, markVarVal) 388 | if (appendix){ 389 | cat("\\clearpage\n", file=outFile) 390 | } 391 | } 392 | -------------------------------------------------------------------------------- /inst/tests/test.Rnw: -------------------------------------------------------------------------------- 1 | % Usage: Copy test.Rnw to a temporary directory and make directories 2 | % gentex and pdf under it, then run knitr on test.Rnw 3 | % Best to use the spaper and knitrl LaTeX packages, which will also do away with 4 | % the need for some of the preamble below 5 | 6 | \documentclass{article} 7 | \usepackage{knitrl} 8 | \usepackage{fancyhdr} 9 | \usepackage{changepage} % for exReport \begin{adjustwidth} 10 | 11 | \def\titl{DSMB Report for EXAMPLE Trial} 12 | 13 | \definecolor{darkblue}{RGB}{0,0,139} 14 | \def\linkcol{darkblue} 15 | 16 | \usepackage[pdftex,hidelinks,bookmarks,pagebackref,pdfpagemode=UseOutlines, 17 | colorlinks,linkcolor=\linkcol, 18 | pdfauthor={Frank E Harrell Jr}, 19 | pdftitle={\titl}]{hyperref} 20 | % Remove colorlinks and linkcolor options to hyperref to box the 21 | % hyperlinked items (for screen only) 22 | 23 | \def\poptype{1} 24 | % 0=no popup tooltips 1=ocgtools 2=movable popups 3=in-line tiny tables 25 | % with no popups 26 | \usepackage{greport} % must appear after \usepackage{hyperref} 27 | 28 | \graphicspath{{pdf/}} 29 | \title{\titl} 30 | \date{\today} 31 | \pagestyle{fancy} 32 | \renewcommand{\subsectionmark}[1]{} % suppress subsection titles in headers 33 | 34 | \begin{document} 35 | \maketitle 36 | \tableofcontents 37 | \listoffigures 38 | \listoftables 39 | \rhead{\scriptsize The {\em EXAMPLE} Study \\ 40 | Protocol xyz--001 \\ 41 | \today} 42 | 43 | <>= 44 | echo <- TRUE # show code 45 | # echo <- FALSE # hide code 46 | require(greport) 47 | knitrSet(echo=echo, results='hide') 48 | @ 49 | 50 | <<>>= 51 | ## Generate test data 52 | set.seed(1) 53 | n <- 500 54 | d <- data.frame(country=sample(c('US', 'Canada', 'Spain', 'France', 55 | 'Germany'), n, TRUE), 56 | site=sample(1:10, n, TRUE)) 57 | d$site <- paste(substring(d$country, 1, 2), d$site, sep='') 58 | d$region <- factor(ifelse(d$country %in% c('US', 'Canada'), 59 | 'North America', 'Europe')) 60 | 61 | d <- upData(d, edate = as.Date('2005-01-01') + 62 | round(rgamma(n, 2, .01)) - 600 * (country == 'US'), 63 | rdate = edate + round(runif(n, 1, 30)), print=FALSE) 64 | d$rdate[runif(nrow(d)) < 0.5] <- NA # non-randomized subjects ) 65 | 66 | # with(d, table(region, country)) 67 | 68 | # For US manually compute # randomized per month 69 | us <- subset(d, country == 'US') 70 | site <- us$site 71 | ed <- us$edate 72 | rd <- us$rdate 73 | months <- difftime(as.Date('2007-12-31'), ed, units='days') / 74 | (365.25 / 12) 75 | m <- max(months) 76 | a <- sum(!is.na(rd)) / as.numeric(m) # .8545774 (agrees with chart) 77 | # Compute maximum months elapsed for each site then sum over sites 78 | maxpersite <- tapply(months, site, max) 79 | b <- sum(!is.na(rd)) / sum(maxpersite) 80 | ## 0.0864429 = 47 / 543.6715 chart: .08645 (rounded) 81 | 82 | ## Suppose there are more subjects enrolled and randomized than really 83 | ## made their way into the dataset 84 | denom <- c(enrolled=nrow(d) * 1.1, 85 | randomized=sum(!is.na(d$rdate)) + 10) 86 | 87 | setgreportOption(gtype=c('pdf', 'interactive')[1], # [2] to debug 88 | tx.var='treat', denom=denom, texwhere='') 89 | 90 | ## Initialize app.tex 91 | file <- sprintf('%s/app.tex', getgreportOption('texdir')) 92 | cat('', file=file) 93 | @ 94 | 95 | \section{Notation} 96 | \ifnum\poptype > 0 97 | \paragraph{Pop-up Tooltips} 98 | Certain elements of the report, signaled by 99 | \textcolor[gray]{0.5}{$\mapsto$}, have pop-up tooltips behind them. 100 | More information will pop up when viewing the report under Acrobat 101 | Reader when the mouse hovers over \textcolor[gray]{0.5}{$\mapsto$}. 102 | \ifnum\poptype=1 103 | Clicking on the information in the pop-up will make it ``stick'', and 104 | clicking on the \textcolor{red}{X} will make it disappear. For 105 | graphics that have pop-up tables you can also click anywhere inside 106 | the graph. When the pop-up is a wide table, it will use full-page 107 | mode. If the table is tall you may need to scroll vertically. To do 108 | that, click on the table when it pops up to make it stick, then 109 | scroll, then click again to make it disappear. 110 | \fi 111 | \ifnum\poptype=2 112 | Clicking on the pop-up and releasing will allow you to move the pop-up 113 | with a mouse gesture (do not hold the mouse button down). Click on 114 | the pop-up to make it stick in a certain location. Hover over 115 | \textcolor[gray]{0.5}{$\mapsto$} to make the pop-up disappear, or 116 | click on the pop-up again to unstick it. 117 | \fi 118 | \fi 119 | 120 | \paragraph{Hyperlinks to Tables} 121 | Some graphics and tables are hyperlinked to tables 122 | in the Appendix. For these, clicking anywhere in the graphic or table 123 | will move the pdf reader to the supporting table. Clicking on the 124 | appendix table will bring you back to the original figure. 125 | 126 | \paragraph{Figure Captions} 127 | Needles represent the fraction of observations used in the current 128 | analysis. The first needle (red) shows the fraction of enrolled 129 | patients used. If randomization was taken into account, a second 130 | needle (green) represents the fraction of randomized subjects included 131 | in the analysis. When the analyses consider treatment assignment, two 132 | more needles may be added to the display, showing, respectively, the 133 | fraction of subjects randomized to treatment A used in the analysis 134 | and the fraction of subjects on treatment B who were analyzed. The 135 | colors of these last two needles are the colors used for the two 136 | treatments throughout the report. The following table shows some 137 | examples. 138 | <>= 139 | # dNeedle uses colors in setgreportOption(tx.col=, er.col=) 140 | dNeedle(1, 'lttdemoa') 141 | dNeedle(c(3,4)/4 , 'lttdemob') 142 | dNeedle(c(1,2)/4, 'lttdemoc') 143 | dNeedle(c(1,2,3,1)/4,'lttdemod') 144 | @ 145 | \begin{center} 146 | \begin{tabular}{ll} 147 | \textbf{Needles} & \textbf{Interpretation} \\ \hline 148 | \lttdemoa & All enrolled subjects analyzed, randomization not considered\\ 149 | \lttdemob & Analysis uses $\frac{3}{4}$ of enrolled subjects, 150 | and all randomized subjects\\ 151 | \lttdemoc & Analysis uses $\frac{1}{4}$ of enrolled subjects, 152 | and $\frac{1}{2}$ of randomized subjects\\ 153 | \lttdemod & Same as previous example, and in addition the analysis\\ 154 | & utilized treatment assignment, analyzing $\frac{3}{4}$ of 155 | those\\ 156 | & randomized to A and $\frac{1}{4}$ of those randomized to B\\ 157 | \hline 158 | \end{tabular} 159 | \end{center} 160 | \paragraph{Extended Box Plots} 161 | \newcommand{\eboxpopup}[1]{\tooltipm{#1}{\includegraphics{bpplt-proto-1}}} 162 | % To not generate pop-up use: \newcommand{\eboxpopup}[1]{} 163 | 164 | For depicting distributions of continuous variables, many of the 165 | following displays use extended box plots, also called 166 | box--percentile plots. A prototype, with explanations, is below. 167 | <>= 168 | bpplt() 169 | @ 170 | 171 | \paragraph{Dot Charts} 172 | Dot charts are used to present stratified proportions. In these 173 | charts the area of the symbols is proportional to the square root of 174 | the denominator. The legend shows representative denominators and 175 | their corresponding symbol areas, using denominators that actually 176 | occurred in the data and extended from the minimum observed to the 177 | maximum observed sample size. 178 | 179 | 180 | \paragraph{Survival Curves} 181 | Graphs containing pairs of Kaplan-Meier survival curves show a shaded 182 | region centered at the midpoint of the two survival estimates and 183 | having a height equal to the half-width of the approximate 0.95 pointwise 184 | confidence interval for the difference of the two survival 185 | probabilities. Time points at which the two survival estimates do not 186 | touch the shaded region denote approximately significantly different 187 | survival estimates, without any multiplicity correction. 188 | \clearpage 189 | 190 | \section{Accrual} 191 | 192 | <>= 193 | accrualReport(enroll(edate) + randomize(rdate) ~ 194 | region(region) + country(country) + site(site), 195 | data=d, hdot=3, 196 | dateRange=c('2005-01-01', '2007-12-31'), 197 | targetN= 198 | data.frame(edate=c(500, 1000), rdate=c(250, 500)), 199 | targetDate=c('2006-01-01', '2007-12-31'), 200 | zoom=c('2005-01-01', '2005-06-30'), 201 | closeDate='2007-12-31') 202 | @ 203 | \clearpage 204 | 205 | \section{Patient Flow and Exclusions} 206 | <>= 207 | d <- upData(d, 208 | subjid = 1 : n, 209 | pend = rbinom(n, 1, .1), 210 | e1 = rbinom(n, 1, .02), 211 | e2 = rbinom(n, 1, .02), 212 | e3 = rbinom(n, 1, .02), 213 | e4 = ifelse(runif(n) < 0.25, NA, rbinom(n, 1, .10)), 214 | tested = rbinom(n, 1, .75), 215 | e5 = ifelse(tested, rbinom(n, 1, .04), NA), 216 | e6 = rbinom(n, 1, .02), 217 | e7 = rbinom(n, 1, .02), 218 | rndz = rbinom(n, 1, .75), 219 | labels=c(e1='Prior MI', e2='History of Asthma', 220 | e3='History of Upper GI Bleeding', 221 | e4='No Significant CAD', e5='Inadequate Renal Function', 222 | e6='Pneumonia within 6 weeks', e7='Prior cardiac surgery'), 223 | print=FALSE) 224 | 225 | erd <- data.frame(subjid = 1 : 50, 226 | loc = sample(c('gastric', 'lung', 'trachea'), 50, TRUE)) 227 | 228 | # To check warning messages, greportOption denom does not match pend, e1-e7 229 | exReport(~ pending(pend) + e1 + e2 + e3 + e4 + e5 + e6 + e7 + 230 | randomized(rndz) + id(subjid) + cond(e5, 'Tested', tested), 231 | erdata = erd, 232 | whenapp= c(e4='CCTA done'), data=d, hc=3.75, h=4) 233 | 234 | # Show exclusions in original variable order 235 | exReport(~ pending(pend) + e1 + e2 + e3 + e4 + e5 + e6 + e7 + 236 | randomized(rndz) + id(subjid) + cond(e5, 'Tested', tested), 237 | erdata=erd, 238 | whenapp=c(e4='CCTA done'), data=d, hc=3.75, h=4, 239 | sort=FALSE, append=TRUE, subpanel='unsorted', app=FALSE) 240 | @ 241 | \clearpage 242 | 243 | \section{Baseline Variables} 244 | <>= 245 | n <- 100 246 | f <- function(na=FALSE) { 247 | x <- sample(c('N', 'Y'), n, TRUE) 248 | if(na) x[runif(100) < .1] <- NA 249 | x 250 | } 251 | set.seed(1) 252 | d <- data.frame(x1=f(), x2=f(), x3=f(), x4=f(), x5=f(), x6=f(), 253 | x7=f(TRUE), 254 | age=rnorm(n, 50, 10), 255 | sbp=rnorm(n, 120, 7), 256 | dbp=rnorm(n, 80, 6), 257 | days=sample(1:n, n, TRUE), 258 | race=sample(c('Asian', 'Black/AA', 'White'), n, TRUE), 259 | sex=sample(c('Female', 'Male'), n, TRUE), 260 | treat=sample(c('A', 'B'), n, TRUE), 261 | region=sample(c('North America','Europe'), n, TRUE), 262 | meda=sample(0:1, n, TRUE), medb=sample(0:1, n, TRUE), 263 | subjid=1:n) 264 | d$days[1] <- NA 265 | d <- upData(d, labels=c(x1='MI', x2='Stroke', x3='AKI', x4='Migraines', 266 | x5='Pregnant', x6='Other event', x7='MD withdrawal', 267 | race='Race', sex='Sex', treat='treatment', 268 | sbp='Systolic BP', days='Time Since Randomization', 269 | meda='Medication A', medb='Medication B'), 270 | units=c(sbp='mmHg', dbp='mmHg', age='years', days='days'), 271 | print=FALSE) 272 | dasna <- subset(d, region=='North America') 273 | # with(dasna, table(race, treat)) 274 | den <- c(enrolled=n + 50, randomized=n, table(d$treat)) 275 | setgreportOption(denom=den, tx.var='treat') 276 | 277 | dReport(race + sex + 278 | ynbind(x1, x2, x3, x4, x5, x6, x7, label='Exclusions') ~ 1, 279 | head='Overall frequencies of categorical demographic variables and exclusions', 280 | data=d, w=4, h=4.5) 281 | 282 | dReport(race + sex ~ region, data=addMarginal(d, region), 283 | groups='region', append=TRUE, 284 | w=4.75, h=3.75, subpanel='demoreg', 285 | head='Demographics') 286 | 287 | ## Add a new block of variables that apply only to males 288 | dReport(race + sex + 289 | pBlock(race, subset=sex=='Male', label='Race: Males') ~ region, 290 | data=d, groups='region', append=TRUE, 291 | w=4.75, h=4, subpanel='demoblock', 292 | head='Demographics with race for males') 293 | 294 | excl <- with(d, ynbind(x1, x2, x3, x4, x5, x6, x7, 295 | label='Exclusions')) 296 | dReport(excl ~ 1, head='Exclusions', append=TRUE, 297 | w=4, h=2.5, subpanel='excl') 298 | 299 | dReport(race + sex + excl ~ treat + region, groups='treat', 300 | head='Categorical demographic variables and exclusions', 301 | data=d, append=TRUE, w=7, h=4.5, subpanel='txreg') 302 | 303 | cat('\\clearpage\n') 304 | 305 | # Show the same information plus numerators and denominators by using 306 | # lattice format 307 | 308 | dReport(race + sex + excl ~ treat + region, groups='treat', 309 | head='Categorical demographic variables and exclusions', 310 | data=d, append=TRUE, w=7, h=4.5, subpanel='txregl', lattice=TRUE) 311 | 312 | ## Show spike histogram for raw data, 50 bins 313 | dReport(age + sbp + dbp ~ region, 314 | data=d, append=TRUE, w=6, h=2, 315 | sopts=list(datadensity=TRUE, 316 | scat1d.opts=list(nhistSpike=1, 317 | col=adjustcolor('red', alpha.f=.5), 318 | nint=50)), 319 | head='Baseline continuous variables') 320 | 321 | dReport(age + sbp + dbp ~ treat + region, w=6, h=3.5, 322 | data=d, append=TRUE, subpanel='txreg', 323 | sopts=list(cex.strip=.65)) 324 | 325 | # Same but show regions combined 326 | dReport(age + sbp + dbp ~ treat + region, w=6, h=4.75, 327 | data=addMarginal(d, region), 328 | append=TRUE, subpanel='txregm') 329 | 330 | # Show raw data and smoothed relationship between age and sbp, 331 | # stratified. 332 | # Label curves in an empty region, for the first panel only 333 | pan <- function(...) 334 | panel.plsmo(..., type='b', label.curves=max(which.packet()) == 1, 335 | datadensity=TRUE) 336 | dReport(sbp ~ age + treat + region, groups='treat', data=d, what='xy', 337 | popts=list(panel=pan, paneldoesgroups=TRUE, 338 | scat1d.opts=list(lwd=.7), key=NULL), 339 | append=TRUE, subpanel='xyplot', h=3, w=6) 340 | 341 | 342 | 343 | f <- function(x) { 344 | x <- x[! is.na(x)] 345 | c(smean.cl.normal(x, na.rm=FALSE), n=length(x)) 346 | } 347 | 348 | #dReport(sbp ~ treat + region, data=d, groups='treat', 349 | # fun = f, head='Mean and confidence limits', 350 | # popts = list(textplot='Mean', digits=1, 351 | # key=list(space='right')), 352 | # append=TRUE, subpanel='statstest', h=3, w=5) 353 | dReport(sbp ~ treat + region, data=d, 354 | fun = f, head='Mean and confidence limits', 355 | popts = list(textplot='Mean', digits=1), 356 | append=TRUE, subpanel='stats', h=3, w=5) 357 | @ 358 | \clearpage 359 | \section{Medication Usage Over Time} 360 | <>= 361 | pan <- function(...) 362 | panel.plsmo(..., type='l', label.curves=max(which.packet()) == 1, 363 | method='intervals', mobs=10) # normally mobs >= 96 364 | 365 | # Generalizes xyplot(meda ~ days | region, groups=treat, 366 | # panel=pan, data=d) 367 | dReport(meda + medb ~ days + treat + region, what='xy', 368 | groups='treat', data=d, h=3.75, 369 | popts=list(panel=pan, paneldoesgroups=TRUE, 370 | ylab='Proportion Using', xlim=c(0, 130), 371 | scat1d.opts=list(lwd=.7)), 372 | head='Medication usage', 373 | # tail='Tick marks indicate observed measurement times.', 374 | tail='Tick marks indicate mean measurement times within intervals.', 375 | panel='meds') 376 | 377 | # Show number being followed as days since randomization gets larger 378 | # make sure nriskReport doesn't get fooled by duplicate data 379 | d2 <- rbind(d, d) 380 | nriskReport(days ~ region + id(subjid), 381 | data=addMarginal(d2, region), 382 | head='Number of subjects followed for medication usage', 383 | panel='meds', append=TRUE, h=3, w=4.5) 384 | 385 | # Separate analysis not stratified by region, which will also provide 386 | # more detailed graphs. Make up some new visits to have more than 1/subj. 387 | # Make up a new definition of time zero 388 | d2$days[(n + 1) : (2 * n)] <- sample(1 : n, n, TRUE) 389 | nriskReport(days ~ id(subjid), data=d2, time0='PCI', 390 | panel='medsb', append=TRUE, 391 | h=3, w=4.5) 392 | @ 393 | \clearpage 394 | 395 | \section{Time to Hospitalization and Surgery} 396 | <>= 397 | set.seed(1) 398 | n <- 400 399 | dat <- data.frame(t1=runif(n, 2, 5), t2=runif(n, 2, 5), 400 | e1=rbinom(n, 1, .5), e2=rbinom(n, 1, .5), 401 | cr1=factor(sample(c('cancer','heart','censor'), n, TRUE), 402 | c('censor', 'cancer', 'heart')), 403 | cr2=factor(sample(c('gastric','diabetic','trauma', 'censor'), 404 | n, TRUE), 405 | c('censor', 'diabetic', 'gastric', 'trauma')), 406 | treat=sample(c('a','b'), n, TRUE)) 407 | dat <- upData(dat, 408 | labels=c(t1='Time to operation', 409 | t2='Time to rehospitalization', 410 | e1='Operation', e2='Hospitalization', 411 | treat='Treatment'), 412 | units=c(t1='Year', t2='Year'), print=FALSE) 413 | denom <- c(enrolled=n + 40, randomized=400, a=sum(dat$treat=='a'), 414 | b=sum(dat$treat=='b')) 415 | setgreportOption(denom=denom, tx.var='treat') 416 | survReport(Surv(t1, e1) + Surv(t2, e2) ~ treat, data=dat, 417 | mfrow=c(2,1), w=4.75, h=6, ps=8, what='S') 418 | # Show estimates combining treatments 419 | survReport(Surv(t1, e1) + Surv(t2, e2) ~ 1, data=dat, subpanel='nostrat', 420 | mfrow=c(2,1), w=4.75, h=6, ps=8, what='S', times=3, ylim=c(.1, 1)) 421 | 422 | # Same but use multiple figures and use 1 - S(t) scale 423 | survReport(Surv(t1, e1) + Surv(t2, e2) ~ treat, data=dat, 424 | multi=TRUE, subpanel='multi', append=TRUE, ps=9, what='1-S', 425 | times=3:4, aehaz=FALSE, y.n.risk=-.02) 426 | 427 | survReport(Surv(t1, e1) + Surv(t2, e2) ~ 1, data=dat, 428 | multi=TRUE, subpanel='multinostrat', append=TRUE, ps=9, what='1-S', 429 | y.n.risk=-.02) 430 | 431 | # Competing risk analysis 432 | if(FALSE) survReport(Surv(t1, cr1) + Surv(t2, cr2) ~ treat, data=dat, 433 | cause=list(c('cancer', 'heart'), 'diabetic'), 434 | subpanel='cr', append=TRUE, w=4.75, h=6, ps=8, multi=TRUE) 435 | @ 436 | \clearpage 437 | \section{Adverse Events} 438 | For this example, the denominators for the two treatments in the 439 | pop-up needles will be incorrect because the dataset did not have 440 | subject IDs. 441 | <>= 442 | # Original source of aeanonym: HH package 443 | # aeanonym <- read.table(hh("datasets/aedotplot.dat"), header=TRUE, sep=",") 444 | # Modified to remove denominators from data and to generate raw data 445 | # (one record per event per subject) 446 | 447 | ae <- 448 | structure(list(RAND = structure(c(1L, 2L, 1L, 2L, 1L, 2L, 1L, 449 | 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 450 | 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 451 | 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 452 | 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L), .Label = c("a", 453 | "b"), class = "factor"), PREF = structure(c(12L, 12L, 454 | 18L, 18L, 26L, 26L, 33L, 33L, 5L, 5L, 27L, 27L, 6L, 6L, 15L, 455 | 15L, 22L, 22L, 23L, 23L, 31L, 31L, 17L, 17L, 2L, 2L, 3L, 3L, 456 | 13L, 13L, 25L, 25L, 28L, 28L, 14L, 14L, 4L, 4L, 8L, 8L, 19L, 457 | 19L, 21L, 21L, 29L, 29L, 10L, 10L, 20L, 20L, 16L, 16L, 32L, 32L, 458 | 11L, 11L, 1L, 1L, 30L, 30L, 24L, 24L, 9L, 9L, 7L, 7L), 459 | .Label = tolower(c("ABDOMINAL PAIN", 460 | "ANOREXIA", "ARTHRALGIA", "BACK PAIN", "BRONCHITIS", "CHEST PAIN", 461 | "CHRONIC OBSTRUCTIVE AIRWAY", "COUGHING", "DIARRHEA", "DIZZINESS", 462 | "DYSPEPSIA", "DYSPNEA", "FATIGUE", "FLATULENCE", "GASTROESOPHAGEAL REFLUX", 463 | "HEADACHE", "HEMATURIA", "HYPERKALEMIA", "INFECTION VIRAL", "INJURY", 464 | "INSOMNIA", "MELENA", "MYALGIA", "NAUSEA", "PAIN", "RASH", "RESPIRATORY DISORDER", 465 | "RHINITIS", "SINUSITIS", "UPPER RESP TRACT INFECTION", "URINARY TRACT INFECTION", 466 | "VOMITING", "WEIGHT DECREASE")), class = "factor"), SAE = c(15L, 467 | 9L, 4L, 9L, 4L, 9L, 2L, 9L, 8L, 11L, 4L, 11L, 9L, 12L, 5L, 12L, 468 | 7L, 12L, 6L, 12L, 6L, 12L, 2L, 14L, 2L, 15L, 1L, 15L, 4L, 16L, 469 | 4L, 17L, 11L, 17L, 6L, 20L, 10L, 23L, 13L, 26L, 12L, 26L, 4L, 470 | 26L, 13L, 28L, 9L, 29L, 12L, 30L, 14L, 36L, 6L, 37L, 8L, 42L, 471 | 20L, 61L, 33L, 68L, 10L, 82L, 23L, 90L, 76L, 95L)), .Names = c("RAND", 472 | "PREF", "SAE"), class = "data.frame", row.names = c(NA, 473 | -66L)) 474 | 475 | subs <- rep(1 : nrow(ae), ae$SAE) 476 | ae <- ae[subs, c('RAND', 'PREF')] 477 | names(ae) <- c('treat', 'event') 478 | label(ae$treat) <- 'Treatment' 479 | 480 | eReport(event ~ treat, data=ae, minincidence=.05, panel='aevents') 481 | @ 482 | \clearpage % needed to get last tooltips to work 483 | 484 | \section{Appendix: Supporting Tables} 485 | \input{gentex/app} 486 | \end{document} 487 | -------------------------------------------------------------------------------- /R/accrualReport.r: -------------------------------------------------------------------------------- 1 | #' Accrual Report 2 | #' 3 | #' Generate graphics and LaTeX to analyze subject accrual 4 | #' 5 | #' Typically the left-hand-side variables of the formula, in order, are date of enrollment and date of randomization, with subjects enrolled but not randomized having missing date of randomization. Given such date variables, this function generates cumulative frequencies optionally with target enrollment/randomization numbers and with time-zooming. Makes a variety of dot charts by right-hand-side variables: number of subjects, number of sites, number of subjects per site, fraction of enrolled subjects randomized, number per month, number per site-month. 6 | #' 7 | #' @param formula formula object, with time variables on the left (separated by +) and grouping variables on the right. Enrollment date, randomization date, region, country, and site when present must have the variables in parenthesis preceeded by the key words \code{enrollment, randomize, region, country, site}. 8 | #' @param data data frame. 9 | #' @param subset a subsetting epression for the entire analysis. 10 | #' @param na.action a NA handling function for data frames, default is \code{na.retain}. 11 | #' @param dateRange \code{Date} or character 2-vector formatted as \code{yyyy-mm-dd}. Provides the range on the \code{x}-axis (before any zooming). 12 | #' @param zoom \code{Date} or character 2-vector for an option zoomed-in look at accrual. 13 | #' @param targetN integer vector with target sample sizes over time, same length as \code{targetDate} 14 | #' @param targetDate \code{Date} or character vector corresponding to \code{targetN} 15 | #' @param closeDate \code{Date} or characterstring. Used for randomizations per month and per site-month - contains the dataset closing date to be able to compute the number of dates that a group (country, site, etc.) has been online since randomizating its first subject. 16 | #' @param enrollmax numeric specifying the upper y-axis limit for cumulative enrollment when not zoomed 17 | #' @param studynos logical. Set to \code{FALSE} to suppress summary study numbers table. 18 | #' @param minrand integer. Minimum number of randomized subjects a country must have before a box plot of time to randomization is included. 19 | #' @param panel character string. Name of panel, which goes into file base names and figure labels for cross-referencing. 20 | #' @param h numeric. Height of ordinary plots, in inches. 21 | #' @param w numeric. Width of ordinary plots. 22 | #' @param hb numeric. Height of extended box plots. 23 | #' @param wb numeric. Weight of extended box plots. 24 | #' @param hdot numeric. Height of dot charts in inches. 25 | #' @export 26 | #' @examples 27 | #' \dontrun{ 28 | #' # See test.Rnw in tests directory 29 | #' } 30 | 31 | accrualReport <- 32 | function(formula, data=NULL, subset=NULL, na.action=na.retain, 33 | dateRange=NULL, zoom=NULL, targetN=NULL, targetDate=NULL, 34 | closeDate=NULL, enrollmax=NULL, studynos=TRUE, 35 | minrand=10, panel = 'accrual', 36 | h=2.5, w=3.75, hb=5, wb=5, hdot=3.5) 37 | { 38 | formula <- Formula(formula) 39 | 40 | if(grepl('[^a-zA-Z-]', panel)) 41 | stop('panel must contain only A-Z a-z -') 42 | 43 | environment(formula) <- new.env(parent = environment(formula)) 44 | en <- environment(formula) 45 | f <- function(x) x 46 | assign(envir = en, "enroll", f) 47 | assign(envir = en, "randomize", f) 48 | assign(envir = en, "region", f) 49 | assign(envir = en, "country", f) 50 | assign(envir = en, "site", f) 51 | 52 | file <- sprintf('%s/%s.tex', getgreportOption('texdir'), panel) 53 | if(getgreportOption('texwhere') == '') file <- '' 54 | else cat('', file=file) 55 | 56 | ltt <- function(used, name='ltt') 57 | dNeedle(sampleFrac(used), 58 | name=name, file=file, append=TRUE) 59 | 60 | lhs <- terms(formula, lhs=1, specials=c('enroll', 'randomize')) 61 | sl <- attr(lhs, 'specials') 62 | rhs <- terms(formula, rhs=1, specials=c('region', 'country', 'site')) 63 | sr <- attr(rhs, 'specials') 64 | 65 | Y <- if(length(subset)) 66 | model.frame(formula, data=data, subset=subset, na.action=na.keep) 67 | else model.frame(formula, data=data, na.action=na.keep) 68 | X <- model.part(formula, data=Y, rhs=1) 69 | Y <- model.part(formula, data=Y, lhs=1) 70 | nY <- NCOL(Y) 71 | nX <- NCOL(X) 72 | namY <- all.vars(lhs) 73 | namX <- all.vars(rhs) 74 | enroll <- sl$enroll 75 | randomize <- sl$randomize 76 | 77 | z <- function(x, nY) if(length(x)) x - nY else NULL 78 | ## specials counts from lhs variables 79 | region <- z(sr$region, nY) 80 | country <- z(sr$country, nY) 81 | site <- z(sr$site, nY) 82 | 83 | penroll <- length(enroll) > 0 84 | prandomize <- length(randomize) > 0 85 | pregion <- length(region) > 0 86 | pcountry <- length(country) > 0 87 | psite <- length(site) > 0 88 | pclose <- length(closeDate) > 0 89 | 90 | cr <- pcountry || pregion 91 | 92 | dr <- dateRange 93 | if(!length(dr)) 94 | dr <- range(pretty(do.call('range', c(as.list(Y), na.rm=TRUE)))) 95 | else dr <- as.Date(dr) 96 | if(length(targetN) && ! length(targetDate)) 97 | stop('must provide targetDate if using targetN') 98 | if(length(targetDate)) targetDate <- as.Date(targetDate) 99 | if(pclose) closeDate <- as.Date(closeDate) 100 | 101 | ylabs <- namY 102 | for(i in 1 : nY) { 103 | if(penroll && enroll == i) ylabs[i] <- 'enrolled' 104 | if(prandomize && randomize == i) ylabs[i] <- 'randomized' 105 | } 106 | xlabs <- namX 107 | for(i in 1 : nX) { 108 | if(pregion && region == i) xlabs[i] <- 'region' 109 | if(pcountry && country == i) xlabs[i] <- 'country' 110 | if(psite && site == i) xlabs[i] <- 'site' 111 | } 112 | 113 | z <- k <- character(0) 114 | g <- function(x, digits) as.character(round(x, digits)) 115 | if(pcountry) { 116 | z <- g(length(unique(X[[country]])), 0) 117 | k <- 'Countries' 118 | } 119 | if(psite) { 120 | Site <- as.character(X[[site]]) 121 | nsites <- length(unique(Site)) 122 | z <- c(z, g(nsites, 0)) 123 | k <- c(k, 'Sites') 124 | } 125 | if(penroll) { 126 | z <- c(z, sum(! is.na(Y[[enroll]]))) 127 | k <- c(k, 'Subjects enrolled') 128 | } 129 | 130 | if(psite && prandomize) { 131 | rdate <- Y[[randomize]] 132 | nrand <- sum(! is.na(rdate)) 133 | persite <- nrand / nsites 134 | nsitesr <- length(unique(Site[! is.na(rdate)])) 135 | persiter <- nrand / nsitesr 136 | z <- c(z, c(nrand, g(persite, 1), nsitesr, g(persiter, 1))) 137 | k <- c(k, c('Subjects randomized', 'Subjects per site', 138 | 'Sites randomizing', 139 | 'Subjects randomized per randomizing site')) 140 | ## maxs = for each site the # months since that site first randomized 141 | ## a subject (NA if none randomized) 142 | ## site months is sum of maxs 143 | ## avg. months since first randomized = mean maxs excluding NAs 144 | ## rand per site per month = # rand / site months 145 | ## Note: # rand / # sites / avg. months != rand per site per month 146 | ## because some sites have not randomized any subjects. Such sites 147 | ## are counted in # sites but not in site-months 148 | if(pclose) { 149 | months <- as.numeric(difftime(closeDate, rdate, units='days')) / 150 | (365.25 / 12) 151 | mx <- function(x) if(! length(x) || all(is.na(x))) NA 152 | else max(x, na.rm=TRUE) 153 | maxs <- tapply(months, Site, mx) 154 | sitemonths <- sum(maxs, na.rm=TRUE) 155 | z <- c(z, g(max(months, na.rm=TRUE), 1), 156 | g(sitemonths, 1), 157 | g(mean(maxs, na.rm=TRUE), 1), 158 | g(nrand / sitemonths, 2)) 159 | k <- c(k, paste('Months from first subject randomized (', 160 | format(min(rdate, na.rm=TRUE)), ') to ', 161 | format(closeDate), sep=''), 162 | 'Site-months for sites randomizing', 163 | 'Average months since a site first randomized', 164 | 'Subjects randomized per site per month') 165 | } 166 | } 167 | 168 | if(penroll && prandomize) { 169 | ttr <- as.numeric(difftime(Y[[randomize]], Y[[enroll]], units='days')) 170 | z <- c(z, g(mean(ttr, na.rm=TRUE), 1)) 171 | k <- c(k, 'Mean days from enrollment to randomization') 172 | z <- c(z, g(median(ttr, na.rm=TRUE), 1)) 173 | k <- c(k, 'Median days from enrollment to randomization') 174 | } 175 | if(studynos && length(z)) { 176 | z <- data.frame(Number=z, Category=k) 177 | u <- latex(z, file=file, append=TRUE, rowname=NULL, 178 | col.just=c('r','l'), where='!htbp', 179 | label=paste(panel, 'studynos', sep='-'), 180 | caption='Study Numbers') 181 | } 182 | 183 | ## axis.Date when given a sequence not on Jan 1 boundaries did not 184 | ## place axis labels at correct location 185 | axisDate <- function(dr) { 186 | cdr <- as.character(dr) 187 | yr <- substring(cdr, 1, 4) 188 | outer <- as.Date(c(paste(yr[1], '01-01', sep='-'), 189 | paste(as.numeric(yr[2]) + 1, '01-01', sep='-'))) 190 | dseq <- seq(outer[1], outer[2], by='year') 191 | if(length(dseq) > 3) dseq <- dseq[- c(1, length(dseq))] 192 | short <- difftime(dr[2], dr[1], units='days') < 550 193 | axis(1, at=as.numeric(dseq), 194 | labels=if(! short) substring(dseq, 1, 4) else FALSE) 195 | dseq <- seq(dr[1], dr[2], by='month') 196 | mo <- as.numeric(substring(dseq, 6, 7)) 197 | mo <- c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct', 198 | 'Nov','Dec')[mo] 199 | mo <- ifelse(mo == 'Jan', substring(dseq, 1, 4), mo) 200 | axis(1, at=as.numeric(dseq), 201 | labels=if(short) mo else FALSE, 202 | tcl = 0.5 * par('tcl'), cex.axis=0.6, las=3) 203 | } 204 | 205 | ## For each date variable in Y, make a cumulative frequency chart and 206 | ## optionally zoomed-in chart 207 | ## If target sample size is present, add that as line graph to chart 208 | for(j in 1 : nY) { 209 | y <- Y[[j]] 210 | nam <- namY[j] 211 | lab <- ylabs[j] 212 | sumnna <- sum(! is.na(y)) 213 | y <- y[! is.na(y)] 214 | target <- if(! length(names(targetN))) targetN else targetN[[nam]] 215 | dtarget <- targetDate 216 | if(length(target) && min(target) > 0) { 217 | target <- c(0, target) 218 | dtarget <- c(dr[1], dtarget) 219 | } 220 | lb <- sprintf('%s-cumulative-%s', panel, lab) 221 | shortcap <- sprintf("Subjects %s over time", lab) 222 | cap <- if(length(target)) 223 | sprintf('. The solid back line depicts the cumulative frequency. The thick grayscale line represent targets.', lab) else '' 224 | pzoom <- length(zoom) > 0 225 | if(pzoom) { 226 | zoom <- as.Date(zoom) 227 | cap <- paste(cap, sprintf( 228 | 'The plot is zoomed to show %s--%s in the right panel. The zoomed interval is depicted with vertical grayscale lines in the left panel', 229 | zoom[1], zoom[2])) 230 | } 231 | 232 | longcap <- paste(shortcap, cap, '~\\hfill\\lttc', sep = '') 233 | 234 | startPlot(lb, h=h, w=w * (1 + 0.75 * pzoom), lattice=FALSE) 235 | par(mfrow=c(1, 1 + pzoom), mar=c(4, 3.5, 2, 1)) 236 | plot(0, 0, type='n', xlab=sprintf('Date %s', upFirst(lab)), 237 | ylab='Cumulative Number', 238 | axes=FALSE, 239 | xlim=as.numeric(dr), 240 | ylim=c(0, if(length(target)) max(length(y), target) 241 | else if(lab == 'enrolled' && length(enrollmax)) enrollmax 242 | else length(y))) 243 | if(length(target)) lines(dtarget, target, lty=1, lwd=5, 244 | col=gray(.8)) 245 | 246 | Ecdf(as.numeric(y), what='f', add=TRUE, lwd=.75) 247 | axis(2) 248 | axisDate(dr) 249 | box(lwd=.75, col=gray(.4)) 250 | 251 | if(pzoom) { 252 | abline(v=as.numeric(zoom), col=gray(.85)) 253 | plot(0, 0, type='n', xlab=sprintf('Date %s', upFirst(lab)), 254 | ylab='Cumulative Number', 255 | axes=FALSE, 256 | xlim=zoom, 257 | ylim=c(0, if(length(target)) max(sum(y <= zoom[2], na.rm=TRUE), 258 | max(target[dtarget <= zoom[2]])) else 259 | sum(y <= zoom[2], na.rm=TRUE))) 260 | if(length(target)) lines(dtarget, target, lty=1, lwd=5, 261 | col=gray(.8)) 262 | Ecdf(as.numeric(y), what='f', add=TRUE, lwd=.75) 263 | axis(2) 264 | axisDate(zoom) 265 | box(lwd=.5, col=gray(.4)) 266 | } 267 | 268 | endPlot() 269 | ltt(switch(lab, enrolled=c(enrolled=sumnna), 270 | randomized=c(enrolled=sumnna, randomized=sumnna)), 'lttc') 271 | putFig(panel = panel, name = lb, caption = shortcap, 272 | longcaption = longcap) 273 | } 274 | 275 | ## Extended box plots of time to randomization for randomized subjects 276 | if(penroll && prandomize && (pregion || pcountry)) { 277 | x1 <- if(pregion) X[[region]] 278 | x2 <- if(pcountry) X[[country]] 279 | lb <- sprintf('%s-timetorand', panel) 280 | startPlot(lb, h=hb, w=wb, lattice=FALSE) 281 | y <- as.numeric(difftime(Y[[j]], Y[[enroll]], units='days')) 282 | use <- TRUE 283 | coexcl <- 0 284 | if(pcountry && minrand > 0) { 285 | ## Exclude countries randomizing fewer than minrand subject 286 | nrn <- tapply(y, x2, function(x) sum(! is.na(x))) 287 | if(any(nrn < minrand)) { 288 | coexcl <- sum(nrn < minrand) 289 | countrieskeep <- names(nrn)[nrn >= minrand] 290 | use <- x2 %in% countrieskeep 291 | } 292 | } 293 | form <- if(length(x1) && length(x2)) x2 ~ y | x1 294 | else if(length(x1)) x1 ~ y 295 | else if(length(x2)) x2 ~ y 296 | else x2 ~ 1 297 | print(bwplot(form, panel=panel.bpplot, xlab='Days to Randomization', 298 | subset=use, 299 | scales=list(y='free', rot=c(0,0)), 300 | violin=TRUE, 301 | violin.opts=list(col=adjustcolor('blue', alpha.f=.35), 302 | border=FALSE))) 303 | endPlot() 304 | Days <- y 305 | form <- if(length(x1)) Days ~ x1 306 | else if(length(x2)) Days ~ x2 307 | else Days ~ 1 308 | popname <- '\\poptabledaysrand' 309 | cat(sprintf('\\def%s{\\protect\n', popname), file=file, append=TRUE) 310 | rddata <- data.frame(Days) 311 | if(length(x1)) rddata$x1 <- x1 312 | if(length(x2)) rddata$x2 <- x2 313 | rddata <- subset(rddata, ! is.na(Days)) 314 | S <- summaryM(form, data=rddata, test=FALSE) 315 | z <- latex(S, table.env=FALSE, file=file, append=TRUE, prmsd=TRUE, 316 | middle.bold=TRUE, center='none', round=1, insert.bottom=FALSE) 317 | cat('}\n', file=file, append=TRUE) 318 | popsize <- if(length(S$group.freq) > 2) 'full' else 'mini' 319 | legend <- attr(z, 'legend') 320 | legend <- if(! length(legend)) '' 321 | else paste('. ', paste(legend, collapse='\n'), sep='') 322 | 323 | excc <- if(coexcl > 0) paste('.', coexcl, 'countries with fewer than', 324 | minrand, 'randomized subjects are not shown.') 325 | else '' 326 | putFig(panel=panel, name=lb, 327 | longcaption=paste('\\protect\\eboxpopup{Extended box} plots and violin plots showing the distribution of days from enrollment to randomization', 328 | excc, '~\\hfill\\lttc', sep=''), 329 | caption='Days from enrollment to randomization', 330 | tcaption='Days from enrollment to randomization', 331 | tlongcaption=paste('Days from enrollment to randomization', 332 | legend, sep=''), 333 | poptable=popname, popfull=popsize == 'full') 334 | } 335 | 336 | ## Chart number of subjects enrolled/randomized/... and other descriptors 337 | ## by right-hand variables 338 | if(nX == 0) return(invisible()) 339 | 340 | if(psite) { 341 | lb <- sprintf('%s-subjpersite', panel) 342 | 343 | startPlot(lb, h=h, w=min(7.75, nY * w), mfrow=c(1, nY), 344 | ps=8, lattice=FALSE) 345 | for(j in 1 : nY) { 346 | y <- X[[site]] 347 | y[is.na(Y[[j]])] <- NA 348 | lab <- ylabs[j] 349 | clab <- capitalize(lab) 350 | nn <- table(table(y)) 351 | plot(as.numeric(names(nn)), as.numeric(nn), 352 | xlab=sprintf('Number of Subjects %s', clab), 353 | ylab='Number of Sites') 354 | } 355 | endPlot() 356 | if(nY > 1) lab <- '' 357 | putFig(panel=panel, name=lb, 358 | longcaption=sprintf('Number of sites having the given number of subjects %s~\\hfill\\lttc', lab), 359 | caption=sprintf('Number of sites $\\times$ number of subjects %s', lab)) 360 | } 361 | 362 | ## Start with counts of subjects by non-site grouping variables 363 | ## Compute number of non-site right-hand variables 364 | ns <- setdiff(1 : nX, site) 365 | dat <- list() 366 | if(pregion) dat$x1 <- X[[region]] 367 | if(pcountry) dat$x2 <- X[[country]] 368 | if(psite) dat$x3 <- X[[site]] ## new 369 | if(length(ns) > 2) { 370 | more <- setdiff(ns, c(region, country)) 371 | k <- 2 372 | for(l in more) { 373 | k <- k + 1 374 | dat[[paste('x', k, sep='')]] <- X[[l]] 375 | } 376 | } 377 | form <- if(length(ns)) { 378 | xvars <- paste(paste('x', 1 : length(ns), sep=''), collapse=' + ') 379 | paste('y ~', xvars) 380 | } else if(psite) 'y ~ x3' 381 | else 'y ~ 1' 382 | form <- as.formula(form) 383 | 384 | by <- paste(xlabs[ns], collapse=' and ') 385 | types <- c('count', 386 | if(psite && cr) 'sites', 387 | if(penroll && prandomize) 'fracrand', 388 | if(prandomize && pclose && cr) 'permonth', 389 | if(prandomize && pclose && psite && cr) 390 | 'persitemonth') 391 | 392 | np <- nY * sum(c('count', 'sites') %in% types) + 393 | sum(c('fracrand', 'permonth', 'persitemonth') %in% 394 | types) 395 | mf <- if(np == 1) c(1, 1) else if(np == 2) c(1, 2) else c(2, 2) 396 | mc <- mf[2] 397 | pages <- ceiling(np / prod(mf)) 398 | width <- if(mf[2] == 1) 3.5 else 7.0 399 | ip <- 0 400 | page <- 0 401 | ended <- FALSE 402 | scap <- if(psite) 'Subject and site counts' 403 | else 'Subject counts' 404 | ## if('fracrand' %in% types) scap <- paste(scap, 'and fraction randomized') 405 | cap <- if(psite) 'Counts of numbers of subjects and numbers of sites' 406 | else 'Counts of numbers of subjects' 407 | ## if('fracrand' %in% types) cap <- paste(cap, 'and fraction randomized') 408 | cap <- paste(cap, '~\\hfill\\lttc', sep='') 409 | for(type in types) { 410 | whichy <- if(type %in% c('fracrand', 'permonth', 'persitemonth')) 411 | randomize else 1 : nY 412 | if(length(whichy)) for(j in whichy) { 413 | ip <- ip + 1 414 | if(ip == 1) { 415 | page <- page + 1 416 | lb <- if(pages == 1) sprintf('%s-count', panel) 417 | else sprintf('%s-count-%s', panel, page) 418 | ## Compute the number of rows in the current page 419 | r <- if(page < pages) mf[1] 420 | else if(np %% 4 == 0) 2 421 | else ceiling((np %% 4) / 2) 422 | height <- min(9, hdot * r) 423 | startPlot(lb, h=height, w=width, mfrow=c(r, mf[2]), 424 | ps=if(r == 2) 10 else 8, lattice=FALSE) 425 | ended <- FALSE 426 | } 427 | gg <- function(x) length(unique(x[! is.na(x)])) 428 | 429 | if(type %in% c('permonth', 'persitemonth')) { 430 | ## Get country if there, otherwise region 431 | group <- if(pcountry) as.character(X[[country]]) 432 | else if(pregion) as.character(X[[region]]) 433 | ## Get more major grouping if present otherwise use above 434 | mgroup <- if(pregion) as.character(X[[region]]) else group 435 | 436 | ## Get enrollment date if present, otherwise use rand. date 437 | k <- if(penroll) enroll 438 | else if(prandomize) randomize 439 | else 1 440 | months <- as.numeric(difftime(closeDate, Y[[k]], units='days')) / 441 | (365.25 / 12) 442 | ## Find maximum months on board for each group 443 | ## E.g. longest elapsed time within a country 444 | gmonths <- tapply(months, group, max, na.rm=TRUE) 445 | ## Find the maximum elapsed time over groups within major groups 446 | ## E.g. longest time for any country within that region 447 | mmonths <- tapply(months, mgroup, max, na.rm=TRUE) 448 | 449 | ## Create a major group lookup object given group 450 | tab <- subset(as.data.frame(table(group, mgroup)), Freq > 0) 451 | mg <- as.character(tab$mgroup) 452 | names(mg) <- as.character(tab$group) 453 | 454 | ## For site-month calculation compute the maximum elapsed time 455 | ## per site, then sum that over all sites within a group 456 | ## Assume sites are unique over countries, regions 457 | if(type == 'persitemonth') { 458 | ## For each site lookup group 459 | tab <- subset(as.data.frame(table(Site, group)), Freq > 0) 460 | gr <- as.character(tab$group) 461 | names(gr) <- as.character(tab$Site) 462 | maxs <- tapply(months, Site, max, na.rm=TRUE) 463 | 464 | ## Starting with only one record per site with that site's 465 | ## maximum time, sum the elapsed months within each group 466 | gsitesum <- tapply(maxs, gr[names(maxs)], sum, na.rm=TRUE) 467 | ## Similar over region 468 | msitesum <- tapply(maxs, mg[gr[names(maxs)]], sum, na.rm=TRUE) 469 | ## Spread to all subjects 470 | y <- cbind(randomized = ! is.na(Y[[randomize]]), 471 | mmonths = msitesum[mg[group]], 472 | gmonths = gsitesum[group]) 473 | yy <- y[group == 'US',] 474 | } 475 | else y <- cbind(randomized = ! is.na(Y[[randomize]]), 476 | mmonths = mmonths[mg[group]], 477 | gmonths = gmonths[group]) 478 | mg <- function(y) sum(y[, 1]) / y[1, 2] 479 | gg <- function(y) sum(y[, 1]) / y[1, 3] 480 | } 481 | 482 | switch(type, 483 | count = { y <- ! is.na(Y[[j]]); fun <- sum }, 484 | sites = { y <- X[[site]]; y[is.na(Y[[j]])] <- NA; fun <- gg }, 485 | fracrand = { y <- ! is.na(Y[[j]]); fun <- mean }, 486 | permonth = { }, 487 | persitemonth = { } ) 488 | 489 | lab <- ylabs[j] 490 | clab <- capitalize(lab) 491 | dat$y <- y 492 | fmt <- function(x) format(round(x, 2)) 493 | if(type %in% c('permonth', 'persitemonth')) 494 | summaryD(form, fun=gg, funm=mg, data=dat, vals=TRUE, fmtvals=fmt, 495 | xlab=switch(type, 496 | permonth = 'Number Randomized Per Month', 497 | persitemonth = 'Number Randomized Per Site Per Month')) 498 | else summaryD(form, fun=fun, data=dat, vals=TRUE, 499 | fmtvals = fmt, 500 | ylab = if(psite && ! length(ns)) 'Site', 501 | xlab=switch(type, 502 | count=sprintf('Number of Subjects %s', clab), 503 | sites=sprintf('Number of Sites That %s', clab), 504 | fracrand=sprintf('Fraction of Subjects %s', clab))) 505 | if(ip == 4) { 506 | endPlot() 507 | putFig(panel=panel, name=lb, longcaption=cap, caption=scap) 508 | ended <- TRUE 509 | ip <- 0 510 | } 511 | } 512 | } 513 | if(!ended) { 514 | endPlot() 515 | putFig(panel=panel, name=lb, longcaption=cap, caption=scap) 516 | } 517 | invisible() 518 | } 519 | --------------------------------------------------------------------------------