added function to transform data to standart gumbel -> gev.d2stgumbel

NAMESPACE

@@ -7,6 +7,7 @@ export(gev.d.diag)
 export(gev.d.fit)
 export(gev.d.params)
 export(gev.d.rl)
+export(gev.d2stdgumbel)
 export(pgev.d)
 export(qgev.d)
 export(rgev.d)

R/IDF.R

@@ -122,7 +122,7 @@ IDF.agg <- function(data,ds,na.accept = 0,
 #' 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)
-#' par <- gev.d.params(fit = fit, ydat = cbind(1,1))
+#' par <- gev.d.params(fit = fit, ydat = matrix(1,1,2))
 #' IDF.plot(data = example[example$cov1==1,c("dat","d")],fitparams = unlist(par),
 #'          calc.dur = 2^(0:5),ylim=c(1,75),st.name = 'Example')
 IDF.plot <- function(data,fitparams,probs=c(0.5,0.9,0.99),calc.dur=NULL,

R/gevdfit.R

@@ -167,7 +167,7 @@ gev.d.fit<-
     #####################################################################################
     # derivations of nll after d-gev-parameters (for boosting):
     
-    # get parameters from covariates and a (vector containing predictors)
+    # get parameters from covariates (and a vector containing predictors)
     # mu <- mulink(mumat %*% (a[1:npmu]))
     # sigma <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
     # xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
@@ -363,10 +363,10 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
 #' @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}
+#' @param fit fit object returned by \code{gev.d.fit} or \code{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}}
-#' @return data.frame containing mu_tilde, sigma0, xi, theta, eta
+#' @return data.frame containing mu_tilde, sigma0, xi, theta, eta (or mu, sigma, xi for gev.fit objects)
 #' @export
 #' 
 #' @examples
@@ -377,56 +377,45 @@ gev.d.diag <- function(fit,subset=NULL,cols=NULL,pch=NULL,which='both',mfrow=c(1
 
 
 gev.d.params <- function(fit,ydat){
-  if(!class(fit)=="gev.d.fit")stop("'fit' must be an object returned by 'gev.d.fit'.")
-  if(is.null(ncol(ydat)))stop("'ydat' must be have class matrix.")
+  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(!fit$trans){warning('No glm for parameters. Max. likelihood estimates are returned.')
+    return(fit$mle)}
+  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.")
   
-  mut <- fit$mle[1]
-  if(is.null(fit$model[[1]])){i <- 1}else{
-    for(i in 1:length(fit$model[[1]])){
-      cov <- fit$model[[1]][i]
-      mut <- mut + fit$mle[1+i]*ydat[,cov]
-    }
-    i <- i+1
-  }
+  #ydat <- rbind(0,ydat) # no error in case ncols=1
   
-  sig0 <- fit$mle[i+1]
-  if(is.null(fit$model[[2]])){j <- 1}else{
-    for(j in 1:length(fit$model[[2]])){
-      cov <- fit$model[[2]][j]
-      sig0 <- sig0 + fit$mle[1+i+j]*ydat[,cov]
-    }
-    j <- j+1
-  }
+  # 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}
   
-  xi <- fit$mle[i+j+1]
-  if(is.null(fit$model[[3]])){k <- 1}else{
-    for(k in 1:length(fit$model[[3]])){
-      cov <- fit$model[[3]][k]
-      xi <- xi + fit$mle[1+i+j+k]*ydat[,cov]
-    }
-    k <- k+1
-  }
+  # link functions
+  mulink <- eval(parse(text=fit$link))[[1]]
+  siglink <- eval(parse(text=fit$link))[[2]]
+  shlink <- eval(parse(text=fit$link))[[3]]
+  if(class(fit)=="gev.d.fit"){thetalink <- eval(parse(text=fit$link))[[4]]}
+  if(class(fit)=="gev.d.fit"){etalink <- eval(parse(text=fit$link))[[5]]}
   
-  theta <- fit$mle[i+j+k+1]
-  if(is.null(fit$model[[4]])){l <- 1}else{
-    for(l in 1:length(fit$model[[4]])){
-      cov <- fit$model[[4]][l]
-      theta <- theta + fit$mle[1+i+j+k+l]*ydat[,cov]
-    }
-    l <- l+1
-  }
+  # 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))}
   
-  eta <- fit$mle[i+j+k+l+1]
-  if(!is.null(fit$model[[5]])){
-    for(m in 1:length(fit$model[[5]])){
-      cov <- fit$model[[5]][m]
-      eta <- eta + fit$mle[1+i+j+k+l+m]*ydat[,cov]
-    }
-  }
+  # 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)]))}
   
-  return(data.frame(mut=mut,sig0=sig0,xi=xi,theta=theta,eta=eta))
+  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))}
 }
 
 
@@ -470,6 +459,42 @@ gev.d.rl <- function(params,p.d){
 }
 
 
+
+#### gev.d2stdgumbel ####
+
+#' Transform data to standart gumbel
+#'
+#' @param xdat A vector containing maxima for different durations.
+#' @param ds A vector of aggregation levels corresponding to the maxima in xdat.
+#' @param params list of parameters mu_tilde, sigma0, xi, theta, eta 
+#' as obtained from \code{\link{gev.d.params}}
+#'
+#' @return Vector containing transformed data.
+#' @export
+#'
+#' @examples 
+#' data('example',package = 'IDF')
+#' # fit subset
+#' ind <- sample(1:10, length(example$dat), replace=TRUE)
+#' fit.subs <- gev.d.fit(example$dat[ind!=1],example$d[ind!=1]
+#'                       ,ydat = as.matrix(example[ind!=1,c("cov1","cov2")])
+#'                       ,mul = c(1,2),sigl = 1)
+#' # calculate parameters for unfitted values
+#' par <- gev.d.params(fit = fit.subs
+#'                       ,ydat = as.matrix(example[ind==1,c("cov1","cov2")]))
+#' # transform unfitted values to standart gumbel
+#' sg.data <- gev.d2stdgumbel(xdat = example$dat[ind==1]
+#'                       ,ds = example$d[ind==1],params = par)
+#' # check unfitted values agains standart gumbel
+#' gev.d.diag(data.frame(data=sg.data,ds=example$d[ind==1]),pch=20)
+gev.d2stdgumbel <- function(xdat,ds,params){
+  sc.d <- params$sig0/((ds+params$theta)^params$eta)
+  sg.data <-  - log(as.vector((1 + params$xi * (xdat/sc.d-params$mut))^(-1/params$xi))) 
+  return(sg.data)
+}
+
+
+
 #### example data ####
 
 #' Sampled data for duration dependent GEV

man/IDF.plot.Rd

@@ -42,7 +42,7 @@ Plotting of IDF curves at a chosen station
 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)
