R/event.R
In raff-k/RainSlide: Rainfall-induced landslide analysis tools
Defines functions
event
Documented in
event
#' @title Get rain event of a landslide
#'
#' @description This function calculates different precipitation characteristics for a specific time-series:
#' total precipitation, number of rainfall events, weighted mean intensity of rainfall events (normalized by MAP, RD or RDN),
#' cumulative critical event rainfall (normalized by MAP, RD or RDN), maximum rainfall during critical rainfall event,
#' duration of critical rainfall event, critical rainfall intensity (normalized by MAP, RD or RDN), rainfall at day of failure (start date),
#' rainfall intensity at day of failure (start date), maximum rainfall at day of failure (start date).
#'
#' @param x vector containing precipitation
#' @param dates vector containing dates. The length of dates must be similar to the length of x. Default: NULL
#' @param timesteps time period or length of observation. The rev(x) and rev(dates) are subsetted to this length according to date.of.failure if set. I.e. 24 for hourly or 1 for daily data. Default: NULL
#' @param date.of.failure date of failure. If set data is subsetted to this date. Must be of class "POSIXct" or "POSIXt". Default: NULL
#' @param sub.RainEvent examine potential sub-rain-events of critical rainfall event. Default: TRUE
#' @param all.RainEvent if TRUE, all rain events in data are extracted. By setting this option, no critical rain event metrics are computed. Default: FALSE
#' @param cumu.RainFall vector containing time intervals for cumulative rainfall. I.e. c(24, 48, 96) for 1, 2 and 4 days aggregation. Default: NULL
#' @param return.DataFrame only the rain events are returned as a data.frame. Default: TRUE
#' @param S1.rainThresh isolated rainfall measurements below this thresholds are removed in the first step. Default: 0.2
#' @param S3.rainThresh exclusion of irrelevant rainfall sub-events under and equal to this threshold (third step). Default: 1 (in mm)
#' @param S1.rainOffLength dry periods between isolated rain events in the first step. Default: c(3, 6) (hours). When dates is NULL, then the smallest values is used for separation.
#' @param S2.rainOffLength dry periods between rainfall sub-events in the second step. Default: c(6, 12) (hours). When dates is NULL, then the smallest values is used for separation.
#' @param S4.rainOffLength dry periods between rainfall sub-events in the second step. Default: c(48, 96) (hours). When dates is NULL, then the smallest values is used for separation.
#' @param RD average number of rainy days in a year, proxy for locate climate conditions. Default: NULL
#' @param MAP mean annual precipitation, the long-term yearly average precipitation, see CRU - climate research units for number. Default: NULL
#' @param RDN a climatic index that provides better description (or proxy) than the MAP for the occurrence of extreme storm events (Guzzetti et al. 2006: 247). Default: MAP/RD
#' @param index.month.warm.season month indices of the warm season. First element is start, and second element represents the end (all including). Only relevant when dates are set. Default: c(4, 10) (including April, including October)
#' @param force.limit Useful for standard output, if result is type list. Must be integer number of specific size. If result is smaller, than results gets filled with NA, otherwise cut to this size. Default: NULL
#'
#' @return
#' vector containing rainfall metrics (see description). If return.DataFrame is TRUE a data.frame is returned containing similar
#' rain metrics for all rain events.
#'
#'
#' @note
#' \itemize{
#' \item thresholds are oriented at hourly data
#' \item timesteps with precipitation equal 0 are included (see Melillo et al. 2015: 314)
#' \item Guzzetti, F., Peruccacci, S., Rossi, M., & Stark, C. P. (2007). Rainfall thresholds for the initiation of landslides in central and southern Europe. Meteorology and atmospheric physics, 98(3-4), 239-267.
#' \item Rossi, M., Luciani, S., Valigi, D., Kirschbaum, D., Brunetti, M. T., Peruccacci, S., & Guzzetti, F. (2017). Statistical approaches for the definition of landslide rainfall thresholds and their uncertainty using rain gauge and satellite data. Geomorphology, 285, 16-27.
#' \item Melillo, M., Brunetti, M. T., Peruccacci, S., Gariano, S. L., & Guzzetti, F. (2015). An algorithm for the objective reconstruction of rainfall events responsible for landslides. Landslides, 12(2), 311-320.
#' }
#'
#'
#' @keywords rainfall tresholds, rainfall event, landslide, rainfall metrics
#'
#'
#' @export
event <- function(x, dates = NULL, timesteps = NULL, date.of.failure = NULL, sub.RainEvent = TRUE, all.RainEvent = FALSE, cumu.RainFall = NULL, return.DataFrame = TRUE,
S1.rainThresh = 0.2, S3.rainThresh = 1, S1.rainOffLength = c(3, 6), S2.rainOffLength = c(6, 12), S4.rainOffLength = c(48, 96),
RD = NULL, MAP = NULL, RDN = MAP/RD, index.month.warm.season = c(4, 10), force.limit = NULL)
{
# # # # # # # # # CHECK POTENTIAL ERRORS # # # # # # # # #
if(all.RainEvent)
{
if(!is.null(timesteps) || !is.null(date.of.failure) || is.null(cumu.RainFall))
{
warnings('The function parameters "timesteps", "date.of.failure", and "cumu.RainFall" are set to NULL')
timesteps <- NULL
date.of.failure <- NULL
cumu.RainFall <- NULL
}
} # end of if all.RainEvent
if(!is.null(dates) && length(dates) != length(x))
{
stop('Length of "x" and "dates" must be identical')
}
if(length(index.month.warm.season) != 2 | max(index.month.warm.season) > 12 | min(index.month.warm.season) < 1)
{
stop('Function argument "index.month.warm.season" is wrongly defined')
}
# if(type != "daily" & type != "hourly")
# {
# stop('"type"must be either "daily" or "hourly"')
# }
if(S1.rainThresh < 0 | S3.rainThresh < 0)
{
stop('"rainThresh" must be a positive value')
}
if(length(S1.rainOffLength) > 2)
{
stop('"rainOffLength" should contain maximum 2 elements')
}
if(length(which(S1.rainOffLength < 0)) > 0 | length(which(S2.rainOffLength < 0)) > 0 | length(which(S4.rainOffLength < 0)) > 0)
{
stop('"rainOffLength" thresholds must contain positive numbers')
}
if((!is.null(RD) && RD == 0) | (!is.null(MAP) && MAP == 0))
{
stop('"RD" or "MAP" are nor allowed to be "0"')
}
if(!is.null(date.of.failure) && class(date.of.failure)[1] != "POSIXct" & class(date.of.failure)[1] != "POSIXt")
{
stop('Date of failure must be of class POSIXct or POSIXt')
}
if(!is.null(timesteps) && (length(timesteps) > 1 | timesteps[1] < 0 | length(x) < timesteps[1]))
{
stop('Something wrong in "timesteps". Only a single positive integer number is accepted, which is equal or smaller to "x"')
}
if(!is.null(cumu.RainFall) && (length(which(cumu.RainFall <= 0)) > 0 | max(cumu.RainFall) > length(x)))
{
stop('The calculation of cumulative rainfall should have at least have 1 time step intervall indicating by positive integer numbers.
In addition, the cumulative rainfall should not exceeded the length of the precipitation vector')
}
if(!is.null(force.limit) && class(force.limit) != "numeric")
{
stop('function parameter "force.limit" must be of class "numeric"')
}
# # # # # # # # # START ALGORITHM # # # # # # # # #
# reverse x, meaning that precipitation before event is at first position
x <- rev(x)
x.input <- x
# reverse dates
dates <- rev(dates)
## subset data to date of failure
if(!is.null(date.of.failure))
{
if(!is.null(dates))
{
# get subset indices
DoF.sub <- which(dates <= date.of.failure)
# subset dates
dates <- dates[DoF.sub]
# subset precipitation
x <- x[DoF.sub]
} else{
warning('date of failure is set, but no dates avaiable. Therefore, subsetting is skipped')
}
}
## subset data to timesteps
if(!is.null(timesteps))
{
if(timesteps > length(x))
{
stop("After subsetting data to the date of failure, there are more timesteps than data")
}
# subset precipitation
x <- x[1:timesteps]
# subset dates
if(!is.null(dates)){dates <- dates[1:timesteps]}
}
if(!is.null(cumu.RainFall) && any(timesteps < cumu.RainFall))
{
stop('The time intervall for cumulative rain fall exceeded timesteps')
}
## extract months of dates and extent dates
## align thresholds
if(!is.null(dates))
{
# get months of date
dates <- list(dates, as.numeric(format(dates, "%m")))
} else {
S1.rainOffLength <- min(S1.rainOffLength) # threshold of first step
S2.rainOffLength <- min(S2.rainOffLength) # threshold of second step
S4.rainOffLength <- min(S4.rainOffLength) # threshold of fourth step
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 1: Detection and exclusion of isolated rainfall measurements --------------------------
# ... find isolated rainfall (rainThresh must be fix to 0)
S1.isolRF <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0, 0), rainOffLength = S1.rainOffLength,
op.rainThresh = ">", op.rainOffLength = "<=",
index.month.warm.season = index.month.warm.season)
# ... set irrelevant rainfall depening on threshold to 0
x[S1.isolRF$index[which(x[S1.isolRF$index] <= S1.rainThresh)]] <- 0 # THRESHOLD MUST BE DEFINED!!!!!!
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 2: Identification of rainfall sub-events ----------------------------------------------
# S2.DryPeriods <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S2.rainOffLength,
# op.rainThresh = "==", op.rainOffLength = ">=",
# index.month.warm.season = index.month.warm.season)
# S2.RainEvents <- .findRainEvent(x = x, x.pos.dryPeriods = S2.DryPeriods)
S2.isolRF <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S2.rainOffLength,
op.rainThresh = ">", op.rainOffLength = ">=",
index.month.warm.season = index.month.warm.season)
# debugonce(.findRainEvent)
S2.RainEvents <- S2.isolRF$index_list
# ... sum of precipitation of sub-rain-events
S2.RE.sum <- sapply(X = S2.RainEvents, FUN = function(X, precip) {
sum(precip[X], na.rm = TRUE)
}, precip = x)
# ... duration of sub-rain-events
# S2.RE.dur <- sapply(X = S2.RainEvents, FUN = length) # DO WE NEED THIS?
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 3: Exclusion if irrelevant rainfall sub-events ----------------------------------------
S3.RainEvents <- S2.RainEvents[which(S2.RE.sum > S3.rainThresh)]
S3.RE.exclusion <- unlist(S2.RainEvents[which(S2.RE.sum <= S3.rainThresh)])
# ... set rainfall to 0
x[S3.RE.exclusion] <- 0
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 4/5: Identification of rainfall events --------------------------------------------------
# S4.DryPeriods <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S4.rainOffLength,
# op.rainThresh = "==", op.rainOffLength = ">=",
# index.month.warm.season = index.month.warm.season)
# S4.RainEvents <- .findRainEvent(x = x, x.pos.dryPeriods = S4.DryPeriods)
S4.isolRF <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S4.rainOffLength,
op.rainThresh = ">", op.rainOffLength = ">=",
index.month.warm.season = index.month.warm.season)
# debugonce(.findRainEvent)
S4.RainEvents <- S4.isolRF$index_list
## ... get rainfall metrics
# general
precip.tot <- sum(x.input, na.rm = TRUE)
names(precip.tot) <- "sum_total"
res <- precip.tot
## ... check if there is precipitation in the data
if(precip.tot == 0)
{
flag.zero <- TRUE
} else {
flag.zero <- FALSE
}
# cumulative rainfall
if(!is.null(cumu.RainFall))
{
precip.cum <- sapply(X = cumu.RainFall, function(X, precip){sum(precip[1:X], na.rm = TRUE)}, precip = x)
names(precip.cum) <- paste0("sum_cumu_", cumu.RainFall)
res <- c(res, precip.cum)
}
if(all.RainEvent)
{
# all rain event data
cERM <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S4.RainEvents, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
# ... gsub s in names
names(cERM) <- gsub(pattern = "^(s)", replacement = "", x = names(cERM))
} else {
# critical rain event
cERM <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S4.RainEvents, modus = "main", RD = RD, MAP = MAP, RDN = RDN)
}
# merge
res <- c(res, cERM)
# fill infinitve values with NAs
if(flag.zero)
{
res[is.infinite(res)] <- NA
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 6: Rainfall measurements for events with landslides --------------------------------------------------
if(sub.RainEvent & !flag.zero)
{
if(all.RainEvent)
{
# ... find all sub events ------------------------------------
cERM.S6.SubEvents <- lapply(X = 1:length(S4.RainEvents), FUN = function(i, S4RE, S3RE, precip, dates, RD, MAP, RDN)
{
# ... get max and min index
# ... ... find nearest min index
S3RE.minIndices <- sapply(X = S3RE, FUN = min)
S4RE.minIndex.pos <- unname(which.min(abs(S3RE.minIndices - min(S4RE[[i]]))))
S4RE.minIndex <- min(S3RE[[S4RE.minIndex.pos]])
S4RE.maxIndex <- max(S4RE[[i]])
# ... check for sub-rainfall events
S6SRE.check.min <- sapply(X = S3RE, FUN = function(x, minIndex){min(x) >= minIndex}, minIndex = S4RE.minIndex)
S6SRE.check.max <- sapply(X = S3RE, FUN = function(x, maxIndex){max(x) <= maxIndex}, maxIndex = S4RE.maxIndex)
S6SE <- S3RE[which(S6SRE.check.min & S6SRE.check.max)]
if(length(S6SE) == 1 && identical(unname(unlist(S6SE)), S4RE[[i]])) return(NULL) # sub-event and event are identica
# aggregated events
if(length(S6SE) > 1){
S6SE.agg <- lapply(X = 1:(length(S6SE)-1), l = S6SE,
FUN = function(i, l){unlist(x = l[1:i], use.names = FALSE)})
} else {
S6SE.agg <- S6SE
}
# ... calculate rainfall metrics
cERM.sub <- .calcEventRainfallMetrics(x = precip, dates = dates, list.RainEvents = S6SE.agg, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
names(cERM.sub) <- paste0(names(cERM.sub), "_", stringr::str_pad(string = i, width = 2, side = "left", pad = "0")) # naming
return(cERM.sub)
}, S3RE = S3.RainEvents, S4RE = S4.RainEvents, precip = x, dates = dates, RD = RD, MAP = MAP, RDN = RDN)
res <- c(res, unlist(cERM.S6.SubEvents))
# ... flatten list
# S6.SubEvents.fl <- unlist(S6.SubEvents, recursive = FALSE)
# S6.SubEvents.Names <- gsub(pattern = "\\." , replacement = "_" , names(S6.SubEvents.fl))
# ... calculate sub-event rainfall metrics
# cERM.sub <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S6.SubEvents.fl, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
# ... rename items
# cERM.sub.NumNames <- paste0(paste0(c(1:length(S4.RainEvents)), "_"), unlist(sapply(X = 1:length(S6.SubEvents.LenName), FUN = function(x, n){rep(x, n[x])}, n = S6.SubEvents.LenName)))
} else {
## ... find sub-events of critical rainfall event
# get largest index of first rain event
S4.RainEvents.maxIndex <- max(S4.RainEvents[[1]])
# ... check for sub-rainfall events
S6.SubEvents.check <- sapply(X = S3.RainEvents, FUN = function(x, maxIndex){max(x) <= maxIndex}, maxIndex = S4.RainEvents.maxIndex)
S6.SubEvents <- S3.RainEvents[which(S6.SubEvents.check)]
# aggregated events
if(length(S6.SubEvents) > 1){
S6.SubEvents.agg <- lapply(X = 1:(length(S6.SubEvents)-1), l = S6.SubEvents,
FUN = function(i, l){unlist(x = l[1:i], use.names = FALSE)})
} else {
S6.SubEvents.agg <- S6.SubEvents
}
# if(length(S6.SubEvents) > 1) # > 1, because 1 would be similar to the critical rainfall event
# {
cERM.sub <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S6.SubEvents.agg, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
res <- c(res, cERM.sub)
# }
} # end of if(all.RainEvent)
} # end if sub.RainEvent
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Return data --------------------------------------------------------------------------------
if(return.DataFrame)
{
# if(sub.RainEvent && length(S6.SubEvents) > 1)
if(sub.RainEvent & !flag.zero)
{
if(all.RainEvent)
{
# ... remove of first two items: "sum_total", "RE_number", "RE_weightIntensity"
# remove items
res <- res[!names(res) %in% c("sum_total", "RE_number", "RE_weightIntensity",
"RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN")]
# ... get and remove number of sub-events
extr.sRENum.pos <- grep(pattern = "sRE_number_.", x = names(res)) # ... get positions
extr.sRENum <- res[extr.sRENum.pos] # ... get number of sub events
extr.sRENum.id <- as.numeric(gsub(pattern = "sRE_number_", replacement = "", x = names(extr.sRENum)))
res <- res[-extr.sRENum.pos] # remove this variable from results
extr.sREWeight.pos <- grep(pattern = "sRE_weightIntensity_.", x = names(res)) # ... get positions
extr.sREWeight <- res[extr.sREWeight.pos] # ... get number of sub events
res <- res[-extr.sREWeight.pos] # remove this variable from results
# ... ... create data.frame for weighted Intensity
sREWeight.ColName <- unique(gsub(pattern = "_[[:digit:]].*", replacement = "", x = names(extr.sREWeight)))
sREWeight.df <- data.frame(matrix(extr.sREWeight, ncol = length(sREWeight.ColName)))
colnames(sREWeight.df) <- sREWeight.ColName
# ... get start indices of sub-events
startSub <- grep(pattern = "sRE_sum_01.", x = names(res))[1]
# ... create main data frame
# ... ... names
res.df.main.ColName <- names(res)[1:(startSub-1)] # get names
res.df.main.ColName <- unique(gsub(pattern = "_[[:digit:]].*", replacement = "", x = res.df.main.ColName)) # adapt colnames
# ... ... data.frame
res.df.main <- data.frame(matrix(res[1:(startSub-1)], ncol = ((startSub-1)/length(S4.RainEvents))))
colnames(res.df.main) <- res.df.main.ColName # re-name columns
sRe.missing <- setdiff(1:nrow(res.df.main), extr.sRENum.id)
extr.sRENum_filled <- extr.sRENum
# fill up missing data
for(m in sort(sRe.missing))
{
extr.sRENum_filled <- R.utils::insert(x = extr.sRENum_filled,
ats = m,
values = 0) # add number of sub-events
sREWeight.df <- dplyr::add_row(sREWeight.df, sRE_weightIntensity = NA, .before = m)
}
res.df.main$sRE_number <- extr.sRENum_filled
res.df.main <- cbind(res.df.main,
sREWeight.df) # weightesIntensitiy data.frame
res.df.main$ID <- c(1:nrow(res.df.main))*100 # id for ordering later
# ... create sub data frame
# ... ... names
res.df.sub.ColName.all <- names(res)[startSub:length(res)] # get names
res.df.sub.ColName <- unique(gsub(pattern = "^s|_[[:digit:]].*", replacement = "", x = res.df.sub.ColName.all)) # adapt colnames
res.df.sub.ColName.order <- lapply(X = res.df.sub.ColName, FUN = function(x, all.n, startSub){
# return(grep(pattern = x, x = all.n) + startSub -1)
return(grep(pattern = paste0(x, "_[[:digit:]].*"), x = all.n) + startSub -1)
}, all.n = res.df.sub.ColName.all, startSub = startSub) %>% unlist(.)
# ... ... data.frame
res.df.sub <- data.frame(matrix(res[res.df.sub.ColName.order], ncol = ((startSub-1)/length(S4.RainEvents)))) # startSub:length(res)
colnames(res.df.sub) <- res.df.sub.ColName # re-name columns
# res.df.sub$ID <- unlist(sapply(X = 1:length(extr.sRENum), FUN = function(i, x){i*100 + seq(1:extr.sRENum[i])}, x = extr.sRENum)) # get ID variables
res.df.sub$ID <- unlist(mapply(i = extr.sRENum.id, j = extr.sRENum, FUN = function(i, j){i*100 + seq(1:j)}, SIMPLIFY = FALSE, USE.NAMES = FALSE))
# ... row-bind data frames
res.df <- dplyr::bind_rows(res.df.main, res.df.sub)
# re-order data.frame based on ID
res.df <- res.df[with(res.df, order(ID)), ]
row.names(res.df)[which(!is.na(res.df$sRE_number))] <- paste0("RE_", res.df[which(!is.na(res.df$sRE_number)), ]$ID)
row.names(res.df)[which(is.na(res.df$sRE_number))] <- paste0("sRE_", res.df[which(is.na(res.df$sRE_number)), ]$ID)
# ... finally remove ID
res.df$ID <- NULL
} else {
# get main event items
items <- c("sRE_number", "sRE_weightIntensity", "sRE_weightIntensity_MAP", "sRE_weightIntensity_RD", "sRE_weightIntensity_RDN",
"sum_total", names(res)[grep(pattern = "sum_cumu", names(res))], "RE_total",
"RE_number", "RE_weightIntensity", "RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN")
# remove items
res.df <- res[!names(res) %in% items]
# rename
names(res.df) <- substring(names(res.df), 2)
## create data frame
startSub <- which(names(res.df) == "RE_sum_01") # RE_sum_1 * changed 20-02-12
res.colNames <- names(res.df)[1: (startSub-1)]
# ... create first main then sub data.frame
res.df.main <- data.frame(matrix(res.df[1:(startSub-1)], ncol = length(c(1:(startSub-1)))))
res.df.sub <- data.frame(matrix(res.df[startSub:length(res.df)], ncol = length(c(1:(startSub-1)))))
# ... combine both data.frames
if(length(S6.SubEvents.agg) >= 1) # if there is a sub-event?
{
res.df <- rbind(res.df.main, res.df.sub)
} else {
res.df <- res.df.main
}
# ... set names
colnames(res.df) <- res.colNames
# ... set items to data frame
items.res <- res[which(names(res) %in% items)]
items.res <- items.res[items[which(items %in% names(res))]] # just re-ordering
# ... create empty data.frame and add values
items.df <- data.frame(matrix(NA, nrow = nrow(res.df), ncol = length(items.res)))
items.df[1, ] <- items.res
colnames(items.df) <- names(items.res)
# ... add new columns to result
res.df <- cbind(res.df, items.df)
if(length(S6.SubEvents.agg) >= 1) # if there is only 1 sub-event?
{
rownames(res.df) <- c("cRE", paste0("sRE", c(1:length(S6.SubEvents.agg))))
} else {
rownames(res.df) <- "cRE"
}
} # end of if all.RainEvent
} else {
if(all.RainEvent)
{
# ... remove of first two items: "sum_total", "RE_number"
# remove items
res <- res[!names(res) %in% c("sum_total", "RE_number", "RE_weightIntensity",
"RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN")]
# get colnames
res.df.ColName <- unique(gsub(pattern = "_[[:digit:]].*", replacement = "", x = names(res))) # adapt colnames
# ... ... data.frame
res.df <- data.frame(matrix(res, ncol = length(res.df.ColName)))
colnames(res.df) <- res.df.ColName # re-name columns
rownames(res.df) <- paste0("RE", seq(100, 100*nrow(res.df), 100))
} else {
# re-order vector
items.fst <- which(names(res) == "cRE_sum")
res <- res[c(items.fst:length(res), 1:(items.fst-1))]
res.df <- data.frame(matrix(data = res, ncol = length(res)))
names(res.df) <- gsub(pattern = "^(c)", replacement = "", x = names(res))
} # end of if a..RainEvent
} # end of if-else: sub.RainEvent & length(S6.SubEvents) > 1
# modified data.frame output
return(res.df)
} else {
# ... standard vector output -------------------
if(!is.null(force.limit))
{
force.limit <- round(force.limit)
res.names <- names(res)
if(length(res) < force.limit)
{
res <- c(res, rep(NA, (force.limit - length(res)))) # fill result
res.names <- c(res.names, rep("NULL DATA", (force.limit - length(res))))
names(res) <- res.names
} else{
res <- res[1:force.limit] # clip result
names(res) <- res.names[1:force.limit]
}
} # end of force.limit
return(res)
}
} # end of function event()
#' calcEventRainfallMetrics
#'
#' This function calcuates different precipitation metrics.
#'
#' @param x vector containing precipitation
#' @param dates see CTRL()
#' @param list.RainEvents list containing indices of rain events
#' @param modus modus of calculation of rain metrics. "sub" of sub-rainfall events or "main" for critical rainfall event
#' @param RD see CTRL()
#' @param MAP see CTRL()
#' @param RDN see CTRL()
#' @return
#' vector containing rainfall metrics
.calcEventRainfallMetrics <- function(x, dates, list.RainEvents, modus, RD = RD, MAP = MAP, RDN = RDN)
{
## cumulative rainfall
# total sum of precipitation of each rain event
RE.sum <- sapply(X = list.RainEvents, FUN = function(X, precip) {
sum(precip[X], na.rm = TRUE)
}, precip = x)
# maximum of precipitation of each rain event
RE.max <- sapply(X = list.RainEvents, FUN = function(X, precip) {
max(precip[X], na.rm = TRUE)
}, precip = x)
## duration of rain events
RE.durRain <- sapply(X = list.RainEvents, FUN = length) # actual rainy elements
RE.dur <- sapply(X = list.RainEvents, FUN = function(x) max(x)-min(x)+1) # entire period
## number of rain events
rainEvent.nb <- length(list.RainEvents)
### ... MAIN rainfall metrics
if(modus == "main")
{
## naming of variables
names(rainEvent.nb) <- "RE_number"
## overall sum of rain events
RE.tot <- sum(RE.sum)
names(RE.tot) <- "RE_total"
# normalizations
if(!is.null(MAP)){RE.sum.MAP <- RE.sum/MAP}
if(!is.null(RD)){RE.sum.RD <- RE.sum/RD}
if(!is.null(MAP) & !is.null(RD)){RE.sum.RDN <- RE.sum/RDN}
## weighted mean intensity of rain events
RE.wID <- stats::weighted.mean(x = RE.sum/RE.dur, w = RE.dur, na.rm = TRUE)
names(RE.wID) <- "RE_weightIntensity"
# normalizations
if(!is.null(MAP)){RE.wID.MAP <- RE.wID/MAP; names(RE.wID.MAP) <- "RE_weightIntensity_MAP"}
if(!is.null(RD)){RE.wID.RD <- RE.wID/RD; names(RE.wID.RD) <- "RE_weightIntensity_RD"}
if(!is.null(MAP) & !is.null(RD)){RE.wID.RDN <- RE.wID/RDN; names(RE.wID.RDN) <- "RE_weightIntensity_RDN"}
## critical rainfall event
# critical event rainfall
cRE.sum <- RE.sum[[1]]
names(cRE.sum) <- "cRE_sum"
# normalizations
if(!is.null(MAP)){cRE.sum.MAP <- RE.sum.MAP[[1]]; names(cRE.sum.MAP) <- "cRE_sum_MAP"}
if(!is.null(RD)){cRE.sum.RD <- RE.sum.RD[[1]]; names(cRE.sum.RD) <- "cRE_sum_RD"}
if(!is.null(MAP) & !is.null(RD)){cRE.sum.RDN <- RE.sum.RDN[[1]]; names(cRE.sum.RDN) <- "cRE_sum_RDN"}
## critical maximal event rainfall
cRE.max <- RE.max[[1]]
names(cRE.max) <- "cRE_max"
## critical event rainfall duration
cRE.dur <- RE.dur[[1]]
names(cRE.dur) <- "cRE_dur"
## critical event rainfall duration for only rainy days (Rain)
cRE.durRain <- RE.durRain[[1]]
names(cRE.durRain) <- "cRE_dur_Rain"
## critical event rainfall intensity
cRE.ID <- cRE.sum/cRE.dur
names(cRE.ID) <- "cRE_Intensity"
## critical event rainfall intensity
cRE.ID.Rain <- cRE.sum/cRE.durRain
names(cRE.ID.Rain) <- "cRE_Intensity_Rain"
# normalizations
if(!is.null(MAP)){cRE.ID.MAP <- cRE.sum.MAP/cRE.dur; names(cRE.ID.MAP) <- "cRE_Intensity_MAP"}
if(!is.null(RD)){cRE.ID.RD <- cRE.sum.RD/cRE.dur; names(cRE.ID.RD) <- "cRE_Intensity_RD"}
if(!is.null(MAP) & !is.null(RD)){cRE.ID.RDN <- cRE.sum.RDN/cRE.dur; names(cRE.ID.RDN) <- "cRE_Intensity_RDN"}
## get range of rain event
# cRE.range <- paste0(range(list.RainEvents[[1]], na.rm = TRUE), collapse = ":")
cRE.range <- range(list.RainEvents[[1]], na.rm = TRUE)
cRE.range.end <- min(cRE.range)
cRE.range.start <- max(cRE.range)
names(cRE.range.start) <- "cRE_range_start"
names(cRE.range.end) <- "cRE_range_end"
## get dates out of range of rain event
if(!is.null(dates))
{
cRE.date.start <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][cRE.range.start], "%Y-%m-%d-%H")))
names(cRE.date.start) <- "cRE_date_start"
# browser()
cRE.date.end <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][cRE.range.end], "%Y-%m-%d-%H")))
names(cRE.date.end) <- "cRE_date_end"
}
} # end of main rainfall metrics
### ... SUB rainfall metrics
if(modus == "sub")
{
## naming of variables
names(rainEvent.nb) <- "sRE_number"
names(RE.sum) <- paste0("sRE_sum_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
names(RE.max) <- paste0("sRE_max_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
names(RE.dur) <- paste0("sRE_dur_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
names(RE.durRain) <- paste0("sRE_dur_Rain_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
## rainfall intensity
RE.ID <- RE.sum/RE.dur
names(RE.ID) <- paste0("sRE_Intensity_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
## rainfall intensity (only rainy days)
RE.ID.Rain <- RE.sum/RE.durRain
names(RE.ID.Rain) <- paste0("sRE_Intensity_Rain_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
# normalizations c(rainEvent.nb, RE.sum, RE.max, RE.dur, RE.ID)
if(!is.null(MAP))
{
RE.sum.MAP <- RE.sum/MAP
names(RE.sum.MAP) <- paste0("sRE_sum_MAP_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.ID.MAP <- RE.sum.MAP/RE.dur
names(RE.ID.MAP) <- paste0("sRE_Intensity_MAP_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
if(!is.null(RD))
{
RE.sum.RD <- RE.sum/RD
names(RE.sum.RD) <- paste0("sRE_sum_RN_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.ID.RD <- RE.sum.RD/RE.dur
names(RE.ID.RD) <- paste0("sRE_Intensity_RD_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
if(!is.null(MAP) & !is.null(RD))
{
RE.sum.RDN <- RE.sum/RDN
names(RE.sum.RDN) <- paste0("sRE_sum_RND_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0")) # c(1:rainEvent.nb))
RE.ID.RDN <- RE.sum.RDN/RE.dur
names(RE.ID.RDN) <- paste0("sRE_Intensity_RDN_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
## weighted mean intensity of sub rain events
RE.wID <- stats::weighted.mean(x = RE.sum/RE.dur, w = RE.dur, na.rm = TRUE)
names(RE.wID) <- "sRE_weightIntensity"
# normalizations
if(!is.null(MAP)){RE.wID.MAP <- RE.wID/MAP; names(RE.wID.MAP) <- "sRE_weightIntensity_MAP"}
if(!is.null(RD)){RE.wID.RD <- RE.wID/RD; names(RE.wID.RD) <- "sRE_weightIntensity_RD"}
if(!is.null(MAP) & !is.null(RD)){RE.wID.RDN <- RE.wID/RDN; names(RE.wID.RDN) <- "sRE_weightIntensity_RDN"}
## get range of rain events
# RE.range <- sapply(X = list.RainEvents, FUN = function(X) { paste0(range(x, na.rm = TRUE), collapse = ":")})
RE.range.start <- sapply(X = list.RainEvents, FUN = max, na.rm = TRUE)
names(RE.range.start ) <- paste0("sRE_range_start_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.range.end <- sapply(X = list.RainEvents, FUN = min, na.rm = TRUE)
names(RE.range.end) <- paste0("sRE_range_end_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
## get dates out of range of rain event
if(!is.null(dates))
{
RE.date.start <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][RE.range.start], "%Y-%m-%d-%H")))
# RE.date.start <- as.numeric(gsub("-|[[:space:]]", "", substring(dates[[1]][RE.range.start], 1, 13)))
names(RE.date.start) <- paste0("sRE_date_start_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.date.end <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][RE.range.end], "%Y-%m-%d-%H")))
# RE.date.end <- as.numeric(gsub("-|[[:space:]]", "", substring(dates[[1]][RE.range.end], 1, 13)))
names(RE.date.end) <- paste0("sRE_date_end_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
} # end of sub rainfall metrics
### ... return data
if(!is.null(MAP) & is.null(RD)){
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, RE.wID.MAP, cRE.sum, cRE.sum.MAP, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.ID.MAP, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "RE_weightIntensity_MAP", "cRE_sum", "cRE_sum_MAP", "cRE_max", "cRE_duration", cRE_duration_Rain", "cRE_Intensity", "cRE_Intensity_Rain", "cRE_Intensity_MAP", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.sum.MAP, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.ID.MAP, RE.wID, RE.wID.MAP, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_sum_MAP_", c(1:rainEvent.nb)),
# paste0("sRE_max_", c(1:rainEvent.nb)), paste0("sRE_dur_", c(1:rainEvent.nb)),
# paste0("sRE_Intensity_", c(1:rainEvent.nb)), paste0("sRE_Intensity_MAP_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} else if(!is.null(RD) & is.null(MAP)){
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, RE.wID.RD, cRE.sum, cRE.sum.RD, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.ID.RD, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "RE_weightIntensity_RD", "cRE_sum", "cRE_sum_RD", "cRE_max", "cRE_duration", "cRE_Intensity", "cRE_Intensity_RD", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.sum.RD, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.ID.RD, RE.wID, RE.wID.RD, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_sum_RD_", c(1:rainEvent.nb)),
# paste0("sRE_max_", c(1:rainEvent.nb)), paste0("sRE_dur_", c(1:rainEvent.nb)),
# paste0("sRE_Intensity_", c(1:rainEvent.nb)), paste0("sRE_Intensity_RD_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} else if(!is.null(RD) & !is.null(MAP)){
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, RE.wID.MAP, RE.wID.RD, RE.wID.RDN, cRE.sum, cRE.sum.MAP, cRE.sum.RD, cRE.sum.RDN, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.ID.MAP, cRE.ID.RD, cRE.ID.RDN, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN",
# "cRE_sum", "cRE_sum_MAP", "cRE_sum_RD", "cRE_sum_RDN", "cRE_max", "cRE_duration", "cRE_Intensity", "cRE_Intensity_MAP", "cRE_Intensity_RD", "cRE_Intensity_RDN", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.sum.MAP, RE.sum.RD, RE.sum.RDN, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.ID.MAP, RE.ID.RD, RE.ID.RDN, RE.wID, RE.wID.MAP, RE.wID.RD, RE.wID.RDN, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_sum_MAP_", c(1:rainEvent.nb)), paste0("sRE_sum_RD_", c(1:rainEvent.nb)), paste0("sRE_sum_RDN_", c(1:rainEvent.nb)),
# paste0("sRE_max_", c(1:rainEvent.nb)), paste0("sRE_dur_", c(1:rainEvent.nb)),
# paste0("sRE_Intensity_", c(1:rainEvent.nb)), paste0("sRE_Intensity_MAP_", c(1:rainEvent.nb)), paste0("sRE_Intensity_RD_", c(1:rainEvent.nb)), paste0("sRE_Intensity_RDN_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} else {
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, cRE.sum, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "cRE_sum", "cRE_max", "cRE_duration", "cRE_Intensity", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.wID, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_max_", c(1:rainEvent.nb)),
# paste0("sRE_dur_", c(1:rainEvent.nb)), paste0("sRE_Intensity_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} # end of if - else if - else statement
return(res)
} # end of calcEventRainfallMetrics
#' findRainFallPosition
#'
#' This function return indices of a specific selection.
#'
#' @param x vector containing precipitation
#' @param dates vector containing months of dates. The length of dates must be similar to the length of x
#' @param rainThresh list containing indices of rain events
#' @param rainOffLength modus of calculation of rain metrics. "sub" of sub-rainfall events or "main" for critical rainfall event
#' @param op.rainThresh operator for rain-threshold: x OP rainThresh
#' @param op.rainOffLength operator for rainOff-threshold: lengths of event OP rainOffLength-Threshold
#' @param index.month.warm.season index of month belonging to warm season
#' @return
#' vector containing indices of x corresponding to specific selection.
.findRainFallPosition <- function(x, dates, rainThresh, rainOffLength, op.rainThresh, op.rainOffLength,
index.month.warm.season)
{
## find position of rainfall under/over/equal to threshold | x OP rainThresh
if(!is.null(dates))
{
## find position of dates correpsonding to season
pos.warm <- which(dates[[2]] >= index.month.warm.season[1] & dates[[2]] <= index.month.warm.season[2])
pos.cold <- which(dates[[2]] < index.month.warm.season[1] | dates[[2]] > index.month.warm.season[2])
## thresholding x based on season and season threshold
x.pos.rainThresh.warm <- which(do.call(op.rainThresh, list(x[pos.warm], rainThresh[1])))
x.pos.rainThresh.cold <- which(do.call(op.rainThresh, list(x[pos.cold], rainThresh[2])))
# x.pos.rainThresh <- sort(c(pos.warm[x.pos.rainThresh.warm], pos.cold[x.pos.rainThresh.cold]))
} else {
x.pos.rainThresh <- which(do.call(op.rainThresh, list(x, rainThresh[1])))
}
if(!is.null(dates))
{
## thresholding x based on season and season threshold
# warm
if(length(x.pos.rainThresh.warm) > 0)
{
x.pos.rainThresh.C.warm <- split(seq_along(along.with = x.pos.rainThresh.warm), cumsum(c(0, (diff(x.pos.rainThresh.warm)-1) > rainOffLength[1]))) # before 1
x.pos.rainThresh.C.warm.filt <- x.pos.rainThresh.C.warm[which(do.call(op.rainOffLength, list(lengths(x.pos.rainThresh.C.warm), 1)))] # before rainOffLength[1]
x.pos.rainThresh.CLen.warm <- unlist(x.pos.rainThresh.C.warm.filt)
x.pos.rainThresh.index.warm <- pos.warm[x.pos.rainThresh.warm[x.pos.rainThresh.CLen.warm]]
x.pos.rainThresh.index.warm.list <- lapply(X = x.pos.rainThresh.C.warm.filt,
sub1 = pos.warm,
sub2 = x.pos.rainThresh.warm,
FUN = function(x, sub1, sub2){ sub1[sub2[x]] })
} else {
x.pos.rainThresh.index.warm <- NULL
x.pos.rainThresh.index.warm.list <- NULL
}
# cold
if(length(x.pos.rainThresh.cold) > 0)
{
x.pos.rainThresh.C.cold <- split(seq_along(along.with = x.pos.rainThresh.cold), cumsum(c(0, (diff(x.pos.rainThresh.cold)-1) > rainOffLength[2])))
x.pos.rainThresh.C.cold.filt <- x.pos.rainThresh.C.cold[which(do.call(op.rainOffLength, list(lengths(x.pos.rainThresh.C.cold), 1)))]
x.pos.rainThresh.CLen.cold <- unlist(x.pos.rainThresh.C.cold.filt)
x.pos.rainThresh.index.cold <- pos.cold[x.pos.rainThresh.cold[x.pos.rainThresh.CLen.cold]]
x.pos.rainThresh.index.cold.list <- lapply(X = x.pos.rainThresh.C.cold.filt,
sub1 = pos.cold,
sub2 = x.pos.rainThresh.cold,
FUN = function(x, sub1, sub2){ sub1[sub2[x]] })
} else {
x.pos.rainThresh.index.cold <- NULL
x.pos.rainThresh.index.cold.list <- NULL
}
x.pos.rainThresh.index <- sort(c(x.pos.rainThresh.index.warm, x.pos.rainThresh.index.cold))
x.pos.rainThresh.index.list.merge <- c(x.pos.rainThresh.index.warm.list, x.pos.rainThresh.index.cold.list)
x.pos.rainThresh.index.list.order <- order(sapply(x.pos.rainThresh.index.list.merge, '[[', 1))
x.pos.rainThresh.index.list <- x.pos.rainThresh.index.list.merge[x.pos.rainThresh.index.list.order]
} else {
## get consecutive positions under rainTreshold | lengths of event OP rainOffLength-Threshold
# ## get consecutive positions under rainTreshold | lengths of event OP rainOffLength-Threshold
x.pos.rainThresh.C <- split(seq_along(along.with = x.pos.rainThresh), cumsum(c(0, (diff(x.pos.rainThresh)-1) > rainOffLength)))
x.pos.rainThresh.C.filt <- x.pos.rainThresh.C[which(do.call(op.rainOffLength, list(lengths(x.pos.rainThresh.C), 1)))]
x.pos.rainThresh.CLen <- unlist(x.pos.rainThresh.C.filt)
x.pos.rainThresh.index <- x.pos.rainThresh[x.pos.rainThresh.CLen]
x.pos.rainThresh.index.list <- lapply(X = x.pos.rainThresh.C.filt,
sub1 = x.pos.rainThresh,
FUN = function(x, sub1){ sub1[x] })
}
return(list(index = x.pos.rainThresh.index, index_list = x.pos.rainThresh.index.list))
} # end of function findIsolatedRainEvent
#' findRainEvent
#'
#' This function return a list of rain events.
#'
#' @param x vector containing precipitation
#' @param x.pos.dryPeriods indices of x containing dry periods. Result of findRainFallPosition.
#' @return
#' list containing rain events as specific indices of x.
.findRainEvent <- function(x = x, x.pos.dryPeriods)
{
# browser()
# get rainy days from dry period
x.pos.rainEvent <- setdiff(seq_along(along.with = x), x.pos.dryPeriods)
# create consecutive number of rainy days
x.pos.rainEvent.Len <- split(seq_along(along.with = x.pos.rainEvent), cumsum(c(0, diff(x.pos.rainEvent) > 1)))
# get original index for rainy days
x.pos.rainEvent.index <- lapply(x.pos.rainEvent.Len, function(x, y){y[x]}, y = x.pos.rainEvent) # get original indices
return(x.pos.rainEvent.index)
}
raff-k/RainSlide documentation built on July 19, 2023, 6:26 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions event
Documented in event
#' @title Get rain event of a landslide
#'
#' @description This function calculates different precipitation characteristics for a specific time-series:
#' total precipitation, number of rainfall events, weighted mean intensity of rainfall events (normalized by MAP, RD or RDN),
#' cumulative critical event rainfall (normalized by MAP, RD or RDN), maximum rainfall during critical rainfall event,
#' duration of critical rainfall event, critical rainfall intensity (normalized by MAP, RD or RDN), rainfall at day of failure (start date),
#' rainfall intensity at day of failure (start date), maximum rainfall at day of failure (start date).
#'
#' @param x vector containing precipitation
#' @param dates vector containing dates. The length of dates must be similar to the length of x. Default: NULL
#' @param timesteps time period or length of observation. The rev(x) and rev(dates) are subsetted to this length according to date.of.failure if set. I.e. 24 for hourly or 1 for daily data. Default: NULL
#' @param date.of.failure date of failure. If set data is subsetted to this date. Must be of class "POSIXct" or "POSIXt". Default: NULL
#' @param sub.RainEvent examine potential sub-rain-events of critical rainfall event. Default: TRUE
#' @param all.RainEvent if TRUE, all rain events in data are extracted. By setting this option, no critical rain event metrics are computed. Default: FALSE
#' @param cumu.RainFall vector containing time intervals for cumulative rainfall. I.e. c(24, 48, 96) for 1, 2 and 4 days aggregation. Default: NULL
#' @param return.DataFrame only the rain events are returned as a data.frame. Default: TRUE
#' @param S1.rainThresh isolated rainfall measurements below this thresholds are removed in the first step. Default: 0.2
#' @param S3.rainThresh exclusion of irrelevant rainfall sub-events under and equal to this threshold (third step). Default: 1 (in mm)
#' @param S1.rainOffLength dry periods between isolated rain events in the first step. Default: c(3, 6) (hours). When dates is NULL, then the smallest values is used for separation.
#' @param S2.rainOffLength dry periods between rainfall sub-events in the second step. Default: c(6, 12) (hours). When dates is NULL, then the smallest values is used for separation.
#' @param S4.rainOffLength dry periods between rainfall sub-events in the second step. Default: c(48, 96) (hours). When dates is NULL, then the smallest values is used for separation.
#' @param RD average number of rainy days in a year, proxy for locate climate conditions. Default: NULL
#' @param MAP mean annual precipitation, the long-term yearly average precipitation, see CRU - climate research units for number. Default: NULL
#' @param RDN a climatic index that provides better description (or proxy) than the MAP for the occurrence of extreme storm events (Guzzetti et al. 2006: 247). Default: MAP/RD
#' @param index.month.warm.season month indices of the warm season. First element is start, and second element represents the end (all including). Only relevant when dates are set. Default: c(4, 10) (including April, including October)
#' @param force.limit Useful for standard output, if result is type list. Must be integer number of specific size. If result is smaller, than results gets filled with NA, otherwise cut to this size. Default: NULL
#'
#' @return
#' vector containing rainfall metrics (see description). If return.DataFrame is TRUE a data.frame is returned containing similar
#' rain metrics for all rain events.
#'
#'
#' @note
#' \itemize{
#' \item thresholds are oriented at hourly data
#' \item timesteps with precipitation equal 0 are included (see Melillo et al. 2015: 314)
#' \item Guzzetti, F., Peruccacci, S., Rossi, M., & Stark, C. P. (2007). Rainfall thresholds for the initiation of landslides in central and southern Europe. Meteorology and atmospheric physics, 98(3-4), 239-267.
#' \item Rossi, M., Luciani, S., Valigi, D., Kirschbaum, D., Brunetti, M. T., Peruccacci, S., & Guzzetti, F. (2017). Statistical approaches for the definition of landslide rainfall thresholds and their uncertainty using rain gauge and satellite data. Geomorphology, 285, 16-27.
#' \item Melillo, M., Brunetti, M. T., Peruccacci, S., Gariano, S. L., & Guzzetti, F. (2015). An algorithm for the objective reconstruction of rainfall events responsible for landslides. Landslides, 12(2), 311-320.
#' }
#'
#'
#' @keywords rainfall tresholds, rainfall event, landslide, rainfall metrics
#'
#'
#' @export
event <- function(x, dates = NULL, timesteps = NULL, date.of.failure = NULL, sub.RainEvent = TRUE, all.RainEvent = FALSE, cumu.RainFall = NULL, return.DataFrame = TRUE,
S1.rainThresh = 0.2, S3.rainThresh = 1, S1.rainOffLength = c(3, 6), S2.rainOffLength = c(6, 12), S4.rainOffLength = c(48, 96),
RD = NULL, MAP = NULL, RDN = MAP/RD, index.month.warm.season = c(4, 10), force.limit = NULL)
{
# # # # # # # # # CHECK POTENTIAL ERRORS # # # # # # # # #
if(all.RainEvent)
{
if(!is.null(timesteps) || !is.null(date.of.failure) || is.null(cumu.RainFall))
{
warnings('The function parameters "timesteps", "date.of.failure", and "cumu.RainFall" are set to NULL')
timesteps <- NULL
date.of.failure <- NULL
cumu.RainFall <- NULL
}
} # end of if all.RainEvent
if(!is.null(dates) && length(dates) != length(x))
{
stop('Length of "x" and "dates" must be identical')
}
if(length(index.month.warm.season) != 2 | max(index.month.warm.season) > 12 | min(index.month.warm.season) < 1)
{
stop('Function argument "index.month.warm.season" is wrongly defined')
}
# if(type != "daily" & type != "hourly")
# {
# stop('"type"must be either "daily" or "hourly"')
# }
if(S1.rainThresh < 0 | S3.rainThresh < 0)
{
stop('"rainThresh" must be a positive value')
}
if(length(S1.rainOffLength) > 2)
{
stop('"rainOffLength" should contain maximum 2 elements')
}
if(length(which(S1.rainOffLength < 0)) > 0 | length(which(S2.rainOffLength < 0)) > 0 | length(which(S4.rainOffLength < 0)) > 0)
{
stop('"rainOffLength" thresholds must contain positive numbers')
}
if((!is.null(RD) && RD == 0) | (!is.null(MAP) && MAP == 0))
{
stop('"RD" or "MAP" are nor allowed to be "0"')
}
if(!is.null(date.of.failure) && class(date.of.failure)[1] != "POSIXct" & class(date.of.failure)[1] != "POSIXt")
{
stop('Date of failure must be of class POSIXct or POSIXt')
}
if(!is.null(timesteps) && (length(timesteps) > 1 | timesteps[1] < 0 | length(x) < timesteps[1]))
{
stop('Something wrong in "timesteps". Only a single positive integer number is accepted, which is equal or smaller to "x"')
}
if(!is.null(cumu.RainFall) && (length(which(cumu.RainFall <= 0)) > 0 | max(cumu.RainFall) > length(x)))
{
stop('The calculation of cumulative rainfall should have at least have 1 time step intervall indicating by positive integer numbers.
In addition, the cumulative rainfall should not exceeded the length of the precipitation vector')
}
if(!is.null(force.limit) && class(force.limit) != "numeric")
{
stop('function parameter "force.limit" must be of class "numeric"')
}
# # # # # # # # # START ALGORITHM # # # # # # # # #
# reverse x, meaning that precipitation before event is at first position
x <- rev(x)
x.input <- x
# reverse dates
dates <- rev(dates)
## subset data to date of failure
if(!is.null(date.of.failure))
{
if(!is.null(dates))
{
# get subset indices
DoF.sub <- which(dates <= date.of.failure)
# subset dates
dates <- dates[DoF.sub]
# subset precipitation
x <- x[DoF.sub]
} else{
warning('date of failure is set, but no dates avaiable. Therefore, subsetting is skipped')
}
}
## subset data to timesteps
if(!is.null(timesteps))
{
if(timesteps > length(x))
{
stop("After subsetting data to the date of failure, there are more timesteps than data")
}
# subset precipitation
x <- x[1:timesteps]
# subset dates
if(!is.null(dates)){dates <- dates[1:timesteps]}
}
if(!is.null(cumu.RainFall) && any(timesteps < cumu.RainFall))
{
stop('The time intervall for cumulative rain fall exceeded timesteps')
}
## extract months of dates and extent dates
## align thresholds
if(!is.null(dates))
{
# get months of date
dates <- list(dates, as.numeric(format(dates, "%m")))
} else {
S1.rainOffLength <- min(S1.rainOffLength) # threshold of first step
S2.rainOffLength <- min(S2.rainOffLength) # threshold of second step
S4.rainOffLength <- min(S4.rainOffLength) # threshold of fourth step
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 1: Detection and exclusion of isolated rainfall measurements --------------------------
# ... find isolated rainfall (rainThresh must be fix to 0)
S1.isolRF <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0, 0), rainOffLength = S1.rainOffLength,
op.rainThresh = ">", op.rainOffLength = "<=",
index.month.warm.season = index.month.warm.season)
# ... set irrelevant rainfall depening on threshold to 0
x[S1.isolRF$index[which(x[S1.isolRF$index] <= S1.rainThresh)]] <- 0 # THRESHOLD MUST BE DEFINED!!!!!!
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 2: Identification of rainfall sub-events ----------------------------------------------
# S2.DryPeriods <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S2.rainOffLength,
# op.rainThresh = "==", op.rainOffLength = ">=",
# index.month.warm.season = index.month.warm.season)
# S2.RainEvents <- .findRainEvent(x = x, x.pos.dryPeriods = S2.DryPeriods)
S2.isolRF <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S2.rainOffLength,
op.rainThresh = ">", op.rainOffLength = ">=",
index.month.warm.season = index.month.warm.season)
# debugonce(.findRainEvent)
S2.RainEvents <- S2.isolRF$index_list
# ... sum of precipitation of sub-rain-events
S2.RE.sum <- sapply(X = S2.RainEvents, FUN = function(X, precip) {
sum(precip[X], na.rm = TRUE)
}, precip = x)
# ... duration of sub-rain-events
# S2.RE.dur <- sapply(X = S2.RainEvents, FUN = length) # DO WE NEED THIS?
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 3: Exclusion if irrelevant rainfall sub-events ----------------------------------------
S3.RainEvents <- S2.RainEvents[which(S2.RE.sum > S3.rainThresh)]
S3.RE.exclusion <- unlist(S2.RainEvents[which(S2.RE.sum <= S3.rainThresh)])
# ... set rainfall to 0
x[S3.RE.exclusion] <- 0
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 4/5: Identification of rainfall events --------------------------------------------------
# S4.DryPeriods <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S4.rainOffLength,
# op.rainThresh = "==", op.rainOffLength = ">=",
# index.month.warm.season = index.month.warm.season)
# S4.RainEvents <- .findRainEvent(x = x, x.pos.dryPeriods = S4.DryPeriods)
S4.isolRF <- .findRainFallPosition(x = x, dates = dates, rainThresh = c(0,0), rainOffLength = S4.rainOffLength,
op.rainThresh = ">", op.rainOffLength = ">=",
index.month.warm.season = index.month.warm.season)
# debugonce(.findRainEvent)
S4.RainEvents <- S4.isolRF$index_list
## ... get rainfall metrics
# general
precip.tot <- sum(x.input, na.rm = TRUE)
names(precip.tot) <- "sum_total"
res <- precip.tot
## ... check if there is precipitation in the data
if(precip.tot == 0)
{
flag.zero <- TRUE
} else {
flag.zero <- FALSE
}
# cumulative rainfall
if(!is.null(cumu.RainFall))
{
precip.cum <- sapply(X = cumu.RainFall, function(X, precip){sum(precip[1:X], na.rm = TRUE)}, precip = x)
names(precip.cum) <- paste0("sum_cumu_", cumu.RainFall)
res <- c(res, precip.cum)
}
if(all.RainEvent)
{
# all rain event data
cERM <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S4.RainEvents, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
# ... gsub s in names
names(cERM) <- gsub(pattern = "^(s)", replacement = "", x = names(cERM))
} else {
# critical rain event
cERM <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S4.RainEvents, modus = "main", RD = RD, MAP = MAP, RDN = RDN)
}
# merge
res <- c(res, cERM)
# fill infinitve values with NAs
if(flag.zero)
{
res[is.infinite(res)] <- NA
}
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Step 6: Rainfall measurements for events with landslides --------------------------------------------------
if(sub.RainEvent & !flag.zero)
{
if(all.RainEvent)
{
# ... find all sub events ------------------------------------
cERM.S6.SubEvents <- lapply(X = 1:length(S4.RainEvents), FUN = function(i, S4RE, S3RE, precip, dates, RD, MAP, RDN)
{
# ... get max and min index
# ... ... find nearest min index
S3RE.minIndices <- sapply(X = S3RE, FUN = min)
S4RE.minIndex.pos <- unname(which.min(abs(S3RE.minIndices - min(S4RE[[i]]))))
S4RE.minIndex <- min(S3RE[[S4RE.minIndex.pos]])
S4RE.maxIndex <- max(S4RE[[i]])
# ... check for sub-rainfall events
S6SRE.check.min <- sapply(X = S3RE, FUN = function(x, minIndex){min(x) >= minIndex}, minIndex = S4RE.minIndex)
S6SRE.check.max <- sapply(X = S3RE, FUN = function(x, maxIndex){max(x) <= maxIndex}, maxIndex = S4RE.maxIndex)
S6SE <- S3RE[which(S6SRE.check.min & S6SRE.check.max)]
if(length(S6SE) == 1 && identical(unname(unlist(S6SE)), S4RE[[i]])) return(NULL) # sub-event and event are identica
# aggregated events
if(length(S6SE) > 1){
S6SE.agg <- lapply(X = 1:(length(S6SE)-1), l = S6SE,
FUN = function(i, l){unlist(x = l[1:i], use.names = FALSE)})
} else {
S6SE.agg <- S6SE
}
# ... calculate rainfall metrics
cERM.sub <- .calcEventRainfallMetrics(x = precip, dates = dates, list.RainEvents = S6SE.agg, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
names(cERM.sub) <- paste0(names(cERM.sub), "_", stringr::str_pad(string = i, width = 2, side = "left", pad = "0")) # naming
return(cERM.sub)
}, S3RE = S3.RainEvents, S4RE = S4.RainEvents, precip = x, dates = dates, RD = RD, MAP = MAP, RDN = RDN)
res <- c(res, unlist(cERM.S6.SubEvents))
# ... flatten list
# S6.SubEvents.fl <- unlist(S6.SubEvents, recursive = FALSE)
# S6.SubEvents.Names <- gsub(pattern = "\\." , replacement = "_" , names(S6.SubEvents.fl))
# ... calculate sub-event rainfall metrics
# cERM.sub <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S6.SubEvents.fl, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
# ... rename items
# cERM.sub.NumNames <- paste0(paste0(c(1:length(S4.RainEvents)), "_"), unlist(sapply(X = 1:length(S6.SubEvents.LenName), FUN = function(x, n){rep(x, n[x])}, n = S6.SubEvents.LenName)))
} else {
## ... find sub-events of critical rainfall event
# get largest index of first rain event
S4.RainEvents.maxIndex <- max(S4.RainEvents[[1]])
# ... check for sub-rainfall events
S6.SubEvents.check <- sapply(X = S3.RainEvents, FUN = function(x, maxIndex){max(x) <= maxIndex}, maxIndex = S4.RainEvents.maxIndex)
S6.SubEvents <- S3.RainEvents[which(S6.SubEvents.check)]
# aggregated events
if(length(S6.SubEvents) > 1){
S6.SubEvents.agg <- lapply(X = 1:(length(S6.SubEvents)-1), l = S6.SubEvents,
FUN = function(i, l){unlist(x = l[1:i], use.names = FALSE)})
} else {
S6.SubEvents.agg <- S6.SubEvents
}
# if(length(S6.SubEvents) > 1) # > 1, because 1 would be similar to the critical rainfall event
# {
cERM.sub <- .calcEventRainfallMetrics(x = x, dates = dates, list.RainEvents = S6.SubEvents.agg, modus = "sub", RD = RD, MAP = MAP, RDN = RDN)
res <- c(res, cERM.sub)
# }
} # end of if(all.RainEvent)
} # end if sub.RainEvent
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
## Return data --------------------------------------------------------------------------------
if(return.DataFrame)
{
# if(sub.RainEvent && length(S6.SubEvents) > 1)
if(sub.RainEvent & !flag.zero)
{
if(all.RainEvent)
{
# ... remove of first two items: "sum_total", "RE_number", "RE_weightIntensity"
# remove items
res <- res[!names(res) %in% c("sum_total", "RE_number", "RE_weightIntensity",
"RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN")]
# ... get and remove number of sub-events
extr.sRENum.pos <- grep(pattern = "sRE_number_.", x = names(res)) # ... get positions
extr.sRENum <- res[extr.sRENum.pos] # ... get number of sub events
extr.sRENum.id <- as.numeric(gsub(pattern = "sRE_number_", replacement = "", x = names(extr.sRENum)))
res <- res[-extr.sRENum.pos] # remove this variable from results
extr.sREWeight.pos <- grep(pattern = "sRE_weightIntensity_.", x = names(res)) # ... get positions
extr.sREWeight <- res[extr.sREWeight.pos] # ... get number of sub events
res <- res[-extr.sREWeight.pos] # remove this variable from results
# ... ... create data.frame for weighted Intensity
sREWeight.ColName <- unique(gsub(pattern = "_[[:digit:]].*", replacement = "", x = names(extr.sREWeight)))
sREWeight.df <- data.frame(matrix(extr.sREWeight, ncol = length(sREWeight.ColName)))
colnames(sREWeight.df) <- sREWeight.ColName
# ... get start indices of sub-events
startSub <- grep(pattern = "sRE_sum_01.", x = names(res))[1]
# ... create main data frame
# ... ... names
res.df.main.ColName <- names(res)[1:(startSub-1)] # get names
res.df.main.ColName <- unique(gsub(pattern = "_[[:digit:]].*", replacement = "", x = res.df.main.ColName)) # adapt colnames
# ... ... data.frame
res.df.main <- data.frame(matrix(res[1:(startSub-1)], ncol = ((startSub-1)/length(S4.RainEvents))))
colnames(res.df.main) <- res.df.main.ColName # re-name columns
sRe.missing <- setdiff(1:nrow(res.df.main), extr.sRENum.id)
extr.sRENum_filled <- extr.sRENum
# fill up missing data
for(m in sort(sRe.missing))
{
extr.sRENum_filled <- R.utils::insert(x = extr.sRENum_filled,
ats = m,
values = 0) # add number of sub-events
sREWeight.df <- dplyr::add_row(sREWeight.df, sRE_weightIntensity = NA, .before = m)
}
res.df.main$sRE_number <- extr.sRENum_filled
res.df.main <- cbind(res.df.main,
sREWeight.df) # weightesIntensitiy data.frame
res.df.main$ID <- c(1:nrow(res.df.main))*100 # id for ordering later
# ... create sub data frame
# ... ... names
res.df.sub.ColName.all <- names(res)[startSub:length(res)] # get names
res.df.sub.ColName <- unique(gsub(pattern = "^s|_[[:digit:]].*", replacement = "", x = res.df.sub.ColName.all)) # adapt colnames
res.df.sub.ColName.order <- lapply(X = res.df.sub.ColName, FUN = function(x, all.n, startSub){
# return(grep(pattern = x, x = all.n) + startSub -1)
return(grep(pattern = paste0(x, "_[[:digit:]].*"), x = all.n) + startSub -1)
}, all.n = res.df.sub.ColName.all, startSub = startSub) %>% unlist(.)
# ... ... data.frame
res.df.sub <- data.frame(matrix(res[res.df.sub.ColName.order], ncol = ((startSub-1)/length(S4.RainEvents)))) # startSub:length(res)
colnames(res.df.sub) <- res.df.sub.ColName # re-name columns
# res.df.sub$ID <- unlist(sapply(X = 1:length(extr.sRENum), FUN = function(i, x){i*100 + seq(1:extr.sRENum[i])}, x = extr.sRENum)) # get ID variables
res.df.sub$ID <- unlist(mapply(i = extr.sRENum.id, j = extr.sRENum, FUN = function(i, j){i*100 + seq(1:j)}, SIMPLIFY = FALSE, USE.NAMES = FALSE))
# ... row-bind data frames
res.df <- dplyr::bind_rows(res.df.main, res.df.sub)
# re-order data.frame based on ID
res.df <- res.df[with(res.df, order(ID)), ]
row.names(res.df)[which(!is.na(res.df$sRE_number))] <- paste0("RE_", res.df[which(!is.na(res.df$sRE_number)), ]$ID)
row.names(res.df)[which(is.na(res.df$sRE_number))] <- paste0("sRE_", res.df[which(is.na(res.df$sRE_number)), ]$ID)
# ... finally remove ID
res.df$ID <- NULL
} else {
# get main event items
items <- c("sRE_number", "sRE_weightIntensity", "sRE_weightIntensity_MAP", "sRE_weightIntensity_RD", "sRE_weightIntensity_RDN",
"sum_total", names(res)[grep(pattern = "sum_cumu", names(res))], "RE_total",
"RE_number", "RE_weightIntensity", "RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN")
# remove items
res.df <- res[!names(res) %in% items]
# rename
names(res.df) <- substring(names(res.df), 2)
## create data frame
startSub <- which(names(res.df) == "RE_sum_01") # RE_sum_1 * changed 20-02-12
res.colNames <- names(res.df)[1: (startSub-1)]
# ... create first main then sub data.frame
res.df.main <- data.frame(matrix(res.df[1:(startSub-1)], ncol = length(c(1:(startSub-1)))))
res.df.sub <- data.frame(matrix(res.df[startSub:length(res.df)], ncol = length(c(1:(startSub-1)))))
# ... combine both data.frames
if(length(S6.SubEvents.agg) >= 1) # if there is a sub-event?
{
res.df <- rbind(res.df.main, res.df.sub)
} else {
res.df <- res.df.main
}
# ... set names
colnames(res.df) <- res.colNames
# ... set items to data frame
items.res <- res[which(names(res) %in% items)]
items.res <- items.res[items[which(items %in% names(res))]] # just re-ordering
# ... create empty data.frame and add values
items.df <- data.frame(matrix(NA, nrow = nrow(res.df), ncol = length(items.res)))
items.df[1, ] <- items.res
colnames(items.df) <- names(items.res)
# ... add new columns to result
res.df <- cbind(res.df, items.df)
if(length(S6.SubEvents.agg) >= 1) # if there is only 1 sub-event?
{
rownames(res.df) <- c("cRE", paste0("sRE", c(1:length(S6.SubEvents.agg))))
} else {
rownames(res.df) <- "cRE"
}
} # end of if all.RainEvent
} else {
if(all.RainEvent)
{
# ... remove of first two items: "sum_total", "RE_number"
# remove items
res <- res[!names(res) %in% c("sum_total", "RE_number", "RE_weightIntensity",
"RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN")]
# get colnames
res.df.ColName <- unique(gsub(pattern = "_[[:digit:]].*", replacement = "", x = names(res))) # adapt colnames
# ... ... data.frame
res.df <- data.frame(matrix(res, ncol = length(res.df.ColName)))
colnames(res.df) <- res.df.ColName # re-name columns
rownames(res.df) <- paste0("RE", seq(100, 100*nrow(res.df), 100))
} else {
# re-order vector
items.fst <- which(names(res) == "cRE_sum")
res <- res[c(items.fst:length(res), 1:(items.fst-1))]
res.df <- data.frame(matrix(data = res, ncol = length(res)))
names(res.df) <- gsub(pattern = "^(c)", replacement = "", x = names(res))
} # end of if a..RainEvent
} # end of if-else: sub.RainEvent & length(S6.SubEvents) > 1
# modified data.frame output
return(res.df)
} else {
# ... standard vector output -------------------
if(!is.null(force.limit))
{
force.limit <- round(force.limit)
res.names <- names(res)
if(length(res) < force.limit)
{
res <- c(res, rep(NA, (force.limit - length(res)))) # fill result
res.names <- c(res.names, rep("NULL DATA", (force.limit - length(res))))
names(res) <- res.names
} else{
res <- res[1:force.limit] # clip result
names(res) <- res.names[1:force.limit]
}
} # end of force.limit
return(res)
}
} # end of function event()
#' calcEventRainfallMetrics
#'
#' This function calcuates different precipitation metrics.
#'
#' @param x vector containing precipitation
#' @param dates see CTRL()
#' @param list.RainEvents list containing indices of rain events
#' @param modus modus of calculation of rain metrics. "sub" of sub-rainfall events or "main" for critical rainfall event
#' @param RD see CTRL()
#' @param MAP see CTRL()
#' @param RDN see CTRL()
#' @return
#' vector containing rainfall metrics
.calcEventRainfallMetrics <- function(x, dates, list.RainEvents, modus, RD = RD, MAP = MAP, RDN = RDN)
{
## cumulative rainfall
# total sum of precipitation of each rain event
RE.sum <- sapply(X = list.RainEvents, FUN = function(X, precip) {
sum(precip[X], na.rm = TRUE)
}, precip = x)
# maximum of precipitation of each rain event
RE.max <- sapply(X = list.RainEvents, FUN = function(X, precip) {
max(precip[X], na.rm = TRUE)
}, precip = x)
## duration of rain events
RE.durRain <- sapply(X = list.RainEvents, FUN = length) # actual rainy elements
RE.dur <- sapply(X = list.RainEvents, FUN = function(x) max(x)-min(x)+1) # entire period
## number of rain events
rainEvent.nb <- length(list.RainEvents)
### ... MAIN rainfall metrics
if(modus == "main")
{
## naming of variables
names(rainEvent.nb) <- "RE_number"
## overall sum of rain events
RE.tot <- sum(RE.sum)
names(RE.tot) <- "RE_total"
# normalizations
if(!is.null(MAP)){RE.sum.MAP <- RE.sum/MAP}
if(!is.null(RD)){RE.sum.RD <- RE.sum/RD}
if(!is.null(MAP) & !is.null(RD)){RE.sum.RDN <- RE.sum/RDN}
## weighted mean intensity of rain events
RE.wID <- stats::weighted.mean(x = RE.sum/RE.dur, w = RE.dur, na.rm = TRUE)
names(RE.wID) <- "RE_weightIntensity"
# normalizations
if(!is.null(MAP)){RE.wID.MAP <- RE.wID/MAP; names(RE.wID.MAP) <- "RE_weightIntensity_MAP"}
if(!is.null(RD)){RE.wID.RD <- RE.wID/RD; names(RE.wID.RD) <- "RE_weightIntensity_RD"}
if(!is.null(MAP) & !is.null(RD)){RE.wID.RDN <- RE.wID/RDN; names(RE.wID.RDN) <- "RE_weightIntensity_RDN"}
## critical rainfall event
# critical event rainfall
cRE.sum <- RE.sum[[1]]
names(cRE.sum) <- "cRE_sum"
# normalizations
if(!is.null(MAP)){cRE.sum.MAP <- RE.sum.MAP[[1]]; names(cRE.sum.MAP) <- "cRE_sum_MAP"}
if(!is.null(RD)){cRE.sum.RD <- RE.sum.RD[[1]]; names(cRE.sum.RD) <- "cRE_sum_RD"}
if(!is.null(MAP) & !is.null(RD)){cRE.sum.RDN <- RE.sum.RDN[[1]]; names(cRE.sum.RDN) <- "cRE_sum_RDN"}
## critical maximal event rainfall
cRE.max <- RE.max[[1]]
names(cRE.max) <- "cRE_max"
## critical event rainfall duration
cRE.dur <- RE.dur[[1]]
names(cRE.dur) <- "cRE_dur"
## critical event rainfall duration for only rainy days (Rain)
cRE.durRain <- RE.durRain[[1]]
names(cRE.durRain) <- "cRE_dur_Rain"
## critical event rainfall intensity
cRE.ID <- cRE.sum/cRE.dur
names(cRE.ID) <- "cRE_Intensity"
## critical event rainfall intensity
cRE.ID.Rain <- cRE.sum/cRE.durRain
names(cRE.ID.Rain) <- "cRE_Intensity_Rain"
# normalizations
if(!is.null(MAP)){cRE.ID.MAP <- cRE.sum.MAP/cRE.dur; names(cRE.ID.MAP) <- "cRE_Intensity_MAP"}
if(!is.null(RD)){cRE.ID.RD <- cRE.sum.RD/cRE.dur; names(cRE.ID.RD) <- "cRE_Intensity_RD"}
if(!is.null(MAP) & !is.null(RD)){cRE.ID.RDN <- cRE.sum.RDN/cRE.dur; names(cRE.ID.RDN) <- "cRE_Intensity_RDN"}
## get range of rain event
# cRE.range <- paste0(range(list.RainEvents[[1]], na.rm = TRUE), collapse = ":")
cRE.range <- range(list.RainEvents[[1]], na.rm = TRUE)
cRE.range.end <- min(cRE.range)
cRE.range.start <- max(cRE.range)
names(cRE.range.start) <- "cRE_range_start"
names(cRE.range.end) <- "cRE_range_end"
## get dates out of range of rain event
if(!is.null(dates))
{
cRE.date.start <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][cRE.range.start], "%Y-%m-%d-%H")))
names(cRE.date.start) <- "cRE_date_start"
# browser()
cRE.date.end <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][cRE.range.end], "%Y-%m-%d-%H")))
names(cRE.date.end) <- "cRE_date_end"
}
} # end of main rainfall metrics
### ... SUB rainfall metrics
if(modus == "sub")
{
## naming of variables
names(rainEvent.nb) <- "sRE_number"
names(RE.sum) <- paste0("sRE_sum_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
names(RE.max) <- paste0("sRE_max_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
names(RE.dur) <- paste0("sRE_dur_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
names(RE.durRain) <- paste0("sRE_dur_Rain_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
## rainfall intensity
RE.ID <- RE.sum/RE.dur
names(RE.ID) <- paste0("sRE_Intensity_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
## rainfall intensity (only rainy days)
RE.ID.Rain <- RE.sum/RE.durRain
names(RE.ID.Rain) <- paste0("sRE_Intensity_Rain_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
# normalizations c(rainEvent.nb, RE.sum, RE.max, RE.dur, RE.ID)
if(!is.null(MAP))
{
RE.sum.MAP <- RE.sum/MAP
names(RE.sum.MAP) <- paste0("sRE_sum_MAP_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.ID.MAP <- RE.sum.MAP/RE.dur
names(RE.ID.MAP) <- paste0("sRE_Intensity_MAP_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
if(!is.null(RD))
{
RE.sum.RD <- RE.sum/RD
names(RE.sum.RD) <- paste0("sRE_sum_RN_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.ID.RD <- RE.sum.RD/RE.dur
names(RE.ID.RD) <- paste0("sRE_Intensity_RD_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
if(!is.null(MAP) & !is.null(RD))
{
RE.sum.RDN <- RE.sum/RDN
names(RE.sum.RDN) <- paste0("sRE_sum_RND_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0")) # c(1:rainEvent.nb))
RE.ID.RDN <- RE.sum.RDN/RE.dur
names(RE.ID.RDN) <- paste0("sRE_Intensity_RDN_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
## weighted mean intensity of sub rain events
RE.wID <- stats::weighted.mean(x = RE.sum/RE.dur, w = RE.dur, na.rm = TRUE)
names(RE.wID) <- "sRE_weightIntensity"
# normalizations
if(!is.null(MAP)){RE.wID.MAP <- RE.wID/MAP; names(RE.wID.MAP) <- "sRE_weightIntensity_MAP"}
if(!is.null(RD)){RE.wID.RD <- RE.wID/RD; names(RE.wID.RD) <- "sRE_weightIntensity_RD"}
if(!is.null(MAP) & !is.null(RD)){RE.wID.RDN <- RE.wID/RDN; names(RE.wID.RDN) <- "sRE_weightIntensity_RDN"}
## get range of rain events
# RE.range <- sapply(X = list.RainEvents, FUN = function(X) { paste0(range(x, na.rm = TRUE), collapse = ":")})
RE.range.start <- sapply(X = list.RainEvents, FUN = max, na.rm = TRUE)
names(RE.range.start ) <- paste0("sRE_range_start_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.range.end <- sapply(X = list.RainEvents, FUN = min, na.rm = TRUE)
names(RE.range.end) <- paste0("sRE_range_end_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
## get dates out of range of rain event
if(!is.null(dates))
{
RE.date.start <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][RE.range.start], "%Y-%m-%d-%H")))
# RE.date.start <- as.numeric(gsub("-|[[:space:]]", "", substring(dates[[1]][RE.range.start], 1, 13)))
names(RE.date.start) <- paste0("sRE_date_start_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
RE.date.end <- as.numeric(gsub("-|[[:space:]]", "", format(dates[[1]][RE.range.end], "%Y-%m-%d-%H")))
# RE.date.end <- as.numeric(gsub("-|[[:space:]]", "", substring(dates[[1]][RE.range.end], 1, 13)))
names(RE.date.end) <- paste0("sRE_date_end_", stringr::str_pad(string = c(1:rainEvent.nb), width = 2, side = "left", pad = "0"))
}
} # end of sub rainfall metrics
### ... return data
if(!is.null(MAP) & is.null(RD)){
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, RE.wID.MAP, cRE.sum, cRE.sum.MAP, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.ID.MAP, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "RE_weightIntensity_MAP", "cRE_sum", "cRE_sum_MAP", "cRE_max", "cRE_duration", cRE_duration_Rain", "cRE_Intensity", "cRE_Intensity_Rain", "cRE_Intensity_MAP", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.sum.MAP, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.ID.MAP, RE.wID, RE.wID.MAP, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_sum_MAP_", c(1:rainEvent.nb)),
# paste0("sRE_max_", c(1:rainEvent.nb)), paste0("sRE_dur_", c(1:rainEvent.nb)),
# paste0("sRE_Intensity_", c(1:rainEvent.nb)), paste0("sRE_Intensity_MAP_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} else if(!is.null(RD) & is.null(MAP)){
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, RE.wID.RD, cRE.sum, cRE.sum.RD, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.ID.RD, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "RE_weightIntensity_RD", "cRE_sum", "cRE_sum_RD", "cRE_max", "cRE_duration", "cRE_Intensity", "cRE_Intensity_RD", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.sum.RD, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.ID.RD, RE.wID, RE.wID.RD, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_sum_RD_", c(1:rainEvent.nb)),
# paste0("sRE_max_", c(1:rainEvent.nb)), paste0("sRE_dur_", c(1:rainEvent.nb)),
# paste0("sRE_Intensity_", c(1:rainEvent.nb)), paste0("sRE_Intensity_RD_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} else if(!is.null(RD) & !is.null(MAP)){
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, RE.wID.MAP, RE.wID.RD, RE.wID.RDN, cRE.sum, cRE.sum.MAP, cRE.sum.RD, cRE.sum.RDN, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.ID.MAP, cRE.ID.RD, cRE.ID.RDN, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "RE_weightIntensity_MAP", "RE_weightIntensity_RD", "RE_weightIntensity_RDN",
# "cRE_sum", "cRE_sum_MAP", "cRE_sum_RD", "cRE_sum_RDN", "cRE_max", "cRE_duration", "cRE_Intensity", "cRE_Intensity_MAP", "cRE_Intensity_RD", "cRE_Intensity_RDN", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.sum.MAP, RE.sum.RD, RE.sum.RDN, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.ID.MAP, RE.ID.RD, RE.ID.RDN, RE.wID, RE.wID.MAP, RE.wID.RD, RE.wID.RDN, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_sum_MAP_", c(1:rainEvent.nb)), paste0("sRE_sum_RD_", c(1:rainEvent.nb)), paste0("sRE_sum_RDN_", c(1:rainEvent.nb)),
# paste0("sRE_max_", c(1:rainEvent.nb)), paste0("sRE_dur_", c(1:rainEvent.nb)),
# paste0("sRE_Intensity_", c(1:rainEvent.nb)), paste0("sRE_Intensity_MAP_", c(1:rainEvent.nb)), paste0("sRE_Intensity_RD_", c(1:rainEvent.nb)), paste0("sRE_Intensity_RDN_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} else {
if(modus == "main")
{
res <- c(RE.tot, rainEvent.nb, RE.wID, cRE.sum, cRE.max, cRE.dur, cRE.durRain, cRE.ID, cRE.ID.Rain, cRE.range.start, cRE.range.end)
# names(res) <- c("RE_total", "RE_number", "RE_weightIntensity", "cRE_sum", "cRE_max", "cRE_duration", "cRE_Intensity", "cRE_range_start", "cRE_range_end")
if(!is.null(dates)){res <- c(res, cRE.date.start, cRE.date.end)}
}
if(modus == "sub")
{
res <- c(rainEvent.nb, RE.sum, RE.max, RE.dur, RE.durRain, RE.ID, RE.ID.Rain, RE.wID, RE.range.start, RE.range.end)
# names(res) <- c("sRE_number", paste0("sRE_sum_", c(1:rainEvent.nb)), paste0("sRE_max_", c(1:rainEvent.nb)),
# paste0("sRE_dur_", c(1:rainEvent.nb)), paste0("sRE_Intensity_", c(1:rainEvent.nb)),
# paste0("sRE_range_start_", c(1:rainEvent.nb)), paste0("sRE_range_end_", c(1:rainEvent.nb)))
if(!is.null(dates)){res <- c(res, RE.date.start, RE.date.end)}
#if(length(list.RainEvents) <= 1){names(res) <- gsub(pattern = "_1", replacement = "", names(res))}
}
} # end of if - else if - else statement
return(res)
} # end of calcEventRainfallMetrics
#' findRainFallPosition
#'
#' This function return indices of a specific selection.
#'
#' @param x vector containing precipitation
#' @param dates vector containing months of dates. The length of dates must be similar to the length of x
#' @param rainThresh list containing indices of rain events
#' @param rainOffLength modus of calculation of rain metrics. "sub" of sub-rainfall events or "main" for critical rainfall event
#' @param op.rainThresh operator for rain-threshold: x OP rainThresh
#' @param op.rainOffLength operator for rainOff-threshold: lengths of event OP rainOffLength-Threshold
#' @param index.month.warm.season index of month belonging to warm season
#' @return
#' vector containing indices of x corresponding to specific selection.
.findRainFallPosition <- function(x, dates, rainThresh, rainOffLength, op.rainThresh, op.rainOffLength,
index.month.warm.season)
{
## find position of rainfall under/over/equal to threshold | x OP rainThresh
if(!is.null(dates))
{
## find position of dates correpsonding to season
pos.warm <- which(dates[[2]] >= index.month.warm.season[1] & dates[[2]] <= index.month.warm.season[2])
pos.cold <- which(dates[[2]] < index.month.warm.season[1] | dates[[2]] > index.month.warm.season[2])
## thresholding x based on season and season threshold
x.pos.rainThresh.warm <- which(do.call(op.rainThresh, list(x[pos.warm], rainThresh[1])))
x.pos.rainThresh.cold <- which(do.call(op.rainThresh, list(x[pos.cold], rainThresh[2])))
# x.pos.rainThresh <- sort(c(pos.warm[x.pos.rainThresh.warm], pos.cold[x.pos.rainThresh.cold]))
} else {
x.pos.rainThresh <- which(do.call(op.rainThresh, list(x, rainThresh[1])))
}
if(!is.null(dates))
{
## thresholding x based on season and season threshold
# warm
if(length(x.pos.rainThresh.warm) > 0)
{
x.pos.rainThresh.C.warm <- split(seq_along(along.with = x.pos.rainThresh.warm), cumsum(c(0, (diff(x.pos.rainThresh.warm)-1) > rainOffLength[1]))) # before 1
x.pos.rainThresh.C.warm.filt <- x.pos.rainThresh.C.warm[which(do.call(op.rainOffLength, list(lengths(x.pos.rainThresh.C.warm), 1)))] # before rainOffLength[1]
x.pos.rainThresh.CLen.warm <- unlist(x.pos.rainThresh.C.warm.filt)
x.pos.rainThresh.index.warm <- pos.warm[x.pos.rainThresh.warm[x.pos.rainThresh.CLen.warm]]
x.pos.rainThresh.index.warm.list <- lapply(X = x.pos.rainThresh.C.warm.filt,
sub1 = pos.warm,
sub2 = x.pos.rainThresh.warm,
FUN = function(x, sub1, sub2){ sub1[sub2[x]] })
} else {
x.pos.rainThresh.index.warm <- NULL
x.pos.rainThresh.index.warm.list <- NULL
}
# cold
if(length(x.pos.rainThresh.cold) > 0)
{
x.pos.rainThresh.C.cold <- split(seq_along(along.with = x.pos.rainThresh.cold), cumsum(c(0, (diff(x.pos.rainThresh.cold)-1) > rainOffLength[2])))
x.pos.rainThresh.C.cold.filt <- x.pos.rainThresh.C.cold[which(do.call(op.rainOffLength, list(lengths(x.pos.rainThresh.C.cold), 1)))]
x.pos.rainThresh.CLen.cold <- unlist(x.pos.rainThresh.C.cold.filt)
x.pos.rainThresh.index.cold <- pos.cold[x.pos.rainThresh.cold[x.pos.rainThresh.CLen.cold]]
x.pos.rainThresh.index.cold.list <- lapply(X = x.pos.rainThresh.C.cold.filt,
sub1 = pos.cold,
sub2 = x.pos.rainThresh.cold,
FUN = function(x, sub1, sub2){ sub1[sub2[x]] })
} else {
x.pos.rainThresh.index.cold <- NULL
x.pos.rainThresh.index.cold.list <- NULL
}
x.pos.rainThresh.index <- sort(c(x.pos.rainThresh.index.warm, x.pos.rainThresh.index.cold))
x.pos.rainThresh.index.list.merge <- c(x.pos.rainThresh.index.warm.list, x.pos.rainThresh.index.cold.list)
x.pos.rainThresh.index.list.order <- order(sapply(x.pos.rainThresh.index.list.merge, '[[', 1))
x.pos.rainThresh.index.list <- x.pos.rainThresh.index.list.merge[x.pos.rainThresh.index.list.order]
} else {
## get consecutive positions under rainTreshold | lengths of event OP rainOffLength-Threshold
# ## get consecutive positions under rainTreshold | lengths of event OP rainOffLength-Threshold
x.pos.rainThresh.C <- split(seq_along(along.with = x.pos.rainThresh), cumsum(c(0, (diff(x.pos.rainThresh)-1) > rainOffLength)))
x.pos.rainThresh.C.filt <- x.pos.rainThresh.C[which(do.call(op.rainOffLength, list(lengths(x.pos.rainThresh.C), 1)))]
x.pos.rainThresh.CLen <- unlist(x.pos.rainThresh.C.filt)
x.pos.rainThresh.index <- x.pos.rainThresh[x.pos.rainThresh.CLen]
x.pos.rainThresh.index.list <- lapply(X = x.pos.rainThresh.C.filt,
sub1 = x.pos.rainThresh,
FUN = function(x, sub1){ sub1[x] })
}
return(list(index = x.pos.rainThresh.index, index_list = x.pos.rainThresh.index.list))
} # end of function findIsolatedRainEvent
#' findRainEvent
#'
#' This function return a list of rain events.
#'
#' @param x vector containing precipitation
#' @param x.pos.dryPeriods indices of x containing dry periods. Result of findRainFallPosition.
#' @return
#' list containing rain events as specific indices of x.
.findRainEvent <- function(x = x, x.pos.dryPeriods)
{
# browser()
# get rainy days from dry period
x.pos.rainEvent <- setdiff(seq_along(along.with = x), x.pos.dryPeriods)
# create consecutive number of rainy days
x.pos.rainEvent.Len <- split(seq_along(along.with = x.pos.rainEvent), cumsum(c(0, diff(x.pos.rainEvent) > 1)))
# get original index for rainy days
x.pos.rainEvent.index <- lapply(x.pos.rainEvent.Len, function(x, y){y[x]}, y = x.pos.rainEvent) # get original indices
return(x.pos.rainEvent.index)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.