gevdfit.R 22 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
#' 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.
36
37
#' @param theta_zero Logical value, indicating if theta parameter should be estimated (TRUE, the default) or
#' remain zero. 
38
39
40
41
42
#' @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. 
43
#' \item{nllh}{single numeric giving the negative log-likelihood value} 
44
45
#' \item{mle}{numeric vector giving the MLE's for the modified location, scale_0, shape, 
#' duration offset and duration exponent, resp.} 
46
#' \item{se}{numeric vector giving the standard errors for the MLE's (in the same order)}
47
48
49
50
51
52
53
#' \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.} 
54
55
56
#' \item{vals}{Parameter values for every data point.}
#' \item{init.vals}{Initial values that where used.}
#' \item{ds}{Durations for every data point.}
57
58
59
#' @seealso \code{\link{dgev.d}}, \code{\link{IDF.agg}}, \code{\link{gev.fit}}, \code{\link{optim}}
#' @export
#' @importFrom stats optim 
60
#' @importFrom stats make.link 
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
#' 
#' @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, 
78
79
           mulink = make.link("identity"), siglink = make.link("identity"), shlink = make.link("identity"),
           thetalink = make.link("identity"), etalink = make.link("identity"),  
80
           muinit = NULL, siginit = NULL, shinit = NULL, thetainit = NULL, etainit = NULL,
81
           show = TRUE, method = "Nelder-Mead", maxit = 10000, init.vals = NULL, theta_zero = FALSE, ...)
82
83
84
85
86
87
88
  {
    
    z <- list()
    # number of parameters (betas) to estimate for each parameter: 
    npmu <- length(mul) + 1
    npsc <- length(sigl) + 1
    npsh <- length(shl) + 1
89
    npth <- ifelse(!theta_zero,length(thetal) + 1,0)
90
91
    npet <- length(etal) + 1
    z$trans <- FALSE  # indicates if fit is non-stationary
92
93
94
    z$model <- list(mul, sigl, shl, thetal, etal)
    z$link <- list(mulink=mulink, siglink=siglink, shlink=shlink, thetalink=thetalink, etalink=etalink)
    
95
    
96
97
98
99
100
    # 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'.")
101
    
102
103
    # if no initial values where passed, calculate initial values for mu.d, sigma_0, xi, eta using IDF.init
    if(!is.null(init.vals)){
104
      if(length(init.vals)!=5){
105
106
107
108
109
110
111
        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])
        }
      }
112
    if(any(is.null(c(muinit,siginit,shinit,etainit)))& is.null(init.vals)){
Jana Ulrich's avatar
Jana Ulrich committed
113
      # message('Initial values are calculated.')
114
      init.vals <- gev.d.init(xdat,ds,z$link)
115
    }
Jana Ulrich's avatar
Jana Ulrich committed
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
    
    # 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))  
152
        thetainit <- init.vals$theta
153
154
155
156
    }else {
      z$trans <- TRUE
      thmat <- cbind(rep(1, length(xdat)), ydat[, thetal])
      if (is.null(thetainit))  
157
        thetainit <- c(init.vals$theta, rep(0, length(thetal)))
158
159
160
161
162
163
164
165
166
167
168
    }
    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)))
    }
169
170
171
172
173
174
    
    if(!theta_zero){#When theta parameter is included (default)
      init <- c(muinit, siginit, shinit, thetainit, etainit)
    }else{ #Do not return initial value for theta if user does not want theta, as Hessian will fail.
      init <- c(muinit, siginit, shinit, etainit)
    }
175
176
177
178
    
    # function to calculate neg log-likelihood:
    gev.lik <- function(a) {
      # computes neg log lik of d-gev model
179
180
181
      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)]))
182
183
      #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)]))}
184
      eta <- etalink$linkinv(etmat %*% (a[seq(npmu + npsc + npsh + npth + 1, length = npet)]))
185
      
186
      ifelse(!theta_zero, ds.t <- ds+theta, ds.t <- ds) #Don't use theta if user requested not to have it.
187
188
189
190
      sigma.d <- sigma/(ds.t^eta)
      y <- xdat/sigma.d - mu
      y <- 1 + xi * y
      
191
192
193
194
195
196
      if(!theta_zero){ #When user wants theta parameter (default)
        if(any(eta <= 0) || any(theta < 0) || any(sigma.d <= 0) || any(y <= 0)) return(10^6)
      }else{ #When user did not ask for theta parameter
        if(any(eta <= 0) || any(sigma.d <= 0) || any(y <= 0)) return(10^6)
      }
      
