###############################################################################
# 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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.