R/shinyPlot_HUC_Summary_Statistics.R

In ssaxe-usgs/METsteps: Aggregate Data to the HUC 2-10 Levels (one line, title case)

#' Primary Time Series and Difference Plot after HUC Click
#'
#' Description goes here.
#' @param x Numeric; The values to be plotted.
#' @param col Character; The plot color.
#' @export
#' @return Numeric vector.
#' @examples
#' shinyPlot_HUC_Time_Series_Statistics()

shinyPlot_HUC_Summary_Statistics <- function(default. = FALSE,
                                             feederList. = NULL,
                                             subToHUC. = subToHUC,
                                             cbPalette. = cbPalette,
                                             iv = oShinyValues$allZoo,
                                             HCU. = HCU){
  require(dplyr)
  if (default.){
    
  }else{
    # Convert
    if (!is.null(iv)){
      ivIndex <- zoo::index(iv)
      modIndex <- zoo::index(subToHUC.)
      ivIndex <- ivIndex[ivIndex %in% modIndex]
      iv <- iv[(zoo::index(iv) %in% ivIndex), ]
      ivMean <- rowMeans(iv, na.rm = T)
    }

    # layout plots
    layout(mat     = matrix(data  = c(1, 2, 3),
                            nrow  = 3,
                            ncol  = 1,
                            byrow = T),
           widths  = 1,
           heights = c(1,1,.2))
    par(mar = c(1.5,0,0,0), oma = c(1,4,3,3))
    
    # calculate stats
    #1. Percentiles
    percentiles <- apply(X      = subToHUC.,
                            MARGIN = 2,
                            FUN    = quantile,
                            probs  = c(0.01, 0.1, 0.25, 0.50, 0.75, 0.90, 0.99),
                            na.rm  = T)
    if (!is.null(iv)){
      percentiles.iv <- quantile(x     = ivMean,
                                 probs = c(0.01, 0.1, 0.25, 0.50, 0.75, 0.90, 0.99),
                                 na.rm = T)
      percentiles.iv <- data.frame(xPosition = 1:nrow(percentiles),
                                   ObsMeans = percentiles.iv)
      percentiles <- data.frame(xPosition = 1:nrow(percentiles),
                                percentiles)
    }else{
      percentiles <- data.frame(xPosition = 1:nrow(percentiles),
                                percentiles)
    }
    
    
    #plot
    plot(1,
         type = 'n',
         ylim = c(floor(min(percentiles)),
                  ceiling(max(percentiles))),
         xlim = c(1, nrow(percentiles)),
         xaxt = 'n',
         ylab = '',
         xlab = '',
         cex.axis = 1.5
    )
    mtext(text = 'AET (mm)',
          side = 2,
          line = 2.5)
    mtext(text = 'Percentile',
          side = 1,
          line = 1.5)
    axis(side = 1,
         at = 1:nrow(percentiles),
         tick = F,
         line = -0.5,
         labels = rownames(percentiles),
         cex.axis = 1.5)
    
    barFun <- function(y, colList, oCEX = 3, iCEX = 2){
      for (i in 2:length(y)){
        points(x = y[1],
               y = y[i],
               pch = 15,
               cex = oCEX,
               col = colList[i-1])
        points(x = y[1],
               y = y[i],
               pch = 15,
               cex = iCEX,
               col = 'white')
      }
    }
    apply(X       = percentiles.iv,
          MARGIN  = 1,
          FUN     = barFun,
          colList = 'red',
          iCEX = 2)
    apply(X       = percentiles,
          MARGIN  = 1,
          FUN     = barFun,
          colList = cbPalette.)

    
    # mean/median/max/min/misc stats
    miscFun <- function(y){
      return(
        c(mean(y, na.rm = T),
          median(y, na.rm = T),
          sd(y, na.rm = T),
          min(y, na.rm = T),
          max(y, na.rm = T))
      )
    }
    miscStats <- apply(X      = subToHUC.,
                       MARGIN = 2,
                       FUN    = miscFun)
    rownames(miscStats) <- c('mean', 'median', 'sd', 'min', 'max')
    miscStats <- data.frame(xPosition = 1:nrow(miscStats),
                            miscStats)
    
    # plot2 
    par(mar = c(0,0,1.5,0))
    plot(1,
         type = 'n',
         ylim = c(floor(min(miscStats)),
                  ceiling(max(miscStats))),
         xlim = c(1, nrow(miscStats)),
         xaxt = 'n',
         ylab = '',
         xlab = '',
         cex.axis = 1.5
    )
    mtext(text = 'AET (mm)',
          side = 2,
          line = 2.5)
    axis(side = 1,
         at = 1:nrow(miscStats),
         tick = F,
         line = -0.5,
         labels = rownames(miscStats),
         cex.axis = 1.5)
    # add points
    apply(X       = miscStats,
          MARGIN  = 1,
          FUN     = barFun,
          colList = cbPalette.)
    
    # add legend
    par(mar = c(0,0,1,0))
    plot(1,
         type = 'n',
         bty = 'n',
         axes = F)
    lmy <- par()$usr[2] * 0.85
    lmx <- par()$usr[1] * 1.1
    legend(x = lmx,
           y = lmy,
           legend = colnames(miscStats)[-1],
           pch = 15,
           col = cbPalette.[1:ncol(miscStats)],
           bty = 'n',
           horiz = T,
           pt.cex = 3,
           cex = 1.25)
  }
}