197
198
199
200
201
202
203
204
205
206
      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
207
208
209
    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)]))
210
211
212
213
214
    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
      theta <- thetalink$linkinv(thmat %*% (0))
    }
215
    eta <- etalink$linkinv(etmat %*% (x$par[seq(npmu + npsc + npsh + npth + 1, length = npet)]))
216
    z$nllh <- x$value
217
    # normalize data to standard Gumbel:
218
219
220
    sc.d <- sc0/((ds+theta)^eta)
    z$data <-  - log(as.vector((1 + xi * (xdat/sc.d-mut))^(-1/xi))) 
    z$mle <- x$par
221
    test <- try(              # catch error 
222
    z$cov <- solve(x$hessian) # invert hessian to get estimation on var-covar-matrix
223
224
225
226
227
    ,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))
        }
228
    z$se <- sqrt(diag(z$cov)) # sqrt(digonal entries) = standart error of mle's 
229
230
231
232
233
    if (!theta_zero) {#When theta parameter is returned (default)
      z$vals <- cbind(mut, sc0, xi, theta, eta)
    } else {#When theta parameter is not returned, asked by user
      z$vals <- cbind(mut, sc0, xi, eta)
    }
234
    z$init.vals <- as.numeric(init.vals)
235
236
237
238
239
    if(!theta_zero){ #When theta parameter is returned (default)
      colnames(z$vals) <-c('mut','sigma0','xi','theta','eta')
    } else { #When theta parameter is not returned, asked by user
      colnames(z$vals) <-c('mut','sigma0','xi','eta')
    }
240
    z$ds <- ds
241
    z$theta_zero <- theta_zero #Indicates if theta parameter was set to zero by user. 
242
243
    if(show) {
      if(z$trans) # for nonstationary fit
244
245
        print(z[c(2, 4)]) # print model, link (3) , conv 
      #TODO: print link function names
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
      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
272
#' @param link list of 5, link functions for parameters, created with \code{\link{make.link}}
273
274
#' @return list of initail values for mu_tilde, sigma_0, xi, eta
#' @importFrom stats lm 
275
#' @importFrom stats median 
276
277
278
#' @importFrom ismev gev.fit
#' @keywords internal 

279
gev.d.init <- function(xdat,ds,link){
280
281
282
  durs <- unique(ds)
  mles <- matrix(NA, nrow=length(durs), ncol= 3)
  for(i in 1:length(durs)){
283
284
    test <- try(fit <- 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}
285
  }
286
  if(all(is.na(mles))){stop('Initial values could not be computed for this dataset.')}
287
  # get values for sig0 and eta (also mu_0) from linear model in log-log scale
288
289
  lmsig <- lm(log(mles[,2])~log(durs))
  lmmu <- lm(log(mles[,1])~log(durs))
290
291
  
  # sig0 <- exp Intercept
292
  siginit <- link$siglink$linkfun(exp(lmsig$coefficients[[1]]))
293
  # eta <- mean of negativ slopes 
294
  etainit <- link$etalink$linkfun(median(c(-lmsig$coefficients[[2]],-lmmu$coefficients[[2]])))
295
296
  # mean of mu_d/sig_d 
  # could try:
297
  # mu0/sig0 = exp(lmmu$coefficients[[1]])/exp(lmsig$coefficients[[1]])
298
  muinit <- link$mulink$linkfun(median(c(mles[,1]/mles[,2]),na.rm = TRUE))
299
  # mean of shape parameters 
300
  shinit <- link$shlink$linkfun(median(mles[,3],na.rm = TRUE))
301
  thetainit <- link$thetalink$linkfun(0)
302
  
Jana Ulrich's avatar
Jana Ulrich committed
303
  return(list(mu=muinit,sigma=siginit,xi=shinit,theta=thetainit,eta=etainit))
304
305
}

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
#### 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
327
328
  if(any(! c(length(ds),length(mut),length(sig0),length(xi),length(theta),length(eta)) %in% 
         c(1,length(xdat)))){
329
330
331
332
333
334
335
336
337
338
    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))
}
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

#### 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
358
359
360
#' @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 
361
362
363
364
365
366
367
368
369
370
371
372
373
374
#'
#' @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
375
376
377
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',...){
378
  # check parameter:
