gevdfit.R 20 KB
Newer Older
1
2
3
# This file contains the functions:
# - gev.d.fit, gev.d.init for fitting
# - gev.d.diag for diagnostic plots
4
# - gev.d.params for calculation of parameters
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# and the documentation of the example data

#### gev.d.fit ####

#' @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 
#' value distribution, following Koutsoyiannis et al. (1988), including generalized linear 
#' modelling 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.
#' @param ydat A matrix of covariates for generalized linear modelling 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) 
#'  if the corresponding parameter is stationary).
#'  Parameters are: modified location, scale_0, shape, duration offset, duration exponent repectively.
24
25
26
27
28
29
#' @param mulink,siglink,shlink,thetalink,etalink Link functions for generalized linear 
#' modelling of the parameters, created with \code{\link{make.link}}.
#' @param muinit,siginit,shinit,thetainit,etainit Initial values as numeric of length 
#' equal to total number of parameters. Alternatively initial values for only the parameter intercepts 
#' can be passed to \code{init.vals}.
#' @param init.vals vector of length 5, giving initial values for parameter intercepts
30
31
32
33
34
35
36
37
38
39
40
#' used to model the parameters. If NULL (the default) is given, initial parameters are obtained 
#' internally by fitting the GEV seperately for each duration and applying a linear model to optain the 
#' duration dependency of the location and shape parameter.
#' @param show Logical; if TRUE (the default), print details of the fit.
#' @param method The optimization method used in \code{\link{optim}}.
#' @param maxit The maximum number of iterations.
#' @param ... Other control parameters for the optimization.
#' @return A list containing the following components. 
#' A subset of these components are printed after the fit. 
#' If show is TRUE, then assuming that successful convergence is indicated, 
#' the components nllh, mle and se are always printed. 
41
#' \item{nllh}{single numeric giving the negative log-likelihood value} 
42
43
#' \item{mle}{numeric vector giving the MLE's for the modified location, scale_0, shape, 
#' duration offset and duration exponent, resp.} 
44
#' \item{se}{numeric vector giving the standard errors for the MLE's (in the same order)}
45
46
47
48
49
50
51
#' \item{trans}{An logical indicator for a non-stationary fit.}
#' \item{model}{A list with components mul, sigl, shl, thetal and etal.}
#' \item{link}{A character vector giving inverse link functions.}
#' \item{conv}{The convergence code, taken from the list returned by \code{\link{optim}}. 
#' A zero indicates successful convergence.}
#' \item{data}{data is standardized to standart Gumbel.} 
#' \item{cov}{The covariance matrix.} 
52
53
54
#' \item{vals}{Parameter values for every data point.}
#' \item{init.vals}{Initial values that where used.}
#' \item{ds}{Durations for every data point.}
55
56
57
#' @seealso \code{\link{dgev.d}}, \code{\link{IDF.agg}}, \code{\link{gev.fit}}, \code{\link{optim}}
#' @export
#' @importFrom stats optim 
58
#' @importFrom stats make.link 
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
#' 
#' @examples 
#' # sampled random data from d-gev with covariates
#' # GEV parameters:
#' # mu = 4 + 0.2*cov1 +0.5*cov2
#' # sigma = 2+0.5*cov1
#' # xi = 0.5
#' # theta = 0
#' # eta = 0.5
#' 
#' data('example',package ='IDF')
#' 
#' gev.d.fit(xdat=example$dat,ds = example$d,ydat=as.matrix(example[,c('cov1','cov2')])
#' ,mul=c(1,2),sigl=1)

gev.d.fit<-
  function(xdat, ds, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL, thetal = NULL, etal = NULL, 
76
77
           mulink = make.link("identity"), siglink = make.link("identity"), shlink = make.link("identity"),
           thetalink = make.link("identity"), etalink = make.link("identity"),  
78
           muinit = NULL, siginit = NULL, shinit = NULL, thetainit = NULL, etainit = NULL,
79
           show = TRUE, method = "Nelder-Mead", maxit = 10000, init.vals = NULL, ...)
