Skip to content

GitLab

Commit 8271db2b authored by Jana Ulrich's avatar Jana Ulrich
Browse files

consistent parameter names, introduction examples

parent 047bc0d7
Hide whitespace changes
Inline Side-by-side
Showing with 252 additions and 133 deletions
NAMESPACE
View file @ 8271db2b
......@@ -5,7 +5,7 @@ export(IDF.plot)
export(dgev.d)
export(gev.d.diag)
export(gev.d.fit)
export(gev.d.nll)
export(gev.d.lik)
export(gev.d.params)
export(pgev.d)
export(qgev.d)
......
R/IDF.R
View file @ 8271db2b
......@@ -41,6 +41,43 @@
#' * Coles, S.An Introduction to Statistical Modeling of Extreme Values; Springer: New York, NY, USA, 2001,
#' https://doi.org/10.1198/tech.2002.s73
#' @md
#'
#' @examples
#' ## Here are a few examples to illustrate the order in which the functions are intended to be used.
#'
#' ## Step 0: sample 20 years of example hourly 'precipitation' data
# dates <- seq(as.POSIXct("2000-01-01 00:00:00"),as.POSIXct("2019-12-31 23:00:00"),by = 'hour')
# sample.precip <- rgamma(n = length(dates), shape = 0.05, rate = 0.4)
# precip.df <- data.frame(date=dates,RR=sample.precip)
#
# ## Step 1: get annual maxima
# durations <- 2^(0:6) # accumulation durations [h]
# ann.max <- IDF.agg(list(precip.df),ds=durations,na.accept = 0.1)
# # plotting the annual maxima in log-log representation
# plot(ann.max$ds,ann.max$xdat,log='xy',xlab = 'Duration [h]',ylab='Intensity [mm/h]')
#
# ## Step 2: fit d-GEV to annual maxima
# fit <- gev.d.fit(xdat = ann.max$xdat,ds = ann.max$ds,sigma0link = make.link('log'))
# # checking the fit
# gev.d.diag(fit,pch=1,legend = FALSE)
# # parameter estimates
# params <- gev.d.params(fit)
# print(params)
# # plotting the probability density for a single duration
# q.min <- floor(min(ann.max$xdat[ann.max$ds%in%1:2]))
# q.max <- ceiling(max(ann.max$xdat[ann.max$ds%in%1:2]))
# q <- seq(q.min,q.max,0.2)
# plot(range(q),c(0,0.55),type = 'n',xlab = 'Intensity [mm/h]',ylab = 'Density')
# for(d in 1:2){ # d=1h and d=2h
# hist(ann.max$xdat[ann.max$ds==d],main = paste('d=',d),q.min:q.max
# ,freq = FALSE,add=TRUE,border = d) # sampled data
# lines(q,dgev.d(q,params$mut,params$sigma0,params$xi,params$theta,params$eta,d = d),col=d) # etimated prob. density
# }
# legend('topright',col=1:2,lwd=1,legend = paste('d=',1:2,'h'),title = 'Duration')
#
# ## Step 3: adding the IDF-curves to the data
# plot(ann.max$ds,ann.max$xdat,log='xy',xlab = 'Duration [h]',ylab='Intensity [mm/h]')
# IDF.plot(durations,params,add=TRUE)
NULL
#### IDF.agg ####
......@@ -68,7 +105,8 @@ NULL
#' different durations, IDF.agg needs to be run separately for the different groups of stations.
#' Afterwards the results can be joint together using `rbind`.
#'
#' @return data.frame containing the annual intensity maxima [mm/h] in `$xdat`, the corresponding duration in `$ds`
#' @return data.frame containing the annual intensity maxima [mm/h] in `$xdat`, the corresponding duration in `$ds`,
#' the `$year` and month (`$mon`) in which the maxima occured
#' and the station id or name in `$station`.
#'
#' @seealso \code{\link{pgev.d}}
......@@ -82,13 +120,22 @@ NULL
#' dates <- as.Date("2019-01-01")+0:729
#' x <- rgamma(n = 730, shape = 0.4, rate = 0.5)
#' df <- data.frame(date=dates,RR=x)
#' IDF.agg(list(df),ds=c(24,48))
#'
#'## xdat ds station
#'## 1 0.3025660 24 1
#'## 2 0.4112304 24 1
#'## 3 0.1650978 48 1
#'## 4 0.2356849 48 1
#' # get annual maxima
#' IDF.agg(list('Sample'= df),ds=c(24,48),na.accept = 0.01)
#'
#' ## xdat ds year mon station
#' ## 0.2853811 24 2019 0:11 Sample
#' ## 0.5673122 24 2020 0:11 Sample
#' ## 0.1598448 48 2019 0:11 Sample
#' ## 0.3112713 48 2020 0:11 Sample
#'
#' # get monthly maxima for each month of june, july and august
#' IDF.agg(list('Sample'=df),ds=c(24,48),na.accept = 0.01,which.mon = list(5,6,7))
#'
#' # get maxima for time range from june to august
#' IDF.agg(list('Sample'=df),ds=c(24,48),na.accept = 0.01,which.mon = list(5:7))
#'
IDF.agg <- function(data,ds,na.accept = 0,
which.stations = NULL,which.mon = list(0:11),names = c('date','RR'),cl = NULL){
......@@ -121,6 +168,7 @@ NULL
max <- ifelse(n.na <= na.accept*length(vec),max(vec,na.rm = TRUE),NA)
return(max)})
df <- data.frame(xdat=max,ds=ds,year=as.numeric(names(max)),mon=deparse(which.mon[[m.i]]),
station= station,
stringsAsFactors = FALSE)
return(df)})
df <- do.call(rbind,max.subset)
......@@ -132,7 +180,7 @@ NULL
return(df) # maxima for all durations at one station
}
# which stations should be used?
if(is.null(which.stations))which.stations <- 1:length(data)
if(is.null(which.stations))which.stations <- if(is.null(names(data))){1:length(data)}else{names(data)}
# call function 2 in lapply to aggregate over all durations at all stations
station.list <- lapply(which.stations,agg.station)
......@@ -148,7 +196,7 @@ NULL
#' (modified location, scale offset, shape, duration offset, duration exponent) for chosen station
#' as obtained from \code{\link{gev.d.fit}}
#' (or \code{\link{gev.d.params}} for model with covariates).
#' @param probs vector of exeedance probabilities for which to plot IDF curves (p = 1-1/ReturnPeriod)
#' @param probs vector of non-exeedance probabilities for which to plot IDF curves (p = 1-1/(Return Period))
#' @param cols vector of colors for IDF curves. Should have same length as \code{probs}
#' @param add logical indicating if plot should be added to existing plot, default is FALSE
#' @param legend logical indicating if legend should be plotted (TRUE, the default)
......
R/d-gev.R
View file @ 8271db2b
......@@ -36,7 +36,7 @@
#' for(i in 2:4){
#' lines(x,dens[[i]],lty=i)
#' }
#' legend('topright',title = 'duration',legend = 1:4,lty=1:4)
#' legend('topright',title = 'Duration',legend = 1:4,lty=1:4)
dgev.d <- function(q,mut,sigma0,xi,theta,eta,d,...) {
if(any(c(length(mut),length(sigma0),length(xi),length(theta),length(eta))>1)){
message('One of the parameters mut, sigma0, xi, theta, eta is a vector. ',
......@@ -140,8 +140,8 @@ pgev.d <- function(q,mut,sigma0,xi,theta,eta,d,...) {
#' for(i in 2:3){
#' lines(ds,qs[i,],lty=i)
#' }
#' legend('topright',title = 'Annual frequency of exceedance',
#' legend = 1-p,lty=1:3,bty = 'n')
#' legend('topright',title = 'p-quantile',
#' legend = p,lty=1:3,bty = 'n')
qgev.d <- function(p,mut,sigma0,xi,theta,eta,d,...) {
if(any(c(length(mut),length(sigma0),length(xi),length(theta),length(eta))>1)){
message('One of the parameters mut, sigma0, xi, theta, eta is a vector. ',
......@@ -182,15 +182,17 @@ qgev.d <- function(p,mut,sigma0,xi,theta,eta,d,...) {
#'
#' @examples
#' # random sample for one duration
#' rgev.d(n=100,mut=4,sigma=2,xi=0,theta=0.1,eta=0.3,d=1)
#' rgev.d(n=100,mut=4,sigma0=2,xi=0,theta=0.1,eta=0.3,d=1)
#'
#' # compare randomn samples for different durations
#' ds <- c(1,4)
#' samp <- lapply(ds,rgev.d,n=100,mut=4,sigma0=2,xi=0,theta=0.1,eta=0.3)
#'
#' hist(samp[[1]],breaks = 10,col=rgb(1,0,0,0.5),freq = FALSE
#' ,ylim=c(0,0.3),xlab='x',main = 'd-GEV samples for two different durations')
#' ,ylim=c(0,0.3),xlim=c(3,20),xlab='x',main = 'Random d-GEV samples')
#' hist(samp[[2]],breaks = 10,add=TRUE,col=rgb(0,0,1,0.5),freq = FALSE)
#' legend('topright',fill = c(rgb(1,0,0,0.5),rgb(0,0,1,0.5)),
#' legend = paste('d=',1:2,'h'),title = 'Duration')
rgev.d <- function(n,mut,sigma0,xi,theta,eta,d) {
if(any(c(length(mut),length(sigma0),length(xi),length(theta),length(eta))>1)){
message('One of the parameters mut, sigma0, xi, theta, eta is a vector. ',
......
R/gevdfit.R
View file @ 8271db2b
......@@ -6,26 +6,26 @@
#### gev.d.fit ####
#' @title Maximum-likelihood Fitting of the duration dependent GEV Distribution
#' @title Maximum-likelihood Fitting of the duration-dependent GEV Distribution
#' @description Modified \code{\link[ismev]{gev.fit}} function for Maximum-likelihood fitting
#' for the duration dependent generalized extreme
#' for the duration-dependent generalized extreme
#' value distribution, following Koutsoyiannis et al. (1998), including generalized linear
#' modelling of each parameter.
#' modeling of each parameter.
#' @param xdat A vector containing maxima for different durations.
#' This can be obtained from \code{\link{IDF.agg}}.
#' @param ds A vector of aggregation levels corresponding to the maxima in xdat.
#' 1/60 corresponds to 1 minute, 1 corresponds to 1 hour.
#' @param ydat A matrix of covariates for generalized linear modelling of the parameters
#' @param ydat A matrix of covariates for generalized linear modeling of the parameters
#' (or NULL (the default) for stationary fitting). The number of rows should be the same as the
#' length of xdat.
#' @param mul,sigl,shl,thetal,etal Numeric vectors of integers, giving the columns of ydat that contain
#' covariates for generalized linear modelling of the parameters (or NULL (the default)
#' @param mutl,sigma0l,xil,thetal,etal Numeric vectors of integers, giving the columns of ydat that contain
#' covariates for generalized linear modeling of the parameters (or NULL (the default)
#' if the corresponding parameter is stationary).
#' Parameters are: modified location, scale_0, shape, duration offset, duration exponent repectively.
#' @param mulink,siglink,shlink,thetalink,etalink Link functions for generalized linear
#' modelling of the parameters, created with \code{\link{make.link}}.
#' Parameters are: modified location, scale offset, shape, duration offset, duration exponent, respectively.
#' @param mutlink,sigma0link,xilink,thetalink,etalink Link functions for generalized linear
#' modeling of the parameters, created with \code{\link{make.link}}. The default is \code{make.link("identity")}.
#' @param init.vals list of length 5, giving initial values for all or some parameters
#' (order: mu, sigma, xi, theta, eta). If as.list(rep(NA,5)) (the default) is given, initial parameters are obtained
#' (order: mut, sigma0, xi, theta, eta). If as.list(rep(NA,5)) (the default) is given, initial parameters are obtained
#' internally by fitting the GEV separately for each duration and applying a linear model to obtain the
#' duration dependency of the location and shape parameter.
#' Initial values for covariate parameters are assumed as 0 if not given.
......@@ -53,7 +53,8 @@
#' \item{vals}{Parameter values for every data point.}
#' \item{init.vals}{Initial values that were used.}
#' \item{ds}{Durations for every data point.}
#' @seealso \code{\link{dgev.d}}, \code{\link{IDF.agg}}, \code{\link{gev.fit}}, \code{\link{optim}}
#' @details For details on the d-GEV and the parameter definitions, see \link{IDF-package}.
#' @seealso \code{\link{IDF-package}}, \code{\link{IDF.agg}}, \code{\link{gev.fit}}, \code{\link{optim}}
#' @export
#' @importFrom stats optim
#' @importFrom stats make.link
......@@ -61,8 +62,8 @@
#' @examples
#' # sampled random data from d-gev with covariates
#' # GEV parameters:
#' # mu = 4 + 0.2*cov1 +0.5*cov2
#' # sigma = 2+0.5*cov1
#' # mut = 4 + 0.2*cov1 +0.5*cov2
#' # sigma0 = 2+0.5*cov1
#' # xi = 0.5
#' # theta = 0
#' # eta = 0.5
......@@ -73,8 +74,8 @@
#' ,mul=c(1,2),sigl=1)
gev.d.fit<-
function(xdat, ds, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL, thetal = NULL, etal = NULL,
mulink = make.link("identity"), siglink = make.link("identity"), shlink = make.link("identity"),
function(xdat, ds, ydat = NULL, mutl = NULL, sigma0l = NULL, xil = NULL, thetal = NULL, etal = NULL,
mutlink = make.link("identity"), sigma0link = make.link("identity"), xilink = make.link("identity"),
thetalink = make.link("identity"), etalink = make.link("identity"),
init.vals = as.list(rep(NA,5)), theta_zero = FALSE,
show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
......@@ -84,14 +85,14 @@ gev.d.fit<-
}
z <- list()
# number of parameters (betas) to estimate for each parameter:
npmu <- length(mul) + 1
npsc <- length(sigl) + 1
npsh <- length(shl) + 1
npmu <- length(mutl) + 1
npsc <- length(sigma0l) + 1
npsh <- length(xil) + 1
npth <- ifelse(!theta_zero,length(thetal) + 1,0)
npet <- length(etal) + 1
z$trans <- FALSE # indicates if fit is non-stationary
z$model <- list(mul, sigl, shl, thetal, etal)
z$link <- list(mulink=mulink, siglink=siglink, shlink=shlink, thetalink=thetalink, etalink=etalink)
z$model <- list(mutl, sigma0l, xil, thetal, etal)
z$link <- list(mutlink=mutlink, sigma0link=sigma0link, xilink=xilink, thetalink=thetalink, etalink=etalink)
# test for NA values:
if(any(is.na(xdat))) stop('xdat contains NA values. NA values need to be removed first.')
......@@ -122,29 +123,29 @@ gev.d.fit<-
}
# generate covariates matrices:
if (is.null(mul)) { #stationary
if (is.null(mutl)) { #stationary
mumat <- as.matrix(rep(1, length(xdat)))
muinit <- init.vals$mu
}else { #non stationary
z$trans <- TRUE
mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
muinit <- c(init.vals$mu, rep(0, length(mul)))[1:npmu] #fill with 0s to length npmu
mumat <- cbind(rep(1, length(xdat)), ydat[, mutl])
muinit <- c(init.vals$mu, rep(0, length(mutl)))[1:npmu] #fill with 0s to length npmu
}
if (is.null(sigl)) {
if (is.null(sigma0l)) {
sigmat <- as.matrix(rep(1, length(xdat)))
siginit <- init.vals$sigma
}else {
z$trans <- TRUE
sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
siginit <- c(init.vals$sigma, rep(0, length(sigl)))[1:npsc]
sigmat <- cbind(rep(1, length(xdat)), ydat[, sigma0l])
siginit <- c(init.vals$sigma, rep(0, length(sigma0l)))[1:npsc]
}
if (is.null(shl)) {
if (is.null(xil)) {
shmat <- as.matrix(rep(1, length(xdat)))
shinit <- init.vals$xi
}else {
z$trans <- TRUE
shmat <- cbind(rep(1, length(xdat)), ydat[, shl])
shinit <- c(init.vals$xi, rep(0, length(shl)))[1:npsh]
shmat <- cbind(rep(1, length(xdat)), ydat[, xil])
shinit <- c(init.vals$xi, rep(0, length(xil)))[1:npsh]
}
if (is.null(thetal)) {
thmat <- as.matrix(rep(1, length(xdat)))
......@@ -174,9 +175,9 @@ gev.d.fit<-
# function to calculate neg log-likelihood:
gev.lik <- function(a) {
# computes neg log lik of d-gev model
mu <- mulink$linkinv(mumat %*% (a[1:npmu]))
sigma <- siglink$linkinv(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
xi <- shlink$linkinv(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
mu <- mutlink$linkinv(mumat %*% (a[1:npmu]))
sigma <- sigma0link$linkinv(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
xi <- xilink$linkinv(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
# Next line will set the theta likelihood as non-existent in case user requested it.
if(!theta_zero) {theta <- thetalink$linkinv(thmat %*% (a[seq(npmu + npsc + npsh + 1, length = npth)]))}
eta <- etalink$linkinv(etmat %*% (a[seq(npmu + npsc + npsh + npth + 1, length = npet)]))
......@@ -202,9 +203,9 @@ gev.d.fit<-
# saving output parameters:
z$conv <- x$convergence
mut <- mulink$linkinv(mumat %*% (x$par[1:npmu]))
sc0 <- siglink$linkinv(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
xi <- shlink$linkinv(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)]))
mut <- mutlink$linkinv(mumat %*% (x$par[1:npmu]))
sc0 <- sigma0link$linkinv(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
xi <- xilink$linkinv(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)]))
if(!theta_zero){ #When user does NOT set theta parameter to zero (default)
theta <- thetalink$linkinv(thmat %*% (x$par[seq(npmu + npsc + npsh + 1, length = npth)]))
}else{ #When user requests theta_parameter to be zero
......@@ -242,7 +243,7 @@ gev.d.fit<-
print(z[c(2, 4)]) # print model, link (3) , conv
# print names of link functions:
cat('$link\n')
print(c(z$link$mulink$name,z$link$siglink$name,z$link$shlink$name,z$link$thetalink$name,z$link$etalink$name))
print(c(z$link$mutlink$name,z$link$sigma0link$name,z$link$xilink$name,z$link$thetalink$name,z$link$etalink$name))
cat('\n')
}else{print(z[4])} # for stationary fit print only conv
if(!z$conv){ # if fit converged
......@@ -281,7 +282,7 @@ gev.d.init <- function(xdat,ds,link){
durs <- unique(ds)
mles <- matrix(NA, nrow=length(durs), ncol= 3)
for(i in 1:length(durs)){
test <- try(fit <- gev.fit(xdat[ds==durs[i]],show = FALSE),silent = TRUE)
test <- try(fit <- ismev::gev.fit(xdat[ds==durs[i]],show = FALSE),silent = TRUE)
if("try-error" %in% class(test) | fit$conv!=0){mles[i,] <- rep(NA,3)}else{mles[i,] <- fit$mle}
}
if(all(is.na(mles))){stop('Initial values could not be computed for this dataset.')}
......@@ -290,52 +291,60 @@ gev.d.init <- function(xdat,ds,link){
lmmu <- lm(log(mles[,1])~log(durs))
# sig0 <- exp Intercept
siginit <- link$siglink$linkfun(exp(lmsig$coefficients[[1]]))
siginit <- link$sigma0link$linkfun(exp(lmsig$coefficients[[1]]))
# eta <- mean of negativ slopes
etainit <- link$etalink$linkfun(mean(c(-lmsig$coefficients[[2]],-lmmu$coefficients[[2]])))
# mean of mu_d/sig_d
# could try:
# mu0/sig0 = exp(lmmu$coefficients[[1]])/exp(lmsig$coefficients[[1]])
muinit <- link$mulink$linkfun(median(c(mles[,1]/mles[,2]),na.rm = TRUE))
muinit <- link$mutlink$linkfun(median(c(mles[,1]/mles[,2]),na.rm = TRUE))
# mean of shape parameters
shinit <- link$shlink$linkfun(median(mles[,3],na.rm = TRUE))
shinit <- link$xilink$linkfun(median(mles[,3],na.rm = TRUE))
thetainit <- link$thetalink$linkfun(0)
return(list(mu=muinit,sigma=siginit,xi=shinit,theta=thetainit,eta=etainit))
}
#### gev.d.nll ####
#' computes negative log-likelihood of d-gev model
#### gev.d.lik ####
#' d-GEV Likelihood
#'
#' Computes (log-) likelihood of d-GEV model
#' @param xdat numeric vector containing observations
#' @param ds numeric vector containing coresponding durations (1/60 corresponds to 1 minute, 1 corresponds to 1 hour)
#' @param mut,sig0,xi,theta,eta numeric vectors containing corresponding mles for each of the parameters
#' @param ds numeric vector containing corresponding durations (1/60 corresponds to 1 minute, 1 corresponds to 1 hour)
#' @param mut,sigma0,xi,theta,eta numeric vectors containing corresponding estimates for each of the parameters
#' @param log Logical; if TRUE, the log likelihood is returned.
#'
#' @return single value containing negative log likelihood
#' @return single value containing (log) likelihood
#' @export
#'
#' @examples
#' # compute nll of values not included in fit
#' # compute log-likelihood of observation values not included in fit
#' train.set <- example[example$d!=2,]
#' test.set <- example[example$d==2,]
#' fit <- gev.d.fit(train.set$dat,train.set$d,mul = c(1,2),sigl = 1
#' ,ydat = as.matrix(train.set[c('cov1','cov2')]))
#' params <- gev.d.params(fit,ydat = as.matrix(test.set[c('cov1','cov2')]))
#' gev.d.nll(xdat = test.set$dat,ds = test.set$d,mut = params[,1],sig0 = params[,2],xi = params[,3]
#' ,theta = params[,4],eta = params[,5])
gev.d.nll <- function(xdat,ds,mut,sig0,xi,theta,eta) {
# computes neg log lik of d-gev model
if(any(! c(length(ds),length(mut),length(sig0),length(xi),length(theta),length(eta)) %in%
#' gev.d.lik(xdat = test.set$dat,ds = test.set$d,mut = params[,1],sigma0 = params[,2],xi = params[,3]
#' ,theta = params[,4],eta = params[,5],log=TRUE)
gev.d.lik <- function(xdat,ds,mut,sigma0,xi,theta,eta,log=FALSE) {
if(any(xi==0)){stop('Function is not defined for shape parameter of zero.')}
if(any(! c(length(ds),length(mut),length(sigma0),length(xi),length(theta),length(eta)) %in%
c(1,length(xdat)))){
warning('Input vectors differ in length, but must have the same length.')
stop('Input vectors differ in length, but must have the same length.')
}
ds.t <- ds+theta
sigma.d <- sig0/(ds.t^eta)
sigma.d <- sigma0/(ds.t^eta)
y <- xdat/sigma.d - mut
y <- 1 + xi * y
sum(log(sigma.d)) + sum(y^(-1/xi)) + sum(log(y) * (1/xi + 1))
if(log){
return(sum(log(sigma.d) + y^(-1/xi) + log(y) * (1/xi + 1)))
}else{
return(prod(sigma.d * exp(y^(-1/xi)) * y ^ (1/xi + 1)))
}
}
#### gev.d.diag ####
......@@ -347,13 +356,13 @@ gev.d.nll <- function(xdat,ds,mut,sig0,xi,theta,eta) {
#' different colors of with different symbols.
#' @param fit object returned by \code{\link{gev.d.fit}}
#' @param subset an optional vector specifying a subset of observations to be used in the plot
#' @param cols optional either one value or vector of same length as \code{unique(durations)} to
#' @param cols optional either one value or vector of same length as \code{unique(fit$ds)} to
#' specify the colors of plotting points.
#' The default uses the \code{rainbow} function.
#' @param pch optional either one value or vector of same length as \code{unique(durations)} containing
#' @param pch optional either one value or vector of same length as \code{unique(fit$ds)} containing
#' integers or symbols to specify the plotting points.
#' @param which string containing 'both', 'pp' or 'qq' to specify, which plots should be produced.
#' @param mfrow vector specifying layout of plots. If both plots should be produced seperately,
#' @param mfrow vector specifying layout of plots. If both plots should be produced separately,
#' set to \code{c(1,1)}.
#' @param legend logical indicating if legends should be plotted
#' @param title character vector of length 2, giving the titles for the pp- and the qq-plot
......@@ -368,11 +377,11 @@ gev.d.nll <- function(xdat,ds,mut,sig0,xi,theta,eta) {
#' data('example',package ='IDF')
#'
#' fit <- gev.d.fit(xdat=example$dat,ds = example$d,ydat=as.matrix(example[,c('cov1','cov2')])
#' ,mul=c(1,2),sigl=1)
#' ,mutl=c(1,2),sigma0l=1)
#' # diagnostic plots for complete data
#' gev.d.diag(fit)
#' gev.d.diag(fit,pch=1)
#' # diagnostic plots for subset of data (e.g. one station)
#' gev.d.diag(fit,subset = example$cov1==1)
#' gev.d.diag(fit,subset = example$cov1==1,pch=1)
gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1,2),legend=TRUE,
title=c('Residual Probability Plot','Residual Quantile Plot'),
emp.lab='Empirical',mod.lab='Model',...){
......@@ -381,7 +390,11 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
" but only 'both','pp' or 'qq' are allowed.")
# subset data
df <- data.frame(data=fit$data,ds=fit$ds)
if(!is.null(subset))df <- df[subset,]
if(!is.null(subset)){
if(dim(df)[1]!=length(subset)){stop("Length of 'subset' does not match length of data
'xdat' used for fitting.")}
df <- df[subset,]
}
# get single durations
durs <- sort(unique(df$ds))
# rescale durations to assign colors
......@@ -407,7 +420,7 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
abline(0, 1, col = 1,lwd=1)
title(title[1])
if(legend){legend('bottomright',legend = round(durs,digits = 2),pch=pch,
col = cols[1:length(durs)],title = 'Durations[h]',ncol = 2)}
col = cols[1:length(durs)],title = 'Duration [h]',ncol = 2)}
}
if(which=='both'|which=='qq'){
# qq
......@@ -416,7 +429,7 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
abline(0, 1, col = 1,lwd=1)
title(title[2])
if(legend){legend('bottomright',legend = round(durs,digits = 2),pch=pch,
col = cols[1:length(durs)],title = 'Durations [h]',ncol = 2)}
col = cols[1:length(durs)],title = 'Duration [h]',ncol = 2)}
}
if(which=='both') par(mfrow=c(1,1)) # reset par
}
......@@ -426,11 +439,11 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
#' Calculate gev(d) parameters from \code{gev.d.fit} output
#'
#' @description function to calculate mut, sigma0, xi, theta, eta
#' (modified location, scale, shape, duration offset, duration exponent)
#' from results of \code{\link{gev.d.fit}} with covariates
#' @param fit fit object returned by \code{gev.d.fit} or \code{gev.fit}
#' (modified location, scale offset, shape, duration offset, duration exponent)
#' from results of \code{\link{gev.d.fit}} with covariates or link funktions other than identity.
#' @param fit fit object returned by \code{\link{gev.d.fit}} or \code{\link{gev.fit}}
#' @param ydat A matrix containing the covariates in the same order as used in \code{gev.d.fit}.
#' @seealso \code{\link{dgev.d}}
#' @seealso \code{\link{IDF-package}}
#' @return data.frame containing mu_tilde, sigma0, xi, theta, eta (or mu, sigma, xi for gev.fit objects)
#' @export
#'
......@@ -441,11 +454,14 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
#' gev.d.params(fit = fit,ydat = cbind(c(0.9,1),c(0.5,1)))
gev.d.params <- function(fit,ydat){
gev.d.params <- function(fit,ydat=NULL){
if(!class(fit)%in%c("gev.d.fit","gev.fit"))stop("'fit' must be an object returned by 'gev.d.fit' or 'gev.fit'.")
if(!is.matrix(ydat))stop("'ydat' must be of class matrix.")
n.par <- max(sapply(fit$model,function(x){return(ifelse(is.null(x),0,max(x)))}))
if(n.par>ncol(ydat))stop("Covariates-Matrix 'ydat' has ",ncol(ydat), " columns, but ", n.par," are required.")
if(fit$trans){
# check covariates matrix
if(!is.matrix(ydat))stop("'ydat' must be of class matrix.")
n.par <- max(sapply(fit$model,function(x){return(ifelse(is.null(x),0,max(x)))}))
if(n.par>ncol(ydat))stop("Covariates-Matrix 'ydat' has ",ncol(ydat), " columns, but ", n.par," are required.")
}else(ydat <- matrix(1))
# number of parameters
npmu <- length(fit$model[[1]]) + 1
......@@ -459,9 +475,9 @@ gev.d.params <- function(fit,ydat){
# inverse link functions
if(class(fit)=="gev.d.fit"){
mulink <- fit$link$mulink$linkinv
siglink <- fit$link$siglink$linkinv
shlink <- fit$link$shlink$linkinv
mulink <- fit$link$mutlink$linkinv
siglink <- fit$link$sigma0link$linkinv
shlink <- fit$link$xilink$linkinv
if(!fit$theta_zero) thetalink <- fit$link$thetalink$linkinv
etalink <- fit$link$etalink$linkinv
}else{
......@@ -489,7 +505,7 @@ gev.d.params <- function(fit,ydat){
if(class(fit)=="gev.d.fit"){eta <- etalink(etmat %*% (fit$mle[seq(npmu + npsc + npsh + npth + 1, length = npet)]))}
if(class(fit)=="gev.d.fit"){
return(data.frame(mut=mut,sig0=sc0,xi=xi,theta=theta,eta=eta))
return(data.frame(mut=mut,sigma0=sc0,xi=xi,theta=theta,eta=eta))
}else{return(data.frame(mu=mut,sig=sc0,xi=xi))}
}
......
man/IDF-package.Rd
View file @ 8271db2b
......@@ -30,6 +30,11 @@ generalized extreme value distribution (GEV) is provided by Coles (2001). It sho
the assumption that block maxima (of different durations or stations) are independent of each other.
}
}
\examples{
## Here are a few examples to illustrate the order in which the functions are intended to be used.
## Step 0: sample 20 years of example hourly 'precipitation' data
}
\references{
\itemize{
\item Ulrich, J.; Jurado, O.E.; Peter, M.; Scheibel, M.;
......
man/IDF.agg.Rd
View file @ 8271db2b
......@@ -36,7 +36,8 @@ containing names of elements in data. If not given, all elements in `data` will
\item{cl}{optional, number of cores to be used from \code{\link[pbapply]{pblapply}} for parallelization.}
}
\value{
data.frame containing the annual intensity maxima [mm/h] in `$xdat`, the corresponding duration in `$ds`
data.frame containing the annual intensity maxima [mm/h] in `$xdat`, the corresponding duration in `$ds`,
the `$year` and month (`$mon`) in which the maxima occured
and the station id or name in `$station`.
}
\description{
......@@ -53,13 +54,22 @@ Afterwards the results can be joint together using `rbind`.
dates <- as.Date("2019-01-01")+0:729
x <- rgamma(n = 730, shape = 0.4, rate = 0.5)
df <- data.frame(date=dates,RR=x)
IDF.agg(list(df),ds=c(24,48))
## xdat ds station
## 1 0.3025660 24 1
## 2 0.4112304 24 1
## 3 0.1650978 48 1
## 4 0.2356849 48 1
# get annual maxima
IDF.agg(list('Sample'= df),ds=c(24,48),na.accept = 0.01)
## xdat ds year mon station
## 0.2853811 24 2019 0:11 Sample
## 0.5673122 24 2020 0:11 Sample
## 0.1598448 48 2019 0:11 Sample
## 0.3112713 48 2020 0:11 Sample
# get monthly maxima for each month of june, july and august
IDF.agg(list('Sample'=df),ds=c(24,48),na.accept = 0.01,which.mon = list(5,6,7))
# get maxima for time range from june to august
IDF.agg(list('Sample'=df),ds=c(24,48),na.accept = 0.01,which.mon = list(5:7))
}
\seealso{
\code{\link{pgev.d}}
......
man/IDF.plot.Rd
View file @ 8271db2b
......@@ -22,7 +22,7 @@ IDF.plot(
as obtained from \code{\link{gev.d.fit}}
(or \code{\link{gev.d.params}} for model with covariates).}
\item{probs}{vector of exeedance probabilities for which to plot IDF curves (p = 1-1/ReturnPeriod)}
\item{probs}{vector of non-exeedance probabilities for which to plot IDF curves (p = 1-1/(Return Period))}
\item{cols}{vector of colors for IDF curves. Should have same length as \code{probs}}
......
man/dgev.d.Rd
View file @ 8271db2b
......@@ -43,7 +43,7 @@ plot(x,dens[[1]],type='l',ylim = c(0,0.21),ylab = 'Probability Density')
for(i in 2:4){
lines(x,dens[[i]],lty=i)
}
legend('topright',title = 'duration',legend = 1:4,lty=1:4)
legend('topright',title = 'Duration',legend = 1:4,lty=1:4)
}
\seealso{
\code{\link{pgev.d}}, \code{\link{qgev.d}}, \code{\link{rgev.d}}
......
man/gev.d.diag.Rd
View file @ 8271db2b
......@@ -23,16 +23,16 @@ gev.d.diag(
\item{subset}{an optional vector specifying a subset of observations to be used in the plot}
\item{cols}{optional either one value or vector of same length as \code{unique(durations)} to
\item{cols}{optional either one value or vector of same length as \code{unique(fit$ds)} to
specify the colors of plotting points.
The default uses the \code{rainbow} function.}