Commit c9422e57 by Felix Fauer

### added intensity offset to gev.d.fit and IDF.plot

parent 53c55a35
 ... @@ -221,14 +221,19 @@ NULL ... @@ -221,14 +221,19 @@ NULL #' points(example[example\$cov1==1,]\$d,example[example\$cov1==1,]\$dat) #' points(example[example\$cov1==1,]\$d,example[example\$cov1==1,]\$dat) IDF.plot <- function(durations,fitparams,probs=c(0.5,0.9,0.99), IDF.plot <- function(durations,fitparams,probs=c(0.5,0.9,0.99), cols=4:2,add=FALSE, cols=4:2,add=FALSE, legend=TRUE,...){ legend=TRUE,tau_zero=TRUE,...){ # if cols is to short, make longer # if cols is to short, make longer if(length(cols)!=length(probs))cols <- rep_len(cols,length.out=length(probs)) if(length(cols)!=length(probs))cols <- rep_len(cols,length.out=length(probs)) if(!tau_zero){ print("WARNING in IDF.plot: this might work now, but is not robust any more when multiscaling is added") tau=fitparams[6] }else{ tau=NULL } ## calculate IDF values for given probability and durations ## calculate IDF values for given probability and durations qs <- lapply(durations,qgev.d,p=probs,mut=fitparams[1],sigma0=fitparams[2],xi=fitparams[3], qs <- lapply(durations,qgev.d,p=probs,mut=fitparams[1],sigma0=fitparams[2],xi=fitparams[3], theta=fitparams[4],eta=fitparams[5]) theta=fitparams[4],eta=fitparams[5], tau=tau) idf.array <- matrix(unlist(qs),length(probs),length(durations)) # array[probs,durs] idf.array <- matrix(unlist(qs),length(probs),length(durations)) # array[probs,durs] if(!add){ #new plot if(!add){ #new plot ## initialize plot window ## initialize plot window ... @@ -246,7 +251,6 @@ IDF.plot <- function(durations,fitparams,probs=c(0.5,0.9,0.99), ... @@ -246,7 +251,6 @@ IDF.plot <- function(durations,fitparams,probs=c(0.5,0.9,0.99), # empty plot # empty plot plot(NA,xlim=xlim,ylim=ylim,xlab="Duration [h]",ylab="Intensity [mm/h]",log="xy",main=main) plot(NA,xlim=xlim,ylim=ylim,xlab="Duration [h]",ylab="Intensity [mm/h]",log="xy",main=main) } } ## plot IDF curves ## plot IDF curves for(i in 1:length(probs)){ for(i in 1:length(probs)){ lines(durations,idf.array[i,],col=cols[i],...) lines(durations,idf.array[i,],col=cols[i],...) ... ...
 ... @@ -142,7 +142,7 @@ pgev.d <- function(q,mut,sigma0,xi,theta,eta,d,...) { ... @@ -142,7 +142,7 @@ pgev.d <- function(q,mut,sigma0,xi,theta,eta,d,...) { #' } #' } #' legend('topright',title = 'p-quantile', #' legend('topright',title = 'p-quantile', #' legend = p,lty=1:3,bty = 'n') #' legend = p,lty=1:3,bty = 'n') qgev.d <- function(p,mut,sigma0,xi,theta,eta,d,...) { qgev.d.old <- function(p,mut,sigma0,xi,theta,eta,d,...) { # cannot deal with tau if(any(c(length(mut),length(sigma0),length(xi),length(theta),length(eta))>1)){ 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. ', message('One of the parameters mut, sigma0, xi, theta, eta is a vector. ', 'This is not intended and might cause an error.')} 'This is not intended and might cause an error.')} ... @@ -155,6 +155,21 @@ qgev.d <- function(p,mut,sigma0,xi,theta,eta,d,...) { ... @@ -155,6 +155,21 @@ qgev.d <- function(p,mut,sigma0,xi,theta,eta,d,...) { sigma.d <-sigma0/(d+theta)^eta sigma.d <-sigma0/(d+theta)^eta return(qgev(p,loc=as.numeric(mut*sigma.d) return(qgev(p,loc=as.numeric(mut*sigma.d) ,scale=as.numeric(sigma.d),shape=as.numeric(xi),...))} ,scale=as.numeric(sigma.d),shape=as.numeric(xi),...))} } # can deal with tau! qgev.d <- function(p,mut,sigma0,xi,theta,eta,d, tau=NULL, ...) { if(any(c(length(mut),length(sigma0),length(xi),length(theta),length(eta), length(tau))>1)){ message('One of the parameters mut, sigma0, xi, theta, eta is a vector. ', 'This is not intended and might cause an error.')} if (d<=0) {stop('The duration d has to be positive.')} if(any(d+theta<=0)){ warning('Some shape parameters are negative, resulting from a negativ theta ' ,theta, ' this will prododuce NAs.')} # if denominator is negative NAs will be returned if(d+theta<=0){return(rep(NA,length(p)))}else{ #sigma.d <-sigma0/(d+theta)^eta ifelse(!is.null(tau), sigma.d <-sigma0/(d+theta)^eta+tau, sigma.d <-sigma0/(d+theta)^eta) return(qgev(p,loc=as.numeric(mut*sigma.d) ,scale=as.numeric(sigma.d),shape=as.numeric(xi),...))} } } ... ...