Commit efbb8850 authored by Jana Ulrich's avatar Jana Ulrich
Browse files

added derivatives of nll after parameters

parent 3994dcb6
...@@ -348,14 +348,14 @@ IDF.nll <- function(mu=0,sigma=1,xi=0,theta=0,eta=1,x,d,use.log=F,DEBUG=F) { ...@@ -348,14 +348,14 @@ IDF.nll <- function(mu=0,sigma=1,xi=0,theta=0,eta=1,x,d,use.log=F,DEBUG=F) {
#' gev.d.fit(xdat=example$dat,ds = example$d,ydat=as.matrix(example[,c('cov1','cov2')]) #' gev.d.fit(xdat=example$dat,ds = example$d,ydat=as.matrix(example[,c('cov1','cov2')])
#' ,mul=c(1,2),sigl=1) #' ,mul=c(1,2),sigl=1)
'gev.d.fit'<- gev.d.fit<-
function(xdat, ds, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL, thetal = NULL, etal = NULL, function(xdat, ds, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL, thetal = NULL, etal = NULL,
mulink = identity, siglink = identity, shlink = identity, thetalink = identity, etalink = identity, mulink = identity, siglink = identity, shlink = identity, thetalink = identity, etalink = identity,
muinit = NULL, siginit = NULL, shinit = NULL, thetainit = NULL, etainit = NULL, muinit = NULL, siginit = NULL, shinit = NULL, thetainit = NULL, etainit = NULL,
show = TRUE, method = "Nelder-Mead", maxit = 10000, ...) show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
{ {
# #
# obtains mles etc for gev(d) distn # obtains mles etc for d-gev distn
# #
# test for NA values: # test for NA values:
...@@ -431,7 +431,7 @@ IDF.nll <- function(mu=0,sigma=1,xi=0,theta=0,eta=1,x,d,use.log=F,DEBUG=F) { ...@@ -431,7 +431,7 @@ IDF.nll <- function(mu=0,sigma=1,xi=0,theta=0,eta=1,x,d,use.log=F,DEBUG=F) {
# function to calculate neg log-likelihood: # function to calculate neg log-likelihood:
gev.lik <- function(a) { gev.lik <- function(a) {
# computes neg log lik of gev(d) model # computes neg log lik of d-gev model
mu <- mulink(mumat %*% (a[1:npmu])) mu <- mulink(mumat %*% (a[1:npmu]))
sigma <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)])) sigma <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)])) xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
...@@ -447,6 +447,28 @@ IDF.nll <- function(mu=0,sigma=1,xi=0,theta=0,eta=1,x,d,use.log=F,DEBUG=F) { ...@@ -447,6 +447,28 @@ IDF.nll <- function(mu=0,sigma=1,xi=0,theta=0,eta=1,x,d,use.log=F,DEBUG=F) {
sum(log(sigma.d)) + sum(y^(-1/xi)) + sum(log(y) * (1/xi + 1)) sum(log(sigma.d)) + sum(y^(-1/xi)) + sum(log(y) * (1/xi + 1))
} }
#####################################################################################
# derivations of nll after d-gev-parameters (for boosting):
# 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)]))
# theta <- thetalink(thmat %*% (a[seq(npmu + npsc + npsh + 1, length = npth)]))
# eta <- etalink(etmat %*% (a[seq(npmu + npsc + npsh + npth + 1, length = npet)]))
# xd <- xdat*(ds+theta)^eta
# y <- 1 + xi * (xd/sigma - mu)
#
# nll <- log(sigma/(ds+theta)^eta) + y^(-1/xi) + log(y) * (1/xi + 1)
# dnll.mu <- -xi/y
# dnll.sigma <- 1/(sigma+xi*xd/(1-mu*xi))
# dnll.xi <- 1/(xi+sigma/(xd-mu*sigma))
# dnll.theta <- - eta*sigma*(mu*xi-1)/(ds+theta)/(-xi*xd+mu*xi*sigma-sigma)
# dnll.eta <- -sigma*(mu*xi-1)*log(ds+theta)/(-xi*xd+mu*xi*sigma-sigma)
#####################################################################################
# finding minimum of log-likelihood: # finding minimum of log-likelihood:
x <- optim(init, gev.lik, hessian = TRUE, method = method, x <- optim(init, gev.lik, hessian = TRUE, method = method,
control = list(maxit = maxit, ...)) control = list(maxit = maxit, ...))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment