├── .gitignore ├── R ├── lhs.R ├── rhs.R ├── publish.data.frame.R ├── publish.univariateTable.R ├── publish.subgroupAnalysis.R ├── print.regressionTable.R ├── iqr.R ├── canbe.numeric.R ├── org.R ├── ci.mean.R ├── ci.mean.data.frame.R ├── print.univariateTable.R ├── ci.geomean.R ├── print.subgroupAnalysis.R ├── publish.default.R ├── publish.list.R ├── publish.summary.prodlim.R ├── publish.FGR.R ├── ci.geomean.formula.R ├── parseFrequencyFormat.R ├── print.ci.R ├── getPyntDefaults.R ├── publish.R ├── ci.mean.formula.R ├── publish.table.R ├── publish.prodlim.R ├── publish.riskRegression.R ├── ci.mean.default.R ├── parseSummaryFormat.R ├── plot.subgroupAnalysis.R ├── publish.ci.R ├── Units.R ├── sutable.R ├── publish.summary.aov.R ├── pubformat.R ├── lazyFactorCoding.R ├── publish.riskReclassification.R ├── glmSeries.R ├── coxphSeries.R ├── prepareLabels.R ├── labelUnits.R ├── publish.Score.R ├── getSummary.R ├── publish.survdiff.R ├── plotLabels.R ├── summary.ci.R ├── table2x2.R ├── plot.ci.R ├── summary.subgroupAnalysis.R ├── splinePlot.lrm.R ├── formatCI.R ├── plot.regressionTable.R ├── publish.coxph.R ├── stripes.R ├── lazyDateCoding.R ├── publish.CauseSpecificCox.R └── publish.glm.R ├── data ├── trace.rda ├── traceR.rda ├── Diabetes.rda ├── SpaceT.csv └── CiTable.csv ├── .Rbuildignore ├── tests ├── TestBaselineTable.pdf ├── test-publish-mi.R ├── TestBaselineTable.tex ├── test-publish.R ├── test-glmSeries.R ├── test-regressionTable.R ├── test-publish-gls.R └── test-univariateTable.R ├── .travis.yml ├── Publish.Rproj ├── man ├── org.Rd ├── ci.mean.Rd ├── Publish-package.Rd ├── print.univariateTable.Rd ├── publish.Rd ├── print.subgroupAnalysis.Rd ├── sutable.Rd ├── CiTable.Rd ├── print.table2x2.Rd ├── Units.Rd ├── publish.survdiff.Rd ├── publish.summary.aov.Rd ├── publish.htest.Rd ├── ci.mean.default.Rd ├── print.ci.Rd ├── lazyFactorCoding.Rd ├── table2x2.Rd ├── pubformat.Rd ├── SpaceT.Rd ├── labelUnits.Rd ├── publish.riskRegression.Rd ├── lazyDateCoding.Rd ├── publish.ci.Rd ├── traceR.Rd ├── fixRegressionTable.Rd ├── trace.Rd ├── plot.subgroupAnalysis.Rd ├── publish.Score.Rd ├── plot.regressionTable.Rd ├── summary.ci.Rd ├── glmSeries.Rd ├── summary.regressionTable.Rd ├── coxphSeries.Rd ├── followupTable.Rd ├── splinePlot.lrm.Rd ├── stripes.Rd ├── publish.CauseSpecificCox.Rd ├── spaghettiogram.Rd ├── summary.subgroupAnalysis.Rd ├── plot.ci.Rd ├── Diabetes.Rd ├── formatCI.Rd ├── publish.coxph.Rd ├── summary.univariateTable.Rd ├── publish.matrix.Rd ├── parseInteractionTerms.Rd ├── publish.glm.Rd ├── specialFrame.Rd ├── publish.MIresult.Rd └── regressionTable.Rd ├── README.md ├── DESCRIPTION └── NAMESPACE /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | *.org -------------------------------------------------------------------------------- /R/lhs.R: -------------------------------------------------------------------------------- 1 | lhs <- function(formula){ 2 | update(formula,.~NULL) 3 | } 4 | -------------------------------------------------------------------------------- /R/rhs.R: -------------------------------------------------------------------------------- 1 | rhs <- function(formula){ 2 | update(formula,NULL~.) 3 | } 4 | -------------------------------------------------------------------------------- /data/trace.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tagteam/Publish/HEAD/data/trace.rda -------------------------------------------------------------------------------- /data/traceR.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tagteam/Publish/HEAD/data/traceR.rda -------------------------------------------------------------------------------- /data/Diabetes.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tagteam/Publish/HEAD/data/Diabetes.rda -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | test/ 2 | manuscript/ 3 | ^\.travis\.yml$ 4 | ^.*\.Rproj$ 5 | ^\.Rproj\.user$ 6 | -------------------------------------------------------------------------------- /tests/TestBaselineTable.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tagteam/Publish/HEAD/tests/TestBaselineTable.pdf -------------------------------------------------------------------------------- /R/publish.data.frame.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.data.frame <- function(object,...){ 3 | publish(as.matrix(object),...) 4 | } 5 | -------------------------------------------------------------------------------- /R/publish.univariateTable.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.univariateTable <- function(object,...){ 3 | publish(summary(object,...),...) 4 | } 5 | -------------------------------------------------------------------------------- /R/publish.subgroupAnalysis.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.subgroupAnalysis <- function(object,...){ 3 | publish(summary(object,...),...) 4 | } 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | sudo: required 5 | r_check_args: --as-cran 6 | cache: packages -------------------------------------------------------------------------------- /R/print.regressionTable.R: -------------------------------------------------------------------------------- 1 | print.regressionTable <- function(x,...){ 2 | Rtab <- summary(x,print=FALSE,...) 3 | ## rownames(Rtab) <- NULL 4 | print.listof(Rtab,...) 5 | Rtab 6 | } 7 | -------------------------------------------------------------------------------- /R/iqr.R: -------------------------------------------------------------------------------- 1 | iqr <- function (x, na.rm = FALSE,digits,...){ 2 | paste("[",paste(format(quantile(as.numeric(x), c(0.25, 0.75), na.rm = na.rm),digits=digits,nsmall=digits),collapse=","),"]",sep="") 3 | } 4 | -------------------------------------------------------------------------------- /R/canbe.numeric.R: -------------------------------------------------------------------------------- 1 | canbe.numeric <- function(x){ 2 | if (!is.character(x)) x <- as.character(x) 3 | u <- x[!is.na(x) & x!="NA"] 4 | test <- suppressWarnings(as.numeric(u)) 5 | if (any(is.na(test))) 6 | FALSE 7 | else 8 | TRUE 9 | } 10 | -------------------------------------------------------------------------------- /R/org.R: -------------------------------------------------------------------------------- 1 | ##' Wrapper for \code{publish(...,org=TRUE)} 2 | ##' 3 | ##' 4 | ##' @title Wrapper function for publish with output format org 5 | ##' @param x object to format as org 6 | ##' @param ... passed to publish 7 | ##' @return See publish 8 | ##' @author Thomas Alexander Gerds 9 | ##' @export 10 | org <- function(x,...){ 11 | publish(x,...,org=TRUE) 12 | } 13 | -------------------------------------------------------------------------------- /Publish.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /R/ci.mean.R: -------------------------------------------------------------------------------- 1 | ##' Compute mean values with confidence intervals 2 | ##' 3 | ##' Normal approximation 4 | ##' @title Compute mean values with confidence intervals 5 | ##' @param x object passed to methods 6 | ##' @param ... passed to methods 7 | ##' @return a list with mean values and confidence limits 8 | ##' @export 9 | ci.mean <- function(x,...){ 10 | UseMethod("ci.mean",object=x) 11 | } 12 | -------------------------------------------------------------------------------- /R/ci.mean.data.frame.R: -------------------------------------------------------------------------------- 1 | ci.mean.data.frame <- function(x,alpha = 0.05,normal = T,na.rm=T,statistic=c("arithmetic","geometric")){ 2 | res <- lapply(x,ci.mean.default,alpha=alpha,normal=normal,na.rm=na.rm,statistic=statistic) 3 | tmp <- data.frame(t(sapply(t(res),function(x)unlist(x[1:4])))) 4 | tmp$labels <- names(x) 5 | out <- lapply(tmp,function(x)x) 6 | out <- c(out,level=alpha,statistic=statistic) 7 | class(out) <- c("ci",class(out)) 8 | out 9 | } 10 | -------------------------------------------------------------------------------- /man/org.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/org.R 3 | \name{org} 4 | \alias{org} 5 | \title{Wrapper function for publish with output format org} 6 | \usage{ 7 | org(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object to format as org} 11 | 12 | \item{...}{passed to publish} 13 | } 14 | \value{ 15 | See publish 16 | } 17 | \description{ 18 | Wrapper for \code{publish(...,org=TRUE)} 19 | } 20 | \author{ 21 | Thomas Alexander Gerds 22 | } 23 | -------------------------------------------------------------------------------- /man/ci.mean.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ci.mean.R 3 | \name{ci.mean} 4 | \alias{ci.mean} 5 | \title{Compute mean values with confidence intervals} 6 | \usage{ 7 | ci.mean(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object passed to methods} 11 | 12 | \item{...}{passed to methods} 13 | } 14 | \value{ 15 | a list with mean values and confidence limits 16 | } 17 | \description{ 18 | Compute mean values with confidence intervals 19 | } 20 | \details{ 21 | Normal approximation 22 | } 23 | -------------------------------------------------------------------------------- /R/print.univariateTable.R: -------------------------------------------------------------------------------- 1 | ##' Print function for univariate tables 2 | ##' 3 | ##' This function is simply calling \code{summary.univariateTable} 4 | ##' @title Printing univariate tables 5 | ##' @param x An object obtained with \code{univariateTable} 6 | ##' @param ... Passed to summary.univariateTable 7 | ##' @return The result of \code{summary.univariateTable(x)} 8 | ##' @seealso \code{univariateTable} 9 | ##' @export 10 | ##' @author Thomas A. Gerds 11 | print.univariateTable <- function(x,...){ 12 | sx <- summary(x,...) 13 | print(sx) 14 | invisible(sx) 15 | } 16 | -------------------------------------------------------------------------------- /R/ci.geomean.R: -------------------------------------------------------------------------------- 1 | ci.geomean <- function(x,alpha = 0.05,normal = T,na.rm=T){ 2 | if (na.rm){x <- x[!is.na(x)]} 3 | logx <- log(x) 4 | n <- length(logx) 5 | m <- mean(logx) 6 | se <- sqrt(var(logx)/n) 7 | df <- n - 1 8 | if(normal) { 9 | q <- qt(1 - alpha/2, df) 10 | } 11 | else { 12 | q <- qnorm(1 - alpha/2) 13 | } 14 | low <- m - se * q 15 | up <- m + se * q 16 | m <- exp(m) 17 | se <- exp(se) 18 | low <- exp(low) 19 | up <- exp(up) 20 | out <- data.frame(geomean = m,se = se,lower = low,upper = up) 21 | class(out) <- c("ci", class(out)) 22 | out 23 | } 24 | -------------------------------------------------------------------------------- /R/print.subgroupAnalysis.R: -------------------------------------------------------------------------------- 1 | ##' Print function for subgroupAnalysis 2 | ##' 3 | ##' This function is simply calling \code{summary.subgroupAnalysis} 4 | ##' @title Printing univariate tables 5 | ##' @param x - An object obtained with \code{subgroupAnalysis} 6 | ##' @param ... Passed to summary.subgroupAnalysis 7 | ##' @return The result of \code{summary.subgroupAnalysis(x)} 8 | ##' @seealso \code{subgroupAnalysis} 9 | ##' @export 10 | ##' @author Christian Torp-Pedersen (ctp@heart.dk) 11 | print.subgroupAnalysis <- function(x,...){ 12 | sx <- summary(x,...) 13 | print(sx) 14 | invisible(sx) 15 | } 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Publish 2 | R package Publish 3 | 4 | ## Installation 5 | 6 | To install the development version of Publish run the following commands from within R 7 | ```{r} 8 | library(devtools) 9 | install_github('tagteam/Publish') 10 | ``` 11 | 12 | ## Trouble shooting 13 | 14 | To install a package from github you need a program to unzip the download. 15 | If you don't have such a program and the install_github above command failed, then you 16 | should try 17 | 18 | ```{r} 19 | library(devtools) 20 | options(unzip="internal") 21 | install_github('tagteam/Publish') 22 | ``` 23 | 24 | ## Examples 25 | -------------------------------------------------------------------------------- /R/publish.default.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.default <- function(object,digits=4,title,bold=TRUE,level=0,hrule=FALSE,title.level,title.hrule,...){ 3 | if (missing(title.level)) title.level <- max(level-1,1) 4 | if (missing(title.hrule)) title.hrule <- 0 5 | if (!missing(title)) publish(x=title,level=title.level,hrule=title.hrule) 6 | if (is.numeric(object) | canbe.numeric(object)){ 7 | x <- format(object,digits=digits,nsmall=digits) 8 | } 9 | cat(paste("\n",paste(rep("*",level),collapse=""),ifelse(level>0," ",""),object,"\n",sep="")) 10 | if (hrule==TRUE) cat("\n----\n") 11 | } 12 | -------------------------------------------------------------------------------- /R/publish.list.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.list <- function(object, 3 | title, 4 | level=0, 5 | hrule=0, 6 | title.level=1, 7 | title.hrule=1, 8 | ...){ 9 | if (!missing(title)) publish(title,level=title.level,hrule=title.hrule) 10 | xnames <- names(object) 11 | nix <- lapply(1:length(object),function(i){ 12 | if (!is.null(xnames)){ 13 | publish(xnames[i],level=level,hrule=hrule) 14 | } 15 | else cat("\n\n") 16 | inX <- object[[i]] 17 | publish(inX,level=min(level+1,3),...) 18 | }) 19 | } 20 | -------------------------------------------------------------------------------- /man/Publish-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish-package.R 3 | \docType{package} 4 | \name{Publish-package} 5 | \alias{Publish} 6 | \alias{Publish-package} 7 | \title{Publish package} 8 | \description{ 9 | This package processes results of descriptive statistcs and regression analysis into final tables and figures of a manuscript 10 | } 11 | \author{ 12 | \strong{Maintainer}: Thomas A. Gerds \email{tag@biostat.ku.dk} 13 | 14 | Authors: 15 | \itemize{ 16 | \item Brice Ozenne \email{broz@sund.ku.dk} 17 | } 18 | 19 | Other contributors: 20 | \itemize{ 21 | \item Christian Torp-Pedersen [contributor] 22 | \item Klaus K Holst [contributor] 23 | } 24 | 25 | } 26 | -------------------------------------------------------------------------------- /man/print.univariateTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.univariateTable.R 3 | \name{print.univariateTable} 4 | \alias{print.univariateTable} 5 | \title{Printing univariate tables} 6 | \usage{ 7 | \method{print}{univariateTable}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An object obtained with \code{univariateTable}} 11 | 12 | \item{...}{Passed to summary.univariateTable} 13 | } 14 | \value{ 15 | The result of \code{summary.univariateTable(x)} 16 | } 17 | \description{ 18 | Print function for univariate tables 19 | } 20 | \details{ 21 | This function is simply calling \code{summary.univariateTable} 22 | } 23 | \seealso{ 24 | \code{univariateTable} 25 | } 26 | \author{ 27 | Thomas A. Gerds 28 | } 29 | -------------------------------------------------------------------------------- /man/publish.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.R 3 | \name{publish} 4 | \alias{publish} 5 | \title{Publishing tables and figures} 6 | \usage{ 7 | publish(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{object to be published} 11 | 12 | \item{...}{Passed to method.} 13 | } 14 | \value{ 15 | Tables and figures 16 | } 17 | \description{ 18 | Publish provides summary functions for data 19 | and results of statistical analysis in ready-for-publication 20 | design 21 | } 22 | \details{ 23 | Some warnings are currently suppressed. 24 | } 25 | \seealso{ 26 | publish.CauseSpecificCox publish.ci publish.coxph publish.glm publish.riskRegression publish.survdiff 27 | } 28 | \author{ 29 | Thomas A. Gerds 30 | } 31 | -------------------------------------------------------------------------------- /tests/test-publish-mi.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(Publish) 3 | library(mitools) 4 | library(smcfcs) 5 | library(riskRegression) 6 | 7 | test_that("multiple imputation",{ 8 | set.seed(71) 9 | d=sampleData(100) 10 | ## generate missing values 11 | d[X1==1,X6:=NA] 12 | d[X2==1,X3:=NA] 13 | d=d[,.(X8,X4,X3,X6,X7)] 14 | sapply(d,function(x)sum(is.na(x))) 15 | d[,X4:=factor(X4,levels=c("0","1"),labels=c("0","1"))] 16 | set.seed(17) 17 | f= smcfcs(d,smtype="lm",smformula=X8~X4*X3+X6+X7,method=c("","","logreg","norm",""),m=3) 18 | ccfit=lm(X8~X4*X3+X6+X7,data=d) 19 | impobj <- imputationList(f$impDatasets) 20 | models <- with(impobj,lm(X8~X4*X3+X6+X7)) 21 | mifit <- MIcombine(models) 22 | a <- publish(mifit,fit=ccfit,data=d) 23 | }) 24 | -------------------------------------------------------------------------------- /R/publish.summary.prodlim.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.summary.prodlim <- function(object, 3 | conf.int = 0.95, 4 | digits = 1, 5 | print=TRUE, 6 | latex=FALSE, 7 | ...){ 8 | otab <- object$table 9 | if (class(otab)[1]=="list"){ 10 | onames <- names(otab) 11 | nix <- lapply(1:length(otab),function(i){ 12 | ## publish(onames[i]) 13 | if (latex==TRUE) 14 | publish(onames[i]) 15 | cat("\n\n") 16 | publish(otab[[i]],digits=digits,rownames=FALSE,latex=latex,...) 17 | }) 18 | } 19 | else{ 20 | publish(otab,digits=digits,rownames=FALSE,latex=latex,...) 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /man/print.subgroupAnalysis.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.subgroupAnalysis.R 3 | \name{print.subgroupAnalysis} 4 | \alias{print.subgroupAnalysis} 5 | \title{Printing univariate tables} 6 | \usage{ 7 | \method{print}{subgroupAnalysis}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{- An object obtained with \code{subgroupAnalysis}} 11 | 12 | \item{...}{Passed to summary.subgroupAnalysis} 13 | } 14 | \value{ 15 | The result of \code{summary.subgroupAnalysis(x)} 16 | } 17 | \description{ 18 | Print function for subgroupAnalysis 19 | } 20 | \details{ 21 | This function is simply calling \code{summary.subgroupAnalysis} 22 | } 23 | \seealso{ 24 | \code{subgroupAnalysis} 25 | } 26 | \author{ 27 | Christian Torp-Pedersen (ctp@heart.dk) 28 | } 29 | -------------------------------------------------------------------------------- /R/publish.FGR.R: -------------------------------------------------------------------------------- 1 | ##' @author Thomas Alexander Gerds 2 | ##' 3 | ##' @export 4 | publish.FGR <- function(object,digits=4,print=TRUE,...){ 5 | sum <- summary(object$crrFit) 6 | p <- sum$coef[,5,drop=TRUE] 7 | subHR <- pubformat(sum$coef[,2,drop=TRUE],handler="sprintf",digits=digits) 8 | ci <- sum$conf.int[,3:4] 9 | colnames(ci) <- c("lower","upper") 10 | ci <- formatCI(x=subHR, 11 | ci[,"lower"], 12 | ci[,"upper"], 13 | show.x=0L) 14 | out <- data.table::data.table(cbind(Variable=rownames(sum$coef), 15 | subHR, 16 | ci, 17 | p)) 18 | if (print==TRUE) publish(out,digits=digits,...) 19 | invisible(out) 20 | } 21 | -------------------------------------------------------------------------------- /man/sutable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sutable.R 3 | \name{sutable} 4 | \alias{sutable} 5 | \title{Fast summary of a univariate table} 6 | \usage{ 7 | sutable(...) 8 | } 9 | \arguments{ 10 | \item{...}{Unnamed arguments and are passed to \code{univariateTable} as well as named arguments 11 | that match \code{univariateTable}'s arguments, other arguments 12 | are passed to \code{summary.univariateTable}} 13 | } 14 | \value{ 15 | Summary table 16 | } 17 | \description{ 18 | First apply univariateTable then call summary. 19 | } 20 | \examples{ 21 | data(Diabetes) 22 | sutable(gender~age+location+Q(BMI)+height+weight,data=Diabetes,BMI="Body mass index (kg/m^2)") 23 | } 24 | \seealso{ 25 | summary.univariateTable univariateTable 26 | } 27 | \author{ 28 | Thomas A. Gerds 29 | } 30 | -------------------------------------------------------------------------------- /man/CiTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish-package.R 3 | \docType{data} 4 | \name{CiTable} 5 | \alias{CiTable} 6 | \title{CiTable data} 7 | \format{ 8 | A data frame with 27 observations on the following 9 variables. 9 | \describe{ 10 | \item{Drug}{} 11 | \item{Time}{} 12 | \item{Drug.Time}{} 13 | \item{Dose}{} 14 | \item{Mean}{} 15 | \item{SD}{} 16 | \item{n}{} 17 | \item{HazardRatio}{} 18 | \item{lower}{} 19 | \item{upper}{} 20 | \item{p}{} 21 | } 22 | } 23 | \description{ 24 | These data are used for testing Publish package functionality. 25 | } 26 | \examples{ 27 | 28 | data(CiTable) 29 | labellist <- split(CiTable[,c("Dose","Mean","SD","n")],CiTable[,"Drug"]) 30 | labellist 31 | plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")], labels=labellist) 32 | 33 | 34 | } 35 | \keyword{datasets} 36 | -------------------------------------------------------------------------------- /man/print.table2x2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.table2x2.R 3 | \name{print.table2x2} 4 | \alias{print.table2x2} 5 | \title{print results of 2x2 contingency table analysis} 6 | \usage{ 7 | \method{print}{table2x2}(x, digits = 1, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object obtained with table2x2} 11 | 12 | \item{digits}{rounding digits} 13 | 14 | \item{...}{not used} 15 | } 16 | \value{ 17 | invisible x 18 | } 19 | \description{ 20 | print results of 2x2 contingency table analysis 21 | } 22 | \examples{ 23 | table2x2(table("marker"=rbinom(100,1,0.4),"response"=rbinom(100,1,0.1))) 24 | table2x2(matrix(c(71,18,38,8),ncol=2),stats="table") 25 | table2x2(matrix(c(71,18,38,8),ncol=2),stats=c("rr","fisher")) 26 | } 27 | \seealso{ 28 | table2x2 29 | } 30 | \author{ 31 | Thomas A. Gerds 32 | } 33 | -------------------------------------------------------------------------------- /man/Units.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Units.R 3 | \name{Units} 4 | \alias{Units} 5 | \title{Add units to data set} 6 | \usage{ 7 | Units(object, units) 8 | } 9 | \arguments{ 10 | \item{object}{A data.frame or data.table} 11 | 12 | \item{units}{Named list of units. Names are variable names. If omitted, show existing units.} 13 | } 14 | \value{ 15 | The object augmented with attribute \code{"units"} 16 | } 17 | \description{ 18 | Add variable units to data.frame (or data.table). 19 | } 20 | \details{ 21 | If the object has units existing units are replaced by given units. 22 | } 23 | \examples{ 24 | data(Diabetes) 25 | Diabetes <- Units(Diabetes,list(BMI="kg/m^2")) 26 | Units(Diabetes) 27 | Diabetes <- Units(Diabetes,list(bp.1s="mm Hg",bp.2s="mm Hg")) 28 | Units(Diabetes) 29 | } 30 | \author{ 31 | Thomas A. Gerds 32 | } 33 | -------------------------------------------------------------------------------- /R/ci.geomean.formula.R: -------------------------------------------------------------------------------- 1 | ci.geomean.formula <- function(formula,data,alpha = 0.05,normal = T,na.rm=T,statistic="geometric"){ 2 | work <- model.frame(formula,data) 3 | nf <- ncol(work)-1 4 | if (nf>1) f <- interaction(work[,-1,drop=FALSE],sep=" - ") 5 | else f <- factor(work[,2]) 6 | res <- lapply(split(model.response(work),f),ci.mean.default,alpha=alpha,normal=normal,na.rm=na.rm,statistic=statistic) 7 | statistic <- unique(unlist(lapply(res,function(x)x$statistic))) 8 | labels <- do.call("rbind",strsplit(names(res)," - ")) 9 | colnames(labels) <- names(work)[-1] 10 | ## we reverse the order of factors for nicer labeling ... 11 | labels <- labels[,rev(1:nf),drop=FALSE] 12 | res <- data.frame(do.call("rbind",res)) 13 | out <- lapply(res[,1:4],function(x)unlist(x)) 14 | out <- c(out,list(labels=labels,level=alpha,statistic=statistic)) 15 | class(out) <- c("ci",class(out)) 16 | out 17 | } 18 | -------------------------------------------------------------------------------- /man/publish.survdiff.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.survdiff.R 3 | \name{publish.survdiff} 4 | \alias{publish.survdiff} 5 | \title{Alternative summary of survdiff results} 6 | \usage{ 7 | \method{publish}{survdiff}(object, digits = c(2, 4), print = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Object obtained with \code{survival::survdiff}.} 11 | 12 | \item{digits}{Vector with digits for rounding numbers: the second for pvalues, the first for all other numbers.} 13 | 14 | \item{print}{If \code{FALSE} do not print results.} 15 | 16 | \item{...}{Not (yet) used.} 17 | } 18 | \description{ 19 | Alternative summary of survdiff results 20 | } 21 | \examples{ 22 | library(survival) 23 | data(pbc) 24 | sd <- survdiff(Surv(time,status!=0)~sex,data=pbc) 25 | publish(sd) 26 | publish(sd,digits=c(3,2)) 27 | 28 | } 29 | \author{ 30 | Thomas A. Gerds 31 | } 32 | -------------------------------------------------------------------------------- /man/publish.summary.aov.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.summary.aov.R 3 | \name{publish.summary.aov} 4 | \alias{publish.summary.aov} 5 | \title{Format summary table of aov results} 6 | \usage{ 7 | \method{publish}{summary.aov}( 8 | object, 9 | print = TRUE, 10 | handler = "sprintf", 11 | digits = c(2, 4), 12 | nsmall = digits, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{object}{glm object} 18 | 19 | \item{print}{Logical. Decide about whether or not to print the results.} 20 | 21 | \item{handler}{see \code{pubformat}} 22 | 23 | \item{digits}{see \code{pubformat}} 24 | 25 | \item{nsmall}{see \code{pubformat}} 26 | 27 | \item{...}{used to transport further arguments} 28 | } 29 | \description{ 30 | Format summary table of aov results 31 | } 32 | \examples{ 33 | 34 | data(Diabetes) 35 | f <- glm(bp.1s~age+chol+gender+location,data=Diabetes) 36 | publish(summary(aov(f)),digits=c(1,2)) 37 | 38 | } 39 | -------------------------------------------------------------------------------- /tests/TestBaselineTable.tex: -------------------------------------------------------------------------------- 1 | % Created 2012-03-22 Thu 06:41 2 | \documentclass[11pt]{article} 3 | \usepackage[utf8]{inputenc} 4 | \usepackage[T1]{fontenc} 5 | \usepackage{fixltx2e} 6 | \usepackage{graphicx} 7 | \usepackage{longtable} 8 | \usepackage{float} 9 | \usepackage{wrapfig} 10 | \usepackage{soul} 11 | \usepackage{textcomp} 12 | \usepackage{marvosym} 13 | \usepackage{wasysym} 14 | \usepackage{latexsym} 15 | \usepackage{amssymb} 16 | \usepackage{hyperref} 17 | \tolerance=1000 18 | \providecommand{\alert}[1]{\textbf{#1}} 19 | 20 | \title{library(Publish)} 21 | \author{Thomas Gerds} 22 | \date{\today} 23 | \hypersetup{ 24 | pdfkeywords={}, 25 | pdfsubject={}, 26 | pdfcreator={Emacs Org-mode version 7.8.03}} 27 | 28 | \begin{document} 29 | 30 | \maketitle 31 | 32 | \setcounter{tocdepth}{3} 33 | \tableofcontents 34 | \vspace*{1cm} 35 | library(Publish) 36 | d=data.frame(Y=rnorm(10),X=rbinom(10,1,.4),S=X=rbinom(10,1,.4)) 37 | BaselineTable(S\~{}Y+X,data=d) 38 | 39 | \end{document} -------------------------------------------------------------------------------- /R/parseFrequencyFormat.R: -------------------------------------------------------------------------------- 1 | parseFrequencyFormat <- function(format,digits){ 2 | tmp <- strsplit(format,"[ \t]+|[^ \t]*=|[^ \t]*:|[^ \t]*-|[^ \t]*\\+|\\(|\\{|\\[|\\)",perl=TRUE)[[1]] 3 | stats <- tmp[grep("^x$",tmp)-1] 4 | for(s in 1:length(stats)){ 5 | subs <- switch(stats[s], 6 | "count"="%s", 7 | "total"="%s", 8 | "percent"="%s", #paste("%1.",digits,"f",sep=""), 9 | "colpercent"="%s", #paste("%1.",digits,"f",sep=""), 10 | stop(paste("Cannot parse function ", 11 | stats[s], 12 | ". ", 13 | "Can only parse count, total and compute percentages for categorical variables", 14 | sep=""))) 15 | format <- gsub(paste(stats[s],"(x)",sep=""),subs,format,fixed=TRUE) 16 | } 17 | list(format=format,stats=stats) 18 | } 19 | -------------------------------------------------------------------------------- /R/print.ci.R: -------------------------------------------------------------------------------- 1 | ##' Print confidence intervals 2 | ##' 3 | ##' This format of the confidence intervals is user-manipulable. 4 | ##' @title Print confidence intervals 5 | ##' @param x Object containing point estimates and the corresponding 6 | ##' confidence intervals 7 | ##' @param se If \code{TRUE} add the standard error. 8 | ##' @param print Logical: if \code{FALSE} do not actually print 9 | ##' confidence intervals but just return them invisibly. 10 | ##' @param ... passed to summary.ci 11 | ##' @return A string: the formatted confidence intervals 12 | ##' @seealso ci plot.ci formatCI summary.ci 13 | ##' @examples 14 | ##' library(lava) 15 | ##' m <- lvm(Y~X) 16 | ##' m <- categorical(m,Y~X,K=4) 17 | ##' set.seed(4) 18 | ##' d <- sim(m,24) 19 | ##' ci.mean(Y~X,data=d) 20 | ##' x <- ci.mean(Y~X,data=d) 21 | ##' print(x,format="(l,u)") 22 | ##' @export 23 | ##' @author Thomas A. Gerds 24 | print.ci <- function(x,se=FALSE,print=TRUE,...){ 25 | summary(x,se=se,print=print,...) 26 | } 27 | -------------------------------------------------------------------------------- /man/publish.htest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.htest.R 3 | \name{publish.htest} 4 | \alias{publish.htest} 5 | \title{Pretty printing of test results.} 6 | \usage{ 7 | \method{publish}{htest}(object, title, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Result of \code{t.test} or \code{wilcox.test}} 11 | 12 | \item{title}{Decoration also used to name output} 13 | 14 | \item{...}{Used to transport arguments \code{ci.arg} and \code{pvalue.arg} to subroutines \code{format.pval} and \code{formatCI}. See also \code{prodlim::SmartControl}.} 15 | } 16 | \description{ 17 | Pretty printing of test results. 18 | } 19 | \examples{ 20 | data(Diabetes) 21 | publish(t.test(bp.2s~gender,data=Diabetes)) 22 | publish(wilcox.test(bp.2s~gender,data=Diabetes)) 23 | publish(with(Diabetes,t.test(bp.2s,bp.1s,paired=TRUE))) 24 | publish(with(Diabetes,wilcox.test(bp.2s,bp.1s,paired=TRUE))) 25 | 26 | } 27 | \author{ 28 | Thomas A. Gerds 29 | } 30 | -------------------------------------------------------------------------------- /data/SpaceT.csv: -------------------------------------------------------------------------------- 1 | "Status";"HR";"Treatment";"ID" 2 | "Post";61;1;1 3 | "Post";59;1;2 4 | "Post";47;1;3 5 | "Post";65;1;4 6 | "Post";69;1;5 7 | "Post";50;1;6 8 | "Post";51;1;7 9 | "Post";60;1;8 10 | "Post";57;1;9 11 | "Post";64;1;10 12 | "Post";67;1;11 13 | "Post";69;1;12 14 | "Post";72;1;13 15 | "Post";69;1;14 16 | "Post";72;1;15 17 | "Post";75;1;16 18 | "Post";77;1;17 19 | "Post";61;0;18 20 | "Post";66;0;19 21 | "Post";61;0;20 22 | "Post";68;0;21 23 | "Post";77;0;22 24 | "Post";103;0;23 25 | "Post";77;0;24 26 | "Post";80;0;25 27 | "Post";79;0;26 28 | "Pre";71;1;1 29 | "Pre";65;1;2 30 | "Pre";52;1;3 31 | "Pre";68;1;4 32 | "Pre";69;1;5 33 | "Pre";49;1;6 34 | "Pre";49;1;7 35 | "Pre";57;1;8 36 | "Pre";51;1;9 37 | "Pre";55;1;10 38 | "Pre";58;1;11 39 | "Pre";57;1;12 40 | "Pre";59;1;13 41 | "Pre";53;1;14 42 | "Pre";53;1;15 43 | "Pre";53;1;16 44 | "Pre";48;1;17 45 | "Pre";61;0;18 46 | "Pre";59;0;19 47 | "Pre";52;0;20 48 | "Pre";54;0;21 49 | "Pre";53;0;22 50 | "Pre";78;0;23 51 | "Pre";52;0;24 52 | "Pre";54;0;25 53 | "Pre";52;0;26 54 | -------------------------------------------------------------------------------- /R/getPyntDefaults.R: -------------------------------------------------------------------------------- 1 | ### getPyntDefaults.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Feb 26 2015 (06:54) 5 | ## Version: 6 | ## last-updated: Feb 26 2015 (07:20) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 10 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | getPyntDefaults <- function(call,names){ 18 | call <- as.list(call) 19 | pub.args <- call[match(names(names),names(call),nomatch=FALSE)] 20 | pynt <- lapply(names(names),function(n){ 21 | if (length(pa <- pub.args[[n]])>0) 22 | eval(pa) 23 | else 24 | names[[n]] 25 | }) 26 | names(pynt) <- names(names) 27 | pynt 28 | } 29 | #---------------------------------------------------------------------- 30 | ### getPyntDefaults.R ends here 31 | -------------------------------------------------------------------------------- /tests/test-publish.R: -------------------------------------------------------------------------------- 1 | ### test-publish.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Brice Ozenne 4 | ## created: apr 6 2017 (10:04) 5 | ## Version: 6 | ## last-updated: Aug 14 2017 (19:29) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 10 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | library(testthat) 18 | library(Publish) 19 | context("publish: default and matrix") 20 | 21 | test_that("publish rounding of a matrix with NA", { 22 | set.seed(7) 23 | y0 <- cbind(a=rnorm(2),b=1:2,c=letters[1:2]) 24 | y1 <- y0 25 | y1[1,1] <- NA 26 | y1[2,2] <- NA 27 | b <- publish(y1,digits=1) 28 | expect_equal(c(b),c(" NA","-1.2","1.0"," NA","a","b")) 29 | }) 30 | 31 | 32 | #---------------------------------------------------------------------- 33 | ### test-publish.R ends here 34 | -------------------------------------------------------------------------------- /R/publish.R: -------------------------------------------------------------------------------- 1 | ##' Publish provides summary functions for data 2 | ##' and results of statistical analysis in ready-for-publication 3 | ##' design 4 | ##' 5 | ##' Some warnings are currently suppressed. 6 | ##' @title Publishing tables and figures 7 | ##' @param object object to be published 8 | ##' @param ... Passed to method. 9 | #' @importFrom survival Surv coxph 10 | #' @importFrom prodlim Hist getEvent 11 | #' @importFrom data.table set 12 | #' @importFrom grDevices dev.size 13 | #' @importFrom graphics abline par plot polygon rect segments strwidth 14 | #' @importFrom stats anova binom.test binomial chisq.test coef confint delete.response fisher.test get_all_vars glm kruskal.test model.frame model.response na.omit na.pass naprint pchisq pt qnorm qt quantile symnum terms update update.formula var 15 | ##' @seealso publish.CauseSpecificCox publish.ci publish.coxph publish.glm publish.riskRegression publish.survdiff 16 | ##' @return Tables and figures 17 | ##' @author Thomas A. Gerds 18 | ##' @export 19 | publish <- function (object, ...) { 20 | UseMethod("publish") 21 | } 22 | -------------------------------------------------------------------------------- /man/ci.mean.default.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ci.mean.default.R 3 | \name{ci.mean.default} 4 | \alias{ci.mean.default} 5 | \title{Compute mean values with confidence intervals} 6 | \usage{ 7 | \method{ci.mean}{default}( 8 | x, 9 | alpha = 0.05, 10 | normal = TRUE, 11 | na.rm = TRUE, 12 | statistic = "arithmetic", 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{x}{numeric vector} 18 | 19 | \item{alpha}{level of significance} 20 | 21 | \item{normal}{If \code{TRUE} use quantile of t-distribution else use normal approximation and quantile of normal approximation. Do you think this is confusing?} 22 | 23 | \item{na.rm}{If \code{TRUE} remove missing values from \code{x}.} 24 | 25 | \item{statistic}{Decide which mean to compute: either \code{"arithmetic"} or \code{"geometric"}} 26 | 27 | \item{...}{not used} 28 | } 29 | \value{ 30 | a list with mean values and confidence limits 31 | } 32 | \description{ 33 | Compute mean values with confidence intervals 34 | } 35 | \details{ 36 | Normal approximation 37 | } 38 | \author{ 39 | Thomas Gerds 40 | } 41 | -------------------------------------------------------------------------------- /R/ci.mean.formula.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | ci.mean.formula <- function(x, 3 | data, 4 | alpha = 0.05, 5 | normal = TRUE, 6 | na.rm=T, 7 | statistic=c("arithmetic","geometric"),...){ 8 | work <- model.frame(x,data) 9 | nf <- ncol(work)-1 10 | if (nf>1) f <- interaction(work[,-1,drop=FALSE],sep=" - ") 11 | else f <- factor(work[,2]) 12 | res <- lapply(split(model.response(work),f),ci.mean.default,alpha=alpha,normal=normal,na.rm=na.rm,statistic=statistic) 13 | statistic <- unique(unlist(lapply(res,function(x)x$statistic))) 14 | labels <- do.call("rbind",strsplit(names(res)," - ")) 15 | colnames(labels) <- names(work)[-1] 16 | ## we reverse the order of factors for nicer labeling ... 17 | labels <- labels[,rev(1:nf),drop=FALSE] 18 | res <- data.frame(do.call("rbind",res)) 19 | out <- lapply(res[,1:4],function(x)unlist(x)) 20 | out <- c(out,list(labels=labels,level=alpha,statistic=statistic)) 21 | class(out) <- c("ci",class(out)) 22 | out 23 | } 24 | -------------------------------------------------------------------------------- /man/print.ci.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.ci.R 3 | \name{print.ci} 4 | \alias{print.ci} 5 | \title{Print confidence intervals} 6 | \usage{ 7 | \method{print}{ci}(x, se = FALSE, print = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object containing point estimates and the corresponding 11 | confidence intervals} 12 | 13 | \item{se}{If \code{TRUE} add the standard error.} 14 | 15 | \item{print}{Logical: if \code{FALSE} do not actually print 16 | confidence intervals but just return them invisibly.} 17 | 18 | \item{...}{passed to summary.ci} 19 | } 20 | \value{ 21 | A string: the formatted confidence intervals 22 | } 23 | \description{ 24 | Print confidence intervals 25 | } 26 | \details{ 27 | This format of the confidence intervals is user-manipulable. 28 | } 29 | \examples{ 30 | library(lava) 31 | m <- lvm(Y~X) 32 | m <- categorical(m,Y~X,K=4) 33 | set.seed(4) 34 | d <- sim(m,24) 35 | ci.mean(Y~X,data=d) 36 | x <- ci.mean(Y~X,data=d) 37 | print(x,format="(l,u)") 38 | } 39 | \seealso{ 40 | ci plot.ci formatCI summary.ci 41 | } 42 | \author{ 43 | Thomas A. Gerds 44 | } 45 | -------------------------------------------------------------------------------- /R/publish.table.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.table <- function(object,title,level,...){ 3 | if ((NM=length(dim(object)))==3){ 4 | if (missing(title)) title <- "" 5 | stopifnot(NM<=4) 6 | invisibleOut=lapply(1:(dim(object)[NM]),function(m){ 7 | newtitle=paste(title,paste(names(dimnames(object))[NM],dimnames(object)[[NM]][m],sep=":")) 8 | xm <- object[,,m] 9 | colnames(xm) <- paste(names(dimnames(object))[2],dimnames(object)[[2]],sep=":") 10 | rownames(xm) <- paste(names(dimnames(object))[1],dimnames(object)[[1]],sep=":") 11 | publish(xm,title=newtitle,level=level) 12 | }) 13 | } 14 | else{ 15 | v <- as.matrix(object) 16 | nn <- names(dimnames(v)) 17 | if (is.null(nn)) 18 | if (is.matrix(object)) nn <- paste("Var",1:2,sep=".") 19 | else nn <- "Var.1" 20 | nn[nn==""] <- paste("Var",(1:length(nn))[nn==""],sep=".") 21 | rownames <- TRUE 22 | ## if (missing(title)) title <- paste("Frequency table:",nn[1],"versus",nn[2],sep=" ") 23 | if (missing(title)) title <- "" 24 | if (missing(level)) level <- 0 25 | publish.matrix(v,title,level=level,rownames=rownames,...) 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /man/lazyFactorCoding.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lazyFactorCoding.R 3 | \name{lazyFactorCoding} 4 | \alias{lazyFactorCoding} 5 | \title{Efficient coding of factor levels} 6 | \usage{ 7 | lazyFactorCoding(data, max.levels = 10) 8 | } 9 | \arguments{ 10 | \item{data}{Data frame in which to search for categorical variables.} 11 | 12 | \item{max.levels}{Treat non-factor variables only if the number of unique values less than max.levels. Defaults to 10.} 13 | } 14 | \value{ 15 | R-code one line for each variable. 16 | } 17 | \description{ 18 | This function eases the process of generating factor variables 19 | with relevant labels. All variables in a data.frame with less than 20 | a user set number of levels result in a line which suggests levels and 21 | labels. The result can then be modified for use. 22 | } 23 | \details{ 24 | The code needs to be copy-and-pasted from the R-output 25 | buffer into the R-code buffer. This can be customized 26 | for the really efficiently working people e.g. in emacs. 27 | } 28 | \examples{ 29 | data(Diabetes) 30 | lazyFactorCoding(Diabetes) 31 | 32 | } 33 | \author{ 34 | Thomas Alexander Gerds 35 | } 36 | -------------------------------------------------------------------------------- /man/table2x2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/table2x2.R 3 | \name{table2x2} 4 | \alias{table2x2} 5 | \title{2x2 table calculus for teaching} 6 | \usage{ 7 | table2x2( 8 | x, 9 | digits = 1, 10 | conf.level = 0.95, 11 | stats = c("table", "rd", "rr", "or", "chisq", "fisher") 12 | ) 13 | } 14 | \arguments{ 15 | \item{x}{2x2 table} 16 | 17 | \item{digits}{rounding digits} 18 | 19 | \item{conf.level}{Confidence level used for constructing confidence intervals. Default is 0.95.} 20 | 21 | \item{stats}{subset or all of \code{c("table","rd","or","rr","chisq","fisher")} where rd= risk difference, rr = risk ratio, or = odds ratio, chisq = chi-square test, fisher= fisher's exact test and table = the 2x2 table} 22 | } 23 | \value{ 24 | see example 25 | } 26 | \description{ 27 | 2x2 table calculus for teaching 28 | } 29 | \details{ 30 | 2x2 table calculus for teaching 31 | } 32 | \examples{ 33 | table2x2(table("marker"=rbinom(100,1,0.4),"response"=rbinom(100,1,0.1))) 34 | table2x2(matrix(c(71,18,38,8),ncol=2),stats="table") 35 | table2x2(matrix(c(71,18,38,8),ncol=2),stats=c("rr","fisher")) 36 | } 37 | \author{ 38 | Thomas A. Gerds 39 | } 40 | -------------------------------------------------------------------------------- /man/pubformat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pubformat.R 3 | \name{pubformat} 4 | \alias{pubformat} 5 | \title{Format numbers for publication} 6 | \usage{ 7 | pubformat(x, digits = 2, nsmall = digits, handler = "sprintf", ...) 8 | } 9 | \arguments{ 10 | \item{x}{numeric vector} 11 | 12 | \item{digits}{number of digits} 13 | 14 | \item{nsmall}{see handler} 15 | 16 | \item{handler}{String specififying the name of the function which should 17 | perform the formatting. See \code{sprintf}, \code{format} and \code{prettyNum}.} 18 | 19 | \item{...}{Passed to handler function if applicable, i.e., not to \code{sprintf}.} 20 | } 21 | \value{ 22 | Formatted number 23 | } 24 | \description{ 25 | Format numbers according to a specified handler function. 26 | Currently supported are sprintf, format and prettyNum. 27 | } 28 | \examples{ 29 | 30 | pubformat(c(0.000143,12.8,1)) 31 | pubformat(c(0.000143,12.8,1),handler="format") 32 | pubformat(c(0.000143,12.8,1),handler="format",trim=TRUE) 33 | pubformat(c(0.000143,12.8,1),handler="prettyNum") 34 | } 35 | \seealso{ 36 | \code{sprintf}, \code{format}, \code{prettyNum} 37 | } 38 | \author{ 39 | Thomas A. Gerds 40 | } 41 | -------------------------------------------------------------------------------- /man/SpaceT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish-package.R 3 | \docType{data} 4 | \name{SpaceT} 5 | \alias{SpaceT} 6 | \title{A study was made of all 26 astronauts on the first eight space shuttle flights (Bungo et.al., 1985). 7 | On a voluntary basis 17 astronauts consumed large quantities of salt and fluid prior to landing as 8 | a countermeasure to space deconditioning, while nine did not.} 9 | \format{ 10 | A data frame with 52 observations on the following 4 variables: 11 | \describe{ 12 | \item{Status}{Factor with levels Post (after flight) and Pre (before flight)} 13 | \item{HR}{Supine heart rate(beats per minute)} 14 | \item{Treatment}{Countermeasure salt/fluid (1= yes, 0=no)} 15 | \item{ID}{Person id} 16 | } 17 | } 18 | \description{ 19 | A study was made of all 26 astronauts on the first eight space shuttle flights (Bungo et.al., 1985). 20 | On a voluntary basis 17 astronauts consumed large quantities of salt and fluid prior to landing as 21 | a countermeasure to space deconditioning, while nine did not. 22 | } 23 | \examples{ 24 | data(SpaceT) 25 | } 26 | \references{ 27 | Altman, Practical statistics for medical research, Page 223, Ex. 9.1. 28 | Bungo et.al., 1985 29 | } 30 | -------------------------------------------------------------------------------- /man/labelUnits.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/labelUnits.R 3 | \name{labelUnits} 4 | \alias{labelUnits} 5 | \title{labelUnits} 6 | \usage{ 7 | labelUnits(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{A matrix obtained with \code{univariateTable}.} 11 | 12 | \item{...}{not used} 13 | } 14 | \value{ 15 | The re-labeled matrix 16 | } 17 | \description{ 18 | Label output tables 19 | } 20 | \details{ 21 | Modify labels and values of variables in summary tables 22 | } 23 | \examples{ 24 | 25 | data(Diabetes) 26 | tab <- summary(univariateTable(gender~AgeGroups+chol+waist,data=Diabetes)) 27 | publish(tab) 28 | ltab <- labelUnits(tab,"chol"="Cholesterol (mg/dL)","<40"="younger than 40") 29 | publish(ltab) 30 | 31 | ## pass labels immediately to utable 32 | utable(gender~AgeGroups+chol+waist,data=Diabetes, 33 | "chol"="Cholesterol (mg/dL)","<40"="younger than 40") 34 | 35 | ## sometimes useful to state explicitly which variables value 36 | ## should be re-labelled 37 | utable(gender~AgeGroups+chol+waist,data=Diabetes, 38 | "chol"="Cholesterol (mg/dL)","AgeGroups.<40"="younger than 40") 39 | } 40 | \seealso{ 41 | univariateTable 42 | } 43 | \author{ 44 | Thomas A. Gerds 45 | } 46 | -------------------------------------------------------------------------------- /man/publish.riskRegression.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.riskRegression.R 3 | \name{publish.riskRegression} 4 | \alias{publish.riskRegression} 5 | \title{Publishing results of riskRegression} 6 | \usage{ 7 | \method{publish}{riskRegression}(object, digits = c(2, 4), print = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{object}{object of class riskRegression as obtained with 11 | functions ARR and LRR.} 12 | 13 | \item{digits}{Number of digits for regression coefficients} 14 | 15 | \item{print}{If \code{FALSE} do not print the results} 16 | 17 | \item{...}{passed to \code{\link{publish.matrix}}} 18 | } 19 | \value{ 20 | Table with regression coefficients, confidence intervals and p-values 21 | } 22 | \description{ 23 | Preparing a publishable table from riskRegression results 24 | } 25 | \examples{ 26 | if (requireNamespace("riskRegression",quietly=TRUE)){ 27 | library(riskRegression) 28 | library(prodlim) 29 | library(lava) 30 | library(survival) 31 | set.seed(20) 32 | d <- SimCompRisk(20) 33 | f <- ARR(Hist(time,event)~X1+X2,data=d,cause=1) 34 | publish(f) 35 | publish(f,digits=c(1,3)) 36 | } 37 | } 38 | \seealso{ 39 | ARR LRR 40 | } 41 | \author{ 42 | Thomas A. Gerds 43 | } 44 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: Publish 2 | Type: Package 3 | Title: Format Output of Various Routines in a Suitable Way for Reports and Publication 4 | Description: A bunch of convenience functions that transform the results of some basic statistical analyses 5 | into table format nearly ready for publication. This includes descriptive tables, tables of 6 | logistic regression and Cox regression results as well as forest plots. 7 | Version: 2025.01.02 8 | Authors@R: c(person("Thomas A.", "Gerds", role = c("aut", "cre"), 9 | email = "tag@biostat.ku.dk"), 10 | person("Christian", "Torp-Pedersen", role = "ctb"), 11 | person("Klaus", "K Holst", role = "ctb"), 12 | person("Brice", "Ozenne", role = "aut", 13 | email = "broz@sund.ku.dk")) 14 | Maintainer: Thomas A. Gerds 15 | Depends: 16 | prodlim (>= 1.5.4) 17 | Imports: 18 | survival (>= 2.38), 19 | data.table (>= 1.10.4), 20 | lava (>= 1.5.1), 21 | multcomp (>= 1.4) 22 | Suggests: 23 | riskRegression (>= 2020.09.07), 24 | testthat, 25 | smcfcs (>= 1.4.1), 26 | rms (>= 6.1.0), 27 | mitools (>= 2.4), 28 | nlme (>= 3.1-131) 29 | License: GPL (>= 2) 30 | RoxygenNote: 7.3.2 31 | -------------------------------------------------------------------------------- /tests/test-glmSeries.R: -------------------------------------------------------------------------------- 1 | ### test-glmSeries.R --- 2 | #---------------------------------------------------------------------- 3 | ## Author: Thomas Alexander Gerds 4 | ## Created: Feb 10 2018 (12:44) 5 | ## Version: 6 | ## Last-Updated: Feb 10 2018 (18:37) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 2 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | library(testthat) 18 | library(Publish) 19 | library(data.table) 20 | data(Diabetes) 21 | 22 | test_that("glmSeries missing data, data.table ",{ 23 | Diabetes <- as.data.frame(Diabetes) 24 | Diabetes$hypertension <- factor(Diabetes$bp.1s>140) 25 | a <- glmSeries(vars=c("bp.2s","frame","weight","age"),formula=hypertension~gender,data=Diabetes,family=binomial) 26 | expect_equal(a$Missing,c(262,12,"","","1","0")) 27 | setDT(Diabetes) 28 | b <- glmSeries(vars=c("bp.2s","frame","weight","age"),formula=hypertension~gender,data=Diabetes,family=binomial) 29 | expect_equal(a,b) 30 | }) 31 | 32 | 33 | 34 | ###################################################################### 35 | ### test-glmSeries.R ends here 36 | -------------------------------------------------------------------------------- /man/lazyDateCoding.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lazyDateCoding.R 3 | \name{lazyDateCoding} 4 | \alias{lazyDateCoding} 5 | \title{Efficient coding of date variables} 6 | \usage{ 7 | lazyDateCoding(data, format, pattern, varnames, testlength = 10) 8 | } 9 | \arguments{ 10 | \item{data}{Data frame in which to search for date variables.} 11 | 12 | \item{format}{passed to as.Date} 13 | 14 | \item{pattern}{match date variables} 15 | 16 | \item{varnames}{variable names} 17 | 18 | \item{testlength}{how many rows of data should be evaluated to guess the format.} 19 | } 20 | \value{ 21 | R-code one line for each variable. 22 | } 23 | \description{ 24 | This function eases the process of generating date variables. 25 | All variables in a data.frame which match a regular expression 26 | are included 27 | } 28 | \details{ 29 | The code needs to be copy-and-pasted from the R-output 30 | buffer into the R-code buffer. This can be customized 31 | for the really efficiently working people, e.g., in emacs. 32 | } 33 | \examples{ 34 | d <- data.frame(x0="190101",x1=c("12/8/2019"),x2="12-8-2019",x3="20190812",stringsAsFactors=FALSE) 35 | lazyDateCoding(d,pattern="x") 36 | lazyDateCoding(d,pattern="3") 37 | 38 | } 39 | \author{ 40 | Thomas Alexander Gerds 41 | } 42 | -------------------------------------------------------------------------------- /man/publish.ci.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.ci.R 3 | \name{publish.ci} 4 | \alias{publish.ci} 5 | \title{Publish tables with confidence intervals} 6 | \usage{ 7 | \method{publish}{ci}(object, format = "[u;l]", se = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Object of class ci containing point estimates and the 11 | corresponding confidence intervals} 12 | 13 | \item{format}{A string which indicates the format used for 14 | confidence intervals. The string is passed to 15 | \code{\link{formatCI}} with two arguments: the lower and the upper 16 | limit. For example \code{'(l;u)'} yields confidence intervals with 17 | round parenthesis in which the upper and the lower limits are 18 | separated by semicolon.} 19 | 20 | \item{se}{If \code{TRUE} add standard error.} 21 | 22 | \item{...}{passed to \code{publish}} 23 | } 24 | \value{ 25 | table with confidence intervals 26 | } 27 | \description{ 28 | Publish tables with confidence intervals 29 | } 30 | \details{ 31 | This function calls summary.ci with print=FALSE and then publish 32 | } 33 | \examples{ 34 | 35 | data(Diabetes) 36 | publish(ci.mean(chol~location+gender,data=Diabetes),org=TRUE) 37 | 38 | } 39 | \seealso{ 40 | summary.ci 41 | } 42 | \author{ 43 | Thomas A. Gerds 44 | } 45 | -------------------------------------------------------------------------------- /man/traceR.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish-package.R 3 | \docType{data} 4 | \name{traceR} 5 | \alias{traceR} 6 | \title{traceR data} 7 | \format{ 8 | A data frame with 1749 observations on the following variables. 9 | \describe{ 10 | \item{weight}{Weight in kilo} 11 | \item{height}{Height in meters} 12 | \item{abdominalCircumference}{in centimeters} 13 | \item{seCreatinine}{in mmol per liter} 14 | \item{wallMotionIndex}{left ventricular function 0-2, 0 worst, 2 normal} 15 | \item{observationTime}{time to death or censor} 16 | \item{age}{age in years} 17 | \item{sex}{0=female,1=male} 18 | \item{smoking}{0=never,1=prior,2=current} 19 | \item{dead}{0=censor,1=dead} 20 | \item{treatment}{placebo or trandolapril} 21 | 22 | } 23 | } 24 | \description{ 25 | These data are from the TRACE randomised trial, a comparison between the angiotensin converting 26 | enzyme inhibitor trandolapril and placebo ford large myocardial infarctions. In all, 1749 patients 27 | were randomised. The current data are from a 15 year follow-up. 28 | } 29 | \examples{ 30 | 31 | data(trace) 32 | Units(trace,list("age"="years")) 33 | fit <- glm(dead ~ smoking+sex+age+Time+offset(log(ObsTime)), family="poisson",data=trace) 34 | rtf <- regressionTable(fit,factor.reference = "inline") 35 | summary(rtf) 36 | publish(fit) 37 | 38 | } 39 | \references{ 40 | Kober et al 1995 NEJM 333,1670 41 | } 42 | \keyword{datasets} 43 | -------------------------------------------------------------------------------- /R/publish.prodlim.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | publish.prodlim <- function(object,times,intervals=TRUE,percent=TRUE,digits=ifelse(percent,1,3),cause=1,surv=TRUE,print=TRUE,...){ 3 | if (missing(times)) stop("Argument times is missing with no default.") 4 | so <- summary(object,times=times,intervals=intervals,percent=percent,cause=cause,surv=surv) 5 | data.table::setDT(so) 6 | if (match("cuminc",colnames(so),nomatch=FALSE)==0){ 7 | nn = "surv" 8 | se = "se.surv" 9 | NN = "Survival probability" 10 | data.table::set(so,j = "Survival probability",value = format(so[["surv"]],digits=digits,nsmall=digits)) 11 | } else{ 12 | nn = "cuminc" 13 | se = "se.cuminc" 14 | NN = "Absolute risk" 15 | data.table::set(so,j = "Absolute risk",value = format(so[["cuminc"]],digits=digits,nsmall=digits)) 16 | } 17 | data.table::set(so,j = "Interval", value = apply(format(so[,c("time0","time1"),drop=FALSE],digits=digits,nsmall=digits),1,paste,collapse="--")) 18 | data.table::set(so,j = "CI.95", value = formatCI(lower = so[["lower"]],upper = so[["upper"]],digits=digits,nsmall=digits)) 19 | for (n in c("time0","time1","lower","upper",nn,se)) data.table::set(so,j = n,value = NULL) 20 | vv = c("Interval",NN,"CI.95") 21 | not_vv = setdiff(names(so),vv) 22 | data.table::setcolorder(so,c(not_vv,vv)) 23 | if (print==TRUE){ 24 | publish(so,rownames=FALSE,...) 25 | } 26 | invisible(so) 27 | } 28 | -------------------------------------------------------------------------------- /man/fixRegressionTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fixRegressionTable.R 3 | \name{fixRegressionTable} 4 | \alias{fixRegressionTable} 5 | \title{Expand regression coefficient table} 6 | \usage{ 7 | fixRegressionTable( 8 | x, 9 | varnames, 10 | reference.value, 11 | reference.style = NULL, 12 | factorlevels, 13 | scale = NULL, 14 | nmiss, 15 | intercept 16 | ) 17 | } 18 | \arguments{ 19 | \item{x}{object resulting from \code{lm}, \code{glm} or \code{coxph}.} 20 | 21 | \item{varnames}{Names of variables} 22 | 23 | \item{reference.value}{Reference value for reference categories} 24 | 25 | \item{reference.style}{Style for showing results for categorical 26 | variables. If \code{"extraline"} show an additional line for the 27 | reference category.} 28 | 29 | \item{factorlevels}{Levels of the categorical variables.} 30 | 31 | \item{scale}{Scale for some or all of the variables} 32 | 33 | \item{nmiss}{Number of missing values} 34 | 35 | \item{intercept}{Intercept} 36 | } 37 | \value{ 38 | a table with regression coefficients 39 | } 40 | \description{ 41 | Expand regression coefficient table 42 | } 43 | \details{ 44 | This function expands results from "regressionTable" with 45 | extralines and columns 46 | 47 | For factor variables the reference group is shown. 48 | For continuous variables the units are shown and 49 | for transformed continuous variables also the scale. 50 | For all variables the numbers of missing values are added. 51 | } 52 | \author{ 53 | Thomas Alexander Gerds 54 | } 55 | -------------------------------------------------------------------------------- /R/publish.riskRegression.R: -------------------------------------------------------------------------------- 1 | ##' Preparing a publishable table from riskRegression results 2 | ##' 3 | ##' 4 | ##' @title Publishing results of riskRegression 5 | ##' @param object object of class riskRegression as obtained with 6 | ##' functions ARR and LRR. 7 | ##' @param digits Number of digits for regression coefficients 8 | ##' @param print If \code{FALSE} do not print the results 9 | ##' @param ... passed to \code{\link{publish.matrix}} 10 | ##' @return Table with regression coefficients, confidence intervals and p-values 11 | ##' @seealso ARR LRR 12 | ##' @examples 13 | ##' if (requireNamespace("riskRegression",quietly=TRUE)){ 14 | ##' library(riskRegression) 15 | ##' library(prodlim) 16 | ##' library(lava) 17 | ##' library(survival) 18 | ##' set.seed(20) 19 | ##' d <- SimCompRisk(20) 20 | ##' f <- ARR(Hist(time,event)~X1+X2,data=d,cause=1) 21 | ##' publish(f) 22 | ##' publish(f,digits=c(1,3)) 23 | ##' } 24 | ##' @export 25 | ##' @author Thomas A. Gerds 26 | publish.riskRegression <- function(object, 27 | digits=c(2,4), 28 | print=TRUE, 29 | ...) { 30 | if (length(digits)==1) digits <- rep(digits,2) 31 | sv <- summary(object,verbose=FALSE,digits=digits[[1]],eps=10^{-digits[[2]]}) 32 | out <- sv[,c("Factor","exp(Coef)","CI_95","Pvalue")] 33 | modeltype <- if (as.name("LRR")==object$call[[1]]) "LRR" else "ARR" 34 | colnames(out) <- c("Factor",modeltype,"CI_95","p-value") 35 | if (print) publish(out,...) 36 | invisible(out) 37 | } 38 | -------------------------------------------------------------------------------- /man/trace.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish-package.R 3 | \docType{data} 4 | \name{trace} 5 | \alias{trace} 6 | \title{trace data} 7 | \format{ 8 | A data frame with 1832 observations on the following 6 variables. 9 | \describe{ 10 | \item{Time}{Time after myocardial infarction, in 6 months intervals} 11 | \item{smoking}{Smoking status. A factor with levels (Never, Current, Previous)} 12 | \item{sex}{A factor with levels (Female, Male)} 13 | \item{age}{Age in years at the time of myocardial infarction} 14 | \item{ObsTime}{Cumulative risk time in each split} 15 | \item{dead}{Count of deaths} 16 | } 17 | } 18 | \description{ 19 | These data are from screening to the TRACE study, a comparison between the angiotensin converting 20 | enzyme inhibitor trandolapril and placebo ford large myocardial infarctions. A total of 6676 21 | patients were screened for the study. Survival has been followed for the screened population for 22 | 16 years. The current data has been prepared for a poisson regression to examine survival. The data 23 | has been "split" in 0.5 year intervals (plitLexis function from Epi package) and then collapsed 24 | on all variables (aggregate function). 25 | } 26 | \examples{ 27 | 28 | data(trace) 29 | Units(trace,list("age"="years")) 30 | fit <- glm(dead ~ smoking+sex+age+Time+offset(log(ObsTime)), family="poisson",data=trace) 31 | rtf <- regressionTable(fit,factor.reference = "inline") 32 | summary(rtf) 33 | publish(fit) 34 | 35 | } 36 | \references{ 37 | Kober et al 1995 Am. J. Cardiol 76,1-5 38 | } 39 | \keyword{datasets} 40 | -------------------------------------------------------------------------------- /tests/test-regressionTable.R: -------------------------------------------------------------------------------- 1 | ### test-regressionTable.R --- 2 | #---------------------------------------------------------------------- 3 | ## Author: Thomas Alexander Gerds 4 | ## Created: Aug 13 2017 (07:39) 5 | ## Version: 6 | ## Last-Updated: Nov 3 2019 (19:32) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 6 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | library(testthat) 18 | library(Publish) 19 | data(Diabetes) 20 | 21 | test_that("regressiontable: transformed variables and factor levels",{ 22 | Diabetes$hyp1 <- factor(1*(Diabetes$bp.1s>140)) 23 | Diabetes$ofak <- ordered(sample(letters[1:11],size=NROW(Diabetes),replace=1L)) 24 | levels(Diabetes$frame) <- c("+large","medi()um=.<",">8") 25 | f <- glm(hyp1~frame+gender+log(age)+I(chol>245)+ofak,data=Diabetes,family="binomial") 26 | regressionTable(f) 27 | summary(regressionTable(f)) 28 | }) 29 | 30 | test_that("plot.regressionTable",{ 31 | Diabetes$hyp1 <- factor(1*(Diabetes$bp.1s>140)) 32 | Diabetes$ofak <- ordered(sample(letters[1:11],size=NROW(Diabetes),replace=1L)) 33 | levels(Diabetes$frame) <- c("+large","medi()um=.<",">8") 34 | f <- glm(hyp1~frame+gender+log(age)+I(chol>245)+ofak,data=Diabetes,family="binomial") 35 | f <- glm(hyp1~log(age)+I(chol>245),data=Diabetes,family="binomial") 36 | u <- regressionTable(f) 37 | plot(u) 38 | }) 39 | 40 | ###################################################################### 41 | ### test-regressionTable.R ends here 42 | -------------------------------------------------------------------------------- /R/ci.mean.default.R: -------------------------------------------------------------------------------- 1 | ##' Compute mean values with confidence intervals 2 | ##' 3 | ##' Normal approximation 4 | ##' @title Compute mean values with confidence intervals 5 | #' @param x numeric vector 6 | #' @param alpha level of significance 7 | #' @param normal If \code{TRUE} use quantile of t-distribution else use normal approximation and quantile of normal approximation. Do you think this is confusing? 8 | #' @param na.rm If \code{TRUE} remove missing values from \code{x}. 9 | #' @param statistic Decide which mean to compute: either \code{"arithmetic"} or \code{"geometric"} 10 | #' @param ... not used 11 | ##' @return a list with mean values and confidence limits 12 | ##' @author Thomas Gerds 13 | #' @export 14 | ci.mean.default <- function(x, 15 | alpha = 0.05, 16 | normal = TRUE, 17 | na.rm=TRUE, 18 | statistic="arithmetic",...){ 19 | stat <- match.arg(statistic,c("arithmetic","geometric")) 20 | if (na.rm){x <- x[!is.na(x)]} 21 | if (stat=="geometric") x <- log(x) 22 | n <- length(x) 23 | m <- mean(x) 24 | se <- sqrt(var(x)/n) 25 | df <- n - 1 26 | if(normal) { 27 | q <- qt(1 - alpha/2, df) 28 | } 29 | else { 30 | q <- qnorm(1 - alpha/2) 31 | } 32 | low <- m - se * q 33 | up <- m + se * q 34 | if (stat=="geometric") 35 | out <- list(geomean = exp(m), se = exp(se),lower = exp(low), upper = exp(up), level=alpha, statistic=stat) 36 | else 37 | out <- list(mean = m, se = se,lower = low, upper = up, level=alpha, statistic=stat) 38 | class(out) <- c("ci",class(out)) 39 | out 40 | } 41 | -------------------------------------------------------------------------------- /R/parseSummaryFormat.R: -------------------------------------------------------------------------------- 1 | parseSummaryFormat <- function(format,digits){ 2 | S <- function(x,format,digits,nsmall){x} 3 | F <- function(x,ref,digits,nsmall){x} 4 | iqr <- function(x)quantile(x,c(0.25,0.75)) 5 | minmax <- function(x)quantile(x,c(0,1)) 6 | CI.95 <- function(x,sep=",",...){ 7 | m <- ci.mean.default(x,...) 8 | paste(format(m$lower,digits=digits,nsmall=digits), 9 | sep," ", 10 | format(m$upper,digits=digits,nsmall=digits)) 11 | } 12 | ## format.numeric <- paste("%1.",digits,"f",sep="") 13 | tmp <- strsplit(format,"[ \t]+|\\(|\\{|\\[|\\)",perl=TRUE)[[1]] 14 | stats <- tmp[grep("^x$",tmp)-1] 15 | outclass <- sapply(stats,function(s)class(do.call(s,list(1:2)))) 16 | outlen <- sapply(stats,function(s)length(do.call(s,list(1:2)))) 17 | for(s in 1:length(stats)){ 18 | subs <- "%s" 19 | if(!(outlen[s]%in%c(1,2))) 20 | stop(paste("The function",stats[s],"returns",outlen[s],"values (can be 1 or 2)")) 21 | subs <- switch(as.character(outlen[s]), 22 | "1"={switch(outclass[s], 23 | "numeric"="%s", 24 | "integer"="%s", 25 | "%s")}, 26 | "2"={switch(outclass[s], 27 | "numeric"=paste("%s",", ","%s",sep=""), 28 | "integer"=paste("%s",", ","%s",sep=""), 29 | paste("%s",", ","%s",sep=""))}) 30 | format <- gsub(paste(stats[s],"(x)",sep=""),subs,format,fixed=TRUE) 31 | } 32 | list(format=format,stats=stats) 33 | } 34 | -------------------------------------------------------------------------------- /man/plot.subgroupAnalysis.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot.subgroupAnalysis.R 3 | \name{plot.subgroupAnalysis} 4 | \alias{plot.subgroupAnalysis} 5 | \title{plot.subgroupAnalysis} 6 | \usage{ 7 | \method{plot}{subgroupAnalysis}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{- a subgroupAnalysis object} 11 | 12 | \item{...}{- passed on to plotConfidence} 13 | } 14 | \description{ 15 | This function operates on a "subgroupAnalysis" object to produce a formatted 16 | table and a forest plot 17 | } 18 | \details{ 19 | This function produces a formatted table of a subgroupAnalysis object and 20 | adds a forest plot. If further details needs attention before plotting is 21 | is advisable use adjust the table produced by the summary function and then 22 | plotting with the plotConfidence function 23 | } 24 | \examples{ 25 | #load libraries 26 | library(Publish) 27 | library(survival) 28 | library(data.table) 29 | data(traceR) #get dataframe traceR 30 | setDT(traceR) 31 | traceR[,':='(wmi2=factor(wallMotionIndex<0.9,levels=c(TRUE,FALSE), 32 | labels=c("bad","good")), 33 | abd2=factor(abdominalCircumference<95, levels=c(TRUE,FALSE), 34 | labels=c("slim","fat")), 35 | sex=factor(sex))] 36 | fit_cox <- coxph(Surv(observationTime,dead)~treatment,data=traceR) 37 | # Selected subgroups - univariable analysis 38 | sub_cox <- subgroupAnalysis(fit_cox,traceR,treatment="treatment", 39 | subgroup=c("smoking","sex","wmi2","abd2")) # subgroups as character string 40 | plot(sub_cox) 41 | } 42 | \seealso{ 43 | subgroupAnalysis, plotConfidence 44 | } 45 | \author{ 46 | Christian Torp-Pedersen 47 | } 48 | -------------------------------------------------------------------------------- /man/publish.Score.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.Score.R 3 | \name{publish.Score} 4 | \alias{publish.Score} 5 | \title{Publish predictive accuracy results} 6 | \usage{ 7 | \method{publish}{Score}(object, metrics, score = TRUE, contrasts = TRUE, level = 3, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Object obtained with \code{riskRegression::Score}} 11 | 12 | \item{metrics}{Which metrics to put into tables. Defaults to 13 | \code{object$metrics}.} 14 | 15 | \item{score}{Logical. If \code{TRUE} print the score elements, i.e., metric applied to the risk prediction models.} 16 | 17 | \item{contrasts}{Logical. If \code{TRUE} print the contrast elements (if any). These compare risk prediction models according to metrics.} 18 | 19 | \item{level}{Level of subsection headers, i.e., ** for level 2 and 20 | *** for level 3 (useful for emacs org-users). Default is plain 21 | subsection headers no stars. A negative value will suppress 22 | subjection headers.} 23 | 24 | \item{...}{Passed to publish} 25 | } 26 | \value{ 27 | Results of Score in tabular form 28 | } 29 | \description{ 30 | Write output of \code{riskRegression::Score} in tables 31 | } 32 | \details{ 33 | Collect prediction accuracy results in tables 34 | } 35 | \examples{ 36 | if (requireNamespace("riskRegression",quietly=TRUE)){ 37 | library(riskRegression) 38 | library(survival) 39 | learn = sampleData(100) 40 | val= sampleData(100) 41 | f1=CSC(Hist(time,event)~X1+X8,data=learn) 42 | f2=CSC(Hist(time,event)~X1+X5+X6+X8,learn) 43 | xs=Score(list(f1,f2),data=val,formula=Hist(time,event)~1) 44 | publish(xs) 45 | } 46 | } 47 | \author{ 48 | Thomas A. Gerds 49 | } 50 | -------------------------------------------------------------------------------- /man/plot.regressionTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot.regressionTable.R 3 | \name{plot.regressionTable} 4 | \alias{plot.regressionTable} 5 | \title{Plotting regression coefficients with confidence limits} 6 | \usage{ 7 | \method{plot}{regressionTable}(x, xlim, xlab, style = 1, ...) 8 | } 9 | \arguments{ 10 | \item{x}{regression table obtained with regressionTable} 11 | 12 | \item{xlim}{Limits for x-axis} 13 | 14 | \item{xlab}{Label for x-axis} 15 | 16 | \item{style}{Determines how to arrange variable names and their corresponding units} 17 | 18 | \item{...}{passed to plotConfidence} 19 | } 20 | \description{ 21 | Plotting regression coefficients with confidence limits 22 | } 23 | \examples{ 24 | ## linear regression 25 | data(Diabetes) 26 | f <- glm(bp.1s~AgeGroups+chol+gender+location,data=Diabetes) 27 | rtf <- regressionTable(f,factor.reference = "inline") 28 | plot(rtf,cex=1.3) 29 | 30 | ## logistic regression 31 | data(Diabetes) 32 | f <- glm(I(BMI>25)~bp.1s+AgeGroups+chol+gender+location,data=Diabetes,family=binomial) 33 | rtf <- regressionTable(f,factor.reference = "inline") 34 | plot(rtf,cex=1.3) 35 | 36 | ## Poisson regression 37 | data(trace) 38 | fit <- glm(dead ~ smoking+ sex+ age+Time+offset(log(ObsTime)), family = poisson,data=trace) 39 | rtab <- regressionTable(fit,factor.reference = "inline") 40 | plot(rtab,xlim=c(0.85,1.15),cex=1.8,xaxis.cex=1.5) 41 | 42 | ## Cox regression 43 | library(survival) 44 | data(pbc) 45 | coxfit <- coxph(Surv(time,status!=0)~age+log(bili)+log(albumin)+factor(edema)+sex,data=pbc) 46 | pubcox <- publish(coxfit) 47 | plot(pubcox,cex=1.5,xratio=c(0.4,0.2)) 48 | 49 | } 50 | \seealso{ 51 | regressionTable 52 | } 53 | \author{ 54 | Thomas A. Gerds 55 | } 56 | -------------------------------------------------------------------------------- /R/plot.subgroupAnalysis.R: -------------------------------------------------------------------------------- 1 | #' @title plot.subgroupAnalysis 2 | #' @description 3 | #' This function operates on a "subgroupAnalysis" object to produce a formatted 4 | #' table and a forest plot 5 | #' @author Christian Torp-Pedersen 6 | #' @param x - a subgroupAnalysis object 7 | #' @param ... - passed on to plotConfidence 8 | #' @details 9 | #' This function produces a formatted table of a subgroupAnalysis object and 10 | #' adds a forest plot. If further details needs attention before plotting is 11 | #' is advisable use adjust the table produced by the summary function and then 12 | #' plotting with the plotConfidence function 13 | #' @return NULL 14 | #' @seealso subgroupAnalysis, plotConfidence 15 | #' @export 16 | #' @examples 17 | #' #load libraries 18 | #' library(Publish) 19 | #' library(survival) 20 | #' library(data.table) 21 | #' data(traceR) #get dataframe traceR 22 | #' setDT(traceR) 23 | #' traceR[,':='(wmi2=factor(wallMotionIndex<0.9,levels=c(TRUE,FALSE), 24 | #' labels=c("bad","good")), 25 | #' abd2=factor(abdominalCircumference<95, levels=c(TRUE,FALSE), 26 | #' labels=c("slim","fat")), 27 | #' sex=factor(sex))] 28 | #' fit_cox <- coxph(Surv(observationTime,dead)~treatment,data=traceR) 29 | #' # Selected subgroups - univariable analysis 30 | #' sub_cox <- subgroupAnalysis(fit_cox,traceR,treatment="treatment", 31 | #' subgroup=c("smoking","sex","wmi2","abd2")) # subgroups as character string 32 | #' plot(sub_cox) 33 | plot.subgroupAnalysis <- function(x,...) 34 | { 35 | if (class(x)[1]!="subgroupAnalysis") stop("Object not of class subgroupAnalysis") 36 | num <- length(names(x)) 37 | plotcols<-x[,(num-4):(num-2)] 38 | tabcols <-x[,1:2] 39 | Publish::plotConfidence(x=plotcols, labels=tabcols) 40 | } -------------------------------------------------------------------------------- /man/summary.ci.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary.ci.R 3 | \name{summary.ci} 4 | \alias{summary.ci} 5 | \title{Summarize confidence intervals} 6 | \usage{ 7 | \method{summary}{ci}(object, format = "[u;l]", se = FALSE, print = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{object}{Object of class ci containing point estimates and the 11 | corresponding confidence intervals} 12 | 13 | \item{format}{A string which indicates the format used for 14 | confidence intervals. The string is passed to 15 | \code{\link{formatCI}} with two arguments: the lower and the upper 16 | limit. For example \code{'(l;u)'} yields confidence intervals with 17 | round parenthesis in which the upper and the lower limits are 18 | separated by semicolon.} 19 | 20 | \item{se}{If \code{TRUE} add standard error.} 21 | 22 | \item{print}{Logical: if \code{FALSE} do not actually print 23 | confidence intervals but just return them invisibly.} 24 | 25 | \item{...}{used to control formatting of numbers} 26 | } 27 | \value{ 28 | Formatted confidence intervals 29 | } 30 | \description{ 31 | Summarize confidence intervals 32 | } 33 | \details{ 34 | This format of the confidence intervals is user-manipulable. 35 | } 36 | \examples{ 37 | library(lava) 38 | m <- lvm(Y~X) 39 | m <- categorical(m,Y~X,K=4) 40 | set.seed(4) 41 | d <- sim(m,24) 42 | ci.mean(Y~X,data=d) 43 | x <- summary(ci.mean(Y~X,data=d),digits=2) 44 | x 45 | x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=2) 46 | x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=1,se=TRUE) 47 | x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=1,handler="format") 48 | x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=1,handler="prettyNum") 49 | } 50 | \seealso{ 51 | ci plot.ci format.ci 52 | } 53 | \author{ 54 | Thomas A. Gerds 55 | } 56 | -------------------------------------------------------------------------------- /R/publish.ci.R: -------------------------------------------------------------------------------- 1 | ### publish.ci.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Oct 29 2015 (06:41) 5 | ## Version: 6 | ## last-updated: Dec 17 2015 (09:23) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 5 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ##' Publish tables with confidence intervals 18 | ##' 19 | ##' This function calls summary.ci with print=FALSE and then publish 20 | ##' @title Publish tables with confidence intervals 21 | ##' @param object Object of class ci containing point estimates and the 22 | ##' corresponding confidence intervals 23 | ##' @param format A string which indicates the format used for 24 | ##' confidence intervals. The string is passed to 25 | ##' \code{\link{formatCI}} with two arguments: the lower and the upper 26 | ##' limit. For example \code{'(l;u)'} yields confidence intervals with 27 | ##' round parenthesis in which the upper and the lower limits are 28 | ##' separated by semicolon. 29 | ##' @param se If \code{TRUE} add standard error. 30 | ##' @param ... passed to \code{publish} 31 | ##' @return table with confidence intervals 32 | ##' @seealso summary.ci 33 | ##' @examples 34 | ##' 35 | ##' data(Diabetes) 36 | ##' publish(ci.mean(chol~location+gender,data=Diabetes),org=TRUE) 37 | ##' 38 | ##' @export 39 | ##' @author Thomas A. Gerds 40 | publish.ci <- function(object,format="[u;l]",se=FALSE,...){ 41 | publish(summary(object,se=se,format=format,print=FALSE),...) 42 | } 43 | 44 | 45 | #---------------------------------------------------------------------- 46 | ### publish.ci.R ends here 47 | -------------------------------------------------------------------------------- /man/glmSeries.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/glmSeries.R 3 | \name{glmSeries} 4 | \alias{glmSeries} 5 | \title{Run a series of generalized linear regression analyses} 6 | \usage{ 7 | glmSeries(formula, data, vars, ...) 8 | } 9 | \arguments{ 10 | \item{formula}{The fixed part of the regression formula. For 11 | univariate analyses this is simply \code{y~1} where \code{y} is 12 | the outcome variable. When the aim is to control the effect of 13 | \code{vars} in each element of the series by a fixed set of 14 | variables it is \code{y~x1+x2} where again y is the outcome and x1 15 | and x2 are confounders.} 16 | 17 | \item{data}{A \code{data.frame} in which we evaluate the formula.} 18 | 19 | \item{vars}{A list of variable names, the changing part of the 20 | regression formula.} 21 | 22 | \item{...}{passed to glm} 23 | } 24 | \value{ 25 | Matrix with regression coefficients, one for each element of \code{vars}. 26 | } 27 | \description{ 28 | Run a series of generalized linear regression analyses for a list of predictor variables 29 | and summarize the results in a table. 30 | The regression models can be adjusted for a fixed set of covariates. 31 | } 32 | \examples{ 33 | 34 | data(Diabetes) 35 | Diabetes$hyper1 <- factor(1*(Diabetes$bp.1s>140)) 36 | ## collect odds ratios from three univariate logistic regression analyses 37 | uni.odds <- glmSeries(hyper1~1,vars=c("chol","hdl","location"),data=Diabetes,family=binomial) 38 | uni.odds 39 | ## control the logistic regression analyses for age and gender 40 | ## but collect only information on the variables in `vars'. 41 | controlled.odds <- glmSeries(hyper1~age+gender, 42 | vars=c("chol","hdl","location"), 43 | data=Diabetes, family=binomial) 44 | controlled.odds 45 | } 46 | \author{ 47 | Thomas Alexander Gerds 48 | } 49 | -------------------------------------------------------------------------------- /R/Units.R: -------------------------------------------------------------------------------- 1 | ### Units.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Apr 9 2015 (10:35) 5 | ## Version: 6 | ## last-updated: Apr 9 2015 (10:54) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 8 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ##' Add variable units to data.frame (or data.table). 18 | ##' 19 | ##' If the object has units existing units are replaced by given units. 20 | ##' @title Add units to data set 21 | ##' @param object A data.frame or data.table 22 | ##' @param units Named list of units. Names are variable names. If omitted, show existing units. 23 | ##' @return 24 | ##' The object augmented with attribute \code{"units"} 25 | ##' @examples 26 | ##' data(Diabetes) 27 | ##' Diabetes <- Units(Diabetes,list(BMI="kg/m^2")) 28 | ##' Units(Diabetes) 29 | ##' Diabetes <- Units(Diabetes,list(bp.1s="mm Hg",bp.2s="mm Hg")) 30 | ##' Units(Diabetes) 31 | ##' @export 32 | ##' @author Thomas A. Gerds 33 | Units <- function(object,units){ 34 | stopifnot("data.frame" %in% class(object)) 35 | if (missing(units)){ 36 | return(attr(object,"units")) 37 | } 38 | else{ 39 | old.units <- attr(object,"units") 40 | if (is.null(old.units)) 41 | attr(object,"units") <- units 42 | else{ 43 | new.units <- c(units,old.units) 44 | new.units <- new.units[!duplicated(names(new.units))] 45 | attr(object,"units") <- new.units 46 | } 47 | } 48 | object 49 | } 50 | 51 | #---------------------------------------------------------------------- 52 | ### Units.R ends here 53 | -------------------------------------------------------------------------------- /R/sutable.R: -------------------------------------------------------------------------------- 1 | ### sutable.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Nov 28 2015 (08:40) 5 | ## Version: 6 | ## last-updated: Oct 22 2017 (12:57) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 7 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ## the sutable first calls utable and then summary 18 | ##' First apply univariateTable then call summary. 19 | ##' 20 | ##' @title Fast summary of a univariate table 21 | ##' @param ... Unnamed arguments and are passed to \code{univariateTable} as well as named arguments 22 | ##' that match \code{univariateTable}'s arguments, other arguments 23 | ##' are passed to \code{summary.univariateTable} 24 | ##' @return Summary table 25 | ##' @seealso summary.univariateTable univariateTable 26 | ##' @examples 27 | ##' data(Diabetes) 28 | ##' sutable(gender~age+location+Q(BMI)+height+weight,data=Diabetes,BMI="Body mass index (kg/m^2)") 29 | ##' @export 30 | ##' @author Thomas A. Gerds 31 | sutable <- function(...){ 32 | args <- list(...) 33 | unames <- c("formula","data","summary.format","Q.format","freq.format","column.percent","digits","strataIsOutcome","short.groupnames","na.rm") 34 | ## no name arguments go into utable 35 | uargs <- args[names(args)==""] 36 | args <- args[names(args)!=""] 37 | test.args <- match(names(args),unames,nomatch=0) 38 | sargs <- args[test.args==0] 39 | uargs <- c(uargs,args[test.args!=0]) 40 | do.call(summary,c(list(object=do.call(univariateTable,uargs)),sargs)) 41 | } 42 | 43 | #---------------------------------------------------------------------- 44 | ### sutable.R ends here 45 | -------------------------------------------------------------------------------- /man/summary.regressionTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary.regressionTable.R 3 | \name{summary.regressionTable} 4 | \alias{summary.regressionTable} 5 | \alias{print.summary.regressionTable} 6 | \title{Formatting regression tables} 7 | \usage{ 8 | \method{summary}{regressionTable}(object, show.missing = "ifany", print = TRUE, ...) 9 | } 10 | \arguments{ 11 | \item{object}{object obtained with \code{regressionTable} or \code{summary.regressionTable}.} 12 | 13 | \item{show.missing}{Decide if number of missing values are shown. 14 | Either logical or character. If \code{'ifany'} then number missing values are 15 | shown if there are some.} 16 | 17 | \item{print}{If \code{TRUE} print results.} 18 | 19 | \item{...}{Used to control formatting of parameter estimates, 20 | confidence intervals and p-values. See examples.} 21 | } 22 | \value{ 23 | List with two elements: 24 | \itemize{ 25 | \item regressionTable: the formatted regression table (a data.frame) 26 | \item rawTable: table with the unformatted values (a data.frame) 27 | } 28 | } 29 | \description{ 30 | Preparing regression results for publication 31 | } 32 | \examples{ 33 | library(survival) 34 | data(pbc) 35 | pbc$edema <- factor(pbc$edema,levels=c("0","0.5","1"),labels=c("0","0.5","1")) 36 | fit = coxph(Surv(time,status!=0)~age+sex+edema+log(bili)+log(albumin)+log(protime), 37 | data=pbc) 38 | u=summary(regressionTable(fit)) 39 | u$regressionTable 40 | u$rawTable 41 | summary(regressionTable(fit),handler="prettyNum") 42 | summary(regressionTable(fit),handler="format") 43 | summary(regressionTable(fit),handler="sprintf",digits=c(2,2),pValue.stars=TRUE) 44 | summary(regressionTable(fit),handler="sprintf",digits=c(2,2),pValue.stars=TRUE,ci.format="(l,u)") 45 | } 46 | \seealso{ 47 | publish.glm publish.coxph 48 | } 49 | \author{ 50 | Thomas A. Gerds 51 | } 52 | -------------------------------------------------------------------------------- /man/coxphSeries.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/coxphSeries.R 3 | \name{coxphSeries} 4 | \alias{coxphSeries} 5 | \title{Run a series of Cox regression models} 6 | \usage{ 7 | coxphSeries(formula, data, vars, ...) 8 | } 9 | \arguments{ 10 | \item{formula}{The fixed part of the regression formula. For 11 | univariate analyses this is simply \code{Surv(time,status)~1} 12 | where \code{Surv(time,status)} is the outcome variable. When the 13 | aim is to control the effect of \code{vars} in each element of the 14 | series by a fixed set of variables it is 15 | \code{Surv(time,status)~x1+x2} where again Surv(time,status) is 16 | the outcome and x1 and x2 are confounders.} 17 | 18 | \item{data}{A \code{data.frame} in which the \code{formula} gets 19 | evaluated.} 20 | 21 | \item{vars}{A list of variable names, the changing part of the 22 | regression formula.} 23 | 24 | \item{...}{passed to publish.coxph} 25 | } 26 | \value{ 27 | matrix with results 28 | } 29 | \description{ 30 | Run a series of Cox regression analyses for a list of predictor variables 31 | and summarize the results in a table. 32 | The Cox models can be adjusted for a fixed set of covariates 33 | 34 | This function runs on \code{coxph} from the survival package. 35 | } 36 | \examples{ 37 | library(survival) 38 | data(pbc) 39 | ## collect hazard ratios from three univariate Cox regression analyses 40 | pbc$edema <- factor(pbc$edema,levels=c("0","0.5","1"),labels=c("0","0.5","1")) 41 | uni.hr <- coxphSeries(Surv(time,status==2)~1,vars=c("edema","bili","protime"),data=pbc) 42 | uni.hr 43 | 44 | ## control the logistic regression analyses for age and gender 45 | ## but collect only information on the variables in `vars'. 46 | controlled.hr <- coxphSeries(Surv(time,status==2)~age+sex,vars=c("edema","bili","protime"),data=pbc) 47 | controlled.hr 48 | 49 | } 50 | \author{ 51 | Thomas Alexander Gerds 52 | } 53 | -------------------------------------------------------------------------------- /man/followupTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/followupTable.R 3 | \name{followupTable} 4 | \alias{followupTable} 5 | \title{Summary tables for a given followup time point.} 6 | \usage{ 7 | followupTable(formula, data, followup.time, compare.groups, ...) 8 | } 9 | \arguments{ 10 | \item{formula}{Formula A formula whose left hand side is a 11 | \code{Hist} object. In some special cases it can also be a 12 | \code{Surv} response object. The right hand side is as in 13 | \code{\link{utable}}.} 14 | 15 | \item{data}{A data.frame in which all the variables of 16 | \code{formula} can be interpreted.} 17 | 18 | \item{followup.time}{Time point at which to evaluate outcome 19 | status.} 20 | 21 | \item{compare.groups}{Method for comparing groups.} 22 | 23 | \item{...}{Passed to \code{utable}. All arguments of \code{utable} 24 | can be controlled in this way except for \code{compare.groups} 25 | which is set to \code{"Cox"}. See details.} 26 | } 27 | \value{ 28 | Summary table. 29 | } 30 | \description{ 31 | Summarize baseline variables in groups defined by outcome 32 | at a given followup time point 33 | } 34 | \details{ 35 | If \code{compare.groups!=FALSE}, p-values are obtained from stopped Cox regression, i.e., all events are censored at follow-up time. 36 | A univariate Cox regression model is fitted to assess the effect of each variable on the right hand side of the formula on the event hazard and shown is the p-value of \code{anova(fit)}, see \code{\link{anova.coxph}}. 37 | } 38 | \examples{ 39 | library(survival) 40 | data(pbc) 41 | pbc$edema <- factor(pbc$edema,levels=c("0","0.5","1"),labels=c("0","0.5","1")) 42 | pbc$sex <- factor(pbc$sex,levels=c("m","f"),labels=c("m","f")) 43 | followupTable(Hist(time,status)~age+edema+sex,data=pbc,followup.time=1000) 44 | 45 | } 46 | \seealso{ 47 | univariateTable 48 | } 49 | \author{ 50 | Thomas A. Gerds 51 | } 52 | -------------------------------------------------------------------------------- /R/publish.summary.aov.R: -------------------------------------------------------------------------------- 1 | ##' Format summary table of aov results 2 | ##' 3 | ##' Format summary table of aov results 4 | ##' @export 5 | ##' @param object glm object 6 | ##' @param print Logical. Decide about whether or not to print the results. 7 | ##' @param handler see \code{pubformat} 8 | ##' @param digits see \code{pubformat} 9 | ##' @param nsmall see \code{pubformat} 10 | ##' @param ... used to transport further arguments 11 | ##' @examples 12 | ##' 13 | ##' data(Diabetes) 14 | ##' f <- glm(bp.1s~age+chol+gender+location,data=Diabetes) 15 | ##' publish(summary(aov(f)),digits=c(1,2)) 16 | ##' 17 | publish.summary.aov <- function(object, 18 | print=TRUE, 19 | handler="sprintf", 20 | digits=c(2,4), 21 | nsmall=digits, 22 | ...){ 23 | y <- object[[1]] 24 | if (length(digits)==1) digits <- rep(digits,2) 25 | pvalue.defaults <- list(digits=digits[[2]],eps=10^{-digits[[2]]},stars=FALSE) 26 | smartF <- prodlim::SmartControl(call=list(...), 27 | keys=c("pvalue"), 28 | ignore=c("object","print","handler","digits","nsmall"), 29 | defaults=list("pvalue"=pvalue.defaults), 30 | forced=list("pvalue"=list(y$"Pr(>F)")), 31 | verbose=FALSE) 32 | yy <- cbind(Df=y$Df, 33 | "F statistic"= pubformat(y$"F value",handler=handler,digits=digits[[1]],nsmall=nsmall[[1]]), 34 | "p-value"=do.call("format.pval",smartF$pvalue)) 35 | rownames(yy) <- rownames(object[[1]]) 36 | ## remove residual line 37 | yy <- yy[-NROW(yy),,drop=FALSE] 38 | if (print) 39 | publish(yy,rownames=TRUE,colnames=TRUE,col1name="Factor",...) 40 | invisible(yy) 41 | } 42 | -------------------------------------------------------------------------------- /R/pubformat.R: -------------------------------------------------------------------------------- 1 | ### pubformat.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Feb 21 2015 (10:34) 5 | ## Version: 6 | ## last-updated: Feb 21 2015 (10:46) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 5 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ##' Format numbers according to a specified handler function. 18 | ##' Currently supported are sprintf, format and prettyNum. 19 | ##' 20 | ##' @title Format numbers for publication 21 | ##' @param x numeric vector 22 | ##' @param digits number of digits 23 | ##' @param nsmall see handler 24 | ##' @param handler String specififying the name of the function which should 25 | ##' perform the formatting. See \code{sprintf}, \code{format} and \code{prettyNum}. 26 | ##' @param ... Passed to handler function if applicable, i.e., not to \code{sprintf}. 27 | ##' @return Formatted number 28 | ##' @seealso \code{sprintf}, \code{format}, \code{prettyNum} 29 | ##' @examples 30 | ##' 31 | ##' pubformat(c(0.000143,12.8,1)) 32 | ##' pubformat(c(0.000143,12.8,1),handler="format") 33 | ##' pubformat(c(0.000143,12.8,1),handler="format",trim=TRUE) 34 | ##' pubformat(c(0.000143,12.8,1),handler="prettyNum") 35 | ##' @export 36 | ##' @author Thomas A. Gerds 37 | pubformat <- function(x,digits=2, 38 | nsmall=digits, 39 | handler="sprintf",...){ 40 | if (handler=="sprintf"){ fmt <- paste0("%1.",digits[[1]],"f")} 41 | if (handler=="sprintf"){ 42 | sprintf(fmt=fmt,x) 43 | }else{ 44 | do.call(handler,list(x,digits=digits[[1]],nsmall=nsmall,...)) 45 | } 46 | } 47 | 48 | 49 | 50 | #---------------------------------------------------------------------- 51 | ### pubformat.R ends here 52 | -------------------------------------------------------------------------------- /R/lazyFactorCoding.R: -------------------------------------------------------------------------------- 1 | ##' This function eases the process of generating factor variables 2 | ##' with relevant labels. All variables in a data.frame with less than 3 | ##' a user set number of levels result in a line which suggests levels and 4 | ##' labels. The result can then be modified for use. 5 | ##' 6 | ##' The code needs to be copy-and-pasted from the R-output 7 | ##' buffer into the R-code buffer. This can be customized 8 | ##' for the really efficiently working people e.g. in emacs. 9 | ##' @title Efficient coding of factor levels 10 | ##' @param data Data frame in which to search for categorical variables. 11 | ##' @param max.levels Treat non-factor variables only if the number of unique values less than max.levels. Defaults to 10. 12 | ##' @return R-code one line for each variable. 13 | ##' @author Thomas Alexander Gerds 14 | ##' @examples 15 | ##' data(Diabetes) 16 | ##' lazyFactorCoding(Diabetes) 17 | ##' 18 | ##' @export 19 | lazyFactorCoding <- function(data,max.levels=10){ 20 | if (!is.character(data)) 21 | data <- as.character(substitute(data)) 22 | d <- get(data, envir=parent.frame()) 23 | isdt <- match("data.table",class(d),nomatch=FALSE) 24 | out <- lapply(names(d),function(x){ 25 | dx <- d[[x]] 26 | if ((is.factor(dx) && length(unique(dx))140) 67 | library(rms) 68 | uu <- datadist(Diabetes) 69 | options(datadist="uu") 70 | fit=lrm(hypertension~rcs(age)+gender+hdl,data=Diabetes) 71 | splinePlot.lrm(fit,xvar="age",xvalues=seq(30,50,1)) 72 | } 73 | \author{ 74 | Thomas A. Gerds 75 | } 76 | -------------------------------------------------------------------------------- /man/stripes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stripes.R 3 | \name{stripes} 4 | \alias{stripes} 5 | \title{Background and grid color control.} 6 | \usage{ 7 | stripes( 8 | xlim, 9 | ylim, 10 | col = "white", 11 | lwd = 1, 12 | gridcol = "gray77", 13 | fill = "white", 14 | horizontal = NULL, 15 | vertical = NULL, 16 | border = "black", 17 | xpd = FALSE 18 | ) 19 | } 20 | \arguments{ 21 | \item{xlim}{Limits for the horizontal x-dimension. Defaults to 22 | par("usr")[1:2].} 23 | 24 | \item{ylim}{Limits for the vertical y-dimension.} 25 | 26 | \item{col}{Colors use for the stripes. Can be a vector of colors 27 | which are then repeated appropriately.} 28 | 29 | \item{lwd}{Line width} 30 | 31 | \item{gridcol}{Color of grid lines} 32 | 33 | \item{fill}{Color to fill the background rectangle given by 34 | par("usr").} 35 | 36 | \item{horizontal}{Numerical values at which to show horizontal grid 37 | lines, and at which to change the color of the stripes.} 38 | 39 | \item{vertical}{Numerical values at which to show vertical grid 40 | lines.} 41 | 42 | \item{border}{If a fill color is provided, the color of the border 43 | around the background.} 44 | 45 | \item{xpd}{From \code{help(par)}: A logical value or NA. If FALSE, 46 | all plotting is clipped to the plot region, if TRUE, all plotting 47 | is clipped to the figure region, and if NA, all plotting is clipped 48 | to the device region. See also \code{clip}.} 49 | } 50 | \description{ 51 | Some users like background colors, and it may be helpful to have grid lines 52 | to read off e.g. probabilities from a Kaplan-Meier graph. Both things can be 53 | controlled with this function. However, it mainly serves 54 | \code{\link{plot.prodlim}}. 55 | } 56 | \examples{ 57 | 58 | 59 | plot(0,0) 60 | backGround(bg="beige",fg="red",vertical=0,horizontal=0) 61 | 62 | plot(0,0) 63 | stripes(col=c("yellow","green"),gridcol="red",xlim=c(-1,1),horizontal=seq(0,1,.1)) 64 | stripes(col=c("yellow","green"),gridcol="red",horizontal=seq(0,1,.1)) 65 | 66 | } 67 | \author{ 68 | Thomas Alexander Gerds 69 | } 70 | \keyword{survival} 71 | -------------------------------------------------------------------------------- /man/publish.CauseSpecificCox.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.CauseSpecificCox.R 3 | \name{publish.CauseSpecificCox} 4 | \alias{publish.CauseSpecificCox} 5 | \title{Tabulizing cause-specific hazard ratio from all causes with confidence limits and Wald test p-values.} 6 | \usage{ 7 | \method{publish}{CauseSpecificCox}( 8 | object, 9 | cause, 10 | confint.method, 11 | pvalue.method, 12 | factor.reference = "extraline", 13 | units = NULL, 14 | print = TRUE, 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{object}{Cause-specific hazard model obtained with 20 | \code{CSC}.} 21 | 22 | \item{cause}{Show a table for this cause. If omitted, list all 23 | causes.} 24 | 25 | \item{confint.method}{See \code{regressionTable}} 26 | 27 | \item{pvalue.method}{See \code{regressionTable}} 28 | 29 | \item{factor.reference}{See \code{regressionTable}} 30 | 31 | \item{units}{See \code{regressionTable}} 32 | 33 | \item{print}{If \code{TRUE} print the table(s).} 34 | 35 | \item{...}{passed on to control formatting of parameters, 36 | confidence intervals and p-values. See 37 | \code{summary.regressionTable}.} 38 | } 39 | \value{ 40 | Table with cause-specific hazard ratios, confidence limits and p-values. 41 | } 42 | \description{ 43 | Publish cause-specific Cox models 44 | } 45 | \details{ 46 | The cause-specific hazard ratio's are combined into one table. 47 | } 48 | \examples{ 49 | if (requireNamespace("riskRegression",quietly=TRUE)){ 50 | library(riskRegression) 51 | library(prodlim) 52 | library(survival) 53 | data(Melanoma,package="riskRegression") 54 | fit1 <- CSC(list(Hist(time,status)~sex,Hist(time,status)~invasion+epicel+age), 55 | data=Melanoma) 56 | publish(fit1) 57 | publish(fit1,pvalue.stars=TRUE) 58 | publish(fit1,factor.reference="inline",units=list("age"="years")) 59 | 60 | # wide format (same variables in both Cox regression formula) 61 | fit2 <- CSC(Hist(time,status)~invasion+epicel+age, data=Melanoma) 62 | publish(fit2) 63 | 64 | # with p-values 65 | x <- publish(fit2,print=FALSE) 66 | table <- cbind(x[[1]]$regressionTable, 67 | x[[2]]$regressionTable[,-c(1,2)]) 68 | } 69 | 70 | } 71 | \author{ 72 | Thomas Alexander Gerds 73 | } 74 | -------------------------------------------------------------------------------- /man/spaghettiogram.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Spaghettiogram.R 3 | \name{spaghettiogram} 4 | \alias{spaghettiogram} 5 | \alias{Spaghettiogram} 6 | \title{Spaghettiogram} 7 | \usage{ 8 | spaghettiogram( 9 | formula, 10 | data, 11 | xlim, 12 | ylim, 13 | xlab = "", 14 | ylab = "", 15 | axes = TRUE, 16 | col, 17 | lwd, 18 | lty, 19 | pch, 20 | legend = FALSE, 21 | add = FALSE, 22 | background = TRUE, 23 | ... 24 | ) 25 | } 26 | \arguments{ 27 | \item{formula}{A formula which specifies the variables for the 28 | spaghettiograms. If Y ~ X + id(Z) then for each value of Z the 29 | spaghettiogram is the graph (X,Y) in the subset defined by the 30 | value of Z. Data are expected to be in the "long" format. Y is 31 | a numeric vector and X is a factor whose levels define the X-axis. 32 | Each level of the id-vector corresponds to 33 | one line (spaghetti) in the plot.} 34 | 35 | \item{data}{data set in which variables X, Y and Z are defined.} 36 | 37 | \item{xlim}{Limits for x-axis} 38 | 39 | \item{ylim}{Limits for y-axis} 40 | 41 | \item{xlab}{Label for x-axis} 42 | 43 | \item{ylab}{Label for x-axis} 44 | 45 | \item{axes}{Logical indicating if axes should be drawn.} 46 | 47 | \item{col}{Colors for the spaghettiograms} 48 | 49 | \item{lwd}{Widths for the spaghettiograms} 50 | 51 | \item{lty}{Type for the spaghettiograms} 52 | 53 | \item{pch}{Point-type for the spaghettiograms} 54 | 55 | \item{legend}{If \code{TRUE} add a legend. Argument A of legend is 56 | controlled as legend.A. E.g., when \code{legend.cex=2} legend will 57 | be called with argument cex=2.} 58 | 59 | \item{add}{If \code{TRUE} add to existing plot device.} 60 | 61 | \item{background}{Control the background color of the graph.} 62 | 63 | \item{...}{used to transport arguments which are passed to the 64 | following subroutines: \code{"plot"}, \code{"lines"}, 65 | \code{"legend"}, \code{"background"}, \code{"axis1"}, 66 | \code{"axis2"}.} 67 | } 68 | \value{ 69 | List with data of each subject 70 | } 71 | \description{ 72 | A spaghettiogram is showing repeated measures (longitudinal data) 73 | } 74 | \examples{ 75 | 76 | data(SpaceT) 77 | Spaghettiogram(HR~Status+id(ID), 78 | data=SpaceT) 79 | } 80 | -------------------------------------------------------------------------------- /R/publish.riskReclassification.R: -------------------------------------------------------------------------------- 1 | ### publish.riskReclassification.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Dec 10 2015 (10:06) 5 | ## Version: 6 | ## last-updated: Oct 22 2017 (12:55) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 8 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | publish.riskReclassification <- function(x,percent=TRUE,digits=ifelse(percent,1,2),...){ 18 | cat("Observed overall re-classification table:\n\n") 19 | dnames <- dimnames(x$reclassification) 20 | cat(names(dnames)[1]," versus ", names(dnames)[2],"\n") 21 | publish(x$reclassification,...) 22 | cat("\nExpected re-classification probabilities (%) among subjects with event until time ",x$time,"\n\n",sep="") 23 | fmt <- paste0("%1.", digits[[1]], "f") 24 | dim <- dim(x$reclassification) 25 | if (percent==TRUE){ 26 | rlist <- lapply(x$event.reclassification,function(x){ 27 | matrix(sprintf(fmt=fmt,100*c(x)),nrow=dim[1],ncol=dim[2],dimnames=dnames) 28 | }) 29 | }else{ 30 | rlist <- lapply(x$event.reclassification,function(x){ 31 | matrix(sprintf(fmt=fmt,c(x)),nrow=dim[1],ncol=dim[2],dimnames=dnames) 32 | }) 33 | } 34 | if (x$model=="competing.risks"){ 35 | for (x in 1:(length(rlist)-1)){ 36 | cat("\n",names(rlist)[x],":\n",sep="") 37 | publish(rlist[[x]],quote=FALSE,...) 38 | } 39 | } else{ 40 | cat("\n",names(rlist)[1],":\n",sep="") 41 | publish(rlist[[1]],quote=FALSE,...) 42 | } 43 | cat("\nExpected re-classification probabilities (%) among subjects event-free until time ",x$time,"\n\n",sep="") 44 | cat("\n",names(rlist)[length(rlist)],":\n",sep="") 45 | publish(rlist[[length(rlist)]],quote=FALSE,...) 46 | ## print.listof(rlist[length(rlist)],quote=FALSE) 47 | } 48 | #---------------------------------------------------------------------- 49 | ### publish.riskReclassification.R ends here 50 | -------------------------------------------------------------------------------- /tests/test-publish-gls.R: -------------------------------------------------------------------------------- 1 | ### test-publish-gls.R --- 2 | #---------------------------------------------------------------------- 3 | ## Author: Thomas Alexander Gerds 4 | ## Created: Aug 14 2017 (18:56) 5 | ## Version: 6 | ## Last-Updated: Dec 1 2020 (17:12) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 6 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | if (requireNamespace("nlme",quietly=TRUE)){ 18 | library(testthat) 19 | context("publish: gls regression") 20 | 21 | ## simulation 22 | library(nlme) 23 | library(Publish) 24 | library(lava) 25 | m <- lvm(Y ~ X1 + gender + group + Interaction) 26 | distribution(m, ~gender) <- binomial.lvm() 27 | distribution(m, ~group) <- binomial.lvm(size = 2) 28 | constrain(m, Interaction ~ gender + group) <- function(x){x[,1]*x[,2]} 29 | d <- sim(m, 1e2) 30 | d$gender <- factor(d$gender, labels = letters[1:2]) 31 | d$group <- factor(d$group) 32 | 33 | ## model 34 | test_that("publish matches gls", { 35 | e.gls <- gls(Y ~ X1 + gender+group, data = d, 36 | weights = varIdent(form = ~1|group)) 37 | res <- summary(regressionTable(e.gls)) 38 | Sgls <- summary(e.gls)$tTable 39 | expect_equal(res$rawTable[c(1,3,5,6),"Coefficient"], 40 | unname(Sgls[c("X1","genderb","group1","group2"),"Value"])) 41 | expect_equal(res$rawTable[c(1,3,5,6),"Pvalue"], 42 | unname(Sgls[c("X1","genderb","group1","group2"),"p-value"])) 43 | }) 44 | 45 | context("publish: lme regression") 46 | 47 | data("Orthodont") 48 | test_that("publish matches lme", { 49 | fm1 <- lme(distance ~ age+Sex, 50 | random = ~1|Subject, 51 | data = Orthodont) 52 | res <- publish(fm1) 53 | # main effects 54 | expect_equal(as.double(res$rawTable[c(1:2,4),"Coefficient"]), 55 | as.double(fixef(fm1)[1:3])) 56 | expect_equal(as.double(res$rawTable[c(1:2,4),"Pvalue"]), 57 | as.double(summary(fm1)$tTable[1:3,5])) 58 | }) 59 | 60 | } 61 | 62 | ###################################################################### 63 | ### test-publish-gls.R ends here 64 | -------------------------------------------------------------------------------- /man/summary.subgroupAnalysis.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary.subgroupAnalysis.R 3 | \name{summary.subgroupAnalysis} 4 | \alias{summary.subgroupAnalysis} 5 | \title{summary.subgroupAnalysis} 6 | \usage{ 7 | \method{summary}{subgroupAnalysis}( 8 | object, 9 | digits = 3, 10 | eps = 0.001, 11 | subgroup.p = FALSE, 12 | keep.digital = FALSE, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{object}{- a subgroupAnalysis object} 18 | 19 | \item{digits}{- number of digits for risk ratios} 20 | 21 | \item{eps}{- lowest value of p to be shown exactly, others will be "140)) 22 | ##' ## collect odds ratios from three univariate logistic regression analyses 23 | ##' uni.odds <- glmSeries(hyper1~1,vars=c("chol","hdl","location"),data=Diabetes,family=binomial) 24 | ##' uni.odds 25 | ##' ## control the logistic regression analyses for age and gender 26 | ##' ## but collect only information on the variables in `vars'. 27 | ##' controlled.odds <- glmSeries(hyper1~age+gender, 28 | ##' vars=c("chol","hdl","location"), 29 | ##' data=Diabetes, family=binomial) 30 | ##' controlled.odds 31 | ##' @export 32 | glmSeries <- function(formula,data,vars,...){ 33 | ## ref <- glm(formula,data=data,...) 34 | Missing=NULL 35 | data.table::setDT(data) 36 | data <- data[,c(all.vars(formula),vars),with=FALSE] 37 | glist <- lapply(vars,function(v){ 38 | form.v <- update.formula(formula,paste(".~.+",v)) 39 | if (is.logical(data[[v]])) 40 | data[[v]] <- factor(data[[v]],levels=c("FALSE","TRUE")) 41 | gf <- glm(form.v,data=data,...) 42 | ## gf$call$data <- data 43 | gf$model <- data 44 | ## nv <- length(gf$xlevels[[v]]) 45 | rtab <- regressionTable(gf) 46 | rtab[[v]] 47 | }) 48 | out <- data.table::rbindlist(glist) 49 | if (all(out$Missing%in%c("","0"))) 50 | out[,Missing:=NULL] 51 | out[] 52 | } 53 | -------------------------------------------------------------------------------- /R/coxphSeries.R: -------------------------------------------------------------------------------- 1 | ##' Run a series of Cox regression analyses for a list of predictor variables 2 | ##' and summarize the results in a table. 3 | ##' The Cox models can be adjusted for a fixed set of covariates 4 | ##' 5 | ##' This function runs on \code{coxph} from the survival package. 6 | ##' @title Run a series of Cox regression models 7 | ##' @param formula The fixed part of the regression formula. For 8 | ##' univariate analyses this is simply \code{Surv(time,status)~1} 9 | ##' where \code{Surv(time,status)} is the outcome variable. When the 10 | ##' aim is to control the effect of \code{vars} in each element of the 11 | ##' series by a fixed set of variables it is 12 | ##' \code{Surv(time,status)~x1+x2} where again Surv(time,status) is 13 | ##' the outcome and x1 and x2 are confounders. 14 | ##' @param data A \code{data.frame} in which the \code{formula} gets 15 | ##' evaluated. 16 | ##' @param vars A list of variable names, the changing part of the 17 | ##' regression formula. 18 | ##' @param ... passed to publish.coxph 19 | ##' @return matrix with results 20 | ##' @author Thomas Alexander Gerds 21 | ##' @examples 22 | ##' library(survival) 23 | ##' data(pbc) 24 | ##' ## collect hazard ratios from three univariate Cox regression analyses 25 | ##' pbc$edema <- factor(pbc$edema,levels=c("0","0.5","1"),labels=c("0","0.5","1")) 26 | ##' uni.hr <- coxphSeries(Surv(time,status==2)~1,vars=c("edema","bili","protime"),data=pbc) 27 | ##' uni.hr 28 | ##' 29 | ##' ## control the logistic regression analyses for age and gender 30 | ##' ## but collect only information on the variables in `vars'. 31 | ##' controlled.hr <- coxphSeries(Surv(time,status==2)~age+sex,vars=c("edema","bili","protime"),data=pbc) 32 | ##' controlled.hr 33 | ##' 34 | ##' @export 35 | coxphSeries <- function(formula,data,vars,...){ 36 | ## ref <- glm(formula,data=data,...) 37 | Missing=NULL 38 | data.table::setDT(data) 39 | data <- data[,c(all.vars(formula),vars),with=FALSE] 40 | clist <- lapply(vars,function(v){ 41 | form.v <- update.formula(formula,paste(".~.+",v)) 42 | if (is.logical(data[[v]])) 43 | data[[v]] <- factor(data[[v]],levels=c("FALSE","TRUE")) 44 | cf <- survival::coxph(form.v,data=data,...) 45 | cf$call$data <- data 46 | cf$model <- data 47 | nv <- length(cf$xlevels[[v]]) 48 | rtab <- regressionTable(cf) 49 | rtab[[v]] 50 | }) 51 | out <- data.table::rbindlist(clist) 52 | if (all(out$Missing%in%c("","0"))) 53 | out[,Missing:=NULL] 54 | out[] 55 | } 56 | -------------------------------------------------------------------------------- /man/Diabetes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish-package.R 3 | \docType{data} 4 | \name{Diabetes} 5 | \alias{Diabetes} 6 | \title{Diabetes data of Dr John Schorling} 7 | \format{ 8 | A data frame with 205 observations on the following 12 variables. 9 | \describe{ 10 | \item{id}{subject id} 11 | \item{chol}{Total Cholesterol} 12 | \item{stab.glu}{Stabilized Glucose} 13 | \item{hdl}{High Density Lipoprotein} 14 | \item{ratio}{Cholesterol/HDL Ratio} 15 | \item{glyhb}{Glycosolated Hemoglobin} 16 | \item{location}{a factor with levels (Buckingham,Louisa)} 17 | \item{age}{age (years)} 18 | \item{gender}{male or female} 19 | \item{height}{height (inches)} 20 | \item{height.europe}{height (cm)} 21 | \item{weight}{weight (pounds)} 22 | \item{weight.europe}{weight (kg)} 23 | \item{frame}{a factor with levels (small,medium,large)} 24 | \item{bp.1s}{First Systolic Blood Pressure} 25 | \item{bp.1d}{First Diastolic Blood Pressure} 26 | \item{bp.2s}{Second Diastolic Blood Pressure} 27 | \item{bp.2d}{Second Diastolic Blood Pressure} 28 | \item{waist}{waist in inches} 29 | \item{hip}{hip in inches} 30 | \item{time.ppn}{Postprandial Time when Labs were Drawn in minutes} 31 | \item{AgeGroups}{Categorized age} 32 | \item{BMI}{Categorized BMI} 33 | } 34 | } 35 | \description{ 36 | These data are courtesy of Dr John Schorling, Department of Medicine, University of Virginia School of Medicine. 37 | The data consist of 19 variables on 403 subjects from 1046 subjects who were interviewed in a study to understand 38 | the prevalence of obesity, diabetes, and other cardiovascular risk factors in central Virginia for African Americans. 39 | According to Dr John Hong, Diabetes Mellitus Type II (adult onset diabetes) is associated most strongly with obesity. 40 | The waist/hip ratio may be a predictor in diabetes and heart disease. DM II is also agssociated with hypertension - 41 | they may both be part of "Syndrome X". The 403 subjects were the ones who were actually screened for diabetes. 42 | Glycosolated hemoglobin > 7.0 is usually taken as a positive diagnosis of diabetes. 43 | } 44 | \examples{ 45 | 46 | data(Diabetes) 47 | 48 | } 49 | \references{ 50 | Willems JP, Saunders JT, DE Hunt, JB Schorling: Prevalence of coronary heart disease risk factors among rural blacks: A community-based study. Southern Medical Journal 90:814-820; 1997 51 | Schorling JB, Roach J, Siegel M, Baturka N, Hunt DE, Guterbock TM, Stewart HL: A trial of church-based smoking cessation interventions for rural African Americans. Preventive Medicine 26:92-101; 1997. 52 | } 53 | \keyword{datasets} 54 | -------------------------------------------------------------------------------- /R/prepareLabels.R: -------------------------------------------------------------------------------- 1 | ### prepareLabels.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: May 13 2015 (07:21) 5 | ## Version: 6 | ## last-updated: Mar 5 2018 (19:39) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 18 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | prepareLabels <- function(labels,titles,...){ 18 | labs <- labels 19 | tits <- titles 20 | labels <- labs$labels 21 | titles <- tits$labels 22 | labs$labels <- NULL 23 | tits$labels <- NULL 24 | if (is.matrix(labels)) { 25 | cnames <- colnames(labels) 26 | labels <- lapply(1:ncol(labels),function(j)labels[,j]) 27 | names(labels) <- cnames 28 | } 29 | if (is.factor(labels) || is.numeric(labels) || is.character(labels)) 30 | labels <- list(" "=labels) 31 | ncolumns <- length(labels) 32 | if (is.null(titles)){ 33 | titles <- names(labels) 34 | do.titles <- TRUE 35 | if (is.null(titles)){ 36 | do.titles <- FALSE 37 | } 38 | } else do.titles <- TRUE 39 | if (do.titles && length(titles)!=length(labels)){ 40 | message(paste("Wrong number of titles: there are",ncolumns,"columns but ",length(titles),"title labels:",paste(titles,collapse=", "))) 41 | } 42 | if (length(labs$cex) 27 | labelUnits <- function(x,...){ 28 | ## stopifnot(match("summary.univariateTable",class(x),nomatch=0)>0) 29 | x 30 | units <- prodlim::SmartControl(list(...), 31 | keys=c("units",unique(x$Variable[x$Variable!=""])), 32 | defaults=NULL, 33 | ignore.case=TRUE, 34 | replaceDefaults=TRUE, 35 | verbose=FALSE) 36 | lunits <- sapply(units,length) 37 | units <- units[lunits>0] 38 | ulvar <- grep("Level|Unit",names(x),value=TRUE) 39 | ## factor specific units 40 | if (length(units)>0){ 41 | for (i in 1:length(units)){ 42 | uat <- grep(names(units)[i],x$Variable) 43 | lat <- match(names(units[[i]]),x[[ulvar]][uat:length(x$Variable)],nomatch=FALSE) 44 | lat <- lat[lat!=0] 45 | vals <- unlist(units[[i]]) 46 | vals <- vals[lat!=0] 47 | x[[ulvar]][uat -1 + lat] <- vals 48 | } 49 | } 50 | ## labels for variables 51 | labels <- list(...) 52 | if (length(labels)>0){ 53 | keys <- names(labels) 54 | Flabels <- labels[match(keys,x$Variable,nomatch=0)!=0] 55 | x$Variable[match(keys,x$Variable,nomatch=0)] <- unlist(Flabels) 56 | Funits <- labels[match(keys,x[[ulvar]],nomatch=0)!=0] 57 | for (f in names(Funits)){ 58 | x[[ulvar]][x[[ulvar]]%in%f] <- Funits[[f]] 59 | } 60 | ## now flatten lists. otherwise 61 | ## write.csv will complain 62 | x$Variable <- unlist(x$Variable) 63 | x[[ulvar]] <- unlist(x[[ulvar]]) 64 | } 65 | x 66 | } 67 | -------------------------------------------------------------------------------- /R/publish.Score.R: -------------------------------------------------------------------------------- 1 | ### publish.Score.R --- 2 | #---------------------------------------------------------------------- 3 | ## Author: Thomas Alexander Gerds 4 | ## Created: Jun 10 2017 (17:47) 5 | ## Version: 6 | ## Last-Updated: Dec 1 2020 (16:49) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 17 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ##' Write output of \code{riskRegression::Score} in tables 18 | ##' 19 | ##' Collect prediction accuracy results in tables 20 | ##' @title Publish predictive accuracy results 21 | ##' @param object Object obtained with \code{riskRegression::Score} 22 | ##' @param metrics Which metrics to put into tables. Defaults to 23 | ##' \code{object$metrics}. 24 | ##' @param score Logical. If \code{TRUE} print the score elements, i.e., metric applied to the risk prediction models. 25 | ##' @param contrasts Logical. If \code{TRUE} print the contrast elements (if any). These compare risk prediction models according to metrics. 26 | ##' @param level Level of subsection headers, i.e., ** for level 2 and 27 | ##' *** for level 3 (useful for emacs org-users). Default is plain 28 | ##' subsection headers no stars. A negative value will suppress 29 | ##' subjection headers. 30 | ##' @param ... Passed to publish 31 | ##' @return Results of Score in tabular form 32 | ##' @examples 33 | ##' if (requireNamespace("riskRegression",quietly=TRUE)){ 34 | ##' library(riskRegression) 35 | ##' library(survival) 36 | ##' learn = sampleData(100) 37 | ##' val= sampleData(100) 38 | ##' f1=CSC(Hist(time,event)~X1+X8,data=learn) 39 | ##' f2=CSC(Hist(time,event)~X1+X5+X6+X8,learn) 40 | ##' xs=Score(list(f1,f2),data=val,formula=Hist(time,event)~1) 41 | ##' publish(xs) 42 | ##' } 43 | ##' @export 44 | ##' @author Thomas A. Gerds 45 | publish.Score <- function(object,metrics,score=TRUE,contrasts=TRUE,level=3,...){ 46 | if (missing(metrics)) metrics <- object$metrics 47 | for (m in metrics){ 48 | if (level>0){ 49 | publish(paste0("Metric ",m,":\n"),level=level,...) 50 | publish("Assessment of predictive accuracy",level=level+1) 51 | } 52 | if (score){ 53 | publish(object[[m]]$score, ...) 54 | } 55 | if (contrasts && !is.null(object[[m]]$contrasts)){ 56 | if (level>0){ 57 | org("Comparison of predictive accuracy",level=level+1) 58 | } 59 | publish(object[[m]]$contrasts, ...) 60 | } 61 | } 62 | } 63 | 64 | 65 | ###################################################################### 66 | ### publish.Score.R ends here 67 | -------------------------------------------------------------------------------- /R/getSummary.R: -------------------------------------------------------------------------------- 1 | getSummary <- function(matrix, 2 | varnames, 3 | groupvar, 4 | groups, 5 | labels, 6 | stats, 7 | format, 8 | digits,big.mark){ 9 | iqr <- function(x)quantile(x,c(0.25,0.75)) 10 | minmax <- function(x)quantile(x,c(0,1)) 11 | CI.95 <- function(x,sep=";",big.mark=big.mark,...){ 12 | m <- ci.mean.default(x,...) 13 | paste(format(m$lower,digits=digits,nsmall=digits,bigmark=big.mark), 14 | sep," ", 15 | format(m$upper,digits=digits,nsmall=digits,bigmark=big.mark),sep="") 16 | } 17 | totals <- vector(NCOL(matrix),mode="list") 18 | names(totals) <- varnames 19 | groupsummary <- vector(NCOL(matrix),mode="list") 20 | names(groupsummary) <- varnames 21 | for (v in varnames){ 22 | vv <- matrix[,v] 23 | missing.v <- is.na(vv) 24 | vvv <- vv[!missing.v] 25 | totals.values <- lapply(stats,function(s){ 26 | do.call(s,list(vvv)) 27 | }) 28 | specialUnlist <- function(list){ 29 | if (any(sapply(list,function(l){length(l)})>1)){ 30 | ll <- lapply(list,function(x){ 31 | if (length(x)>1) as.list(x) else x 32 | }) 33 | return(as.list(unlist(ll,recursive=FALSE))) 34 | } 35 | else{ 36 | return(list) 37 | } 38 | } 39 | totals.values <- lapply(totals.values,function(x){ 40 | a <- sprintf(fmt=paste("%1.",digits,"f",sep=""),x) 41 | if (big.mark!="") 42 | a <- format(as.numeric(a),big.mark=big.mark,scientific=FALSE) 43 | a 44 | }) 45 | totals[[v]] <- do.call("sprintf",c(format,specialUnlist(totals.values))) 46 | if (!is.null(groupvar) && !missing(groupvar) && length(groupvar)==NROW(matrix)){ 47 | ggg <- factor(groupvar[!missing.v],levels=groups) 48 | gsum.v <- lapply(groups,function(g){ 49 | values <- lapply(stats,function(s){ 50 | do.call(s,list(vvv[ggg==g])) 51 | }) 52 | values <- lapply(values,function(x){ 53 | a <- sprintf(fmt=paste("%1.",digits,"f",sep=""),x) 54 | if (big.mark!="") 55 | a <- format(as.numeric(a),big.mark=big.mark,scientific=FALSE) 56 | a 57 | }) 58 | do.call("sprintf",c(format, specialUnlist(values))) 59 | }) 60 | names(gsum.v) <- labels 61 | groupsummary[[v]] <- do.call("cbind", gsum.v) 62 | } 63 | } 64 | list(totals=totals,groupsummary=groupsummary) 65 | } 66 | -------------------------------------------------------------------------------- /R/publish.survdiff.R: -------------------------------------------------------------------------------- 1 | ## based on a copy from print.survdiff, tag, 07 Aug 2009 (11:19) 2 | #' Alternative summary of survdiff results 3 | #' 4 | #' @title Alternative summary of survdiff results 5 | ##' @param object Object obtained with \code{survival::survdiff}. 6 | ##' @param digits Vector with digits for rounding numbers: the second for pvalues, the first for all other numbers. 7 | ##' @param print If \code{FALSE} do not print results. 8 | ##' @param ... Not (yet) used. 9 | ##' @examples 10 | ##' library(survival) 11 | ##' data(pbc) 12 | ##' sd <- survdiff(Surv(time,status!=0)~sex,data=pbc) 13 | ##' publish(sd) 14 | ##' publish(sd,digits=c(3,2)) 15 | ##' 16 | ##' @author Thomas A. Gerds 17 | ##' @export 18 | publish.survdiff <- function (object, digits = c(2,4),print=TRUE,...) { 19 | if (length(digits)==1) digits <- rep(digits,2) 20 | saveopt <- options(digits = digits) 21 | on.exit(options(saveopt)) 22 | if (!inherits(object, "survdiff")) 23 | stop("Object is not the result of survdiff") 24 | ## if (!is.null(cl <- object$call)) { 25 | ## cat("Call:\n") 26 | ## dput(cl) 27 | ## cat("\n") 28 | ## } 29 | omit <- object$na.action 30 | if (length(omit)) 31 | cat("n=", sum(object$n), ", ", naprint(omit), ".\n\n", sep = "") 32 | if (length(object$n) == 1) { 33 | z <- sign(object$exp - object$obs) * sqrt(object$chisq) 34 | temp <- c(object$obs, object$exp, z, format.pval(1 - pchisq(object$chisq,1),digits=digits,eps=10^{-digits[[2]]})) 35 | names(temp) <- c("Observed", "Expected", "Z", "p") 36 | if (print==TRUE) 37 | print(temp) 38 | } 39 | else { 40 | if (is.matrix(object$obs)) { 41 | otmp <- apply(object$obs, 1, sum) 42 | etmp <- apply(object$exp, 1, sum) 43 | } 44 | else { 45 | otmp <- object$obs 46 | etmp <- object$exp 47 | } 48 | df <- (sum(1 * (etmp > 0))) - 1 49 | temp <- cbind(object$n, otmp, etmp, ((otmp - etmp)^2)/etmp, 50 | ((otmp - etmp)^2)/diag(object$var)) 51 | dimnames(temp) <- list(names(object$n), c("N", "Observed", 52 | "Expected", "squared(O-E)/E", "squared(O-E)/V")) 53 | if (print==TRUE){ 54 | publish(temp,digits=digits[[1]],col1name="Log-rank test") 55 | cat("\n Chisq=", 56 | format(object$chisq, digits=digits[[1]]), 57 | " on", 58 | df, 59 | "degrees of freedom, p=", 60 | format.pval(1 - pchisq(object$chisq,df),digits=digits[[2]],eps=10^{-digits[[2]]}), 61 | "\n") 62 | } 63 | } 64 | attr(temp,"p-value") <- 1 - pchisq(object$chisq,df) 65 | invisible(temp) 66 | } 67 | -------------------------------------------------------------------------------- /man/formatCI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/formatCI.R 3 | \name{formatCI} 4 | \alias{formatCI} 5 | \title{Formatting confidence intervals} 6 | \usage{ 7 | formatCI( 8 | x, 9 | lower, 10 | upper, 11 | show.x = FALSE, 12 | handler = "sprintf", 13 | format = "[l;u]", 14 | degenerated = "asis", 15 | digits = 2, 16 | nsmall = digits, 17 | sep = "", 18 | reference.pos, 19 | reference.label = "", 20 | ... 21 | ) 22 | } 23 | \arguments{ 24 | \item{x}{not used (for compatibility with format)} 25 | 26 | \item{lower}{Numeric vector of lower limits} 27 | 28 | \item{upper}{Numeric vector of upper limits} 29 | 30 | \item{show.x}{Logical. If \code{TRUE} show value of x in front of confidence interval.} 31 | 32 | \item{handler}{Function to format numeric values. Default is 33 | \code{sprintf}, also supported are \code{format} and 34 | \code{prettyNum}} 35 | 36 | \item{format}{Character string in which \code{l} will be replaced 37 | by the value of the lower limit (argument lower) and \code{u} 38 | by the value of the upper upper limit. For example, 39 | \code{(l,u)} yields confidence intervals in round parenthesis 40 | in which the upper and lower limits are comma 41 | separated. Default is \code{[l;u]}.} 42 | 43 | \item{degenerated}{String to show when lower==upper. Default is 44 | '--'} 45 | 46 | \item{digits}{If handler \code{format} or \code{prettyNum} used 47 | format numeric vectors.} 48 | 49 | \item{nsmall}{If handler \code{format} or \code{prettyNum} used 50 | format numeric vectors.} 51 | 52 | \item{sep}{Field separator} 53 | 54 | \item{reference.pos}{Position of factor reference} 55 | 56 | \item{reference.label}{Label for factor reference} 57 | 58 | \item{...}{passed to handler} 59 | } 60 | \value{ 61 | String vector with confidence intervals 62 | } 63 | \description{ 64 | Format confidence intervals 65 | } 66 | \details{ 67 | The default format for confidence intervals is [lower; upper]. 68 | } 69 | \examples{ 70 | 71 | x=ci.mean(rnorm(10)) 72 | formatCI(lower=x[3],upper=x[4]) 73 | formatCI(lower=c(0.001,-2.8413),upper=c(1,3.0008884)) 74 | # change format 75 | formatCI(lower=c(0.001,-2.8413),upper=c(1,3.0008884),format="(l, u)") 76 | # show x 77 | formatCI(x=x$mean,lower=x$lower,upper=x$upper,format="(l, u)",show.x=TRUE) 78 | 79 | # change of handler function 80 | l <- c(-0.0890139,0.0084736,144.898333,0.000000001) 81 | u <- c(0.03911392,0.3784706,3338944.8821221,0.00001) 82 | cbind(format=formatCI(lower=l,upper=u,format="[l;u)",digits=2,nsmall=2,handler="format"), 83 | prettyNum=formatCI(lower=l,upper=u,format="[l;u)",digits=2,nsmall=2,handler="prettyNum"), 84 | sprintf=formatCI(lower=l,upper=u,format="[l;u)",digits=2,nsmall=2,handler="sprintf")) 85 | 86 | } 87 | \seealso{ 88 | plot.ci ci.mean 89 | } 90 | \author{ 91 | Thomas A. Gerds 92 | } 93 | -------------------------------------------------------------------------------- /man/publish.coxph.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.coxph.R 3 | \name{publish.coxph} 4 | \alias{publish.coxph} 5 | \title{Tabulize hazard ratios with confidence intervals and 6 | p-values.} 7 | \usage{ 8 | \method{publish}{coxph}( 9 | object, 10 | confint.method, 11 | pvalue.method, 12 | print = TRUE, 13 | factor.reference = "extraline", 14 | units = NULL, 15 | probindex = FALSE, 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{object}{A \code{coxph} object.} 21 | 22 | \item{confint.method}{See \code{regressionTable}} 23 | 24 | \item{pvalue.method}{See \code{regressionTable}} 25 | 26 | \item{print}{If \code{FALSE} do not print results.} 27 | 28 | \item{factor.reference}{See \code{regressionTable}} 29 | 30 | \item{units}{See \code{regressionTable}} 31 | 32 | \item{probindex}{Logical. If \code{TRUE} show coefficients on probabilistic index scale instead of hazard ratio scale.} 33 | 34 | \item{...}{passed to \code{summary.regressionTable} and also to 35 | \code{labelUnits}.} 36 | } 37 | \value{ 38 | Table with hazard ratios, confidence intervals and 39 | p-values. 40 | } 41 | \description{ 42 | Tabulize the part of the result of a Cox regression analysis which is commonly shown in publications. 43 | } 44 | \details{ 45 | Transforms the log hazard ratios to hazard ratios and returns them 46 | with confidence limits and p-values. If explanatory variables are 47 | log transformed or log2 transformed, a scaling factor is 48 | multiplied to both the log-hazard ratio and its standard-error. 49 | } 50 | \examples{ 51 | library(survival) 52 | data(pbc) 53 | pbc$edema <- factor(pbc$edema, 54 | levels=c("0","0.5","1"), labels=c("0","0.5","1")) 55 | fit = coxph(Surv(time,status!=0)~age+sex+edema+log(bili)+log(albumin), 56 | data=na.omit(pbc)) 57 | publish(fit) 58 | ## forest plot 59 | plot(publish(fit),cex=1.3) 60 | 61 | publish(fit,ci.digits=2,pvalue.eps=0.01,pvalue.digits=2,pvalue.stars=TRUE) 62 | publish(fit,ci.digits=2,ci.handler="prettyNum",pvalue.eps=0.01, 63 | pvalue.digits=2,pvalue.stars=TRUE) 64 | publish(fit, ci.digits=2, ci.handler="sprintf", pvalue.eps=0.01, 65 | pvalue.digits=2,pvalue.stars=TRUE, ci.trim=FALSE) 66 | 67 | fit2 = coxph(Surv(time,status!=0)~age+sex+edema+log(bili,base=2)+log(albumin)+log(protime), 68 | data=na.omit(pbc)) 69 | publish(fit2) 70 | 71 | # with cluster variable 72 | fit3 = coxph(Surv(time,status!=0)~age+cluster(sex)+edema+log(bili,base=2) 73 | +log(albumin)+log(protime), 74 | data=na.omit(pbc)) 75 | publish(fit3) 76 | 77 | # with strata and cluster variable 78 | fit4 = coxph(Surv(time,status!=0)~age+cluster(sex)+strata(edema)+log(bili,base=2) 79 | +log(albumin)+log(protime), 80 | data=pbc) 81 | publish(fit4) 82 | 83 | } 84 | \author{ 85 | Thomas Alexander Gerds 86 | } 87 | -------------------------------------------------------------------------------- /R/plotLabels.R: -------------------------------------------------------------------------------- 1 | ### plotLabels.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: May 11 2015 (09:05) 5 | ## Version: 6 | ## last-updated: May 8 2020 (07:41) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 69 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | plotLabels <- function(labels, 18 | labels.args, 19 | titles, 20 | titles.args, 21 | width, 22 | ylim, 23 | ncolumns, 24 | columnwidths, 25 | ## xpos, 26 | stripes, 27 | ...){ 28 | ## available space (width) is divided according to relative widths 29 | labelrelwidth <- columnwidths/sum(columnwidths) 30 | colwidths <- labelrelwidth*width 31 | if (labels.args$pos==4) 32 | ## aligned on right hand 33 | xpos <- c(0,cumsum(colwidths)[-ncolumns]) 34 | else 35 | ## aligned on left hand 36 | xpos <- cumsum(colwidths) 37 | ## empty plot 38 | plot(0,0,type="n",axes=FALSE,xlim=c(0,width),ylim=ylim,xlab="",ylab="") 39 | if (!missing(stripes) && length(stripes)>0){ 40 | stripes$xlim <- c(0,width) 41 | do.call("stripes",stripes) 42 | } 43 | ## arrows(x0=0,x1=width,y0=12,y1=12,lwd=8,col="orange") 44 | ## abline(v=xpos,col=1:5) 45 | nix <- lapply(1:ncolumns,function(l){ 46 | labels.args$x <- xpos[[l]] 47 | labels.args$labels <- labels[[l]] 48 | labels.args$cex <- labels.args$cex[[l]] 49 | ## if (length(grep("\\;",labels[[1]]))>0) browser() 50 | ## if (!is.null(labels.args$adj)) labels.args$pos=NULL 51 | do.call("text",labels.args) 52 | }) 53 | ## to avoid that expression(bold(CI[95])) is 54 | ## changed to bold(CI[95]) we make titles a list 55 | if (length(titles)==1) titles <- list(titles) 56 | if (length(titles)>0){ 57 | ## title.columns <- lapply(1:ncolumns,function(cc){sprintf(fmt=fmt.columns[[cc]],titles[[cc]])}) 58 | nix <- lapply(1:ncolumns,function(l){ 59 | titles.args$x <- xpos[[l]] 60 | titles.args$labels <- titles[[l]] 61 | titles.args$cex <- titles.args$cex[[l]] 62 | do.call("text",titles.args) 63 | }) 64 | } 65 | } 66 | 67 | #---------------------------------------------------------------------- 68 | ### plotLabels.R ends here 69 | -------------------------------------------------------------------------------- /man/summary.univariateTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary.univariateTable.R 3 | \name{summary.univariateTable} 4 | \alias{summary.univariateTable} 5 | \alias{summary.utable} 6 | \title{Preparing univariate tables for publication} 7 | \usage{ 8 | \method{summary}{univariateTable}( 9 | object, 10 | n = "inNames", 11 | drop.reference = FALSE, 12 | pvalue.stars = FALSE, 13 | pvalue.digits = 4, 14 | show.missing = c("ifany", "always", "never"), 15 | show.pvalues, 16 | show.totals, 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{object}{\code{univariateTable} object as obtained with 22 | function \code{univariateTable}.} 23 | 24 | \item{n}{If not missing, show the number of subjects in each 25 | column. If equal to \code{"inNames"}, show the numbers in 26 | parentheses in the column names. If missing the value 27 | \code{object$n} is used.} 28 | 29 | \item{drop.reference}{Logical or character (vector). Decide if line with reference 30 | level should be suppressed for factors. If \code{TRUE} or \code{"all"} 31 | suppress for all categorical factors. If \code{'binary'} suppress only for binary variables. 32 | Can be character vector in which case reference lines are suppressed for variables 33 | that are included in the vector.} 34 | 35 | \item{pvalue.stars}{If TRUE use \code{symnum} to parse p-values 36 | otherwise use \code{format.pval}.} 37 | 38 | \item{pvalue.digits}{Passed to \code{format.pval}.} 39 | 40 | \item{show.missing}{Decides if number of missing values are shown in table. 41 | Defaults to \code{"ifany"}, and can also be set to \code{"always"} or \code{"never"}.} 42 | 43 | \item{show.pvalues}{Logical. If set to \code{FALSE} the column 44 | \code{p-values} is removed. If missing the value 45 | \code{object$compare.groups[[1]]==TRUE} is used.} 46 | 47 | \item{show.totals}{Logical. If set to \code{FALSE} the column 48 | \code{Totals} is removed. If missing the value 49 | \code{object$show.totals} is used.} 50 | 51 | \item{...}{passed on to \code{labelUnits}. This overwrites labels 52 | stored in \code{object$labels}} 53 | } 54 | \value{ 55 | Summary table 56 | } 57 | \description{ 58 | Summary function for univariate table 59 | } 60 | \details{ 61 | Collects results of univariate table in a matrix. 62 | } 63 | \examples{ 64 | data(Diabetes) 65 | u <- univariateTable(gender~age+location+Q(BMI)+height+weight, 66 | data=Diabetes) 67 | summary(u) 68 | summary(u,n=NULL) 69 | summary(u,pvalue.digits=2,"age"="Age (years)","height"="Body height (cm)") 70 | 71 | u2 <- univariateTable(location~age+AgeGroups+gender+height+weight, 72 | data=Diabetes) 73 | summary(u2) 74 | summary(u2,drop.reference=TRUE) 75 | ## same but more flexible 76 | summary(u2,drop.reference=c("binary")) 77 | ## same but even more flexible 78 | summary(u2,drop.reference=c("gender")) 79 | 80 | 81 | } 82 | \author{ 83 | Thomas A. Gerds 84 | } 85 | -------------------------------------------------------------------------------- /R/summary.ci.R: -------------------------------------------------------------------------------- 1 | ##' Summarize confidence intervals 2 | ##' 3 | ##' This format of the confidence intervals is user-manipulable. 4 | ##' @title Summarize confidence intervals 5 | ##' @param object Object of class ci containing point estimates and the 6 | ##' corresponding confidence intervals 7 | ##' @param format A string which indicates the format used for 8 | ##' confidence intervals. The string is passed to 9 | ##' \code{\link{formatCI}} with two arguments: the lower and the upper 10 | ##' limit. For example \code{'(l;u)'} yields confidence intervals with 11 | ##' round parenthesis in which the upper and the lower limits are 12 | ##' separated by semicolon. 13 | ##' @param se If \code{TRUE} add standard error. 14 | ##' @param print Logical: if \code{FALSE} do not actually print 15 | ##' confidence intervals but just return them invisibly. 16 | ##' @param ... used to control formatting of numbers 17 | ##' @return Formatted confidence intervals 18 | ##' @seealso ci plot.ci format.ci 19 | ##' @examples 20 | ##' library(lava) 21 | ##' m <- lvm(Y~X) 22 | ##' m <- categorical(m,Y~X,K=4) 23 | ##' set.seed(4) 24 | ##' d <- sim(m,24) 25 | ##' ci.mean(Y~X,data=d) 26 | ##' x <- summary(ci.mean(Y~X,data=d),digits=2) 27 | ##' x 28 | ##' x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=2) 29 | ##' x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=1,se=TRUE) 30 | ##' x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=1,handler="format") 31 | ##' x <- summary(ci.mean(Y~X,data=d),format="(u,l)",digits=1,handler="prettyNum") 32 | #' @export 33 | ##' @author Thomas A. Gerds 34 | summary.ci <- function(object,format="[u;l]",se=FALSE,print=TRUE,...){ 35 | pynt <- getPyntDefaults(list(...),names=list("digits"=c(2,3),"handler"="sprintf",nsmall=NULL)) 36 | digits <- pynt$digits 37 | handler <- pynt$handler 38 | if (length(digits)==1) digits <- rep(digits,2) 39 | if (length(pynt$nsmall)>0) nsmall <- pynt$nsmall else nsmall <- pynt$digits 40 | if (missing(format) || is.null(format)) format <- "[u;l]" 41 | if (is.null(object$level)) level <- 0.05 else level <- object$level 42 | parm <- pubformat(object[[1]],handler=handler,digits=digits,nsmall=nsmall) 43 | ci <- formatCI(lower=object[["lower"]],upper=object[["upper"]],format=format,handler=handler,digits=digits,nsmall=nsmall) 44 | if (match("se",names(object)) && se==TRUE){ 45 | se <- pubformat(object[[2]],handler=handler,digits=digits,nsmall=nsmall) 46 | pci <- cbind(parm,se,ci) 47 | colnames(pci) <- c(names(object)[1:2],paste("CI-",as.character(100*(1-level)),"%",sep="")) 48 | }else{ 49 | pci <- cbind(parm,ci) 50 | colnames(pci) <- c(names(object)[1],paste("CI-",as.character(100*(1-level)),"%",sep="")) 51 | } 52 | pci <- cbind(object$labels,pci) 53 | rownames(pci) <- rep("",nrow(pci)) 54 | if (print==TRUE) 55 | print(pci,right=FALSE,quote=FALSE,...) 56 | invisible(pci) 57 | } 58 | -------------------------------------------------------------------------------- /R/table2x2.R: -------------------------------------------------------------------------------- 1 | ##' 2x2 table calculus for teaching 2 | ##' 3 | ##' 2x2 table calculus for teaching 4 | ##' @title 2x2 table calculus for teaching 5 | ##' @param x 2x2 table 6 | ##' @param digits rounding digits 7 | ##' @param conf.level Confidence level used for constructing confidence intervals. Default is 0.95. 8 | ##' @param stats subset or all of \code{c("table","rd","or","rr","chisq","fisher")} where rd= risk difference, rr = risk ratio, or = odds ratio, chisq = chi-square test, fisher= fisher's exact test and table = the 2x2 table 9 | ##' @return see example 10 | ##' @examples 11 | ##' table2x2(table("marker"=rbinom(100,1,0.4),"response"=rbinom(100,1,0.1))) 12 | ##' table2x2(matrix(c(71,18,38,8),ncol=2),stats="table") 13 | ##' table2x2(matrix(c(71,18,38,8),ncol=2),stats=c("rr","fisher")) 14 | ##' @export 15 | ##' @author Thomas A. Gerds 16 | table2x2 <- function(x, 17 | digits=1, 18 | conf.level=0.95, 19 | stats=c("table","rd","rr","or","chisq","fisher")){ 20 | if (class(x)[1]=="data.frame"){ 21 | table2x2 <- as.matrix(x) 22 | } else{ 23 | if ("matrix"%in%class(x)||"table" %in% class(x)){ 24 | if ("table"%in%class(x)){table2x2 <- as.matrix(x)} 25 | else table2x2 <- x 26 | } else{ 27 | stop("first argument `x' must be a matrix or a data.frame") 28 | } 29 | } 30 | if (NROW(x)!=2) stop("Matrix must have exactly 2 rows") 31 | if (NCOL(x)!=2) stop("Matrix must have exactly 2 columns") 32 | a <- table2x2[1,1] 33 | b <- table2x2[1,2] 34 | c <- table2x2[2,1] 35 | d <- table2x2[2,2] 36 | p1 <- a/(a+b) 37 | p2 <- c/(c+d) 38 | ## ## test statistic 39 | ## n <- (a+b+c+d) 40 | ## chi2test <- (a*d-b*c)^2*n/((a+c)*(b+d)*(a+b)*(c+d)) 41 | ## 2x2 table 42 | out <- list(table2x2=table2x2,stats=stats) 43 | if ("rd" %in% stats){ 44 | rd <- (p1-p2) 45 | se.rd <- sqrt(p1*(1-p1)/(a+b)+p2*(1-p2)/(c+d)) 46 | rd.lower <- rd - qnorm(1-(1-conf.level)/2)*se.rd 47 | rd.upper <- rd + qnorm(1-(1-conf.level)/2)*se.rd 48 | out <- c(out,list(rd=rd,se.rd=se.rd,rd.lower=rd.lower,rd.upper=rd.upper)) 49 | } 50 | if ("rr" %in% stats){ 51 | rr <- p1/p2 52 | se.rr <- sqrt((1-p1)/a+(1-p2)/c) 53 | rr.lower <- rr * exp(- qnorm(1-(1-conf.level)/2) * se.rr) 54 | rr.upper <- rr * exp( qnorm(1-(1-conf.level)/2) * se.rr) 55 | out <- c(out,list(rr=rr,se.rr=se.rr,rr.lower=rr.lower,rr.upper=rr.upper)) 56 | } 57 | if ("or" %in% stats){ 58 | or <- (a*d)/(b*c) 59 | se.or <- sqrt(1/a+1/b+1/c+1/d) 60 | or.lower <- exp(log(or) - qnorm(1-(1-conf.level)/2)*se.or) 61 | or.upper <- exp(log(or) + qnorm(1-(1-conf.level)/2)*se.or) 62 | out <- c(out,list(or=or,se.or=se.or,or.lower=or.lower,or.upper=or.upper)) 63 | } 64 | class(out) <- "table2x2" 65 | out 66 | } 67 | -------------------------------------------------------------------------------- /R/plot.ci.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------ 2 | ## _____ _____ 3 | ## |_ _|_ _ __ |_ _|__ __ _ _ __ ___ 4 | ## | |/ _` |/ _` || |/ _ \/ _` | '_ ` _ \ 5 | ## | | (_| | (_| || | __/ (_| | | | | | | 6 | ## |_|\__,_|\__, ||_|\___|\__,_|_| |_| |_| 7 | ## |___/ 8 | ## ------------------------------------------------------------------ 9 | ##' Function to plot confidence intervals 10 | ##' 11 | ##' Function to plot means and other point estimates with confidence 12 | ##' intervals 13 | ##' @title Plot confidence intervals 14 | ##' @param x List, data.frame or other object of this form containing point estimates (first element) and the corresponding confidence intervals as elements lower and upper. 15 | ##' @param xlim Limit of the x-axis 16 | ##' @param xlab Label for the y-axis 17 | ##' @param labels labels 18 | ##' @param ... Used to transport arguments to \code{plotConfidence}. 19 | ##' @examples 20 | ##' 21 | ##' data(Diabetes) 22 | ##' x=ci.mean(bp.2s~AgeGroups,data=Diabetes) 23 | ##' plot(x,title.labels="Age groups",xratio=c(0.4,0.3)) 24 | ##' x=ci.mean(bp.2s/500~AgeGroups+gender,data=Diabetes) 25 | ##' plot(x,xratio=c(0.4,0.2)) 26 | ##' plot(x,xratio=c(0.4,0.2), 27 | ##' labels=split(x$labels[,"AgeGroups"],x$labels[,"gender"]), 28 | ##' title.labels="Age groups") 29 | ##' \dontrun{ 30 | ##' plot(x, leftmargin=0, rightmargin=0) 31 | ##' plotConfidence(x, leftmargin=0, rightmargin=0) 32 | ##' 33 | ##' data(CiTable) 34 | ##' with(CiTable,plotConfidence(x=list(HazardRatio), 35 | ##' lower=lower, 36 | ##' upper=upper, 37 | ##' labels=CiTable[,2:6], 38 | ##' factor.reference.pos=c(1,10,19), 39 | ##' format="(u-l)", 40 | ##' points.col="blue", 41 | ##' digits=2)) 42 | ##' 43 | ##' with(CiTable,Publish::plot.ci(x=list(HazardRatio), 44 | ##' lower=lower, 45 | ##' upper=upper, 46 | ##' labels=CiTable[,2:6], 47 | ##' factor.reference.pos=c(1,10,19), 48 | ##' format="(u-l)", 49 | ##' points.col="blue", 50 | ##' digits=2, 51 | ##' leftmargin=-2, 52 | ##' title.labels.cex=1.1, 53 | ##' labels.cex=0.8,values.cex=0.8)) 54 | ##' } 55 | ##' @author Thomas A. Gerds 56 | ##' @export 57 | plot.ci <- function(x,xlim,xlab="",labels,...){ 58 | M <- x[[1]] 59 | Lower <- x$lower 60 | Upper <- x$upper 61 | if (missing(xlim)) xlim <- c(min(Lower),max(Upper)) 62 | if (missing(labels)) 63 | labels <- x$labels 64 | plotConfidence(list(x=M,lower=Lower,upper=Upper), 65 | xlim=xlim, 66 | labels=labels, 67 | xlab=xlab, 68 | ...) 69 | } 70 | 71 | -------------------------------------------------------------------------------- /man/publish.matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.matrix.R 3 | \name{publish.matrix} 4 | \alias{publish.matrix} 5 | \title{Publishing a matrix in raw, org, latex, or muse format} 6 | \usage{ 7 | \method{publish}{matrix}( 8 | object, 9 | title, 10 | colnames = TRUE, 11 | rownames = TRUE, 12 | col1name = "", 13 | digits = 4, 14 | try.convert = TRUE, 15 | sep = " ", 16 | endhead, 17 | endrow, 18 | style, 19 | inter.lines, 20 | latex = FALSE, 21 | wiki = FALSE, 22 | org = FALSE, 23 | markdown = FALSE, 24 | tabular = TRUE, 25 | latex.table.format = NA, 26 | latex.hline = 1, 27 | latex.nodollar = FALSE, 28 | ... 29 | ) 30 | } 31 | \arguments{ 32 | \item{object}{Matrix to be published} 33 | 34 | \item{title}{Title for table, only in wiki and muse format} 35 | 36 | \item{colnames}{If \code{TRUE} show column names} 37 | 38 | \item{rownames}{If \code{TRUE} show row names} 39 | 40 | \item{col1name}{Name for first column} 41 | 42 | \item{digits}{Numbers are rounded according to digits} 43 | 44 | \item{try.convert}{Logical. If \code{TRUE} try to convert also non-numeric 45 | formats such as character to numeric before rounding. Default is \code{TRUE}.} 46 | 47 | \item{sep}{Field separator when style is \code{"none"}} 48 | 49 | \item{endhead}{String to be pasted at the end of the first row 50 | (header)} 51 | 52 | \item{endrow}{String to be pasted at the end of each row} 53 | 54 | \item{style}{Table style for export to \code{"latex"}, 55 | \code{"org"}, \code{"markdown"}, \code{"wiki"}, 56 | \code{"none"}. Overwritten by argments below.} 57 | 58 | \item{inter.lines}{A named list which contains strings to be 59 | placed between the rows of the table. An element with name 60 | \code{"0"} is used to place a line before the first column, 61 | elements with name \code{"r"} are placed between line r and 62 | r+1.} 63 | 64 | \item{latex}{If \code{TRUE} use latex table format} 65 | 66 | \item{wiki}{If \code{TRUE} use mediawiki table format} 67 | 68 | \item{org}{If \code{TRUE} use emacs orgmode table format} 69 | 70 | \item{markdown}{If \code{TRUE} use markdown table format} 71 | 72 | \item{tabular}{For style \code{latex} only: if \code{TRUE} enclose 73 | the table in begin/end tabular environement.} 74 | 75 | \item{latex.table.format}{For style \code{latex} only: format of 76 | the tabular environement.} 77 | 78 | \item{latex.hline}{For style \code{latex} only: if \code{TRUE} add 79 | hline statements add the end of each line.} 80 | 81 | \item{latex.nodollar}{For style \code{latex} only: if \code{TRUE} 82 | do not enclose numbers in dollars.} 83 | 84 | \item{...}{Used to transport arguments. Currently supports 85 | \code{wiki.class}.} 86 | } 87 | \description{ 88 | This is the heart of the Publish package 89 | } 90 | \examples{ 91 | 92 | x <- matrix(1:12,ncol=3) 93 | publish(x) 94 | 95 | # rounding the numeric part of data mixtures 96 | y <- cbind(matrix(letters[1:12],ncol=3),x,matrix(rnorm(12),ncol=3)) 97 | publish(y,digits=1) 98 | 99 | publish(x,latex=TRUE, 100 | inter.lines=list("1"="text between line 1 and line 2", 101 | "3"="text between line 3 and line 4")) 102 | 103 | } 104 | -------------------------------------------------------------------------------- /R/summary.subgroupAnalysis.R: -------------------------------------------------------------------------------- 1 | #' @title summary.subgroupAnalysis 2 | #' @description 3 | #' This function operates on a "subgroupAnalysis" object to produce a formatted 4 | #' table. 5 | #' @author Christian Torp-Pedersen 6 | #' @param object - a subgroupAnalysis object 7 | #' @param digits - number of digits for risk ratios 8 | #' @param eps - lowest value of p to be shown exactly, others will be " 92 | } 93 | -------------------------------------------------------------------------------- /R/splinePlot.lrm.R: -------------------------------------------------------------------------------- 1 | ### splinePlot.lrm.R --- 2 | #---------------------------------------------------------------------- 3 | ## Author: Thomas Alexander Gerds 4 | ## Created: Dec 31 2017 (11:04) 5 | ## Version: 1 6 | ## Last-Updated: Dec 1 2020 (16:52) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 24 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ##' Plotting the prediction of a logistic regression model 18 | ##' with confidence bands against one continuous variable. 19 | ##' 20 | ##' Function which extracts from a logistic regression model 21 | ##' fitted with \code{rms::lrm} the predicted risks or odds. 22 | ##' @title Plot predictions of logistic regression 23 | ##' @author Thomas A. Gerds 24 | ##' @param object Logistic regression model fitted with \code{rms::lrm} 25 | ##' @param xvar Name of the variable to show on x-axis 26 | ##' @param xvalues Sequence of \code{xvar} values 27 | ##' @param xlim x-axis limits 28 | ##' @param ylim y-axis limits 29 | ##' @param xlab x-axis labels 30 | ##' @param ylab y-axis labels 31 | ##' @param col color of the line 32 | ##' @param lty line style 33 | ##' @param lwd line width 34 | ##' @param confint Logical. If \code{TRUE} show confidence shadows 35 | ##' @param newdata How to adjust 36 | ##' @param scale Character string that determines the outcome scale (y-axis). Choose between \code{"risk"} and \code{"odds"}. 37 | ##' @param add Logical. If \code{TRUE} add lines to an existing graph 38 | ##' @param ... Further arguments passed to \code{plot}. Only if \code{add} is \code{FALSE}. 39 | ##' @examples 40 | ##' data(Diabetes) 41 | ##' Diabetes$hypertension= 1*(Diabetes$bp.1s>140) 42 | ##' library(rms) 43 | ##' uu <- datadist(Diabetes) 44 | ##' options(datadist="uu") 45 | ##' fit=lrm(hypertension~rcs(age)+gender+hdl,data=Diabetes) 46 | ##' splinePlot.lrm(fit,xvar="age",xvalues=seq(30,50,1)) 47 | ##' @export 48 | splinePlot.lrm <- function(object, 49 | xvar, 50 | xvalues, 51 | xlim=range(xvalues), 52 | ylim, 53 | xlab=xvar, 54 | ylab=scale[[1]], 55 | col=1, 56 | lty=1, 57 | lwd=3, 58 | confint=TRUE, 59 | newdata=NULL, 60 | scale=c("risk","odds"), 61 | add=FALSE,...){ 62 | lower=upper=yhat=NULL 63 | expit <- function (x){exp(x)/(1 + exp(x))} 64 | input <- list(object=object,xvalues) 65 | if (!is.null(newdata) && is.list(newdata)){ 66 | input <- c(input,newdata) 67 | } 68 | names(input)[[2]] <- xvar 69 | if (scale[[1]]=="risk") input$fun <- expit 70 | else{ ## set reference level for odds 71 | input$fun <- exp 72 | } 73 | pframe <- do.call(rms::Predict,input) 74 | data.table::setDT(pframe) 75 | if (missing(ylim)) ylim <- pframe[,c(min(lower),max(upper))] 76 | if(!add){ 77 | plot(0,0,type="n",ylim=ylim,xlim=xlim,xlab=xlab,ylab=ylab,...) 78 | } 79 | pframe[,graphics::lines(xvalues,yhat,lwd=lwd,lty=lty,col=col,type="l",ylim=ylim)] 80 | if (confint==TRUE){ 81 | pframe[,polygon(x=c(xvalues,rev(xvalues)),y=c(lower,rev(upper)),col=prodlim::dimColor(col),border=NA)] 82 | } 83 | pframe 84 | } 85 | ###################################################################### 86 | ### splinePlot.lrm.R ends here 87 | -------------------------------------------------------------------------------- /R/formatCI.R: -------------------------------------------------------------------------------- 1 | ##' Format confidence intervals 2 | ##' 3 | ##' The default format for confidence intervals is [lower; upper]. 4 | ##' @title Formatting confidence intervals 5 | ##' @param x not used (for compatibility with format) 6 | ##' @param lower Numeric vector of lower limits 7 | ##' @param upper Numeric vector of upper limits 8 | ##' @param show.x Logical. If \code{TRUE} show value of x in front of confidence interval. 9 | ##' @param handler Function to format numeric values. Default is 10 | ##' \code{sprintf}, also supported are \code{format} and 11 | ##' \code{prettyNum} 12 | ##' @param format Character string in which \code{l} will be replaced 13 | ##' by the value of the lower limit (argument lower) and \code{u} 14 | ##' by the value of the upper upper limit. For example, 15 | ##' \code{(l,u)} yields confidence intervals in round parenthesis 16 | ##' in which the upper and lower limits are comma 17 | ##' separated. Default is \code{[l;u]}. 18 | ##' @param degenerated String to show when lower==upper. Default is 19 | ##' '--' 20 | ##' @param digits If handler \code{format} or \code{prettyNum} used 21 | ##' format numeric vectors. 22 | ##' @param nsmall If handler \code{format} or \code{prettyNum} used 23 | ##' format numeric vectors. 24 | ##' @param sep Field separator 25 | ##' @param reference.pos Position of factor reference 26 | ##' @param reference.label Label for factor reference 27 | ##' @param ... passed to handler 28 | ##' @return String vector with confidence intervals 29 | ##' @seealso plot.ci ci.mean 30 | ##' @examples 31 | ##' 32 | ##' x=ci.mean(rnorm(10)) 33 | ##' formatCI(lower=x[3],upper=x[4]) 34 | ##' formatCI(lower=c(0.001,-2.8413),upper=c(1,3.0008884)) 35 | ##' # change format 36 | ##' formatCI(lower=c(0.001,-2.8413),upper=c(1,3.0008884),format="(l, u)") 37 | ##' # show x 38 | ##' formatCI(x=x$mean,lower=x$lower,upper=x$upper,format="(l, u)",show.x=TRUE) 39 | ##' 40 | ##' # change of handler function 41 | ##' l <- c(-0.0890139,0.0084736,144.898333,0.000000001) 42 | ##' u <- c(0.03911392,0.3784706,3338944.8821221,0.00001) 43 | ##' cbind(format=formatCI(lower=l,upper=u,format="[l;u)",digits=2,nsmall=2,handler="format"), 44 | ##' prettyNum=formatCI(lower=l,upper=u,format="[l;u)",digits=2,nsmall=2,handler="prettyNum"), 45 | ##' sprintf=formatCI(lower=l,upper=u,format="[l;u)",digits=2,nsmall=2,handler="sprintf")) 46 | ##' 47 | ##' @export 48 | ##' @author Thomas A. Gerds 49 | formatCI <- function(x, 50 | lower, 51 | upper, 52 | show.x=FALSE, 53 | handler="sprintf", 54 | format="[l;u]", 55 | degenerated="asis", 56 | digits=2, 57 | nsmall=digits, 58 | sep="", 59 | reference.pos, 60 | reference.label="", 61 | ...){ 62 | stopifnot(length(upper)==length(lower)) 63 | format <- sub("l","%s",format) 64 | format <- sub("u","%s",format) 65 | lower <- pubformat(lower,digits=digits[[1]],nsmall=nsmall[[1]],handler=handler) 66 | upper <- pubformat(upper,digits=digits[[1]],nsmall=nsmall[[1]],handler=handler) 67 | N <- length(lower) 68 | out <- sapply(1:N,function(i){ 69 | if (is.character(degenerated) && degenerated!="asis" && lower[i]==upper[i]) 70 | ci <- degenerated 71 | else 72 | ci <- do.call("sprintf",list(fmt=format,lower[i],upper[i])) 73 | ci 74 | }) 75 | if (show.x) 76 | out <- paste(pubformat(x,digits=digits,handler=handler,nsmall=nsmall),out) 77 | if (!missing(reference.pos)) 78 | out[reference.pos] <- reference.label 79 | out 80 | } 81 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(as.data.frame,specialFrame) 4 | S3method(ci.mean,default) 5 | S3method(ci.mean,formula) 6 | S3method(plot,ci) 7 | S3method(plot,regressionTable) 8 | S3method(plot,subgroupAnalysis) 9 | S3method(plot,summary.regressionTable) 10 | S3method(print,ci) 11 | S3method(print,subgroupAnalysis) 12 | S3method(print,summary.regressionTable) 13 | S3method(print,table2x2) 14 | S3method(print,univariateTable) 15 | S3method(publish,CauseSpecificCox) 16 | S3method(publish,FGR) 17 | S3method(publish,MIresult) 18 | S3method(publish,Score) 19 | S3method(publish,ci) 20 | S3method(publish,coxph) 21 | S3method(publish,data.frame) 22 | S3method(publish,default) 23 | S3method(publish,geeglm) 24 | S3method(publish,glm) 25 | S3method(publish,gls) 26 | S3method(publish,htest) 27 | S3method(publish,list) 28 | S3method(publish,lm) 29 | S3method(publish,lme) 30 | S3method(publish,matrix) 31 | S3method(publish,prodlim) 32 | S3method(publish,riskRegression) 33 | S3method(publish,subgroupAnalysis) 34 | S3method(publish,summary.aov) 35 | S3method(publish,summary.prodlim) 36 | S3method(publish,survdiff) 37 | S3method(publish,table) 38 | S3method(publish,univariateTable) 39 | S3method(summary,ci) 40 | S3method(summary,regressionTable) 41 | S3method(summary,subgroupAnalysis) 42 | S3method(summary,univariateTable) 43 | S3method(summary,utable) 44 | export(Spaghettiogram) 45 | export(Units) 46 | export(acut) 47 | export(ci.mean) 48 | export(coxphSeries) 49 | export(fixRegressionTable) 50 | export(followupTable) 51 | export(formatCI) 52 | export(glmSeries) 53 | export(labelUnits) 54 | export(lazyDateCoding) 55 | export(lazyFactorCoding) 56 | export(org) 57 | export(parseInteractionTerms) 58 | export(plotConfidence) 59 | export(pubformat) 60 | export(publish) 61 | export(regressionTable) 62 | export(spaghettiogram) 63 | export(specialFrame) 64 | export(splinePlot.lrm) 65 | export(stripes) 66 | export(subgroupAnalysis) 67 | export(summary.univariateTable) 68 | export(summary.utable) 69 | export(sutable) 70 | export(table2x2) 71 | export(univariateTable) 72 | export(utable) 73 | importFrom(data.table,".N") 74 | importFrom(data.table,".SD") 75 | importFrom(data.table,":=") 76 | importFrom(data.table,as.data.table) 77 | importFrom(data.table,copy) 78 | importFrom(data.table,data.table) 79 | importFrom(data.table,is.data.table) 80 | importFrom(data.table,melt) 81 | importFrom(data.table,rbindlist) 82 | importFrom(data.table,set) 83 | importFrom(data.table,setcolorder) 84 | importFrom(data.table,setkey) 85 | importFrom(data.table,setnames) 86 | importFrom(data.table,setorder) 87 | importFrom(grDevices,dev.size) 88 | importFrom(graphics,abline) 89 | importFrom(graphics,par) 90 | importFrom(graphics,plot) 91 | importFrom(graphics,polygon) 92 | importFrom(graphics,rect) 93 | importFrom(graphics,segments) 94 | importFrom(graphics,strwidth) 95 | importFrom(prodlim,Hist) 96 | importFrom(prodlim,getEvent) 97 | importFrom(stats,anova) 98 | importFrom(stats,binom.test) 99 | importFrom(stats,binomial) 100 | importFrom(stats,chisq.test) 101 | importFrom(stats,coef) 102 | importFrom(stats,confint) 103 | importFrom(stats,delete.response) 104 | importFrom(stats,fisher.test) 105 | importFrom(stats,get_all_vars) 106 | importFrom(stats,glm) 107 | importFrom(stats,kruskal.test) 108 | importFrom(stats,model.frame) 109 | importFrom(stats,model.response) 110 | importFrom(stats,na.omit) 111 | importFrom(stats,na.pass) 112 | importFrom(stats,naprint) 113 | importFrom(stats,pchisq) 114 | importFrom(stats,pt) 115 | importFrom(stats,qnorm) 116 | importFrom(stats,qt) 117 | importFrom(stats,quantile) 118 | importFrom(stats,symnum) 119 | importFrom(stats,terms) 120 | importFrom(stats,update) 121 | importFrom(stats,update.formula) 122 | importFrom(stats,var) 123 | importFrom(survival,Surv) 124 | importFrom(survival,coxph) 125 | -------------------------------------------------------------------------------- /man/publish.glm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.glm.R 3 | \name{publish.glm} 4 | \alias{publish.glm} 5 | \title{Tabulize regression coefficients with confidence intervals and p-values.} 6 | \usage{ 7 | \method{publish}{glm}( 8 | object, 9 | confint.method, 10 | pvalue.method, 11 | digits = c(2, 4), 12 | print = TRUE, 13 | factor.reference = "extraline", 14 | intercept = ifelse((is.null(object$family) || object$family$family == "gaussian"), 1L, 15 | 0L), 16 | units = NULL, 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{object}{A \code{glm} object.} 22 | 23 | \item{confint.method}{See \code{regressionTable}.} 24 | 25 | \item{pvalue.method}{See \code{regressionTable}.} 26 | 27 | \item{digits}{A vector of two integer values. These determine how to round 28 | numbers (first value) and p-values (second value). E.g., c(1,3) would 29 | mean 1 digit for all numbers and 3 digits for p-values. 30 | The actual rounding is done by \code{summary.regressionTable}.} 31 | 32 | \item{print}{If \code{FALSE} do not print results.} 33 | 34 | \item{factor.reference}{Style for showing results for categorical. See \code{regressionTable}.} 35 | 36 | \item{intercept}{See \code{regressionTable}.} 37 | 38 | \item{units}{See \code{regressionTable}.} 39 | 40 | \item{...}{passed to \code{summary.regressionTable} and also 41 | to \code{labelUnits}.} 42 | 43 | \item{reference}{Style for showing results for categorical 44 | variables. If \code{"extraline"} show an additional line for the 45 | reference category.} 46 | } 47 | \value{ 48 | Table with regression coefficients, confidence intervals and p-values. 49 | } 50 | \description{ 51 | Tabulate the results of a generalized linear regression analysis. 52 | } 53 | \details{ 54 | The table shows changes in mean for linear regression and 55 | odds ratios for logistic regression (family = binomial). 56 | } 57 | \examples{ 58 | data(Diabetes) 59 | ## Linear regression 60 | f = glm(bp.2s~frame+gender+age,data=Diabetes) 61 | publish(f) 62 | publish(f,factor.reference="inline") 63 | publish(f,pvalue.stars=TRUE) 64 | publish(f,ci.format="(l,u)") 65 | 66 | ### interaction 67 | fit = glm(bp.2s~frame+gender*age,data=Diabetes) 68 | summary(fit) 69 | publish(fit) 70 | 71 | Fit = glm(bp.2s~frame*gender+age,data=Diabetes) 72 | publish(Fit) 73 | 74 | ## Logistic regression 75 | Diabetes$hyper1 <- factor(1*(Diabetes$bp.1s>140)) 76 | lrfit <- glm(hyper1~frame+gender+age,data=Diabetes,family=binomial) 77 | publish(lrfit) 78 | 79 | ### interaction 80 | lrfit1 <- glm(hyper1~frame+gender*age,data=Diabetes,family=binomial) 81 | publish(lrfit1) 82 | 83 | lrfit2 <- glm(hyper1~frame*gender+age,data=Diabetes,family=binomial) 84 | publish(lrfit2) 85 | 86 | ## Poisson regression 87 | data(trace) 88 | trace <- Units(trace,list("age"="years")) 89 | fit <- glm(dead ~ smoking+sex+age+Time+offset(log(ObsTime)), family="poisson",data=trace) 90 | rtf <- regressionTable(fit,factor.reference = "inline") 91 | summary(rtf) 92 | publish(fit) 93 | 94 | ## gls regression 95 | if (requireNamespace("nlme",quietly=TRUE)){ 96 | requireNamespace("lava",quietly=TRUE) 97 | library(lava) 98 | library(nlme) 99 | m <- lvm(Y ~ X1 + gender + group + Interaction) 100 | distribution(m, ~gender) <- binomial.lvm() 101 | distribution(m, ~group) <- binomial.lvm(size = 2) 102 | constrain(m, Interaction ~ gender + group) <- function(x){x[,1]*x[,2]} 103 | d <- sim(m, 1e2) 104 | d$gender <- factor(d$gender, labels = letters[1:2]) 105 | d$group <- factor(d$group) 106 | 107 | e.gls <- gls(Y ~ X1 + gender*group, data = d, 108 | weights = varIdent(form = ~1|group)) 109 | publish(e.gls) 110 | 111 | ## lme 112 | fm1 <- lme(distance ~ age*Sex, 113 | random = ~1|Subject, 114 | data = Orthodont) 115 | res <- publish(fm1) 116 | } 117 | } 118 | \author{ 119 | Thomas Alexander Gerds 120 | } 121 | -------------------------------------------------------------------------------- /R/plot.regressionTable.R: -------------------------------------------------------------------------------- 1 | ### plot.regressionTable.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: Feb 2 2015 (06:55) 5 | ## Version: 6 | ## last-updated: May 13 2018 (14:36) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 103 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | ##' Plotting regression coefficients with confidence limits 18 | ##' 19 | ##' 20 | ##' @title Plotting regression coefficients with confidence limits 21 | ##' @param x regression table obtained with regressionTable 22 | ##' @param xlim Limits for x-axis 23 | ##' @param xlab Label for x-axis 24 | ##' @param style Determines how to arrange variable names and their corresponding units 25 | ##' @param ... passed to plotConfidence 26 | ##' @return NULL 27 | ##' @seealso regressionTable 28 | ##' @examples 29 | ##' ## linear regression 30 | ##' data(Diabetes) 31 | ##' f <- glm(bp.1s~AgeGroups+chol+gender+location,data=Diabetes) 32 | ##' rtf <- regressionTable(f,factor.reference = "inline") 33 | ##' plot(rtf,cex=1.3) 34 | ##' 35 | ##' ## logistic regression 36 | ##' data(Diabetes) 37 | ##' f <- glm(I(BMI>25)~bp.1s+AgeGroups+chol+gender+location,data=Diabetes,family=binomial) 38 | ##' rtf <- regressionTable(f,factor.reference = "inline") 39 | ##' plot(rtf,cex=1.3) 40 | ##' 41 | ##' ## Poisson regression 42 | ##' data(trace) 43 | ##' fit <- glm(dead ~ smoking+ sex+ age+Time+offset(log(ObsTime)), family = poisson,data=trace) 44 | ##' rtab <- regressionTable(fit,factor.reference = "inline") 45 | ##' plot(rtab,xlim=c(0.85,1.15),cex=1.8,xaxis.cex=1.5) 46 | ##' 47 | ##' ## Cox regression 48 | ##' library(survival) 49 | ##' data(pbc) 50 | ##' coxfit <- coxph(Surv(time,status!=0)~age+log(bili)+log(albumin)+factor(edema)+sex,data=pbc) 51 | ##' pubcox <- publish(coxfit) 52 | ##' plot(pubcox,cex=1.5,xratio=c(0.4,0.2)) 53 | ##' 54 | ##' @export 55 | ##' @author Thomas A. Gerds 56 | plot.regressionTable <- function(x,xlim,xlab,style=1,...){ 57 | plot(summary(x,print=FALSE),xlim=xlim,xlab=xlab,style=style,...) 58 | } 59 | ##' @export 60 | plot.summary.regressionTable <- function(x,xlim,xlab,style=1,...){ 61 | X <- x$rawTable 62 | X <- labelUnits(X,...) 63 | if (sum(X$Units=="")>0) 64 | X[X$Units=="",]$Units <- "1 unit" 65 | model <- x$model 66 | if (missing(xlab)) 67 | xlab <- switch(model, 68 | "Linear regression"="Difference", 69 | "Logistic regression"="Odds ratio", 70 | "Poisson regression"="Hazard ratio", 71 | "Cox regression"="Hazard ratio") 72 | Coef <- X[,grep("OddsRatio|HazardRatio|ProbIndex|Coefficient",colnames(X))] 73 | Lower <- X$Lower 74 | Upper <- X$Upper 75 | if (missing(xlim)) xlim <- c(min(Lower),max(Upper)) 76 | U <- X$Units 77 | V <- X$Variable 78 | if (style==1){ 79 | Labs <- split(U,rep(1:length(x$blocks),x$blocks)) 80 | names(Labs) <- names(x$blocks) 81 | labels <- list(...) 82 | keys <- names(labels) 83 | Flabels <- labels[match(keys,names(Labs),nomatch=0)!=0] 84 | if (length(Flabels)>0) 85 | names(Labs)[match(keys,names(Labs),nomatch=0)] <- Flabels 86 | } else { 87 | Labs <- data.frame(Variable=V,Units=U) 88 | } 89 | plotConfidence(list(Coef,lower=Lower,upper=Upper), 90 | xlim=xlim, 91 | labels=Labs, 92 | xlab=xlab, 93 | refline=1*(model!="Linear regression"), 94 | ...) 95 | } 96 | 97 | 98 | #---------------------------------------------------------------------- 99 | ### plot.regressionTable.R ends here 100 | -------------------------------------------------------------------------------- /tests/test-univariateTable.R: -------------------------------------------------------------------------------- 1 | ### test-univariateTable.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: May 9 2015 (07:55) 5 | ## Version: 6 | ## last-updated: Apr 3 2022 (11:57) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 10 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | 18 | library(testthat) 19 | library(prodlim) 20 | library(Publish) 21 | data(Diabetes) 22 | 23 | test_that("univariateTable no groups",{ 24 | u1 <- univariateTable(~age +gender + height + weight,data=Diabetes) 25 | a <- summary(u1,show.missing=1L) 26 | expect_equal(NROW(a),9) 27 | b <- summary(u1,show.missing=0L) 28 | expect_equal(NROW(b),5) 29 | u2 <- univariateTable(~age,data=Diabetes) 30 | u3 <- univariateTable(~gender,data=Diabetes) 31 | a1 <- publish(univariateTable(~age+gender+ height+weight,data=Diabetes)) 32 | a2 <- publish(summary(univariateTable(~age+gender+ height+weight,data=Diabetes))) 33 | expect_equal(a1,a2) 34 | }) 35 | 36 | test_that("Univariate table with groups and missing values and labels with special characters",{ 37 | Diabetes$AgeGroups <- cut(Diabetes$age, 38 | c(19,29,39,49,59,69,92), 39 | include.lowest=TRUE) 40 | univariateTable(location~age+gender+height+weight+AgeGroups,data=Diabetes) 41 | publish(summary(univariateTable(location~age+gender+height+weight, 42 | data=Diabetes)),org=TRUE) 43 | v <- univariateTable(gender ~age+height,data=Diabetes) 44 | sv <- summary(v,show.missing="always") 45 | univariateTable(location~factor(AgeGroups)+gender+height+weight, 46 | data=Diabetes, 47 | summary.format="median(x) {iqr(x)}") 48 | levels(Diabetes$frame) <- c("+large","medi()um=.<",">8") 49 | expect_output(publish(summary(univariateTable(frame~age+gender+height+weight+location, 50 | data=Diabetes)),org=TRUE)) 51 | expect_output(publish(summary(univariateTable(location~age+gender+height+weight+frame, 52 | data=Diabetes)),org=TRUE)) 53 | }) 54 | 55 | test_that("Univariate table with row percent",{ 56 | a <- summary(univariateTable(frame~gender+location, data=Diabetes,column.percent=TRUE)) 57 | b <- summary(univariateTable(frame~gender+location, data=Diabetes,column.percent=FALSE)) 58 | expect_equal(as.numeric(colSums(a[a$Variable=="gender"]==b[b$Variable=="gender"])),c(4,0)) 59 | }) 60 | 61 | if (FALSE){ 62 | test_that("Univariate table with stupid function",{ 63 | stupid <- function(x){ 64 | if (mean(x)>47) "large" else "small" 65 | } 66 | univariateTable(location~age+height+weight, 67 | data=Diabetes, 68 | summary.format="Mean: mean(x) stupid's distance: (stupid(x))") 69 | 70 | publish(summary(univariateTable(location~age+height+weight, 71 | data=Diabetes, 72 | summary.format="Mean: mean(x) stupid's distance: (stupid(x))")), 73 | org=TRUE) 74 | MeanSe <- function(x){ 75 | paste("Mean=",round(mean(x),1)," Standard.error=",round(sd(x)/sqrt(length(x)),3),sep="") 76 | } 77 | expect_output(publish(univariateTable(location~age+height+weight,data=Diabetes,summary.format="MeanSe(x)"))) 78 | ux <- univariateTable(location~gender+age+AgeGroups, 79 | data=Diabetes, 80 | column.percent=FALSE, 81 | freq.format="count(x)") 82 | sux <- summary(ux) 83 | publish(sux,org=TRUE) 84 | }) 85 | } 86 | 87 | 88 | 89 | 90 | #---------------------------------------------------------------------- 91 | ### test-univariateTable.R ends here 92 | -------------------------------------------------------------------------------- /R/publish.coxph.R: -------------------------------------------------------------------------------- 1 | ##' Tabulize the part of the result of a Cox regression analysis which is commonly shown in publications. 2 | ##' 3 | ##' Transforms the log hazard ratios to hazard ratios and returns them 4 | ##' with confidence limits and p-values. If explanatory variables are 5 | ##' log transformed or log2 transformed, a scaling factor is 6 | ##' multiplied to both the log-hazard ratio and its standard-error. 7 | ##' @title Tabulize hazard ratios with confidence intervals and 8 | ##' p-values. 9 | ##' @param object A \code{coxph} object. 10 | ##' @param confint.method See \code{regressionTable} 11 | ##' @param pvalue.method See \code{regressionTable} 12 | ##' @param print If \code{FALSE} do not print results. 13 | ##' @param factor.reference See \code{regressionTable} 14 | ##' @param units See \code{regressionTable} 15 | ##' @param probindex Logical. If \code{TRUE} show coefficients on probabilistic index scale instead of hazard ratio scale. 16 | ##' @param ... passed to \code{summary.regressionTable} and also to 17 | ##' \code{labelUnits}. 18 | ##' @return Table with hazard ratios, confidence intervals and 19 | ##' p-values. 20 | ##' @author Thomas Alexander Gerds 21 | ##' @examples 22 | ##' library(survival) 23 | ##' data(pbc) 24 | ##' pbc$edema <- factor(pbc$edema, 25 | ##' levels=c("0","0.5","1"), labels=c("0","0.5","1")) 26 | ##' fit = coxph(Surv(time,status!=0)~age+sex+edema+log(bili)+log(albumin), 27 | ##' data=na.omit(pbc)) 28 | ##' publish(fit) 29 | ##' ## forest plot 30 | ##' plot(publish(fit),cex=1.3) 31 | ##' 32 | ##' publish(fit,ci.digits=2,pvalue.eps=0.01,pvalue.digits=2,pvalue.stars=TRUE) 33 | ##' publish(fit,ci.digits=2,ci.handler="prettyNum",pvalue.eps=0.01, 34 | ##' pvalue.digits=2,pvalue.stars=TRUE) 35 | ##' publish(fit, ci.digits=2, ci.handler="sprintf", pvalue.eps=0.01, 36 | ##' pvalue.digits=2,pvalue.stars=TRUE, ci.trim=FALSE) 37 | ##' 38 | ##' fit2 = coxph(Surv(time,status!=0)~age+sex+edema+log(bili,base=2)+log(albumin)+log(protime), 39 | ##' data=na.omit(pbc)) 40 | ##' publish(fit2) 41 | ##' 42 | ##' # with cluster variable 43 | ##' fit3 = coxph(Surv(time,status!=0)~age+cluster(sex)+edema+log(bili,base=2) 44 | ##' +log(albumin)+log(protime), 45 | ##' data=na.omit(pbc)) 46 | ##' publish(fit3) 47 | ##' 48 | ##' # with strata and cluster variable 49 | ##' fit4 = coxph(Surv(time,status!=0)~age+cluster(sex)+strata(edema)+log(bili,base=2) 50 | ##' +log(albumin)+log(protime), 51 | ##' data=pbc) 52 | ##' publish(fit4) 53 | ##' 54 | ##' @export 55 | publish.coxph <- function(object, 56 | confint.method, 57 | pvalue.method, 58 | print=TRUE, 59 | factor.reference="extraline", 60 | units=NULL, 61 | probindex=FALSE, 62 | ...){ 63 | if (missing(confint.method)) confint.method="default" 64 | if (missing(pvalue.method)) 65 | pvalue.method=switch(confint.method, 66 | "robust"={"robust"}, 67 | "simultaneous"={"simultaneous"}, 68 | "default") 69 | spec <- attr(terms(object),"specials") 70 | cluster <- spec$cluster-1 71 | strata <- spec$strata-1 72 | # if (!is.null(cluster)) cluster <- cluster-1 73 | rt <- regressionTable(object, 74 | noterms=c(cluster,strata), 75 | confint.method=confint.method, 76 | pvalue.method=pvalue.method, 77 | factor.reference=factor.reference, 78 | units=units, 79 | probindex=probindex) 80 | srt <- summary.regressionTable(rt, 81 | ## digits=digits, 82 | print=FALSE,...) 83 | if (print==TRUE) 84 | publish(srt$regressionTable,...) 85 | invisible(srt) 86 | } 87 | 88 | #---------------------------------------------------------------------- 89 | ### publish.coxph.R ends here 90 | -------------------------------------------------------------------------------- /man/specialFrame.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/specialFrame.R 3 | \name{specialFrame} 4 | \alias{specialFrame} 5 | \title{Special frame} 6 | \usage{ 7 | specialFrame( 8 | formula, 9 | data, 10 | unspecials.design = TRUE, 11 | specials, 12 | specials.factor = TRUE, 13 | specials.design = FALSE, 14 | strip.specials = TRUE, 15 | strip.arguments = NULL, 16 | strip.alias = NULL, 17 | strip.unspecials = NULL, 18 | drop.intercept = TRUE, 19 | response = TRUE, 20 | na.action = options()$na.action 21 | ) 22 | } 23 | \arguments{ 24 | \item{formula}{Formula whose left hand side specifies the event 25 | history, i.e., either via Surv() or Hist().} 26 | 27 | \item{data}{Data frame in which the formula is interpreted} 28 | 29 | \item{unspecials.design}{Passed as is to 30 | \code{\link{model.design}}.} 31 | 32 | \item{specials}{Character vector of special function names. 33 | Usually the body of the special functions is function(x)x but 34 | e.g., \code{\link{strata}} from the survival package does treat 35 | the values} 36 | 37 | \item{specials.factor}{Passed as is to \code{\link{model.design}}.} 38 | 39 | \item{specials.design}{Passed as is to \code{\link{model.design}}} 40 | 41 | \item{strip.specials}{Passed as \code{specials} to 42 | \code{\link{strip.terms}}} 43 | 44 | \item{strip.arguments}{Passed as \code{arguments} to 45 | \code{\link{strip.terms}}} 46 | 47 | \item{strip.alias}{Passed as \code{alias.names} to 48 | \code{\link{strip.terms}}} 49 | 50 | \item{strip.unspecials}{Passed as \code{unspecials} to 51 | \code{\link{strip.terms}}} 52 | 53 | \item{drop.intercept}{Passed as is to \code{\link{model.design}}} 54 | 55 | \item{response}{If FALSE do not get response data.} 56 | 57 | \item{na.action}{Decide what to do with missing values.} 58 | } 59 | \value{ 60 | A list which contains 61 | - the response 62 | - the design matrix (see \code{\link{model.design}}) 63 | - one entry for each special (see \code{\link{model.design}}) 64 | } 65 | \description{ 66 | Extract data and design matrix including specials from call 67 | } 68 | \details{ 69 | Obtain a list with the data used for event history regression analysis. This 70 | function cannot be used directly on the user level but inside a function 71 | to prepare data for survival analysis. 72 | } 73 | \examples{ 74 | 75 | ## Here are some data with an event time and no competing risks 76 | ## and two covariates X1 and X2. 77 | ## Suppose we want to declare that variable X1 is treated differently 78 | ## than variable X2. For example, X1 could be a cluster variable, or 79 | ## X1 should have a proportional effect on the outcome. 80 | d <- data.frame(y=1:7, 81 | X2=c(2.24,3.22,9.59,4.4,3.54,6.81,5.05), 82 | X3=c(1,1,1,1,0,0,1), 83 | X4=c(44.69,37.41,68.54,38.85,35.9,27.02,41.84), 84 | X1=factor(c("a","b","a","c","c","a","b"), 85 | levels=c("c","a","b"))) 86 | ## define special functions prop and cluster 87 | prop <- function(x)x 88 | cluster <- function(x)x 89 | ## We pass a formula and the data 90 | e <- specialFrame(y~prop(X1)+X2+cluster(X3)+X4, 91 | data=d, 92 | specials=c("prop","cluster")) 93 | ## The first element is the response 94 | e$response 95 | ## The other elements are the design, i.e., model.matrix for the non-special covariates 96 | e$design 97 | ## and a data.frame for the special covariates 98 | e$prop 99 | ## The special covariates can be returned as a model.matrix 100 | e2 <- specialFrame(y~prop(X1)+X2+cluster(X3)+X4, 101 | data=d, 102 | specials=c("prop","cluster"), 103 | specials.design=TRUE) 104 | e2$prop 105 | ## and the non-special covariates can be returned as a data.frame 106 | e3 <- specialFrame(y~prop(X1)+X2+cluster(X3)+X4, 107 | data=d, 108 | specials=c("prop","cluster"), 109 | specials.design=TRUE, 110 | unspecials.design=FALSE) 111 | e3$design 112 | } 113 | \seealso{ 114 | model.frame model.design Hist 115 | } 116 | \author{ 117 | Thomas A. Gerds 118 | } 119 | -------------------------------------------------------------------------------- /R/stripes.R: -------------------------------------------------------------------------------- 1 | ### stripes.R --- 2 | #---------------------------------------------------------------------- 3 | ## author: Thomas Alexander Gerds 4 | ## created: May 12 2015 (06:52) 5 | ## Version: 6 | ## last-updated: Feb 11 2019 (17:10) 7 | ## By: Thomas Alexander Gerds 8 | ## Update #: 26 9 | #---------------------------------------------------------------------- 10 | ## 11 | ### Commentary: 12 | ## 13 | ### Change Log: 14 | #---------------------------------------------------------------------- 15 | ## 16 | ### Code: 17 | #' Background and grid color control. 18 | #' 19 | #' Some users like background colors, and it may be helpful to have grid lines 20 | #' to read off e.g. probabilities from a Kaplan-Meier graph. Both things can be 21 | #' controlled with this function. However, it mainly serves 22 | #' \code{\link{plot.prodlim}}. 23 | #' 24 | #' 25 | #' @param xlim Limits for the horizontal x-dimension. Defaults to 26 | #' par("usr")[1:2]. 27 | #' @param ylim Limits for the vertical y-dimension. 28 | #' @param col Colors use for the stripes. Can be a vector of colors 29 | #' which are then repeated appropriately. 30 | #' @param lwd Line width 31 | #' @param gridcol Color of grid lines 32 | #' @param fill Color to fill the background rectangle given by 33 | #' par("usr"). 34 | #' @param horizontal Numerical values at which to show horizontal grid 35 | #' lines, and at which to change the color of the stripes. 36 | #' @param vertical Numerical values at which to show vertical grid 37 | #' lines. 38 | #' @param border If a fill color is provided, the color of the border 39 | #' around the background. 40 | #' @param xpd From \code{help(par)}: A logical value or NA. If FALSE, 41 | #' all plotting is clipped to the plot region, if TRUE, all plotting 42 | #' is clipped to the figure region, and if NA, all plotting is clipped 43 | #' to the device region. See also \code{clip}. 44 | #' @author Thomas Alexander Gerds 45 | #' @keywords survival 46 | #' @examples 47 | #' 48 | #' 49 | #' plot(0,0) 50 | #' backGround(bg="beige",fg="red",vertical=0,horizontal=0) 51 | #' 52 | #' plot(0,0) 53 | #' stripes(col=c("yellow","green"),gridcol="red",xlim=c(-1,1),horizontal=seq(0,1,.1)) 54 | #' stripes(col=c("yellow","green"),gridcol="red",horizontal=seq(0,1,.1)) 55 | #' 56 | #' @export 57 | stripes <- function(xlim, 58 | ylim, 59 | col="white", 60 | lwd=1, 61 | gridcol="gray77", 62 | fill="white", 63 | horizontal=NULL, 64 | vertical=NULL, 65 | border="black",xpd=FALSE){ 66 | U <- par("usr") 67 | if (!missing(xlim)){ 68 | U[1] <- xlim[1] 69 | U[2] <- xlim[2] 70 | } 71 | if (!missing(ylim)){ 72 | U[3] <- ylim[1] 73 | U[4] <- ylim[2] 74 | } 75 | print(U) 76 | # background 77 | if (!is.null(fill)) 78 | rect(U[1],U[3],U[2],U[4],col=fill, border=border,xpd=xpd) 79 | if (!is.null(col)){ 80 | if (length(col)==1){ 81 | rect(U[1],U[3],U[2],U[4],col=col[1], border=border,xpd=xpd) 82 | }else{ 83 | if (length(col)>1){ 84 | NR <- length(horizontal) 85 | bcol <- rep(col,length.out=NR) 86 | nix <- sapply(1:(NR-1),function(r){ 87 | polygon(x=c(U[1],U[1],U[2],U[2],U[1]), 88 | y=c(horizontal[r],horizontal[r+1],horizontal[r+1],horizontal[r],horizontal[r]), 89 | col=bcol[r], 90 | xpd=xpd, 91 | border=FALSE) 92 | ## do NOT specify: density=100 as this slows this down! 93 | }) 94 | } 95 | } 96 | } 97 | # grid 98 | if (length(gridcol)>0){ 99 | if (length(vertical)>0) 100 | abline(v=vertical,col=gridcol,xpd=xpd) 101 | if (length(horizontal)>0){ 102 | ## abline(h=horizontal,col=gridcol,xpd=xpd) 103 | for (h in horizontal){ 104 | segments(x0=U[1],x1=U[2],y0=h,y1=h,col=gridcol,xpd=xpd,lwd=lwd) 105 | } 106 | } 107 | } 108 | } 109 | 110 | 111 | #---------------------------------------------------------------------- 112 | ### stripes.R ends here 113 | -------------------------------------------------------------------------------- /R/lazyDateCoding.R: -------------------------------------------------------------------------------- 1 | ##' This function eases the process of generating date variables. 2 | ##' All variables in a data.frame which match a regular expression 3 | ##' are included 4 | ##' 5 | ##' The code needs to be copy-and-pasted from the R-output 6 | ##' buffer into the R-code buffer. This can be customized 7 | ##' for the really efficiently working people, e.g., in emacs. 8 | ##' @title Efficient coding of date variables 9 | ##' @param data Data frame in which to search for date variables. 10 | ##' @param format passed to as.Date 11 | ##' @param pattern match date variables 12 | ##' @param varnames variable names 13 | ##' @param testlength how many rows of data should be evaluated to guess the format. 14 | ##' @return R-code one line for each variable. 15 | ##' @author Thomas Alexander Gerds 16 | ##' @examples 17 | ##' d <- data.frame(x0="190101",x1=c("12/8/2019"),x2="12-8-2019",x3="20190812",stringsAsFactors=FALSE) 18 | ##' lazyDateCoding(d,pattern="x") 19 | ##' lazyDateCoding(d,pattern="3") 20 | ##' 21 | ##' @export 22 | lazyDateCoding <- function(data,format,pattern,varnames,testlength=10){ 23 | if (!is.character(data)) 24 | data <- as.character(substitute(data)) 25 | d <- get(data, envir=parent.frame()) 26 | isdt <- match("data.table",class(d),nomatch=FALSE) 27 | datevars <- grep(pattern,names(d),value=TRUE) 28 | out <- lapply(datevars,function(x){ 29 | dx <- d[[x]] 30 | if (is.character(dx)){ 31 | test.x <- dx[!is.na(dx)] 32 | test.x <- test.x[1:(min(length(test.x),testlength))] 33 | ## separator 34 | separators <- c("-","/","\\|"," ") 35 | sep <- sapply(separators,grep,test.x,value=TRUE) 36 | lsep <- sapply(sep,length) 37 | if (all(lsep==0)) 38 | sep <- "" 39 | else 40 | sep <- names(sep)[lsep==max(lsep)] 41 | ## day 42 | day <- "%d" 43 | ## month m or b 44 | if (any(grepl("[:alpha:]",test.x))) 45 | month <- "%b" else month <- "%m" 46 | ## year 07 or 2007 47 | l.x <- nchar(test.x) 48 | if (any((l.x-2*nchar(sep))<=6)) 49 | year <- "%y" else year <- "%Y" 50 | ## order 51 | test.formats <- c(paste0(day,sep,month,sep,year), 52 | paste0(day,sep,year,sep,month), 53 | paste0(year,sep,month,sep,day), 54 | paste0(year,sep,day,sep,month), 55 | paste0(month,sep,year,sep,day), 56 | paste0(month,sep,day,sep,year)) 57 | if (sep!=""){ 58 | list.x <- strsplit(test.x,sep) 59 | Y <- match(4,nchar(list.x[[1]]),nomatch=0) 60 | if (Y>0) year <- "%Y" 61 | test.formats <- switch(as.character(Y), 62 | "3"={c(paste0(day,sep,month,sep,year), 63 | paste0(month,sep,day,sep,year))}, 64 | "1"={c(paste0(year,sep,month,sep,day), 65 | paste0(year,sep,day,sep,month))}, 66 | "2"={c(paste0(month,sep,year,sep,day), 67 | paste0(day,sep,year,sep,month))}, 68 | {test.formats}) 69 | } 70 | ## print(test.formats) 71 | nix <- try(this.x <- as.Date(test.x[[1]],format=test.formats)) 72 | if ((class(nix)[[1]]=="try-error") || all(is.na(this.x))){ 73 | format.x <- "dontknow" 74 | }else{ 75 | format.x <- test.formats[!is.na(this.x)] 76 | if (length(format.x)>1){ # multiple matches 77 | winner <- sapply(format.x,function(fx){sum(!is.na(as.Date(test.x,format=fx)))}) 78 | format.x <- format.x[winner==max(winner)][1] 79 | } 80 | } 81 | if (isdt){ 82 | paste0(data,"[",",",x,":=as.Date(",x,",format=\"",format.x,"\")]\n") 83 | }else{ 84 | obj.x <- paste(data,"$",x,sep="") 85 | paste(obj.x," <- as.Date(",obj.x,",format=c(\"",format.x,"\")\n",sep="") 86 | } 87 | }else{ 88 | NULL 89 | }}) 90 | out <- out[!sapply(out,is.null)] 91 | sapply(unlist(out),cat) 92 | invisible(out) 93 | } 94 | -------------------------------------------------------------------------------- /R/publish.CauseSpecificCox.R: -------------------------------------------------------------------------------- 1 | ##' Publish cause-specific Cox models 2 | ##' 3 | ##' The cause-specific hazard ratio's are combined into one table. 4 | ##' @title Tabulizing cause-specific hazard ratio from all causes with confidence limits and Wald test p-values. 5 | ##' @param object Cause-specific hazard model obtained with 6 | ##' \code{CSC}. 7 | ##' @param cause Show a table for this cause. If omitted, list all 8 | ##' causes. 9 | ##' @param confint.method See \code{regressionTable} 10 | ##' @param pvalue.method See \code{regressionTable} 11 | ##' @param factor.reference See \code{regressionTable} 12 | ##' @param units See \code{regressionTable} 13 | ##' @param print If \code{TRUE} print the table(s). 14 | ##' @param ... passed on to control formatting of parameters, 15 | ##' confidence intervals and p-values. See 16 | ##' \code{summary.regressionTable}. 17 | ##' @return Table with cause-specific hazard ratios, confidence limits and p-values. 18 | ##' @author Thomas Alexander Gerds 19 | ##' @examples 20 | ##' if (requireNamespace("riskRegression",quietly=TRUE)){ 21 | ##' library(riskRegression) 22 | ##' library(prodlim) 23 | ##' library(survival) 24 | ##' data(Melanoma,package="riskRegression") 25 | ##' fit1 <- CSC(list(Hist(time,status)~sex,Hist(time,status)~invasion+epicel+age), 26 | ##' data=Melanoma) 27 | ##' publish(fit1) 28 | ##' publish(fit1,pvalue.stars=TRUE) 29 | ##' publish(fit1,factor.reference="inline",units=list("age"="years")) 30 | ##' 31 | ##' # wide format (same variables in both Cox regression formula) 32 | ##' fit2 <- CSC(Hist(time,status)~invasion+epicel+age, data=Melanoma) 33 | ##' publish(fit2) 34 | ##' 35 | ##' # with p-values 36 | ##' x <- publish(fit2,print=FALSE) 37 | ##' table <- cbind(x[[1]]$regressionTable, 38 | ##' x[[2]]$regressionTable[,-c(1,2)]) 39 | ##' } 40 | ##' 41 | ##' @export 42 | publish.CauseSpecificCox <- function(object, 43 | cause, 44 | confint.method, 45 | pvalue.method, 46 | factor.reference="extraline", 47 | units=NULL, 48 | print=TRUE, 49 | ...){ 50 | 51 | if (missing(confint.method)) confint.method="default" 52 | if (missing(pvalue.method)) 53 | pvalue.method=switch(confint.method, 54 | "robust"={"robust"}, 55 | "simultaneous"={"simultaneous"}, 56 | "default") 57 | if (missing(cause)) { 58 | clist <- lapply(object$models,function(m){ 59 | ## m$call$data <- object$call$data 60 | pm <- regressionTable(m, 61 | pvalue.method=pvalue.method, 62 | confint.method=confint.method, 63 | print=FALSE, 64 | factor.reference=factor.reference, 65 | units=units,...) 66 | summary.regressionTable(pm,print=FALSE,...) 67 | }) 68 | cause1 <- clist[[1]]$regressionTable 69 | ## colnames(cause1) <- paste(names(object$models)[[1]],names(cause1),sep=".") 70 | cause2 <- clist[[2]]$regressionTable 71 | if (NROW(cause1)==NROW(cause2)){ 72 | table=cbind(cause1[,1:2],"A"=paste(cause1[,3],cause1[,4]),"B"=paste(cause2[,3],cause2[,4])) 73 | colnames(table)[3:4] <- object$causes 74 | }else{table <- NULL} 75 | ## colnames(cause2) <- paste(names(object$models)[[2]],names(cause2),sep=".") 76 | out <- clist 77 | } else{ 78 | m <- object$models[[cause]] 79 | ## m$call$data <- object$call$data 80 | pm <- regressionTable(m, 81 | pvalue.method=pvalue.method, 82 | confint.method=confint.method, 83 | print=FALSE, 84 | factor.reference=factor.reference, 85 | units=units,...) 86 | ## now pm is a regression table 87 | out <- summary.regressionTable(pm,print=FALSE,...)$regressionTable 88 | } 89 | if (print==TRUE) { 90 | if (is.null(table)) 91 | lapply(1:length(out),function(i){ 92 | publish(names(out)[[i]]) 93 | publish(out[[i]]$regressionTable) 94 | }) 95 | else{ 96 | publish(table,...) 97 | } 98 | } 99 | invisible(out) 100 | } 101 | 102 | #---------------------------------------------------------------------- 103 | ### publish.CauseSpecificCox.R ends here 104 | -------------------------------------------------------------------------------- /R/publish.glm.R: -------------------------------------------------------------------------------- 1 | ##' Tabulate the results of a generalized linear regression analysis. 2 | ##' 3 | ##' The table shows changes in mean for linear regression and 4 | ##' odds ratios for logistic regression (family = binomial). 5 | ##' @title Tabulize regression coefficients with confidence intervals and p-values. 6 | ##' @export 7 | ##' @param object A \code{glm} object. 8 | ##' @param confint.method See \code{regressionTable}. 9 | ##' @param pvalue.method See \code{regressionTable}. 10 | ##' @param digits A vector of two integer values. These determine how to round 11 | ##' numbers (first value) and p-values (second value). E.g., c(1,3) would 12 | ##' mean 1 digit for all numbers and 3 digits for p-values. 13 | ##' The actual rounding is done by \code{summary.regressionTable}. 14 | ##' @param print If \code{FALSE} do not print results. 15 | ##' @param factor.reference Style for showing results for categorical. See \code{regressionTable}. 16 | ##' @param intercept See \code{regressionTable}. 17 | ##' @param units See \code{regressionTable}. 18 | ##' @param ... passed to \code{summary.regressionTable} and also 19 | ##' to \code{labelUnits}. 20 | ##' @param reference Style for showing results for categorical 21 | ##' variables. If \code{"extraline"} show an additional line for the 22 | ##' reference category. 23 | ##' @return Table with regression coefficients, confidence intervals and p-values. 24 | ##' @author Thomas Alexander Gerds 25 | ##' @examples 26 | ##' data(Diabetes) 27 | ##' ## Linear regression 28 | ##' f = glm(bp.2s~frame+gender+age,data=Diabetes) 29 | ##' publish(f) 30 | ##' publish(f,factor.reference="inline") 31 | ##' publish(f,pvalue.stars=TRUE) 32 | ##' publish(f,ci.format="(l,u)") 33 | ##' 34 | ##' ### interaction 35 | ##' fit = glm(bp.2s~frame+gender*age,data=Diabetes) 36 | ##' summary(fit) 37 | ##' publish(fit) 38 | ##' 39 | ##' Fit = glm(bp.2s~frame*gender+age,data=Diabetes) 40 | ##' publish(Fit) 41 | ##' 42 | ##' ## Logistic regression 43 | ##' Diabetes$hyper1 <- factor(1*(Diabetes$bp.1s>140)) 44 | ##' lrfit <- glm(hyper1~frame+gender+age,data=Diabetes,family=binomial) 45 | ##' publish(lrfit) 46 | ##' 47 | ##' ### interaction 48 | ##' lrfit1 <- glm(hyper1~frame+gender*age,data=Diabetes,family=binomial) 49 | ##' publish(lrfit1) 50 | ##' 51 | ##' lrfit2 <- glm(hyper1~frame*gender+age,data=Diabetes,family=binomial) 52 | ##' publish(lrfit2) 53 | ##' 54 | ##' ## Poisson regression 55 | ##' data(trace) 56 | ##' trace <- Units(trace,list("age"="years")) 57 | ##' fit <- glm(dead ~ smoking+sex+age+Time+offset(log(ObsTime)), family="poisson",data=trace) 58 | ##' rtf <- regressionTable(fit,factor.reference = "inline") 59 | ##' summary(rtf) 60 | ##' publish(fit) 61 | ##' 62 | ##' ## gls regression 63 | ##' if (requireNamespace("nlme",quietly=TRUE)){ 64 | ##' requireNamespace("lava",quietly=TRUE) 65 | ##' library(lava) 66 | ##' library(nlme) 67 | ##' m <- lvm(Y ~ X1 + gender + group + Interaction) 68 | ##' distribution(m, ~gender) <- binomial.lvm() 69 | ##' distribution(m, ~group) <- binomial.lvm(size = 2) 70 | ##' constrain(m, Interaction ~ gender + group) <- function(x){x[,1]*x[,2]} 71 | ##' d <- sim(m, 1e2) 72 | ##' d$gender <- factor(d$gender, labels = letters[1:2]) 73 | ##' d$group <- factor(d$group) 74 | ##' 75 | ##' e.gls <- gls(Y ~ X1 + gender*group, data = d, 76 | ##' weights = varIdent(form = ~1|group)) 77 | ##' publish(e.gls) 78 | ##' 79 | ##' ## lme 80 | ##' fm1 <- lme(distance ~ age*Sex, 81 | ##' random = ~1|Subject, 82 | ##' data = Orthodont) 83 | ##' res <- publish(fm1) 84 | ##' } 85 | ##' @export 86 | publish.glm <- function(object, 87 | confint.method, 88 | pvalue.method, 89 | digits=c(2,4), 90 | print=TRUE, 91 | factor.reference="extraline", 92 | intercept=ifelse((is.null(object$family)||object$family$family=="gaussian"),1L,0L), 93 | units=NULL, 94 | ...){ 95 | if (missing(confint.method)) confint.method="default" 96 | if (missing(pvalue.method)) 97 | pvalue.method=switch(confint.method, 98 | "robust"={"robust"}, 99 | "simultaneous"={"simultaneous"}, 100 | "default") 101 | rt <- regressionTable(object, 102 | confint.method=confint.method, 103 | pvalue.method=pvalue.method, 104 | factor.reference=factor.reference, 105 | intercept=intercept, 106 | units=units) 107 | srt <- summary.regressionTable(rt, 108 | digits=digits, 109 | print=FALSE,...) 110 | if (print==TRUE) 111 | publish(srt$regressionTable,...) 112 | invisible(srt) 113 | } 114 | ##' @export 115 | publish.lm <- publish.glm 116 | ##' @export 117 | publish.gls <- publish.glm 118 | ##' @export 119 | publish.lme <- publish.glm 120 | ##' @export 121 | publish.geeglm <- publish.glm 122 | -------------------------------------------------------------------------------- /man/publish.MIresult.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/publish.MIresult.R 3 | \name{publish.MIresult} 4 | \alias{publish.MIresult} 5 | \title{Present logistic regression and Cox regression obtained with mitools::MIcombine based on smcfcs::smcfcs multiple imputation analysis} 6 | \usage{ 7 | \method{publish}{MIresult}( 8 | object, 9 | confint.method, 10 | pvalue.method, 11 | digits = c(2, 4), 12 | print = TRUE, 13 | factor.reference = "extraline", 14 | intercept, 15 | units = NULL, 16 | fit, 17 | data, 18 | ... 19 | ) 20 | } 21 | \arguments{ 22 | \item{object}{Object obtained with mitools::MIcombine based on smcfcs::smcfcs multiple imputation analysis} 23 | 24 | \item{confint.method}{No options here. Only Wald type confidence 25 | intervals.} 26 | 27 | \item{pvalue.method}{No options here. Only Wald type tests.} 28 | 29 | \item{digits}{Rounding digits for all numbers but the p-values.} 30 | 31 | \item{print}{If \code{FALSE} suppress printing of the results} 32 | 33 | \item{factor.reference}{Style for showing results for 34 | categorical. See \code{regressionTable}.} 35 | 36 | \item{intercept}{See \code{regressionTable}.} 37 | 38 | \item{units}{See \code{regressionTable}.} 39 | 40 | \item{fit}{One fitted model using the same formula as 41 | \code{object}. This can be the fit to the complete case data or 42 | the fit to one of the completed data. It is used to get 43 | xlevels, formula and terms. For usage see examples. is used to 44 | fit} 45 | 46 | \item{data}{Original data set which includes the missing values} 47 | 48 | \item{...}{passed to summary.regressionTable, labelUnits and publish.default.} 49 | } 50 | \description{ 51 | Regression tables after multiple imputations 52 | } 53 | \details{ 54 | Show results of smcfcs based multiple imputations of missing covariates in publishable format 55 | } 56 | \examples{ 57 | 58 | \dontrun{ 59 | if (requireNamespace("riskRegression",quietly=TRUE) 60 | & requireNamespace("mitools",quietly=TRUE) 61 | & requireNamespace("smcfcs",quietly=TRUE)){ 62 | library(riskRegression) 63 | library(mitools) 64 | library(smcfcs) 65 | ## continuous outcome: linear regression 66 | # lava some data with missing values 67 | set.seed(7) 68 | d=sampleData(78) 69 | ## generate missing values 70 | d[X1==1,X6:=NA] 71 | d[X2==1,X3:=NA] 72 | d=d[,.(X8,X4,X3,X6,X7)] 73 | sapply(d,function(x)sum(is.na(x))) 74 | 75 | # multiple imputation (should set m to a large value) 76 | 77 | set.seed(17) 78 | f= smcfcs(d,smtype="lm", 79 | smformula=X8~X4+X3+X6+X7, 80 | method=c("","","logreg","norm",""),m=3) 81 | ccfit=lm(X8~X4+X3+X6+X7,data=d) 82 | mifit=MIcombine(with(imputationList(f$impDatasets), 83 | lm(X8~X4+X3+X6+X7))) 84 | publish(mifit,fit=ccfit,data=d) 85 | publish(ccfit) 86 | 87 | ## binary outcome 88 | # lava some data with missing values 89 | set.seed(7) 90 | db=sampleData(78,outcome="binary") 91 | ## generate missing values 92 | db[X1==1,X6:=NA] 93 | db[X2==1,X3:=NA] 94 | db=db[,.(Y,X4,X3,X6,X7)] 95 | sapply(db,function(x)sum(is.na(x))) 96 | 97 | # multiple imputation (should set m to a large value) 98 | set.seed(17) 99 | fb= smcfcs(db,smtype="logistic", 100 | smformula=Y~X4+X3+X6+X7, 101 | method=c("","","logreg","norm",""),m=2) 102 | ccfit=glm(Y~X4+X3+X6+X7,family="binomial",data=db) 103 | mifit=MIcombine(with(imputationList(fb$impDatasets), 104 | glm(Y~X4+X3+X6+X7,family="binomial"))) 105 | publish(mifit,fit=ccfit) 106 | publish(ccfit) 107 | 108 | ## survival: Cox regression 109 | library(survival) 110 | # lava some data with missing values 111 | set.seed(7) 112 | ds=sampleData(78,outcome="survival") 113 | ## generate missing values 114 | ds[X5==1,X6:=NA] 115 | ds[X2==1,X3:=NA] 116 | ds=ds[,.(time,event,X4,X3,X6,X7)] 117 | sapply(ds,function(x)sum(is.na(x))) 118 | 119 | set.seed(17) 120 | fs= smcfcs(ds,smtype="coxph", 121 | smformula="Surv(time,event)~X4+X3+X6+X7", 122 | method=c("","","","logreg","norm",""),m=2) 123 | ccfit=coxph(Surv(time,event)~X4+X3+X6+X7,data=ds) 124 | mifit=MIcombine(with(imputationList(fs$impDatasets), 125 | coxph(Surv(time,event)~X4+X3+X6+X7))) 126 | publish(mifit,fit=ccfit,data=ds) 127 | publish(ccfit) 128 | 129 | ## competing risks: Cause-specific Cox regression 130 | library(survival) 131 | # lava some data with missing values 132 | set.seed(7) 133 | dcr=sampleData(78,outcome="competing.risks") 134 | ## generate missing values 135 | dcr[X5==1,X6:=NA] 136 | dcr[X2==1,X3:=NA] 137 | dcr=dcr[,.(time,event,X4,X3,X6,X7)] 138 | sapply(dcr,function(x)sum(is.na(x))) 139 | 140 | set.seed(17) 141 | fcr= smcfcs(dcr,smtype="compet", 142 | smformula=c("Surv(time,event==1)~X4+X3+X6+X7", 143 | "Surv(time,event==2)~X4+X3+X6+X7"), 144 | method=c("","","","logreg","norm",""),m=2) 145 | ## cause 2 146 | ccfit2=coxph(Surv(time,event==2)~X4+X3+X6+X7,data=dcr) 147 | mifit2=MIcombine(with(imputationList(fcr$impDatasets), 148 | coxph(Surv(time,event==2)~X4+X3+X6+X7))) 149 | publish(mifit2,fit=ccfit2,data=dcr) 150 | publish(ccfit2) 151 | } 152 | } 153 | 154 | } 155 | \author{ 156 | Thomas A. Gerds 157 | } 158 | -------------------------------------------------------------------------------- /man/regressionTable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/regressionTable.R 3 | \name{regressionTable} 4 | \alias{regressionTable} 5 | \title{Regression table} 6 | \usage{ 7 | regressionTable( 8 | object, 9 | param.method = "coef", 10 | confint.method = c("default", "profile", "robust", "simultaneous"), 11 | pvalue.method = c("default", "robust", "simultaneous"), 12 | factor.reference = "extraline", 13 | intercept = 0L, 14 | units = NULL, 15 | noterms = NULL, 16 | probindex = 0L, 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{object}{Fitted regression model obtained with \code{lm}, 22 | \code{glm} or \code{coxph}.} 23 | 24 | \item{param.method}{Method to obtain model coefficients.} 25 | 26 | \item{confint.method}{Method to obtain confidence 27 | intervals. Default is 'default' which leads to Wald 28 | type intervals using the model based estimate of standard 29 | error. 'profile' yields profile likelihood confidence 30 | intervals, available from library MASS for \code{lm} and 31 | \code{glm} objects. 'robust' uses the sandwich form 32 | standard error to construct Wald type intervals (see 33 | \code{lava::estimate.default}). 'simultaneous' calls 34 | \code{multcomp::glht} to obtain simultaneous confidence 35 | intervals.} 36 | 37 | \item{pvalue.method}{Method to obtain p-values. If 38 | \code{'default'} show raw p-values. If \code{'robust'} use 39 | p-value corresponding to robust standard error as provided by 40 | \code{lava::estimate.default}. If \code{'simultaneous'} call 41 | \code{multcomp::glht} to obtain p-values.} 42 | 43 | \item{factor.reference}{Style for showing results for categorical 44 | variables. If \code{'extraline'} show an additional line for 45 | the reference category. If \code{'inline'} display as level 46 | vs. reference.} 47 | 48 | \item{intercept}{Logical. If \code{FALSE} suppress intercept.} 49 | 50 | \item{units}{List of units for continuous variables. See examples.} 51 | 52 | \item{noterms}{Position of terms that should be ignored. E.g., for 53 | a Cox model with a cluster(id) term, there will be no hazard 54 | ratio for variable id.} 55 | 56 | \item{probindex}{Logical. If \code{TRUE} show coefficients on probabilistic index scale instead of hazard ratio scale.} 57 | 58 | \item{...}{Not yet used} 59 | } 60 | \value{ 61 | List of regression blocks 62 | } 63 | \description{ 64 | Tabulate the results of a regression analysis. 65 | } 66 | \details{ 67 | The basic use of this function is to generate a near publication worthy table from a regression 68 | object. As with summary(object) reference levels of factor variables are not included. Expansion 69 | of the table with such values can be performed using the "fixRegressionTable" function. Forest 70 | plot can be added to the output with "plotRegressionTable". 71 | 72 | regressionTable produces an object (list) with the parameters deriveds. The summary function creates 73 | a data frame which can be used as a (near) publication ready table. 74 | 75 | The table shows changes in mean for linear regression, odds ratios 76 | for logistic regression (family = binomial) and hazard ratios for 77 | Cox regression. 78 | } 79 | \examples{ 80 | # linear regression 81 | data(Diabetes) 82 | f1 <- glm(bp.1s~age+gender+frame+chol,data=Diabetes) 83 | summary(regressionTable(f1)) 84 | summary(regressionTable(f1,units=list("chol"="mmol/L","age"="years"))) 85 | ## with interaction 86 | f2 <- glm(bp.1s~age*gender+frame+chol,data=Diabetes) 87 | summary(regressionTable(f2)) 88 | #Add reference values 89 | summary(regressionTable(f2)) 90 | f3 <- glm(bp.1s~age+gender*frame+chol,data=Diabetes) 91 | publish(f3) 92 | regressionTable(f3) 93 | 94 | # logistic regression 95 | Diabetes$hyp1 <- factor(1*(Diabetes$bp.1s>140)) 96 | l1 <- glm(hyp1~age+gender+frame+chol,data=Diabetes,family="binomial") 97 | regressionTable(l1) 98 | publish(l1) 99 | plot(regressionTable(l1)) 100 | 101 | ## with interaction 102 | l2 <- glm(hyp1~age+gender+frame*chol,data=Diabetes,family="binomial") 103 | regressionTable(l2) 104 | l3 <- glm(hyp1~age*gender+frame*chol,data=Diabetes,family="binomial") 105 | regressionTable(l3) 106 | 107 | # Cox regression 108 | library(survival) 109 | data(pbc) 110 | pbc$edema <- factor(pbc$edema,levels=c("0","0.5","1"),labels=c("0","0.5","1")) 111 | c1 <- coxph(Surv(time,status!=0)~log(bili)+age+protime+sex+edema,data=pbc) 112 | regressionTable(c1) 113 | # with interaction 114 | c2 <- coxph(Surv(time,status!=0)~log(bili)+age+protime*sex+edema,data=pbc) 115 | regressionTable(c2) 116 | c3 <- coxph(Surv(time,status!=0)~edema*log(bili)+age+protime+sex+edema+edema:sex,data=pbc) 117 | regressionTable(c3) 118 | 119 | 120 | if (requireNamespace("nlme",quietly=TRUE)){ 121 | ## gls regression 122 | library(lava) 123 | library(nlme) 124 | m <- lvm(Y ~ X1 + gender + group + Interaction) 125 | distribution(m, ~gender) <- binomial.lvm() 126 | distribution(m, ~group) <- binomial.lvm(size = 2) 127 | constrain(m, Interaction ~ gender + group) <- function(x){x[,1]*x[,2]} 128 | d <- sim(m, 1e2) 129 | d$gender <- factor(d$gender, labels = letters[1:2]) 130 | d$group <- factor(d$group) 131 | 132 | e.gls <- gls(Y ~ X1 + gender*group, data = d, 133 | weights = varIdent(form = ~1|group)) 134 | regressionTable(e.gls) 135 | summary(regressionTable(e.gls)) 136 | } 137 | } 138 | \author{ 139 | Thomas A. Gerds 140 | } 141 | --------------------------------------------------------------------------------