R/PlotHistogram.r

In einaooka/tea.eo.plots: TEA's plotting functions

#' @title Plot Histograms
#'
#' @param x A data array.
#' @param lst A list of data series.
#' @param q1 An array of quantiles. Default set at c(0.25, 0.75).
#' @param q2 An array of quantiles. Default set at c(0.05, 0.95).
#' @param qs An array of quantiles for multiple histograms. Defalt set at NULL.
#' @param col.f A colar function with transparency index.
#' @param cols.f A list of colar functions with transparency index. The length needs to match that of lst.
#' @param textStagger Binary. Default set at FALSE.
#' @param br Number of histogram breaks
#' @param legend A list of (need, location, cex).
#'
#' @export PlotHistogram
#' @export PlotHistograms
#'
#' @examples
#' # A histogram
#' x <- rnorm(1000, 3,1)
#' PlotHistogram(x, green.f)
#' PlotHistogram(x, blue.f, textStagger=TRUE)
#'
#' # A histogram for large values
#' x <- rnorm(1000, 10000,1000)
#' PlotHistogram(x, red.f, q1 = c(0.2, 0.8), q2 = c(0.1, 0.9), textStagger=TRUE, xlab="x")
#'
#' # Multiple histograms together
#' x1 <- rnorm(1000, 3,1)
#' x2 <- rnorm(1000, 5,1)
#' x3 <- rnorm(1000, -3,1)
#' PlotHistograms(list("x1"=x1, "x2"=x2), cols.f = list(red.f, blue.f), qs=c(0.05, 0.95))
#'
#' PlotHistograms(list("x1"=x1, "x2"=x2, "x3"=x3), cols.f = list(red.f, blue.f, green.f)
#'                , legend=list(need = TRUE, location="topleft", cex=1.2))


PlotHistogram <- function(data, col.f=blue.f, q1 = c(0.25, 0.75), q2 = c(0.05, 0.95), textStagger=FALSE, digit = 2, ...){

  data <- as.numeric(data)
  den <- density(data)
  plot0(den$x, den$y, axes=1, col=col.f(1), lwd=2, ylab="", ...)
  FillArea(den$x, den$y, col.f(0.2))
  title(ylab="Density", line=1)

  # Stats
  q11 <- quantile(data, q1[1], na.rm=TRUE)
  q12 <- quantile(data, q1[2], na.rm=TRUE)
  q21 <- quantile(data, q2[1], na.rm=TRUE)
  q22 <- quantile(data, q2[2], na.rm=TRUE)
  m <- mean(data, na.rm=TRUE)
  
  # Quantiles
  filtr <- den$x > q11 & den$x < q12; FillArea(den$x[filtr], den$y[filtr] , col=col.f(0.3))
  filtr <- den$x > q21 & den$x < q22; FillArea(den$x[filtr], den$y[filtr] , col=col.f(0.3))
  abline(v=m, col=col.f(1), lwd=2)

  # Texts
  if (textStagger){
    textLoc1 <- par("usr")[3]+ (par("usr")[4]-par("usr")[3])*0.15
    textLoc2 <- par("usr")[3]+ (par("usr")[4]-par("usr")[3])*0.1
    textLoc3 <- par("usr")[3]+ (par("usr")[4]-par("usr")[3])*0.05
  }else { textLoc1 <- textLoc2 <- textLoc3 <- par("usr")[3]+ (par("usr")[4]-par("usr")[3])*0.05 }
  text(m, textLoc1, format(round(m, digits = digit), big.mark=",",scientific=FALSE), pos=4, col=col.f(1), cex=0.8)
  text(q12, textLoc2, format(round(q12, digits = digit), big.mark=",", scientific=FALSE), pos=4, col=col.f(1), cex=0.8)
  text(q22, textLoc3, format(round(q22, digits = digit), big.mark=",", scientific=FALSE), pos=4, col=col.f(1), cex=0.8)
}

#' @describeIn PlotHistogram Plot multiple histograms together
PlotHistograms <- function(lst, cols.f=blue.f, qs=vector(), xlim=NULL, ylim=NULL, legend=list(need = FALSE, location="topleft", cex=1), ...){

  # Data
  den.lst <- vector("list", 0)
  for (i in 1:length(lst)){
    lst[[i]] <- as.numeric(lst[[i]])
    den.lst[[i]] <- density(lst[[i]])
    }
  nList <- length(lst)
  
  # identify range
  if (is.null(xlim)){
    xlim <- unlist(lapply(den.lst, function(l)range(l$x)))
    xlim <- c(min(xlim), max(xlim))
  }
  if (is.null(ylim)){
    ylim <- unlist(lapply(den.lst, function(l)range(l$y)))
    ylim <- c(min(ylim), max(ylim))
  }

  # Plot histograms
  plot0(den.lst[[1]]$x, den.lst[[1]]$y, axes=1, col=cols.f[[1]](1), lwd=2, ylab="", main="", xlim=xlim, ylim=ylim, ...)
  for (i in 1:nList){
    lines(den.lst[[i]]$x, den.lst[[i]]$y, col=cols.f[[i]](1), lwd=2)
    FillArea(den.lst[[i]]$x, den.lst[[i]]$y, col=cols.f[[i]](0.4))
    abline(v=mean(lst[[i]], na.rm=TRUE), col=cols.f[[i]](1), lwd=2)
    if(length(qs) > 0){abline(v=quantile(lst[[i]], qs, na.rm=TRUE), col=cols.f[[i]](1), lty=3)}
  }
  DrawHLines(ylim)
  title(ylab="Density", line=1)

  # format color for legend
  col1.v <- col2.v <- c()
  for (i in 1:length(cols.f)){
    col1.v <- c(col1.v, unlist(lapply(0.4, cols.f[[i]])))
    col2.v <- c(col2.v, unlist(lapply(1, cols.f[[i]])))
  }

  if(legend$need & !is.null(names(lst))){
    legend(legend$location
           , inset=.05
           , cex=legend$cex
           , names(lst)
           , fill=col1.v
           , border=col2.v
           , bg="white"
    )
  }
}