R/shinyPlot_HUC_Modeled_vs_Observational.R

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

#' Modeled vs Observation vs Envelopes
#'
#' Description goes here.
#' @param x Numeric; The values to be plotted.
#' @param col Character; The plot color.
#' @export
#' @return Numeric vector.
#' @examples
#' shinyPlot_HUC_Modeled_vs_Observational()

shinyPlot_HUC_Modeled_vs_Observational   <- function(default. = FALSE,
                                                     feederList. = NULL,
                                                     x = subToHUC,
                                                     z = oShinyValues,
                                                     ptSP. = ptSP.trim,
                                                     timeStep. = timeStep,
                                                     path.obs. = path.obs,
                                                     col = cbPalette,
                                                     ablCol = 'darkgrey',
                                                     colDif = 'firebrick',
                                                     HCU. = HCU,
                                                     dataCategory. = dataCategory,
                                                     multiplot.cex = 1.4,
                                                     multiplot.lab = 1.4,
                                                     cex.main = 1.2,
                                                     ...){
  # Extract sliderTime. from feederList
  if (!is.null(feederList.)){
    sliderTime. <- feederList.$slider_time
  }else{
    sliderTime. <- NULL
  }
  
  # Set xlim based on drange
  if (is.null(sliderTime.)){
    drange <- NULL
  }else{
    drange <- as.Date(ISOdate(year = sliderTime.,
                              month = c(1,12),
                              day = c(1,31)))
  }
  
  
  if (default.){
    layout(mat     = matrix(data  = c(1,2,3,4,5),
                            nrow  = 5,
                            ncol  = 1,
                            byrow = T),
           widths  = 1,
           heights = c(1,1,1,0.25,0.25))
    par(mar = c(0,0,0,0), oma = c(3,6,3,3))
    plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
    mtext(text = 'HUC',
          line = 1,
          font = 2,
          cex = cex.main)
    mtext(text = paste0('Modeled','\n'),
          side = 2,
          line = 3)
    plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
    mtext(text = paste0('All Obs','\n'),
          side = 2,
          line = 3)
    plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
    mtext(text = paste0('Obs. Envelope','\n'),
          side = 2,
          line = 3)
    plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
    mtext(text = paste0('n','\n'),
          side = 2,
          line = 3)
    plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
    mtext(text = paste0('SD','\n'),
          side = 2,
          line = 3)
    
  }else{
    layout(mat     = matrix(data  = c(1,2,3,4,5),
                            nrow  = 5,
                            ncol  = 1,
                            byrow = T),
           widths  = 1,
           heights = c(1,1,1,0.25,0.25))
    par(mar = c(0,0,0,0), oma = c(3,6,3,3))
    
    # P1 - plot modeled data normally
    if (!is.null(drange)){
      y <- x[((as.Date(zoo::index(x)) >= as.Date(drange[1])) & (as.Date(zoo::index(x)) <= as.Date(drange[2]))),]
      if (is.null(dim(y))) {
        x <- zoo::as.zoo(as.data.frame(y))
        zoo::index(x) <- as.Date(zoo::index(y))
      }else{
        x <- y
      }
    }
    
    plot(x        = x[,1],
         col      = col[1],
         main     = '',
         xaxs     = "i",
         ylab     = paste0(dataCategory.,'\n(mm)'),
         #xlim     = drange,
         ylim     = range(x, na.rm = T),
         xlab     = '',
         xaxt     = 'n',
         cex.axis = multiplot.cex,
         cex.lab  = multiplot.lab,
         cex.main = cex.main,
         lwd      = 2,
         yaxs     = 'i')
    mtext(text = paste('HUC', HCU.),
          line = 1,
          font = 2,
          cex = cex.main)
    mtext(text = paste0(dataCategory.,'\n(mm)'),
          side = 2,
          line = 3)
    # add remaining datasets with line() function and calculate ensemble mean
    if (ncol(x) > 1){
      for (i in 2:ncol(x)){
        lines(x    = x[,i],
              col  = cbPalette[i],
              xaxs = "i",
              lwd  = 2)
      }
      # Calculate ensemble means and add to plot
      ensembleMeans <- zoo::zoo(rowMeans(x), stats::time(x))
      points(x = ensembleMeans,
             col = 'black',
             xaxs = 'i',
             lwd = 2,
             pch = 16)
      lines(x = ensembleMeans,
            col = 'black',
            xaxs = 'i',
            lwd = 1,
            lty = 1)
    }
    
    yrs <- as.Date(ISOdate(year = unique(lubridate::year(index(x))),
                           month = 1,
                           day = 1))
    abline(v   = yrs,
           col = ablCol,
           lty = 2)
    
    # P2 - plot observational data (all)
    noObsplots <- function(){
      plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
      mtext(text = paste0('All Obs','\n'),
            side = 2,
            line = 3)
      text(x = mean(par()$usr[1:2]),
           y = mean(par()$usr[3:4]),
           labels = 'No observational data supplied',
           col = 'red',
           cex = 1.25)
      plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
      mtext(text = paste0('Obs. Envelope','\n'),
            side = 2,
            line = 3)
      plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
      mtext(text = paste0('n','\n'),
            side = 2,
            line = 3)
      plot(1, type = 'n', xaxt = 'n', yaxt = 'n')
      mtext(text = paste0('SD','\n'),
            side = 2,
            line = 3)
    }
    
    if (!is.null(ptSP.)){
      if (nrow(ptSP.) > 0){
        # z <- METsteps::zooEnvParameters(zoo.fnames = paste0(path.obs.,
        #                                        ptSP.@data$OurID,
        #                                        '.csv'),
        #                                 timeStep2 = timeStep.,
        #                                 returnObs = TRUE)
        allZoo <- z$allZoo
        if (!is.null(z)){
          yRange <- c(floor(min(z$envInput$yMin, na.rm = T)),
                      ceiling(max(z$envInput$yMax, na.rm =T)))
          # Plot 2.  create plot
          plot(x        = x[,1],
               type     = 'n',
               main     = '',
               xaxs     = 'i',
               ylab     = 'Diff (mm)',
               xlab     = '',
               xaxt     = 'n',
               yaxt     = 'n',
               ylim     = yRange,
               cex.axis = multiplot.cex,
               cex.lab  = multiplot.lab)
          mtext(text = paste0('Obs','\n(mm)'),
                side = 2,
                line = 3)
          axis(side = 4,
               cex.axis = multiplot.cex)
          # add observation lines
          lapply(as.list(allZoo), lines)
          abline(v   = yrs,
                 col = ablCol,
                 lty = 2)
        
          # Plot 3. 
          plot(x        = x[,1],
               type     = 'n',
               main     = '',
               xaxs     = "i",
               ylab     = '',
               xlab     = '',
               xaxt     = 'n',
               ylim     = yRange,
               cex.axis = multiplot.cex,
               cex.lab  = multiplot.lab)
          mtext(text = paste0('Obs. Envelope','\n(mm)'),
                side = 2,
                line = 3)
          
          # Min/Max poly
          METsteps::envelope(xall = z$envInput$xMinMax,
                             y1 = z$envInput$yMax,
                             y2 = z$envInput$yMin,
                             col = 'lightgrey',
                             border = 'lightgrey')
          
          # 25/75 poly
          METsteps::envelope(xall = z$envInput$x2575,
                             y1 = z$envInput$y75,
                             y2 = z$envInput$y25,
                             col = 'darkgrey',
                             border = 'darkgrey')
          
          # plot median
          lines(z$envZoo$envMedian, lty = 2)
          
          abline(v   = yrs,
                 col = ablCol,
                 lty = 2)
          
          # Plot 4.  Counts
          ctFun <- function(x){
            x <- as.numeric(x)
            return(sum(!is.na(x)))
          }
          cts <- apply(allZoo, MARGIN = 1, FUN = ctFun)
          cts <- as.zoo(cts)
          index(cts) <- as.Date(zoo::index(allZoo))
          # Create blank plot
          plot(x        = x[,1],
               type     = 'n',
               main     = '',
               xaxs     = "i",
               xaxt     = 'n',
               yaxt     = 'n',
               ylab     = '',
               xlab     = 'Time',
               ylim     = range(cts, na.rm = T),
               cex.axis = multiplot.cex,
               cex.lab  = multiplot.lab)
          mtext(text = paste0('n','\n'),
                side = 2,
                line = 3)
          axis(side = 4)
          lines(cts, type = 'h')
          abline(v   = yrs,
                 col = ablCol,
                 lty = 2)
          
          # Plot 5
          sds <- apply(allZoo, MARGIN = 1, FUN = sd, na.rm = T)
          sds <- as.zoo(sds)
          index(sds) <- as.Date(zoo::index(allZoo))
          plot(x        = x[,1],
               type     = 'n',
               main     = '',
               xaxs     = "i",
               ylab     = '',
               xlab     = 'Time',
               ylim     = range(sds, na.rm = T),
               cex.axis = multiplot.cex,
               cex.lab  = multiplot.lab)
          mtext(text = paste0('SD','\n(mm)'),
                side = 2,
                line = 3)
          lines(sds, col = 'red')
          abline(v   = yrs,
                 col = ablCol,
                 lty = 2)
          
        }else{
          noObsplots()
        }
      }else{
        noObsplots()
      }
    }else{
      noObsplots()
    }
  }
}