#' Kaplan-Meier Estimates
#'
#' For two strata, estimates the standard error of the difference in two
#' Kaplan-Meier estimates at each value of times, and plots half-width
#' of confidence level for the difference, centered at the midpoint
#' of the survival estimates.
#'
#' details
#'
#' @param fit survfit object. See \code{\link[rms]{survfit.formula}}.
#' @param times numeric vector. Time value for each record.
#' @param fun function. Function to plot estimates.
#' @param offset numeric. Offset value to apply to \sQuote{x} coordinate points.
#' @param lwd numeric. The line width, passed to \code{lines}.
#' @param lty numeric. The line type, passed to \code{lines}.
#' @export
#' @examples
#' set.seed(20)
#' time <- rep(365, 50)
#' event <- rbinom(50, 1, 1/3)
#' time[event == 1] <- sample(365, sum(event == 1), replace=TRUE)
#' trt <- sample(1:2, 50, replace=TRUE)
#' require('rms')
#' fit <- survfit.formula(Surv(time, event) ~ trt)
#' survplot.survfit(fit)
#' plotKmHalfCL(fit, time)
plotKmHalfCL <- function(fit, times, fun=function(x) x,
offset=0, lwd=0.5, lty=1) {
s <- summary(fit, times=times)
st <- s$strata
lev <- levels(st)
if(length(lev) != 2) {
stop('only handles 2 strata')
}
s1 <- s$surv[st==lev[1]]
s2 <- s$surv[st==lev[2]]
se1 <- s$std.err[st==lev[1]]
se2 <- s$std.err[st==lev[2]]
se.diff <- sqrt(se1^2 + se2^2)
clhalf <- 1.96*se.diff
midpt <- (s1 + s2)/2
for(i in 1:length(times)) {
lines(offset+c(times[i],times[i]),
fun(c(midpt[i]-clhalf[i]/2, midpt[i]+clhalf[i]/2)),
lwd=lwd, lty=lty, col=gray(0.7))
}
}
#' Set mfrow Parameter
#'
#' Compute and set a good \code{par("mfrow")} given the
#' number of figures to plot.
#'
#' \code{trellis} and \code{small} may not both be specified as \sQuote{TRUE}.
#'
#' @param n numeric. Total number of figures to place in layout.
#' @param trellis logical. Set to \sQuote{TRUE} when a \sQuote{trellis} plot
#' is requested.
#' @param small logical. Set to \sQuote{TRUE} if the plot area should be
#' smaller to accomodate many plots.
#' @return return numeric vector.
#' If \code{trellis = TRUE} the suggested \sQuote{mfrow} is returned.
#' Otherwise the original \sQuote{mfrow} is returned invisibly.
#' @export
#' @examples
#' oldmfrow <- mfrowSet(8)
mfrowSet <- function(n, trellis=FALSE, small=FALSE) {
if(small && trellis) stop('may not specify small=T when trellis=T')
omf <- mf <- if(trellis)NULL else par('mfrow')
if(length(mf)==0) mf <- c(1,1)
if(n > 1 & max(mf)==1) {
if(small) {
mf <- if(n <= 4) {
c(2,2)
} else if(n <= 6) {
c(2,3)
} else if(n <= 12) {
c(3,4)
} else if(n <= 16) {
c(4,4)
} else if(n <= 20) {
c(4,5)
} else if(n <= 24) {
c(4,6)
} else if(n <= 25) {
c(5,5)
} else if(n <= 30) {
c(5,6)
} else if(n <= 36) {
c(6,6)
} else if(n <= 42) {
c(6,7)
} else {
c(6,8)
}
} else {
mf <- if(n <= 4) {
c(2,2)
} else if(n <= 6) {
c(2,3)
} else if(n <= 9) {
c(3,3)
} else {
c(4,3)
}
if(n > 12 & n <= 16) {
mf <- c(4,4)
}
}
if(!trellis) {
par(mfrow=mf)
}
}
if(trellis) {
mf
} else {
invisible(omf)
}
}
#' Put Figure
#'
#' Included a generated figure within LaTex document.
#'
#' @param panel character. Panel name.
#' @param name character. Name for figure.
#' @param caption character. Short caption for figure.
#' @param longcaption character. Long caption for figure.
#' @param append logical. If \sQuote{TRUE} output will be appended instead of overwritten.
#' @export
putFig <- function(panel, name, caption=NULL, longcaption=NULL, append=TRUE) {
gtype <- getOption('rreport.gtype')
if(gtype=='interactive') {
return(invisible())
}
panel <- paste(translate(panel, '.', '-'), '.tex', sep='')
name <- translate(name, '.', '-')
file <- file.path(TexDirName(), panel)
suffix <- paste('.', gtype, sep='')
## if(length(caption)) caption <- latexTranslate(caption)
## if(length(longcaption)) longcaption <- latexTranslate(longcaption)
capt1 <- capt2 <- ""
if(length(longcaption)) {
capt1 <- sprintf("\\caption[%s]{%s}\n", caption, longcaption)
} else if(length(caption)) {
capt1 <- sprintf("\\caption{%s}\n", caption)
}
if(length(caption)) {
capt2 <- sprintf("\\label{fig:%s}\n", name)
}
mytex <- sprintf("\\begin{figure}[hbp!]\\leavevmode\\centerline{\\includegraphics{%s%s}}\n%s%s\\end{figure}\n", name, suffix, capt1, capt2)
cat(mytex, file=file, append=append)
invisible()
}
#' Plot Initialization
#'
#' Toggle plotting. Sets options by examining \code{.Options$rreport.gtype}.
#'
#' @param file character. Character string specifying file prefix.
#' @param \dots Arguments to be passed to \code{\link[Hmisc]{setps}} or \code{\link[Hmisc]{setpdf}}.
#' @export
#' @seealso \code{\link[Hmisc]{ps.slide}}
startPlot <- function(file, ...) {
gtype <- getOption('rreport.gtype')
file <- translate(file,'.','-')
if(gtype == 'pdf') {
options(setpdfPrefix=file.path('pdf',''))
setpdf(file, ..., type='char')
} else if(gtype == 'ps') {
options(setpsPrefix=file.path('ps',''))
setps(file, ..., type='char')
}
invisible()
}
#' @rdname startPlot
#' @export
endPlot <- function() {
gtype <- getOption('rreport.gtype')
if(gtype != 'interactive') {
dev.off()
}
invisible()
}
#' Combine Equal
#'
#' Given a contingency table of counts, combine factors with equal counts.
#'
#' Factor names will be pasted together to make new names. A code and definition will be generated
#' if the new name should exceed \code{maxChar}.
#'
#' @param x numeric. Contingency table or matrix of names and counts, see \code{\link[base]{table}}.
#' @param maxChar numeric. Maximum length of character string. Names exceeding this will be replaced with a letter-code.
#' @return a list with three elements
#' \item{x}{Named vector of code frequencies. The name corresponds to the code.}
#'
#' \item{codes}{Character vector of alpha-code labels.}
#'
#' \item{defs}{Character vector of code definitions.}
#'
#' @export
#' @examples
#' combineEqual(table(rep(991:1010, times=rep(1:4, each=5))))
#' combineEqual(table(rep(991:1010, times=rep(1:4, each=5))), maxChar=10)
combineEqual <- function(x, maxChar=24) {
xorig <- x
if(is.matrix(x)) {
x <- apply(x, 2, paste, collapse=',')
}
if(!any(duplicated(x))) {
return(xorig)
}
z <- split(names(x), x)
v <- if(is.matrix(xorig)) {
names(z)
} else {
as.numeric(names(z))
}
nam <- codes <- defs <- character(0)
j <- 0
all.letters <- c(letters,LETTERS)
for(i in 1:length(z)) {
a <- z[[i]]
ac <- paste(a, collapse=', ')
if(nchar(ac) <= maxChar) {
nam <- c(nam,ac)
} else {
j <- j + 1
k <- paste('(',all.letters[j],')',sep='')
nam <- c(nam, k)
codes <- c(codes, k)
defs <- c(defs, ac)
}
}
names(v) <- nam
if(is.matrix(xorig)) {
v <- matrix(as.numeric(unlist(strsplit(v,','))),ncol=length(v),
dimnames=list(dimnames(xorig)[[1]], nam))
}
list(x=v, codes=codes, defs=defs)
}
#' Make Treatment Key
#'
#' Use treatment levels to generate treatment key in LaTeX.
#'
#' Typically will be called with \code{paramFile} missing as the filename
#' will be generated by package options.
#'
#' @param tlevels vector. unique treatment levels, expected to have length two
#' @param paramFile character. params filename
#' @param append logical. If \sQuote{TRUE} output will be appended to \sQuote{file},
#' otherwise, contents will be overwritten
#' @export
#' @examples
#' makeTreatKey(c('A', 'B'), paramFile='') # prints to standard output
makeTreatKey <- function(tlevels, paramFile, append=FALSE) {
if(length(tlevels) != 2) {
stop('expected two levels of treatment')
}
if(missing(paramFile)) {
paramFile <- paramTexFile()
}
cat('\\def\\treatkey{', tlevels[1], ':\\rule[.05in]{.25in}{.5pt}; ', tlevels[2], ':\\textcolor[gray]{0.7}{\\rule[.05in]{.25in}{1.25pt}}.}\n',
sep='', file=paramFile, append=append)
invisible()
}
#' Put Params
#'
#' Define parameters and provide LaTeX formatting.
#'
#' Parameters will be saved to the parameter LaTeX file.
#'
#' @param \dots list of name-value pairs. parameter names and their associated formats
#' @param paramFile character. params filename
#' @export
#' @examples
#' putparams(go=1, fish='blue', paramFile='') #prints to standard output
putparams <- function(..., paramFile) {
if(missing(paramFile)) {
paramFile <- paramTexFile()
}
x <- list(...)
if(!length(x)) {
cat('% $Id$\n', file=paramFile)
} else {
for(n in names(x)) {
cat('\\def\\', n, '{', format(x[[n]]), '}\n', sep='', file=paramFile, append=TRUE)
}
}
invisible()
}
#' PS-to-PDF Directory
#'
#' Used if want to create PS files and later convert all to PDF
#'
#' Utilize the \sQuote{epstopdf} command for conversion.
#'
#' @export
dirps2pdf <- function() {
files <- dir('ps/', pattern='\\.ps$')
nfiles <- sub('ps$', 'pdf', files)
i <- 0
for(file in files) {
i <- i + 1
psname <- file.path('ps', file)
pdfname <- file.path('pdf', nfiles[i])
input.date <- file.info(psname)$mtime
output.date <- file.info(pdfname)$mtime
if(is.na(output.date) || output.date < input.date) {
cat('Converting file:',file,'\n')
cmd <- sprintf("epstopdf %s -o %s", shQuote(psname), shQuote(pdfname))
system(cmd)
}
}
invisible()
}
#' Publish PDF
#'
#' summary
#'
#' details
#'
#' @param reports NEEDDOC
#' @param minutes NEEDDOC
#' @param title NEEDDOC
#' @param server NEEDDOC
#' @param path NEEDDOC
#' @param extension NEEDDOC
#' @param upload NEEDDOC
#' @param email NEEDDOC
#' @param uid NEEDDOC
#' @param passwd NEEDDOC
#' @param to NEEDDOC
#' @param cc NEEDDOC
#' @param bcc NEEDDOC
#' @param sig NEEDDOC
#' @param hardcopies NEEDDOC
#' @param verbose NEEDDOC
#' @param mailer NEEDDOC
#' @param extra NEEDDOC
#' @return return something
#' @export
#' @examples
#' 1
publishPdf <- function(reports, minutes=NULL, title, server, path, extension="pdf",
upload=TRUE, email=FALSE, uid=NULL, passwd=NULL,
to=NULL, cc=NULL, bcc=NULL, sig=NULL,
hardcopies=TRUE, verbose=TRUE,
mailer=c('mail','kmail'), extra=NULL) {
## E.g. publishPdf(c(report='Closed Meeting Report',
## Oreport='Open Meeting Report'),title='My Project',
## server='myserver.edu', path='/home/www/html/myproject')
## Be sure to put something like export REPLYTO=foo@place.edu in ~/.bashrc
## if using mailer='mail'
mailer <- match.arg(mailer)
nl <- ifelse(mailer=='kmail','\n','\\n')
if(upload) {
f <- tempfile()
if(file.exists(f) && !file.info(f)$isdir) {
file.remove(f)
}
dir.create(f, recursive=TRUE)
if (extension=="") {sep=""} else {sep="."}
rn <- paste(names(c(reports,minutes)), extension, sep=sep)
paths <- file.path(f, c('index.html', basename(rn)))
info <- file.info(rn)[,c('size','mtime')]
cat('<html><body bgcolor=white>',
paste('<h2>', title, '</h2>', sep=''),
sep='\n', file=paths[1])
i <- with(info, data.frame(Bytes=size, 'Date Created'=mtime,
Description=c(reports,minutes),
row.names=basename(row.names(info)),
check.names=FALSE))
z <- html(i, file=paths[1], append=TRUE, link=basename(rn), linkCol='Name',
linkType='href')
file.copy(rn, paths[-1], overwrite=TRUE)
system(paste('chmod u=rw,g=rw,o=', paste(shQuote(paths), collapse=' ')))
system(paste('scp ', paste(shQuote(paths), collapse=' '), ' ', server, ':', path, sep=''))
#file.remove(paths, f)
}
if(email) {
url <- strsplit(path, '/')[[1]]
url <- url[length(url)]
url <- paste('http://', server, '/', url, sep='')
cmd <- paste(
if(length(c(reports,minutes)) ==1) {
'The following document has'
} else {
'The following documents have'
},
' been placed or updated on a secure web page:',nl,#nl,
paste(c(reports,minutes), collapse=nl), nl, nl,
'Point your browser to ', url, #nl,
' and use the username ', uid,
' and the password that will be in the next email. ',
'For accuracy, copy the password from the e-mail and',
' paste it in the proper field in your browser.',nl,nl,
'Please confirm your ability to open the pdf files within 24 hours by replying to this message.',nl,nl,
if(hardcopies) {
'I will bring final hard copies to the meeting.'
},
if(length(extra)) {
paste(nl,nl, extra,sep='')
},
sep='')
if(length(sig)) {
sig <- paste(sig, collapse=nl)
cmd <- paste(cmd, nl, '----------', nl, sig, sep='')
}
if(mailer=='kmail') {
tf <- tempfile()
cat(cmd, file=tf)
to <- paste('"', paste(to, collapse=','), '"', sep='')
if(length(cc)) {
cc <- paste(' -c "', paste(cc, collapse=','),'"',sep='')
}
if(length(bcc)) {
bcc <- paste(' -b "', paste(bcc, collapse=','),'"',sep='')
}
} else {
to <- paste(to, collapse=' ')
if(length(cc)) {
cc <- paste(paste(' -c', cc), collapse='')
}
if(length(bcc)) {
bcc <- paste(paste(' -b', bcc),collapse='')
}
}
cmd <- if(mailer=='kmail') {
paste('kmail -s "', title, '"', cc,
bcc, ' --msg ', tf, ' ', to, sep='')
} else {
paste('echo "', cmd, '" | mail -s "',
title, ' Reports"', cc, bcc, ' ', to, sep='')
}
system(cmd)
if(verbose) {
cat('\n\nMail command sent:\n', cmd, '\n')
}
prn(passwd)
if(length(passwd)) {
cmd <- if(mailer=='kmail') {
paste('kmail -s "Additional information"', cc, bcc,
' --body "', passwd, '" ', to, sep='')
} else {
paste('echo ', passwd, ' | mail -s "Additional information"',
cc, bcc, ' ', to, sep='')
}
system(cmd)
if(verbose) {
cat('\n\nMail command sent:\n', cmd, '\n')
}
}
}
invisible()
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.