R/xts_helperFunctions.R

In RWDataPlyr: Read and Manipulate Data from 'RiverWare'

###############################################################################
# Functions to aggregate and process slot data XTS objects generated by the
#   rdfSlotToXTS() function in rdf_helperFunctions.R
#
###############################################################################

# RETURNS XTS WATER YEAR ENDPOINTS FOR AGGREGATION CALCULATIONS
# rdfXTS <- xts array returned by rdfSlotToMatrix()
getWyEndpoints <- function(rdfXTS)
{
  tVals <- zoo::index(rdfXTS[xts::.indexmon(rdfXTS) %in% 8]) 
  ep <-  c(0, which(zoo::index(rdfXTS) %in% tVals)) 
  return(ep)
}

# RETURNS XTS CALENDAR YEAR ENDPOINTS FOR AGGREGATION CALCULATIONS
# rdfXTS <- xts array returned by rdfSlotToMatrix()
getCyEndpoints <- function(rdfXTS)
{
  tVals <- zoo::index(rdfXTS[xts::.indexmon(rdfXTS) %in% 11]) 
  ep <-  c(0, which(zoo::index(rdfXTS) %in% tVals)) 
  return(ep)
}

#' Get values that meet a month requirement
#' 
#' @param rdfXTS XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param month Integer month(s) as a single value or a vector with 1<=month<=12
#' @return an XTS object with the selected slot data
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' peJanFeb <- RWDataPlyr:::getTraceMonthVal(pe, c(1, 2))
#' 
#' @keywords internal

getTraceMonthVal <- function(rdfXTS, month)
{
  # CHECK FOR A VALID MONTH
  if (any(month <= 0) || any(month > 12))
    stop(paste0(
      month, 
      " is not a valid month. Use a month from 1 to 12"
    ))
  # GET VALUES OF EACH TRACE BY MONTH INDEX
  outXTS <- rdfXTS[xts::.indexmon(rdfXTS) %in% (month - 1)]
  return(outXTS)
}

#' Get the average annual value for each trace
#' 
#' @param rdfXTS XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param yearType String 'CY' or 'WY' denoting a Calendar Year (Jan-1 to 
#'   Dec-31) or Water Year (Oct-1 to Sep-30)
#' @return an XTS object with the selected slot annual average
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' peWY <- RWDataPlyr:::getTraceAvg(pe, 'WY')
#' 
#' @keywords internal

getTraceAvg <- function(rdfXTS, yearType)
{
  if (yearType == "WY")
    ep <- getWyEndpoints(rdfXTS)
  else
    ep <- getCyEndpoints(rdfXTS)
  # GET CY ANNUAL AVERAGE BY TRACE 
  outXTS <- xts::period.apply(rdfXTS, ep, mean)
  return(outXTS)
}

#' Get the annual sum for each trace
#' 
#' @param rdfXTS XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param yearType String 'CY' or 'WY' denoting a Calendar Year (Jan-1 to 
#'   Dec-31) or Water Year (Oct-1 to Sep-30)
#' @return an XTS object with the selected slot annual sum
#' 
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' peWY <- RWDataPlyr:::getTraceSum(pe, 'WY')
#' 
#' @keywords internal

getTraceSum <- function(rdfXTS, yearType)
{
  if (yearType == "WY")
    ep <- getWyEndpoints(rdfXTS)
  else
    ep <- getCyEndpoints(rdfXTS)
  # GET CY ANNUAL SUMS BY TRACE 
  outXTS <- xts::period.apply(rdfXTS, ep, colSums)
  return(outXTS)
}

#' Get the annual minimum for each trace
#' 
#' @param rdfXTS XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param yearType String 'CY' or 'WY' denoting a Calendar Year (Jan-1 to 
#'   Dec-31) or Water Year (Oct-1 to Sep-30)
#' @return an XTS object with the selected slot annual minimum
#' 
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' peWY <- RWDataPlyr:::getTraceMin(pe, 'WY')
#' 
#' @keywords internal