80
81
82
83
84
85
86
87
88
89
  {
    
    z <- list()
    # number of parameters (betas) to estimate for each parameter: 
    npmu <- length(mul) + 1
    npsc <- length(sigl) + 1
    npsh <- length(shl) + 1
    npth <- length(thetal) + 1
    npet <- length(etal) + 1
    z$trans <- FALSE  # indicates if fit is non-stationary
90
91
92
93
94
95
96
97
    z$model <- list(mul, sigl, shl, thetal, etal)
    z$link <- list(mulink=mulink, siglink=siglink, shlink=shlink, 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.')
    # test if covariates matrix is given correctly
    npar <- max(sapply(z$model,function(x){return(ifelse(is.null(x),0,max(x)))}))
    if(any(npar>ncol(ydat),npar>0 & is.null(ydat)))stop("Not enough columns in covariates-Matrix 'ydat'.")
98
    
99
100
101
102
103
104
105
106
107
108
    # if no initial values where passed, calculate initial values for mu.d, sigma_0, xi, eta using IDF.init
    if(!is.null(init.vals)){
      if(length(init.vals!=5)){
        warning('Parameter init.vals is not used, because it is not of length 5.')
        init.vals <- NULL
        }else{
        init.vals <- data.frame(mu = init.vals[1], sigma = init.vals[2], xi = init.vals[3]
                                                    ,theta = init.vals[4], eta = init.vals[5])
        }
      }
109
    if(any(is.null(c(muinit,siginit,shinit,etainit)))& is.null(init.vals)){
Jana Ulrich's avatar
Jana Ulrich committed
110
      # message('Initial values are calculated.')
111
      init.vals <- gev.d.init(xdat,ds,z$link)
112
    }
Jana Ulrich's avatar
Jana Ulrich committed
113
    
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
    
    # generate covariates matrices: 
    if (is.null(mul)) {
      mumat <- as.matrix(rep(1, length(xdat)))
      if (is.null(muinit)) 
        muinit <- init.vals$mu
    }else {
      z$trans <- TRUE
      mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
      if (is.null(muinit)) 
        muinit <- c(init.vals$mu, rep(0, length(mul)))
    }
    if (is.null(sigl)) {
      sigmat <- as.matrix(rep(1, length(xdat)))
      if (is.null(siginit)) 
        siginit <- init.vals$sigma
    }else {
      z$trans <- TRUE
      sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
      if (is.null(siginit)) 
        siginit <- c(init.vals$sigma, rep(0, length(sigl)))
    }
    if (is.null(shl)) {
      shmat <- as.matrix(rep(1, length(xdat)))
      if (is.null(shinit)) 
        shinit <- init.vals$xi 
    }else {
      z$trans <- TRUE
      shmat <- cbind(rep(1, length(xdat)), ydat[, shl])
      if (is.null(shinit)) 
        shinit <- c(init.vals$xi, rep(0, length(shl)))
    }
    if (is.null(thetal)) {
      thmat <- as.matrix(rep(1, length(xdat)))
      if (is.null(thetainit))  
        thetainit <- 0
    }else {
      z$trans <- TRUE
      thmat <- cbind(rep(1, length(xdat)), ydat[, thetal])
      if (is.null(thetainit))  
        thetainit <- c(0, rep(0, length(thetal)))
    }
    if (is.null(etal)) {
      etmat <- as.matrix(rep(1, length(xdat)))
      if (is.null(etainit)) 
        etainit <- init.vals$eta
    }else {
      z$trans <- TRUE
      etmat <- cbind(rep(1, length(xdat)), ydat[, etal])
      if (is.null(etainit)) 
        etainit <- c(init.vals$eta, rep(0, length(etal)))
    }
166

167
168
169
170
171
    init <- c(muinit, siginit, shinit, thetainit, etainit)
    
    # function to calculate neg log-likelihood:
    gev.lik <- function(a) {
      # computes neg log lik of d-gev model
172
173
174
175
176
      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)]))
      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)]))
177
178
179
180
181
182
      
      ds.t <- ds+theta
      sigma.d <- sigma/(ds.t^eta)
      y <- xdat/sigma.d - mu
      y <- 1 + xi * y
      
183
      if(any(eta <= 0) || any(theta < 0) || any(sigma.d <= 0) || any(y <= 0)) return(10^6)
184
185
186
187
188
189
190
191
192
193
      sum(log(sigma.d)) + sum(y^(-1/xi)) + sum(log(y) * (1/xi + 1))
    }
    
    
    # finding minimum of log-likelihood:
    x <- optim(init, gev.lik, hessian = TRUE, method = method,
               control = list(maxit = maxit, ...))
    
    # saving output parameters:
    z$conv <- x$convergence
194
195
196
197
198
    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)]))
    theta <- thetalink$linkinv(thmat %*% (x$par[seq(npmu + npsc + npsh + 1, length = npth)]))
    eta <- etalink$linkinv(etmat %*% (x$par[seq(npmu + npsc + npsh + npth + 1, length = npet)]))
199
200
201
202
203
    z$nllh <- x$value
    # normalize data to standart gumbel:
    sc.d <- sc0/((ds+theta)^eta)
    z$data <-  - log(as.vector((1 + xi * (xdat/sc.d-mut))^(-1/xi))) 
    z$mle <- x$par
204
    test <- try(              # catch error 
205
    z$cov <- solve(x$hessian) # invert hessian to get estimation on var-covar-matrix
206
207
208
209
210
    ,silent = TRUE )
    if("try-error" %in% class(test)){
      warning("Hessian could not be inverted. NAs were produced.")
      z$cov <- matrix(NA,length(z$mle),length(z$mle))
        }
211
212
    z$se <- sqrt(diag(z$cov)) # sqrt(digonal entries) = standart error of mle's 
    z$vals <- cbind(mut, sc0, xi, theta, eta)
213
    z$init.vals <- as.numeric(init.vals)
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
    colnames(z$vals) <- c('mut','sigma0','xi','theta','eta')
    z$ds <- ds
    if(show) {
      if(z$trans) # for nonstationary fit
        print(z[c(2, 3, 4)]) # print model, link, conv
      else print(z[4]) # for stationary fit print only conv
      if(!z$conv) # if fit converged 
        print(z[c(5, 7, 9)]) # print nll, mle, se
    }
    class( z) <- "gev.d.fit"
    invisible(z)
}


#### gev.d.init ####

# function to get initial values for gev.d.fit:
# obtain initial values 
# by fitting every duration seperately

# possible ways to improve:
# take given initial values into accout, if there are any
# xi -> mean vs. median ... how do we improve that?
# mu_tilde -> is not very good for small sample sizes yet
# improved inital value for eta, by fitting both mu~d and sigma~d in log-log scale

#' @title get initial values for gev.d.fit
#' @description obtain initial values by fitting every duration seperately
#' @param xdat vector of maxima for differnt durations
#' @param ds vector of durations belonging to maxima in xdat
#' @param thetainit initial parameter for theta
245
#' @param link list of 5, link functions for parameters, created with \code{\link{make.link}}
246
247
248
249
250
#' @return list of initail values for mu_tilde, sigma_0, xi, eta
#' @importFrom stats lm 
#' @importFrom ismev gev.fit
#' @keywords internal 

251
gev.d.init <- function(xdat,ds,link){
252
253
254
  durs <- unique(ds)
  mles <- matrix(NA, nrow=length(durs), ncol= 3)
  for(i in 1:length(durs)){
Jana Ulrich's avatar
Jana Ulrich committed
255
256
    test <- try(mles[i,] <- gev.fit(xdat[ds==durs[i]],show = FALSE)$mle,silent = TRUE)
    if("try-error" %in% class(test)){mles[i,] <- rep(NA,3)}
257
258
  }
  # get values for sig0 and eta (also mu_0) from linear model in log-log scale
259
260
  lmsig <- lm(log(mles[,2])~log(durs))
  lmmu <- lm(log(mles[,1])~log(durs))
261
262
  
  # sig0 <- exp Intercept
263
  siginit <- link$siglink$linkfun(exp(lmsig$coefficients[[1]]))
264
  # eta <- mean of negativ slopes 
265
  etainit <- link$etalink$linkfun(mean(c(-lmsig$coefficients[[2]],-lmmu$coefficients[[2]])))
266
267
  # mean of mu_d/sig_d 
  # could try:
268
269
  # mu0/sig0 = exp(lmmu$coefficients[[1]])/exp(lmsig$coefficients[[1]])
  muinit <- link$mulink$linkfun(mean(c(mles[,1]/mles[,2]),na.rm = TRUE))
270
  # mean of shape parameters 
271
272
  shinit <- link$shlink$linkfun(mean(mles[,3],na.rm = TRUE))
  thetainit <- link$thetalink$linkfun(0)
273
  
Jana Ulrich's avatar
Jana Ulrich committed
274
  return(list(mu=muinit,sigma=siginit,xi=shinit,theta=thetainit,eta=etainit))
275
276
}

277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
#### gev.d.nll ####
#' computes negative log-likelihood of d-gev model
#'
#' @param xdat numeric vector containing observations
#' @param ds numeric vector containing coresponding durations
#' @param mut,sig0,xi,theta,eta numeric vectors containing corresponding mles for each of the parameters
#'
#' @return single value containing negative log likelihood 
#' @export
#'
#' @examples
#' # compute nll of 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))!=length(xdat))){
    warning('Input vectors differ in length, but must have the same length.')
  }
  
  ds.t <- ds+theta
  sigma.d <- sig0/(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))
}
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327

#### gev.d.diag ####

#' Diagnostic Plots for d-gev Models
#'
#' @description  Produces diagnostic plots for d-gev models using 
#' the output of the function \code{\link{gev.d.fit}}. Values for different durations can be plotted in 
#' 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
#' 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
#' 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,
#' set to \code{c(1,1)}.
#' @param legend logical indicating if legends should be plotted
Jana Ulrich's avatar
Jana Ulrich committed
328
329
330
#' @param title character vector of length 2, giving the titles for the pp- and the qq-plot
#' @param emp.lab,mod.lab character string containing names for empirical and model axis
#' @param ... additional parameters passed on to the plotting function 
331
332
333
334
335
336
337
338
339
340
341
342
343
344
#'
#' @export
#' @importFrom graphics plot abline par title
#' @importFrom grDevices rainbow
#'
#' @examples
#' 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)
#' # diagnostic plots for complete data                
#' gev.d.diag(fit)    
#' # diagnostic plots for subset of data (e.g. one station)            
#' gev.d.diag(fit,subset = example$cov1==1)
Jana Ulrich's avatar
Jana Ulrich committed
345
346
347
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',...){
348
  # check parameter:
Jana Ulrich's avatar
Jana Ulrich committed
349
  if(!is.element(which,c('both','pp','qq'))) stop("Parameter 'which'= ",which,
350
351
352
353
                                                 " 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,]
Jana Ulrich's avatar
Jana Ulrich committed
354
355
356
357
358
  # get single durations
  durs <- sort(unique(df$ds))
  # rescale durations to assign colors
  df$cval <- sapply(df$ds,function(d){which(durs==d)})

359
360
361
362
363
364
365
366
367
368
  # sort data 
  df <- df[order(df$data),]
  
  # plotting position
  n <- length(df$data)
  px <- (1:n)/(n + 1)

  # create plots:
  if(which=='both') par(mfrow=mfrow) # 2 subplots
  # colors and symbols
Jana Ulrich's avatar
Jana Ulrich committed
369
  if(is.null(cols))cols <- rainbow(length(durs))
370
371
372
373
374
  if(is.null(pch))pch <- df$cval
  
  if(which=='both'|which=='pp'){
    # pp
    plot(px, exp( - exp( - df$data)), xlab =
Jana Ulrich's avatar
Jana Ulrich committed
375
376
377
           emp.lab, ylab = mod.lab,col=cols[df$cval],pch=pch,...)
    abline(0, 1, col = 1,lwd=1)
    title(title[1])
Jana Ulrich's avatar
Jana Ulrich committed
378
    if(legend){legend('bottomright',legend = round(durs,digits = 2),pch=pch,
Jana Ulrich's avatar
Jana Ulrich committed
379
                      col = cols[1:length(durs)],title = 'Durations',ncol = 2)}
380
381
382
383
  }
  if(which=='both'|which=='qq'){
    # qq
    plot( - log( - log(px)), df$data, ylab =
Jana Ulrich's avatar
Jana Ulrich committed
384
385
386
            emp.lab, xlab = mod.lab,col=cols[df$cval],pch=pch,...)
    abline(0, 1, col = 1,lwd=1)
    title(title[2])
Jana Ulrich's avatar
Jana Ulrich committed
387
    if(legend){legend('bottomright',legend = round(durs,digits = 2),pch=pch,
Jana Ulrich's avatar
Jana Ulrich committed
388
                      col = cols[1:length(durs)],title = 'Durations',ncol = 2)}
389
390
391
392
393
394
395
396
397
398
399
  }
  if(which=='both') par(mfrow=c(1,1)) # reset par
}