-par <- gev.d.params(fit = fit, ydat = cbind(1,1))
+par <- gev.d.params(fit = fit, ydat = matrix(1,1,2))
 IDF.plot(data = example[example$cov1==1,c("dat","d")],fitparams = unlist(par),
          calc.dur = 2^(0:5),ylim=c(1,75),st.name = 'Example')
 }

man/gev.d.params.Rd

@@ -7,12 +7,12 @@
 gev.d.params(fit, ydat)
 }
 \arguments{
-\item{fit}{fit object returned by \code{gev.d.fit}}
+\item{fit}{fit object returned by \code{gev.d.fit} or \code{gev.fit}}
 
 \item{ydat}{A matrix containing the covariates in the same order as used in \code{gev.d.fit}.}
 }
 \value{
-data.frame containing mu_tilde, sigma0, xi, theta, eta
+data.frame containing mu_tilde, sigma0, xi, theta, eta (or mu, sigma, xi for gev.fit objects)
 }
 \description{
 function to calculate mut, sigma0, xi, theta, eta 

man/gev.d2stdgumbel.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/gevdfit.R
+\name{gev.d2stdgumbel}
+\alias{gev.d2stdgumbel}
+\title{Transform data to standart gumbel}
+\usage{
+gev.d2stdgumbel(xdat, ds, params)
+}
+\arguments{
+\item{xdat}{A vector containing maxima for different durations.}
+
+\item{ds}{A vector of aggregation levels corresponding to the maxima in xdat.}
+
+\item{params}{list of parameters mu_tilde, sigma0, xi, theta, eta 
+as obtained from \code{\link{gev.d.params}}}
+}
+\value{
+Vector containing transformed data.
+}
+\description{
+Transform data to standart gumbel
+}
+\examples{
+data('example',package = 'IDF')
+# fit subset
+ind <- sample(1:10, length(example$dat), replace=TRUE)
+fit.subs <- gev.d.fit(example$dat[ind!=1],example$d[ind!=1]
+                      ,ydat = as.matrix(example[ind!=1,c("cov1","cov2")])
+                      ,mul = c(1,2),sigl = 1)
+# calculate parameters for unfitted values
+par <- gev.d.params(fit = fit.subs
+                      ,ydat = as.matrix(example[ind==1,c("cov1","cov2")]))
+# transform unfitted values to standart gumbel
+sg.data <- gev.d2stdgumbel(xdat = example$dat[ind==1]
+                      ,ds = example$d[ind==1],params = par)
+# check unfitted values agains standart gumbel
+gev.d.diag(data.frame(data=sg.data,ds=example$d[ind==1]),pch=20)
+}