getTraceMin <- function(rdfXTS, yearType)
{
  if (yearType == "WY")
    ep <- getWyEndpoints(rdfXTS)
  else
    ep <- getCyEndpoints(rdfXTS)
  # GET CY ANNUAL MIN BY TRACE 
  outXTS <- xts::period.apply(rdfXTS, ep, function(x) apply(x, 2, min))
  return(outXTS)
}

#' Get the annual maximum for each trace
#' 
#' @param rdfXTS XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param yearType String 'CY' or 'WY' denoting a Calendar Year (Jan-1 to 
#'   Dec-31) or Water Year (Oct-1 to Sep-30)
#' @return an XTS object with the selected slot annual maximum
#' 
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' peWY <- RWDataPlyr:::getTraceMax(pe, 'WY')
#' 
#' @keywords internal

getTraceMax <- function(rdfXTS, yearType)
{
  if (yearType == "WY")
    ep <- getWyEndpoints(rdfXTS)
  else
    ep <- getCyEndpoints(rdfXTS)
  # GET CY ANNUAL MAX BY TRACE 
  outXTS <- xts::period.apply(rdfXTS, ep, function(x) apply(x, 2, max))
  return(outXTS)
}

#' Get values at the input exceedance levels for the entire array by date
#' 
#' @param rdfXTS Object returned by \code{\link{rdfSlotToXTS}}
#' @param pctlLevels Decimal value(s) for the desired exceedance levels with 
#'   0.0<value<1.0
#' @return an XTS object with the selected slot data at the input exceedance 
#'   levels
#'   
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' pe105090 <- RWDataPlyr:::getArrayPctl(pe, c(0.1, 0.5, 0.9))
#' 
#' @keywords internal

getArrayPctl <- function(rdfXTS, pctlLevels)
{
  # DEFINE PERCENTILE VALUES OF INTEREST
  toPctls <- function(rdfXTS) stats::quantile(rdfXTS, pctlLevels)
  # DEFINE TIME STEP OF THE INPUT DATA
  tStep <- paste(xts::periodicity(rdfXTS)$label,"s",sep="")
  # GET DATA INDICES
  ep <- xts::endpoints(rdfXTS,tStep)
  # PERFORM STATS
  outXTS <- xts::period.apply(rdfXTS, ep, toPctls)
  return(outXTS)
}

#' Get values at the input exceedance levels for the entire array by date
#' 
#' @param rdfXTS XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param valueIn Numeric value for the desired threshold to compare the data 
#'   against
#' @param comparison String 'GT' or 'LT' for a greater-than or less-than 
#'   comparison
#' @return an XTS object with the frequency in which the array of traces exceed 
#'   a threshold
#'   
#' @examples
#' pe <- RWDataPlyr:::rdfSlotToXTS(keyRdf, 'Mead.Pool Elevation')
#' peLT3575 <- RWDataPlyr:::getArrayThresholdExceedance(pe, 3575, 'LT')
#' 
#' @keywords internal

getArrayThresholdExceedance <- function(rdfXTS, valueIn, comparison)
{
  # DETERMINE COMPARISON TYPE AND GET A BOOLEAN ARRAY OF VALUES THAT MEET 
  # THE THRESHOLD
  if (comparison == "GT")
    boolArray <- rdfXTS > valueIn  
  else if (comparison == "LT")
    boolArray <- rdfXTS < valueIn 
  else
    stop(paste(
      comparison, 
      " is not a valid input. Use GT for greater than or LT for less than", 
      sep=""
    ))
  # GET A COUNT OF TRUE VALUES AT EACH COLUMN FOR EACH ROW
  trueCount <- xts::xts(rowSums(boolArray),zoo::index(boolArray))
  # GET THE TOTAL COUNT OF COLUMNS
  totalCount <- length(dimnames(boolArray)[[2]])
  # RETURN PERCENTAGE OF VALUES THAT MEET THE COMPARISON TYPE
  return(trueCount/totalCount * 100)
}