#### gev.d.params ####

#' 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
400
#' @param fit fit object returned by \code{gev.d.fit} or \code{gev.fit}
401
#' @param ydat A matrix containing the covariates in the same order as used in \code{gev.d.fit}.
402
#' @seealso \code{\link{dgev.d}}
403
#' @return data.frame containing mu_tilde, sigma0, xi, theta, eta (or mu, sigma, xi for gev.fit objects)
404
405
406
407
408
409
#' @export
#' 
#' @examples
#' data('example',package = 'IDF')
#' fit <- gev.d.fit(example$dat,example$d,ydat = as.matrix(example[,c("cov1","cov2")])
#'                  ,mul = c(1,2),sigl = 1)
410
411
412
413
#' gev.d.params(fit = fit,ydat = cbind(c(0.9,1),c(0.5,1)))


gev.d.params <- function(fit,ydat){
414
415
  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.")
416
417
418
  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.")
  
419
420
421
422
423
424
  # number of parameters
  npmu <- length(fit$model[[1]]) + 1
  npsc <- length(fit$model[[2]]) + 1
  npsh <- length(fit$model[[3]]) + 1
  if(class(fit)=="gev.d.fit"){npth <- length(fit$model[[4]]) + 1}
  if(class(fit)=="gev.d.fit"){npet <- length(fit$model[[5]]) + 1}
425
  
426
427
428
429
430
431
  # inverse link functions
  mulink <- fit$link$mulink$linkinv
  siglink <- fit$link$siglink$linkinv
  shlink <- fit$link$shlink$linkinv
  if(class(fit)=="gev.d.fit"){thetalink <- fit$link$thetalink$linkinv}
  if(class(fit)=="gev.d.fit"){etalink <- fit$link$etalink$linkinv}
432
  
433
434
435
436
437
438
  # covariates matrices
  mumat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[1]]],dim(ydat)[1],npmu-1))
  sigmat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[2]]],dim(ydat)[1],npsc-1))
  shmat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[3]]],dim(ydat)[1],npsh-1))
  if(class(fit)=="gev.d.fit"){thmat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[4]]],dim(ydat)[1],npth-1))}
  if(class(fit)=="gev.d.fit"){etmat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[5]]],dim(ydat)[1],npet-1))}
439
  
440
441
442
443
444
445
  # calculate parameters
  mut <- mulink(mumat %*% (fit$mle[1:npmu]))
  sc0 <- siglink(sigmat %*% (fit$mle[seq(npmu + 1, length = npsc)]))
  xi <- shlink(shmat %*% (fit$mle[seq(npmu + npsc + 1, length = npsh)]))
  if(class(fit)=="gev.d.fit"){theta <- thetalink(thmat %*% (fit$mle[seq(npmu + npsc + npsh + 1, length = npth)]))}
  if(class(fit)=="gev.d.fit"){eta <- etalink(etmat %*% (fit$mle[seq(npmu + npsc + npsh + npth + 1, length = npet)]))}
446
  
447
448
  if(class(fit)=="gev.d.fit"){return(data.frame(mut=mut,sig0=sc0,xi=xi,theta=theta,eta=eta))
  }else{return(data.frame(mu=mut,sig=sc0,xi=xi))}
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
}


#### example data ####

#' Sampled data for duration dependent GEV
#'
#' A dataset containing:
#' \itemize{
#'   \item \code{$xdat}: 'annual' maxima values
#'   \item \code{$ds}: corresponding durations
#'   \item \code{$cov1}, \code{$cov2}: covariates}
#' GEV parameters:
#' \itemize{
#'   \item mu = 4 + 0.2*cov1 +0.5*cov2
#'   \item sigma = 2+0.5*cov1
#'   \item xi = 0.5
#'   \item theta = 0
#'   \item eta = 0.5}
#'
#' @docType data
#' @keywords datasets
#' @name example
#' @usage data('example',package ='IDF')
NULL