R/xts_helperFunctions.R

In rabutler/RWDataPlot: Read, manipulate, and plot data from RiverWareTM (riverware.org), that is saved as rdf (RiverWare data format) files

########################################################################################
# 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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' peJanFeb <- getTraceMonthVal(pe, c(1, 2))
#' }
#' 
getTraceMonthVal <- function(rdfXTS, month)
{
  # CHECK FOR A VALID MONTH
  if (month <= 0 || month > 12)
    stop(paste(month, " is not a valid month. Use a month from 1 to 12", sep=""))
  # 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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' peWY <- getTraceAvg(pe, 'WY')
#' }

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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' peWY <- getTraceSum(pe, 'WY')
#' }

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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' peWY <- getTraceMin(pe, 'WY')
#' }

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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' peWY <- getTraceMax(pe, 'WY')
#' }

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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' pe105090 <- getTraceMax(pe, c(0.1, 0.5, 0.9))
#' }

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
#' \dontrun{
#' pe <- rdfSlotToXTS(keyRdf, 'Powell.Pool Elevation')
#' peLT3575 <- getArrayThresholdExceedance(pe, 3575, 'LT')
#' }

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)
}