R/ciplot.R

In twolodzko/twextras: twextras

#' Plot confidence intervals
#' 
#' @param x     a vector. If x is a matrix or data.frame: (a) with two columns
#'              - they are considered as lower and upper boundries subsequently;
#'              (b) with minimum three columns, the first column is considered
#'              as the lower boundry, second as midpoint and the third as upper
#'              boundry. 
#' @param se    single value or a vector of standard errors.
#' @param hi    a vector of precomputed higher boundry of cofidence interval.
#' @param lo    a vector of precomputed lower boundry of cofidence interval.
#' @param alpha transparency intensity.
#' @param add   if true adds this plot to previously plotted.
#' @param mid   if true line for a mid value is plotted.
#' 
#' @importFrom stats qnorm
#' @importFrom graphics plot
#' @export

ciplot <- function(x, se, alpha=0.3, col="grey", add=FALSE,
                   ci=0.95, lo, hi, border=NA, mid=TRUE, 
                   xlab="", ylab="", ...) UseMethod("ciplot")


#' @export

ciplot.default <- function(x, se, alpha=0.3, col="grey", add=FALSE,
                           ci=0.95, lo, hi, border=NA, mid=TRUE, 
                           xlab="", ylab="", ...) {
  
  if (missing(lo) && missing(hi)) {
    if (ci > 0) {
      qn <- qnorm(1-((1-ci)/2))
      lo <- x - se * qn
      hi <- x + se * qn
    } else {
      lo <- x - se
      hi <- x + se
    }
  }
  
  n <- length(x)
  
  if (!add)
    plot(c(1:n, 1:n), c(hi, lo), type="n", xlab=xlab, ylab=ylab, ...)
  
  polyshape(hi, lo, 1:n, fill=col, alpha=alpha, border=border, add=FALSE, ...)
  if (mid) lines(x, col=col, ...)
}


#' @export

ciplot.matrix <- function(x, se, alpha=0.3, col="grey", add=FALSE,
                          ci=0.95, lo, hi, border=NA, mid=TRUE, 
                          xlab=xlab, ylab=ylab, ...) {
   
   if (ncol(x) == 1) {
      ciplot.default(x, se = se, lo = lo, hi = hi,
                     alpha = alpha, col = col, add = add,
                     ci = ci, border = border, mid = mid,
                     xlab=xlab, ylab=ylab, ...)
   } else if (ncol(x) == 2) {
      n <- nrow(x)
      polyshape(x[, 1], x[, 2], 1:n, fill = col, alpha = alpha,
                border = border, add = FALSE, ...)
   } else if (ncol(x) >= 3) {
      ciplot.default(x[, 2], lo=x[, 1], hi=x[, 3],
                     alpha = alpha, col = col, add = add,
                     ci = ci, border = border, mid = mid,
                     xlab="", ylab="", ...)
   }
}


#' @export

ciplot.data.frame <- function(x, se, alpha=0.3, col="grey", add=FALSE,
                          ci=0.95, lo, hi, border=NA, mid=TRUE, 
                          xlab="", ylab="", ...) {
   if (ncol(x) == 1) {
      ciplot.default(x, se = se, lo = lo, hi = hi,
                     alpha = alpha, col = col, add = add,
                     ci = ci, border = border, mid = mid, 
                     xlab=xlab, ylab=ylab, ...)
   } else if (ncol(x) == 2) {
      n <- nrow(x)
      polyshape(x[, 1], x[, 2], 1:n, fill = col, alpha = alpha,
                border = border, add = FALSE, ...)
   } else if (ncol(x) >= 3) {
      ciplot.default(x[, 2], lo=x[, 1], hi=x[, 3],
                     alpha = alpha, col = col, add = add,
                     ci = ci, border = border, mid = mid, 
                     xlab=xlab, ylab=ylab, ...)
   }
}



#' Draw polygon shape
#'
#' @param x values of x
#' @param yu upper boundry of y
#' @param yl lower boundry of y
#' @param fill color of shape
#' @param alpha transparency level
#' @param border the color to draw the border (see \code{\link{polygon}})
#' @param \dots further parameters for \code{\link{polygon}} function
#' 
#' @importFrom graphics polygon
#' @export

polyshape <- function(yu, yl, x=1:length(yu), fill=NULL, border=1,
                      alpha=0.3, add=TRUE, xlab="", ylab="", ...) {
  if (!is.null(fill) && !is.na(fill))
    fill <- add.alpha(fill, alpha)
  if (add) plot(c(x, x), c(yu, yl), type="n", xlab=xlab, ylab=ylab)
  polygon(c(x, rev(x)), c(yl, rev(yu)), col=fill, border=border, ...)
}