Nothing
### 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
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.