global.R

# ----------------------------------------------------------------------------
# **************************  rdfSlotToXTS  **********************************
# ----------------------------------------------------------------------------
#' Get one slot out of an rdf list and put it in an XTS object
#' 
#' \code{rdfSlotToXTS} Takes a list created by \code{\link{read.rdf}} and convert 
#' the nested slot values over the multiple traces into an XTS array 
#' indexing over traces.
#' 
#' @param rdf list returned by \code{\link{read.rdf}}
#' @param slot string of slot name that exists in \code{rdf} that will be converted to a matrix
#' @return an XTS object with the selected slot data
#' @examples
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, 'Powell.Pool Elevation')
rdfSlotToXTS <- function(rdf, slot)
{
  # check to see if the slot exists in the rdf, if it does not exit
  if(!(slot %in% listSlots(rdf)))
    stop(paste(slot,'not found in rdf:',deparse(substitute(rdf))))
  # Get date-times from rdf
  tArray <- rdf$runs[[1]]$times
  # OPERATIONS IN ORDER OF EXECUTION
  # 1. rdfSlotToMatrix - read data for 'slot' string given 'rdf' file
  # 2. cbind - combine datetime and data arrays
  # 3. data.frame - define R dataframe for conversion to XTS
  # 4. read.zoo - convert dataframe to zoo matrix
  # 5. as.xts - convert zoo matrix to XTS
  # 6. Storage.mode() - convert char values in the XTS matrix to numeric
  rdfXTS <- as.xts(read.zoo(data.frame(cbind(tArray,rdfSlotToMatrix(rdf, slot)))))
  storage.mode(rdfXTS) <- "numeric"
  runNames <- c()
  for (ithRun in c(1:as.numeric(rdf$meta$number_of_runs))){
    runNames <- c(runNames, paste('Trace',ithRun,sep=""))
  }
  names(rdfXTS) <- runNames
  rdfXTS
}

generate5YearTable <- function(meadZ, powellZ, powellQ)
{
  # Get Mead elevation tier percentages
  srplus <- getArrayThresholdExceedance(meadZ,1145,'GTE')
  short1 <- getArrayThresholdExceedance(meadZ,1075,'LTE')
  icsSrp <- getArrayThresholdExceedance(meadZ,0,'GTE') - (srplus + short1)
  short2 <- getArrayThresholdExceedance(meadZ,1050,'LT')
  short3 <- getArrayThresholdExceedance(meadZ,1025,'LT')
  allSht <- short1
  short1 <- short1 - short2
  short2 <- short2 - short3
  # Get Powell elevation tier percentages
  eqlBal <- getArrayThresholdExceedance(powellZ,3700,'LT')
  uprBal <- getArrayThresholdExceedance(powellZ,3646,'LT')
  midBal <- getArrayThresholdExceedance(powellZ,3575,'LTE')
  lowBal <- getArrayThresholdExceedance(powellZ,3525,'LTE')
  eqlBal <- eqlBal - uprBal
  uprBal <- uprBal - midBal
  midBal <- midBal - lowBal
  # Get Powell flow volume tier percentages
  powSum <- getTraceSum(powellQ, 'WY')
  powGT823 <- getArrayThresholdExceedance(powSum,8230000,'GT')
  powAT823 <- getArrayThresholdExceedance(powSum,8230000,'EQ')
  powLT823 <- getArrayThresholdExceedance(powSum,8230000,'LT')
  qData <- merge(powGT823,powAT823,powLT823)
  zData <- merge(srplus,icsSrp,allSht,short1,short2,short3,eqlBal,uprBal,midBal,lowBal)
  index(qData) <- index(zData)
  data <- round(merge(zData,qData), digits=0)
  data <- data.frame(coredata(data))
  return(t(data))
}

########################################################################################
# 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 <- index(rdfXTS[.indexmon(rdfXTS) %in% 8]) 
  ep <-  c(0, which(index(rdfXTS) %in% tVals)) 
  return(ep)
}

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

#' Get values that meet a month requirement
#' 
#' @param XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param integer month(s) as a single value or a vector with 1<=month<=12
#' @return an XTS object with the selected slot data
#' @examples
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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[.indexmon(rdfXTS) %in% (month - 1)]
  return(outXTS)
}

#' Get the average annual value for each trace
#' 
#' @param XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param 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
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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 <- period.apply(rdfXTS, ep, mean)
  return(outXTS)
}

#' Get the annual sum for each trace
#' 
#' @param XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param 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
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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 <- period.apply(rdfXTS, ep, colSums)
  return(outXTS)
}

#' Get the annual minimum for each trace
#' 
#' @param XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param 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
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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 <- period.apply(rdfXTS, ep, function(x) apply(x, 2, min))
  return(outXTS)
}

#' Get the annual maximum for each trace
#' 
#' @param XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param 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
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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 <- 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 XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param 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
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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) quantile(rdfXTS, pctlLevels)
  # DEFINE TIME STEP OF THE INPUT DATA
  tStep <- paste(periodicity(rdfXTS)$label,"s",sep="")
  # GET DATA INDICES
  ep <- endpoints(rdfXTS,tStep)
  # PERFORM STATS
  outXTS <- period.apply(rdfXTS, ep, toPctls)
  return(outXTS)
}

#' Get values at the input exceedance levels for the entire array by date
#' 
#' @param XTS object returned by \code{\link{rdfSlotToXTS}}
#' @param numeric value for the desired threshold to compare the data against
#' @param 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
#' zz <- read.rdf('KeySlots.rdf')
#' pe <- rdfSlotToXTS(zz, '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 if (comparison == "GTE")
    boolArray <- rdfXTS >= valueIn  
  else if (comparison == "LTE")
    boolArray <- rdfXTS <= valueIn 
  else if (comparison == "EQ")
    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(rowSums(boolArray),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)
}