Jana Ulrich's avatar
Jana Ulrich committed
379
  if(!is.element(which,c('both','pp','qq'))) stop("Parameter 'which'= ",which,
380
381
382
383
                                                 " 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
384
385
386
387
388
  # get single durations
  durs <- sort(unique(df$ds))
  # rescale durations to assign colors
  df$cval <- sapply(df$ds,function(d){which(durs==d)})

389
390
391
392
393
394
395
396
397
398
  # 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
399
  if(is.null(cols))cols <- rainbow(length(durs))
400
401
402
403
404
  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
405
406
407
           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
408
    if(legend){legend('bottomright',legend = round(durs,digits = 2),pch=pch,
Jana Ulrich's avatar
Jana Ulrich committed
409
                      col = cols[1:length(durs)],title = 'Durations',ncol = 2)}
410
411
412
413
  }
  if(which=='both'|which=='qq'){
    # qq
    plot( - log( - log(px)), df$data, ylab =
Jana Ulrich's avatar
Jana Ulrich committed
414
415
416
            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
417
    if(legend){legend('bottomright',legend = round(durs,digits = 2),pch=pch,
Jana Ulrich's avatar
Jana Ulrich committed
418
                      col = cols[1:length(durs)],title = 'Durations',ncol = 2)}
419
420
421
422
423
424
425
426
427
428
429
  }
  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
430
#' @param fit fit object returned by \code{gev.d.fit} or \code{gev.fit}
431
#' @param ydat A matrix containing the covariates in the same order as used in \code{gev.d.fit}.
432
#' @seealso \code{\link{dgev.d}}
433
#' @return data.frame containing mu_tilde, sigma0, xi, theta, eta (or mu, sigma, xi for gev.fit objects)
434
435
436
437
438
439
#' @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)
440
441
442
443
#' gev.d.params(fit = fit,ydat = cbind(c(0.9,1),c(0.5,1)))


gev.d.params <- function(fit,ydat){
444
445
  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.")
446
447
448
  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.")
  
449
450
451
452
  # number of parameters
  npmu <- length(fit$model[[1]]) + 1
  npsc <- length(fit$model[[2]]) + 1
  npsh <- length(fit$model[[3]]) + 1
453
454
  if(class(fit)=="gev.d.fit" & !fit$theta_zero){npth <- length(fit$model[[4]]) + 1} #Including theta parameter (default)
  if(class(fit)=="gev.d.fit" & fit$theta_zero){npth <- 0} #With no theta parameter, asked by user
455
  if(class(fit)=="gev.d.fit"){npet <- length(fit$model[[5]]) + 1}
456
  
457
  # inverse link functions
458
459
460
461
  if(class(fit)=="gev.d.fit"){
    mulink <- fit$link$mulink$linkinv
    siglink <- fit$link$siglink$linkinv
    shlink <- fit$link$shlink$linkinv
462
    if(!fit$theta_zero) thetalink <- fit$link$thetalink$linkinv
463
464
465
466
467
468
    etalink <- fit$link$etalink$linkinv
  }else{
    mulink <- eval(parse(text=fit$link))[[1]]
    siglink <- eval(parse(text=fit$link))[[2]]
    shlink <- eval(parse(text=fit$link))[[3]]
  }
469
  
470
471
472
473
  # 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))
474
  if(class(fit)=="gev.d.fit" & !fit$theta_zero){thmat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[4]]],dim(ydat)[1],npth-1))}
475
  if(class(fit)=="gev.d.fit"){etmat <- cbind(rep(1, dim(ydat)[1]), matrix(ydat[, fit$model[[5]]],dim(ydat)[1],npet-1))}
476
  
477
478
479
480
  # 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)]))
481
482
483
  if(class(fit)=="gev.d.fit" ){
    if(!fit$theta_zero){theta <- thetalink(thmat %*% (fit$mle[seq(npmu + npsc + npsh + 1, length = npth)]))
    }else{theta <- rep(0,dim(ydat)[1])}}
484
  if(class(fit)=="gev.d.fit"){eta <- etalink(etmat %*% (fit$mle[seq(npmu + npsc + npsh + npth + 1, length = npet)]))}
485
  
486
  if(class(fit)=="gev.d.fit"){
487
    return(data.frame(mut=mut,sig0=sc0,xi=xi,theta=theta,eta=eta))
488
  }else{return(data.frame(mu=mut,sig=sc0,xi=xi))}
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
}


#### 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