### plotConfidence.R ---
#-------
## author: Thomas Alexander Gerds
## created: May 10 2015 (11:03)
## Version:
## last-updated: Jul 29 2021 (10:03)
## By: Thomas Alexander Gerds
## Update #: 561
#----------------------------------------------------------------------
##
### Commentary:
##
### Change Log:
#----------------------------------------------------------------------
##
### Code:
##' Function to plot confidence intervals with their values and additional labels.
##' One anticipated use of this function involves first the generation of a regression object,
##' then arrangement of a result table with "regressionTable", further arrangment of table with
##' with e.g. "fixRegressionTable" and various user defined changes - and then finally table
##' along with forest plot using the current function.
##'
##' Function to plot means and other point estimates with confidence intervals,
##' their values and additional labels .
##' Horizonal margins as determined by par()$mar are ignored.
##' Instead layout is used to divide the plotting region horizontally
##' into two or three parts plus leftmargin and rightmargin.
##'
##' When values is FALSE there are only two parts. The default order is
##' labels on the left confidence intervals on the right.
##' When no labels are given or labels is FALSE there are only two parts. The default order is
##' confidence intervals on the left values on the right.
##'
##' The default order of three parts from left to right is
##' labels, confidence intervals, values. The order can be changed as shown
##' by the examples below. The relative widths of the two or three parts
##' need to be adapted to the actual size of the text of the labels. This
##' depends on the plotting device and the size of the font and figures and
##' thus has to be adjusted manually.
##'
##' Oma can be used to further control horizontal margins, e.g., par(oma=c(0,4,0,4)).
##'
##' If confidence limits extend beyond the range determined by xlim, then
##' arrows are drawn at the x-lim borders to indicate that the confidence
##' limits continue.
##' @title Plot confidence intervals
##' @param x Either a vector containing the point estimates or a list
##' whose first element contains the point estimates. Further list
##' elements can contain the confidence intervals and labels. In this
##' case the list needs to have names 'lower' and 'upper' to indicate
##' the values of the lower and the upper limits of the confidence
##' intervals, respectively, and may have an element 'labels' which is
##' a vector or matrix or list with labels.
##' @param y.at Optional vector of y-position for the confidence intervals and corresponding values and labels.
##' @param lower Lower confidence limits. Used if object \code{x} is a
##' vector and if \code{x} is a list \code{lower} overwrites element
##' \code{x$lower}.
##' @param upper Upper confidence limits. Used if object \code{x} is a
##' vector and if \code{x} is a list \code{upper} overwrites element
##' \code{x$upper}.
##' @param pch Symbol for points.
##' @param cex Defaults size of all figures and plotting symbol.
##' Single elements are controlled separately. See \code{...}.
##' @param lwd Default width of all lines Single elements are
##' controlled separately. See \code{...}.
##' @param col Default colour of confidence intervals.
##' @param xlim Plotting limits for the confidence intervals. See also
##' \code{xratio} on how to control the layout.
##' @param xlab Label for the x-axis.
##' @param labels Vector or matrix or list with \code{labels}. Used if
##' object \code{x} is a vector and if \code{x} is a list it
##' overwrites element \code{x$labels}. To avoid drawing of labels, set \code{labels=FALSE}.
##' @param title.labels Main title for the column which shows the \code{labels}. If \code{labels}
##' is a matrix or list \code{title.labels} should be a vector with as
##' many elements as labels has columns or elements.
##' @param values Either logical or vector, matrix or list with
##' values. If \code{values=TRUE} values are constructed according to
##' \code{format} from \code{lower} and \code{upper} overwrites
##' constructed values. If \code{values=FALSE} do not draw values.
##' @param title.values Main title for the column \code{values}. If \code{values}
##' is a matrix or list \code{title.labels} should be a vector with as
##' many elements as values has columns or elements.
##' @param section.sep Amount of space between paragraphs (applies only if \code{labels} is a named list)
##' @param section.title Intermediate section headings.
##' @param section.title.x x-position for section.titles
##' @param section.pos Vector with y-axis posititions for section.titles.
##' @param section.title.offset Y-offset for section.titles
##' @param order Order of the three columns: labels, confidence limits,
##' values. See examples.
##' @param leftmargin Percentage of plotting region used for
##' leftmargin. Default is 0.025. See also Details.
##' @param rightmargin Percentage of plotting region used for
##' rightmargin. Default is 0.025. See also Details.
##' @param stripes Vector of up to three Logicals. If \code{TRUE} draw
##' stripes into the background. The first applies to the labels, the
##' second to the graphical presentation of the confidence intervals
##' and the third to the values. Thus, stripes
##' @param factor.reference.pos Position at which factors attain
##' reference values.
##' @param factor.reference.label Label to use at
##' \code{factor.reference.pos} instead of values.
##' @param factor.reference.pch Plotting symbol to use at
##' \code{factor.reference.pos}
##' @param refline Position of a vertical line to indicate the null
##' hypothesis. Default is 1 which would work for odds ratios and
##' hazard ratios.
##' @param title.line Position of a horizontal line to separate the title line from the plot
##' @param xratio One or two values between 0 and 1 which determine
##' how to split the plot window in horizontal x-direction. If there
##' are two columns (labels, CI) or (CI, values) only one value is used
##' and the default is 0.618 (goldener schnitt) which gives the
##' graphical presentation of the confidence intervals 38.2 % of the
##' graph. The remaining 61.8 % are used for the labels (or values).
##' If there are three columns (labels, CI, values), xratio has two
##' values which default to fractions of 0.7 according to the relative
##' widths of labels and values, thus by default only 0.3 are used for
##' the graphical presentation of the confidence intervals. The
##' remaining 30 % are used for the graphical presentation of the
##' confidence intervals. See examles.
##' @param y.offset Either a single value or a vector determining the
##' vertical offset of all rows. If it is a single value all rows are
##' shifted up (or down if negative) by this value. This can be used
##' to add a second set of confidence intervals to an existing graph
##' or to achieve a visual grouping of rows that belong
##' together. See examples.
##' @param y.title.offset Numeric value by which to vertically shift
##' the titles of the labels and values.
##' @param digits Number of digits, passed to \code{pubformat} and
##' \code{formatCI}.
##' @param format Format for constructing values of confidence
##' intervals. Defaults to '(u;l)' if there are negative lower or
##' upper values and to '(u-l)' otherwise.
##' @param extremearrows.length Length of the arrows in case of
##' confidence intervals that stretch beyond xlim.
##' @param extremearrows.angle Angle of the arrows in case of
##' confidence intervals that stretch beyond xlim.
##' @param add Logical. If \code{TRUE} do not draw labels or values
##' and add confidence intervals to existing plot.
##' @param layout Logical. If \code{FALSE} do not call layout. This is useful when
##' several plotConfidence results should be combined in one graph and hence layout is called
##' externally.
##' @param xaxis Logical. If \code{FALSE} do not draw x-axis.
##' @param ... Used to control arguments of the following subroutines:
##' \code{plot}: Applies to plotting frame of the graphical
##' presentation of confidence intervals. Use arguments of
##' \code{plot}, e.g., \code{plot.main="Odds ratio"}. \code{points},
##' \code{arrows}: Use arguments of \code{points} and \code{arrows},
##' respectively. E.g., \code{points.pch=8} and \code{arrows.lwd=2}.
##' \code{refline}: Use arguments of \code{segments}, e.g.,
##' \code{refline.lwd=2}. See \link{segments}. \code{labels},
##' \code{values}, \code{title.labels}, \code{title.values}: Use
##' arguments of \code{text}, e.g., \code{labels.col="red"} or
##' \code{title.values.cex=1.8}. \code{xaxis}: Use arguments of
##' \code{axis}, e.g., \code{xaxis.at=c(-0.3,0,0.3)} \code{xlab}: Use
##' arguments of \code{mtext}, e.g., \code{xlab.line=2}.
##' \code{stripes}: Use arguments of \code{stripes}. See examples.
##' See examples for usage.
##' @return List of dimensions and coordinates
##' @examples
##'
##' library(Publish)
##' data(CiTable)
##'
##' ## A first draft version of the plot is obtained as follows
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper","p")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")])
##'
##' ## if argument labels is a named list the table is subdivided:
##' labellist <- split(CiTable[,c("Dose","Time","Mean","SD","n")],CiTable[,"Drug"])
##' labellist
##' ## the data need to be ordered accordingly
##' CC= data.table::rbindlist(split(CiTable[,c("HazardRatio","lower","upper")],CiTable[,"Drug"]))
##' plotConfidence(x=CC, labels=labellist)
##'
##'
##' ## The graph consist of at most three columns:
##' ##
##' ## column 1: labels
##' ## column 2: printed values of the confidence intervals
##' ## column 3: graphical presentation of the confidence intervals
##' ##
##' ## NOTE: column 3 appears always, the user decides if also
##' ## column 1, 2 should appear
##' ##
##' ## The columns are arranged with the function layout
##' ## and the default order is 1,3,2 such that the graphical
##' ## display of the confidence intervals appears in the middle
##' ##
##' ## the order of appearance of the three columns can be changed as follows
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' order=c(1,3,2))
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' order=c(2,3,1))
##' ## if there are only two columns the order is 1, 2
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' values=FALSE,
##' order=c(2,1))
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' values=FALSE,
##' order=c(1,2))
##'
##'
##'
##' ## The relative size of the columns needs to be controlled manually
##' ## by using the argument xratio. If there are only two columns
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xratio=c(0.4,0.15))
##'
##' ## The amount of space on the left and right margin can be controlled
##' ## as follows:
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xratio=c(0.4,0.15),
##' leftmargin=0.1,rightmargin=0.00)
##'
##' ## The actual size of the current graphics device determines
##' ## the size of the figures and the space between them.
##' ## The sizes and line widths are increased as follows:
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' xlab="Hazard ratio",
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' points.cex=3,
##' cex=2,
##' lwd=3,
##' xaxis.lwd=1.3,
##' xaxis.cex=1.3)
##' ## Note that 'cex' of axis ticks is controlled via 'par' but
##' ## cex of the label via argument 'cex' of 'mtext'.
##' ## The sizes and line widths are decreased as follows:
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' cex=0.8,
##' lwd=0.8,
##' xaxis.lwd=0.8,
##' xaxis.cex=0.8)
##'
##' ## Another good news is that all figures can be controlled separately
##'
##' ## The size of the graphic device can be controlled in the usual way, e.g.:
##' \dontrun{
##' pdf("~/tmp/testCI.pdf",width=8,height=8)
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")])
##' dev.off()
##' }
##'
##' ## More control of the x-axis and confidence intervals that
##' ## stretch outside the x-range end in an arrow.
##' ## the argument xlab.line adjusts the distance of the x-axis
##' ## label from the graph
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' xlab="Hazard ratio",
##' xlab.line=1.8,
##' xaxis.at=c(0.8,1,1.3),
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xlim=c(0.8,1.3))
##'
##' ## log-scale
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' xlab="Hazard ratio",
##' xlab.line=1.8,
##' xaxis.at=c(0.8,1,1.3),
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xlim=c(0.8,1.3),plot.log="x")
##' ## More pronounced arrows
##' ## Coloured xlab expression
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' xlab=expression(HR[1](s)),
##' xlab.line=1.8,
##' xlab.col="darkred",
##' extremearrows.angle=50,
##' extremearrows.length=0.1,
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xlim=c(0.8,1.3))
##'
##' ## Controlling the labels and their titles
##' ## and the values and their titles
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xlab="Hazard ratio",
##' title.values=expression(bold(HR (CI[95]))),
##' title.labels=c("Drug/Time","Dose","Mean","St.dev.","N"),
##' factor.reference.pos=c(1,10,19),
##' factor.reference.pch=16,
##' cex=1.3,
##' xaxis.at=c(0.75,1,1.25,1.5,2))
##'
##' ## For factor reference groups, one may want to replace the
##' ## confidence intervals by the word Reference, as in the previous example.
##' ## To change the word 'Reference' we use the argument factor.reference.label:
##' ## To change the plot symbol for the reference lines factor.reference.pch
##' ## To remove the plot symbol in the reference lines use 'NA' as follows:
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xlab="Hazard ratio",
##' factor.reference.label="Ref",
##' title.values=expression(bold(HR (CI[95]))),
##' title.labels=c("Drug/Time","Dose","Mean","St.dev.","N"),
##' factor.reference.pos=c(1,10,19),
##' factor.reference.pch=NA,
##' cex=1.3,
##' xaxis.at=c(0.75,1,1.25,1.5,2))
##'
##'
##' ## changing the style of the graphical confidence intervals
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' xlab="Hazard ratio",
##' factor.reference.pos=c(1,10,19),
##' points.pch=15,
##' points.col=rainbow(27),
##' points.cex=2,
##' arrows.col="darkblue",
##' cex=1.3,
##' order=c(1,3,2),
##' xaxis.at=c(0.75,1,1.25,1.5))
##'
##' ## the values column of the graph can have multiple columns as well
##' ## to illustrate this we create the confidence intervals
##' ## before calling the function and then cbind them
##' ## to the pvalues
##' HR <- pubformat(CiTable[,6])
##' CI95 <- formatCI(lower=CiTable[,7],upper=CiTable[,8],format="(l-u)")
##' pval <- format.pval(CiTable[,9],digits=3,eps=10^{-3})
##' pval[pval=="NA"] <- ""
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' values=list("HR"=HR,"CI-95"=CI95,"P-value"=pval),
##' cex=1.2,
##' xratio=c(0.5,0.3))
##'
##' ## Finally, vertical columns can be delimited with background color
##' ## NOTE: this may slow things down and potentially create
##' ## large figures (many bytes)
##' col1 <- rep(c(prodlim::dimColor("green",density=22),
##' prodlim::dimColor("green")),length.out=9)
##' col2 <- rep(c(prodlim::dimColor("orange",density=22),
##' prodlim::dimColor("orange")),length.out=9)
##' col3 <- rep(c(prodlim::dimColor("blue",density=22),
##' prodlim::dimColor("blue")),length.out=9)
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' stripes=c(1,0,1),
##' stripes.col=c(col1,col2,col3))
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' stripes=c(1,1,1),
##' stripes.col=c(col1,col2,col3))
##'
##' threegreens <- c(prodlim::dimColor("green",density=55),
##' prodlim::dimColor("green",density=33),
##' prodlim::dimColor("green",density=22))
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Drug.Time","Dose","Mean","SD","n")],
##' values=FALSE,
##' xlim=c(0.75,1.5),
##' stripes=c(1,1,1),
##' xratio=c(0.5,0.15),
##' stripes.horizontal=c(0,9,18,27)+0.5,
##' stripes.col=threegreens)
##'
##' # combining multiple plots into one
##' layout(t(matrix(1:5)))
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' labels=CiTable[,c("Mean","n")],
##' layout=FALSE)
##' plotConfidence(x=CiTable[,c("HazardRatio","lower","upper")],
##' layout=FALSE)
##'
##'
##' @export
##' @author Thomas A. Gerds <tag@@biostat.ku.dk>
plotConfidence <- function(x,
y.at,
lower,
upper,
pch=16,
cex=1,
lwd=1,
col=4,
xlim,
xlab,
labels,
title.labels,
values,
title.values,
section.pos,
section.sep,
section.title=NULL,
section.title.x,
section.title.offset,
order,
leftmargin=0.025,
rightmargin=0.025,
stripes,
factor.reference.pos,
factor.reference.label="Reference",
factor.reference.pch=16,
refline=1,
title.line=TRUE,
xratio,
y.offset=0,
y.title.offset,
digits=2,
format,
extremearrows.length=0.05,
extremearrows.angle=30,
add=FALSE,
layout=TRUE,
xaxis=TRUE,
...){
# {{{ extract confidence data
if (!is.list(x)) x <- list(x=x)
m <- x[[1]]
names(x) <- tolower(names(x))
if (missing(lower)) {
lower <- x$lower
}
if (missing(upper)) upper <- x$upper
if (missing(xlim))
xlim <- c(min(lower)-0.1*min(lower),max(upper)+0.1*min(upper))
if (missing(xlab)) xlab <- ""
# }}}
# {{{ preprocessing of labels and title.labels
NR <- length(x[[1]])
if (length(lower)!=NR)
stop(paste0("lower has wrong dimension. There are ",NR," contrasts but ",length(upper)," upper limits"))
if (length(upper)!=NR)
stop(paste0("upper has wrong dimension. There are ",NR," contrasts but ",length(upper)," upper limits"))
if (!missing(labels) && (is.logical(labels) && labels[[1]]==FALSE))
do.labels <- FALSE
else
do.labels <- TRUE
if (!do.labels || (!missing(title.labels) && (is.logical(title.labels) && title.labels[[1]]==FALSE)))
do.title.labels <- FALSE
else
do.title.labels <- TRUE
if (do.labels && missing(labels)) {
labels <- x$labels
if (is.null(labels)) do.labels <- FALSE
}
if (missing(labels)) labels <- NULL
if (!is.data.frame(labels) && is.list(labels)){
section.rows <- sapply(labels,NROW)
nsections <- length(labels)
if (sum(section.rows)!=NR) stop(paste0("Label list has wrong dimension. There are ",NR," confidence intervals but ",sum(section.rows)," labels"))
}else{
nsections <- 0
section.rows <- NULL
}
# }}}
# {{{ set y positions and ylim
if (missing(y.at)) {at <- 1:NR
} else{
if(length(y.at)!=NR) stop(paste0("Number of y positions must match number of confidence intervals which is ",NR))
at <- y.at
}
if (nsections>0){
if (!missing(section.title) && length(section.title)>0){
names(labels) <- section.title
## stop("Cannot have section.titles when labels is a named list")
}
do.sections <- TRUE
section.title <- rev(names(labels))
## check for second level
if (!is.data.frame(labels[[1]]) && is.list(labels[[1]])){
sublevels <- names(labels)
labels <- lapply(1:length(labels),function(l){
cbind(sublevels[[l]],data.table::data.table(labels[[l]]))
})
}
labels <- data.table::rbindlist(lapply(labels,data.table::data.table),use.names=TRUE)
section.pos <- cumsum(rev(section.rows))
}else{
if (!missing(section.title) && length(section.title)>0){
if (missing(section.pos))
stop("Need y-positions for section.titles")
do.sections <- TRUE
}else{
do.sections <- FALSE
}
}
## oneM <- strheight("M",cex=cex)
oneM <- .5
if (do.sections){
if (missing(section.title.offset)) section.title.offset <- 1.5*oneM
if (missing(section.sep)) section.sep <- 2*oneM
section.shift <- rep(cumsum(c(0,section.sep+rep(section.sep,nsections-1))),
c(section.pos[1],diff(section.pos)))
section.pos+section.shift[section.pos]
if ((sub.diff <- (length(at)-length(section.shift)))>0)
section.shift <- c(section.shift,rep(section.title.offset+section.shift[length(section.shift)],sub.diff))
}else{
section.shift <- 0
}
at <- at+section.shift
## if (!(length(y.offset) %in% c(1,NR))){
## warning(paste("The given",length(y.offset),"many y-offsets are pruned/extended to the length",NR,"lines of the plot."))
## }
if (length(y.offset)!=NR)
y.offset <- rep(y.offset,length.out=NR)
at <- at+y.offset
if (do.sections){
section.y <- at[section.pos]
section.title.y <- section.y+section.title.offset
}else{
section.title.y <- 0
}
if (missing(y.title.offset)) {
if (do.sections){
y.title.offset <- 1.5*oneM + section.title.offset
} else{
y.title.offset <- 1.5*oneM
}
}
title.y <- max(at)+y.title.offset
rat <- rev(at)
ylim <- c(0,at[length(at)]+1)
dimensions <- list("NumberRows"=NR,xlim=xlim,ylim=ylim,y.at=at)
# }}}
# {{{ preprocessing of values and confidence intervals
if (!missing(values) && (is.logical(values) && values[[1]]==FALSE))
do.values <- FALSE
else
do.values <- TRUE
if (do.values==TRUE){
if (!missing(title.values) && (is.logical(title.values) && title.values[[1]]==FALSE))
do.title.values <- FALSE
else
do.title.values <- TRUE
}else{
do.title.values <- FALSE
}
if (do.values){
if (missing(values)){
if (missing(format))
if (all(!is.na(upper)) && any(upper<0))
format <- "(u;l)"
else
format <- "(u-l)"
values.defaults <- paste(pubformat(x[[1]],digits=digits),
apply(cbind(lower,upper),
1,
function(x)formatCI(lower=x[1],upper=x[2],format=format,digits=digits)))
if (!missing(factor.reference.pos) && is.numeric(factor.reference.pos) && all(factor.reference.pos<length(values.defaults)))
values.defaults[factor.reference.pos] <- factor.reference.label
if (do.title.values && (missing(title.values)) || (!is.expression(title.values) && !is.character(title.values)))
title.values <- expression(paste(bold(Estimate)," (",bold(CI[95]),")"))
}else{
values.defaults <- values
if (missing(title.values)) title.values <- NULL
}
} else{
values.defaults <- NULL
title.values <- NULL
}
# }}}
if (add==TRUE) do.values <- do.title.values <- do.labels <- do.title.labels <- FALSE
# {{{ smart argument control
dist <- (at[2]-at[1])/2
if (missing(stripes) || is.null(stripes))
do.stripes <- FALSE
else
do.stripes <- stripes
stripes.DefaultArgs <- list(col=c(prodlim::dimColor("orange"),"white"),
horizontal=seq(min(at)-dist,max(at)+dist,1),
xlim=xlim,
border=NA)
if (xaxis) do.xaxis <- TRUE
xaxis.DefaultArgs <- list(side=1,las=1,pos=0,cex=cex)
xlab.DefaultArgs <- list(text=xlab,side=1,line=1.5,xpd=NA,cex=cex)
plot.DefaultArgs <- list(0,0,type="n",ylim=ylim,xlim=xlim,axes=FALSE,ylab="",xlab=xlab)
points.DefaultArgs <- list(x=m,y=rat,pch=16,cex=cex,col=col,xpd=NA)
arrows.DefaultArgs <- list(x0=lower,y0=rat,x1=upper,y1=rat,lwd=lwd,col=col,xpd=NA,length=0,code=3,angle=90)
refline.DefaultArgs <- list(x0=refline,y0=0,x1=refline,y1=max(at),lwd=lwd,col="gray71",xpd=NA)
if (missing(title.labels)) title.labels <- NULL
labels.DefaultArgs <- list(x=0,y=rat,cex=cex,labels=labels,xpd=NA,pos=4)
title.labels.DefaultArgs <- list(x=0,
y=at[length(at)]+y.title.offset,
cex=NULL,
labels=title.labels,
xpd=NA,
font=2,
pos=NULL)
values.DefaultArgs <- list(x=0,y=rat,labels=values.defaults,cex=cex,xpd=NA,pos=4)
title.y <- at[length(at)]+y.title.offset
title.values.DefaultArgs <- list(x=0,
y=title.y,
labels=title.values,
cex=NULL,
xpd=NA,
font=2,
pos=NULL)
if (do.sections)
title.line.y <- (title.y+max(section.title.y))/2
else
title.line.y <- title.y-.25
title.line.DefaultArgs <- list(x0=-Inf,
y0=title.line.y,
x1=Inf,
y1=title.line.y,
lwd=lwd,
col="gray71",
xpd=TRUE)
section.title.DefaultArgs <- list(x=0,y=section.title.y,labels=section.title,cex=NULL,xpd=NA,font=4,pos=4)
smartA <- prodlim::SmartControl(call= list(...),
keys=c("plot","points","arrows","refline","title.line","labels","values","title.labels","section.title","title.values","xaxis","stripes","xlab"),
ignore=c("formula","data","add","col","lty","lwd","ylim","xlim","xlab","ylab","axes","factor.reference.pos","factor.reference.label","extremearrows.angle","extremearrows.length"),
defaults=list("plot"=plot.DefaultArgs,
"points"=points.DefaultArgs,
"refline"=refline.DefaultArgs,
"title.line"=title.line.DefaultArgs,
"labels"=labels.DefaultArgs,
"title.labels"=title.labels.DefaultArgs,
"section.title"=section.title.DefaultArgs,
"stripes"=stripes.DefaultArgs,
"values"=values.DefaultArgs,
"title.values"=title.values.DefaultArgs,
"arrows"=arrows.DefaultArgs,
"xaxis"=xaxis.DefaultArgs,
"xlab"=xlab.DefaultArgs),
forced=list("plot"=list(axes=FALSE,xlab=""),"xaxis"=list(side=1)),
verbose=TRUE)
if (is.null(smartA$title.labels$pos)) smartA$title.labels$pos <- smartA$labels$pos
if (is.null(smartA$title.values$pos)) smartA$title.values$pos <- smartA$values$pos
if (is.null(smartA$title.labels$cex)) smartA$title.labels$cex <- smartA$labels$cex
if (is.null(smartA$section.title$cex)) smartA$section.title$cex <- smartA$labels$cex
if (is.null(smartA$title.values$cex)) smartA$title.values$cex <- smartA$values$cex
if (!missing(factor.reference.pos) && is.numeric(factor.reference.pos) && all(factor.reference.pos<length(values.defaults))){
if (length(smartA$points$pch)<NR)
smartA$points$pch <- rep(smartA$points$pch,length.out=NR)
smartA$points$pch[factor.reference.pos] <- factor.reference.pch
}
# }}}
# {{{ layout
if (add==FALSE){
oldmar <- par()$mar
on.exit(par(mar=oldmar))
on.exit(par(mfrow=c(1,1)))
par(mar=c(0,0,0,0))
## layout
dsize <- dev.size(units="cm")
leftmarginwidth <- leftmargin*dsize[1]
rightmarginwidth <- rightmargin*dsize[1]
plotwidth <- dsize[1]-leftmarginwidth-rightmarginwidth
if (do.labels){
preplabels <- prepareLabels(labels=smartA$labels,
titles=smartA$title.labels)
}
if (do.values){
prepvalues <- prepareLabels(labels=smartA$values,
titles=smartA$title.values)
}
if (do.labels){
## force label into list, then count label columns
## and compute strwidth
if (do.values){
## both values and labels
do.stripes <- rep(do.stripes,length.out=3)
names(do.stripes) <- c("labels","ci","values")
if (missing(xratio)) {
lwidth <- sum(preplabels$columnwidth)
vwidth <- sum(prepvalues$columnwidth)
xratio <- c(lwidth/(lwidth+vwidth)*0.7,vwidth/(lwidth+vwidth)*0.7)
## if (lwidth>vwidth)
## xratio <- c((1-(vwidth/lwidth))*0.7,(vwidth/lwidth)*0.7)
## else
## xratio <- c((1-(lwidth/vwidth))*0.7,(lwidth/vwidth)*0.7)
## xratio <- c(0.5,0.2)
}
labelswidth <- plotwidth * xratio[1]
valueswidth <- plotwidth * xratio[2]
ciwidth <- plotwidth - labelswidth - valueswidth
mat <- matrix(c(0,c(1,3,2)[order],0),ncol=5)
if (!missing(order) && length(order)!=3) order <- rep(order,length.out=3)
if (layout)
layout(mat,width=c(leftmarginwidth,c(labelswidth,ciwidth,valueswidth)[order],rightmarginwidth))
## layout.show(n=3)
} else{
## only labels
do.stripes <- rep(do.stripes,length.out=2)
names(do.stripes) <- c("labels","ci")
if (missing(xratio)) xratio <- 0.618
labelswidth <- plotwidth * xratio[1]
ciwidth <- plotwidth - labelswidth
valueswidth <- 0
if (!missing(order) && length(order)!=2) order <- rep(order,length.out=2)
mat <- matrix(c(0,c(1,2)[order],0),ncol=4)
if (layout)
layout(mat,width=c(leftmarginwidth,c(labelswidth,ciwidth)[order],rightmarginwidth))
}
} else{
if (do.values){
## only values
do.stripes <- rep(do.stripes,length.out=2)
names(do.stripes) <- c("ci","values")
if (missing(xratio)) xratio <- 0.618
valueswidth <- plotwidth * (1-xratio[1])
ciwidth <- plotwidth - valueswidth
labelswidth <- 0
mat <- matrix(c(0,c(2,1)[order],0),ncol=4)
if (!missing(order) && length(order)!=2) order <- rep(order,length.out=2)
if (layout)
layout(mat,width=c(leftmarginwidth,c(ciwidth,valueswidth)[order],rightmarginwidth))
}else{
# none
xratio <- 1
ciwidth <- plotwidth
do.stripes <- do.stripes[1]
names(do.stripes) <- "ci"
labelswidth <- 0
valueswidth <- 0
mat <- matrix(c(0,1,0),ncol=3)
if (layout)
layout(mat,width=c(leftmarginwidth,ciwidth,rightmarginwidth))
}
}
dimensions <- c(dimensions,list(xratio=xratio,
labelswidth=labelswidth,
valueswidth=valueswidth,
ciwidth=ciwidth,layout=mat))
}
# }}}
# {{{ labels
if (add==FALSE) par(mar=oldmar*c(1,0,1,0))
if (do.labels){
if (do.stripes[["labels"]])
preplabels <- c(preplabels,list(width=labelswidth,ylim=ylim,stripes=smartA$stripes))
else
preplabels <- c(preplabels,list(width=labelswidth,ylim=ylim))
do.call("plotLabels",preplabels)
# }}}
# {{{ title underline
if ((missing(title.line) || !is.null(title.line))
&& ((add==FALSE) & is.infinite(smartA$title.line$x0))){
smartA$title.line$x0 <- par()$usr[1]
smartA$title.line$x1 <- par()$usr[2]
do.call("segments",smartA$title.line)
smartA$title.line$x0 <- -Inf
## box()
}
}
# }}}
# {{{ section.titles
if (do.sections){
do.call("text",smartA$section.title)
}
# }}}
# {{{ values
if (do.values){
if (do.stripes[["values"]])
prepvalues <- c(prepvalues,list(width=valueswidth,ylim=ylim,stripes=smartA$stripes))
else
prepvalues <- c(prepvalues,list(width=valueswidth,ylim=ylim))
do.call("plotLabels",prepvalues)
if ((missing(title.line) || !is.null(title.line))
&& ((add==FALSE) & is.infinite(smartA$title.line$x0))){
smartA$title.line$x0 <- par()$usr[1]
smartA$title.line$x1 <- par()$usr[2]
do.call("segments",smartA$title.line)
smartA$title.line$x0 <- -Inf
## box()
}
}
# }}}
# {{{ plot which contains the confidence intervals
if (add==FALSE){
do.call("plot",smartA$plot)
if (do.stripes[["ci"]])
do.call("stripes",smartA$stripes)
if (do.xaxis==TRUE){
oldcexaxis <- par()$cex.axis
on.exit(par(cex.axis=oldcexaxis))
par(cex.axis=smartA$xaxis$cex)
if (is.null(smartA$xaxis$labels))
do.call("axis",smartA$xaxis)
}
do.call("mtext",smartA$xlab)
}
# }}}
# {{{ ref line
if (add==FALSE){
if (missing(refline) || !is.null(refline))
do.call("segments",smartA$refline)
}
# }}}
# {{{ title underline
if (add==FALSE){
if (missing(title.line) || !is.null(title.line)){
if (is.infinite(smartA$title.line$x0)){
smartA$title.line$x0 <- par()$usr[1]
smartA$title.line$x1 <- par()$usr[2]
}
do.call("segments",smartA$title.line)
}
}
# }}}
# {{{ point estimates and confidence
do.call("points",smartA$points)
## treat arrows that go beyond the x-limits
if (any(smartA$arrows$x0>xlim[2],na.rm=TRUE)||any(smartA$arrows$x1<xlim[1],na.rm=TRUE))
warning("One or several confidence intervals are completely outside xlim. You should adjust xlim.")
tooHigh <- smartA$arrows$x1>xlim[2]
tooHigh[is.na(tooHigh)] <- FALSE
tooLow <- smartA$arrows$x0<xlim[1]
tooLow[is.na(tooLow)] <- FALSE
if (any(c(tooHigh,tooLow))){
if (length(smartA$arrows$angle)<NR)
smartA$arrows$angle <- rep(smartA$arrows$angle,length.out=NR)
if (length(smartA$arrows$length)<NR)
smartA$arrows$length <- rep(smartA$arrows$length,length.out=NR)
if (length(smartA$arrows$code)<NR)
smartA$arrows$code <- rep(smartA$arrows$code,length.out=NR)
if (length(smartA$arrows$col)<NR)
smartA$arrows$col <- rep(smartA$arrows$col,length.out=NR)
smartA$arrows$x0 <- pmax(xlim[1],smartA$arrows$x0)
smartA$arrows$x1 <- pmin(xlim[2],smartA$arrows$x1)
smartA$arrows$code[tooLow & tooHigh] <- 3
smartA$arrows$code[tooLow & !tooHigh] <- 1
smartA$arrows$code[!tooLow & tooHigh] <- 2
smartA$arrows$angle[tooLow | tooHigh] <- extremearrows.angle
smartA$arrows$length[tooLow | tooHigh] <- extremearrows.length
aargs <- smartA$arrows
for (r in 1:NR){
aargs$x0 <- smartA$arrows$x0[r]
aargs$x1 <- smartA$arrows$x1[r]
aargs$y0 <- smartA$arrows$y0[r]
aargs$y1 <- smartA$arrows$y1[r]
aargs$code <- smartA$arrows$code[r]
aargs$col <- smartA$arrows$col[r]
aargs$length <- smartA$arrows$length[r]
aargs$angle <- smartA$arrows$angle[r]
suppressWarnings(do.call("arrows",aargs))
}
} else{
suppressWarnings(do.call("arrows",smartA$arrows))
}
# }}}
## if (show.coords){
## axis(1,xpd=NA)
## }
dimensions <- c(smartA,dimensions)
invisible(dimensions)
}
#----------------------------------------------------------------------
### plotResults.R ends here
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.