[Depmix-commits] r671 - in pkg/depmixS4: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 17 12:42:08 CEST 2018
Author: ingmarvisser
Date: 2018-10-17 12:42:07 +0200 (Wed, 17 Oct 2018)
New Revision: 671
Added:
pkg/depmixS4/R/hessian.R
Removed:
pkg/depmixS4/R/fdHessHmm.R
Modified:
pkg/depmixS4/NAMESPACE
Log:
=changed filename from fdHessHmm.R to hessian.R
Modified: pkg/depmixS4/NAMESPACE
===================================================================
--- pkg/depmixS4/NAMESPACE 2018-10-17 09:53:34 UTC (rev 670)
+++ pkg/depmixS4/NAMESPACE 2018-10-17 10:42:07 UTC (rev 671)
@@ -23,7 +23,8 @@
em.control,
viterbi,
mlogit,
- logLik
+ logLik,
+ hessian2vcov
)
exportClasses(
Deleted: pkg/depmixS4/R/fdHessHmm.R
===================================================================
--- pkg/depmixS4/R/fdHessHmm.R 2018-10-17 09:53:34 UTC (rev 670)
+++ pkg/depmixS4/R/fdHessHmm.R 2018-10-17 10:42:07 UTC (rev 671)
@@ -1,102 +0,0 @@
-
-
-
-setMethod("hessian", "mix",
- function(object,fixed=NULL,equal=NULL,
- conrows=NULL,conrows.upper=NULL,conrows.lower=NULL,
- method="finiteDifferences", ...) {
-
- fi <- !is.null(fixed)
- cr <- !is.null(conrows)
- eq <- !is.null(equal)
-
- constr <- any(c(fi,cr,eq))
-
- if(is.nan(logLik(object))) stop("Log likelihood is 'NaN'; cannot compute hessian. ")
-
- # determine which parameters are fixed
- if(fi) {
- if(length(fixed)!=npar(object)) stop("'fixed' does not have correct length")
- } else {
- if(eq) {
- if(length(equal)!=npar(object)) stop("'equal' does not have correct length")
- fixed <- !pa2conr(equal)$free
- } else {
- fixed <- getpars(object,"fixed")
- }
- }
-
- # set those fixed parameters in the appropriate submodels
- object <- setpars(object,fixed,which="fixed")
-
- # get the full set of parameters
- allpars <- getpars(object)
-
- # get the reduced set of parameters, ie the ones that will be optimized
- pars <- allpars[!fixed]
-
- constraints <- getConstraints(object)
-
- lincon=constraints$lincon
- lin.u=constraints$lin.u
- lin.l=constraints$lin.l
- par.u=constraints$par.u
- par.l=constraints$par.l
-
- # incorporate equality constraints provided with the fit function, if any
- if(eq) {
- if(length(equal)!=npar(object)) stop("'equal' does not have correct length")
- equal <- pa2conr(equal)$conr
- lincon <- rbind(lincon,equal)
- lin.u <- c(lin.u,rep(0,nrow(equal)))
- lin.l <- c(lin.l,rep(0,nrow(equal)))
- }
-
- # incorporate general linear constraints, if any
- if(cr) {
- if(ncol(conrows)!=npar(object)) stop("'conrows' does not have the right dimensions")
- lincon <- rbind(lincon,conrows)
- if(any(conrows.upper==0)) {
- lin.u <- c(lin.u,rep(0,nrow(conrows)))
- } else {
- if(length(conrows.upper)!=nrow(conrows)) stop("'conrows.upper does not have correct length")
- lin.u <- c(lin.u,conrows.upper)
- }
- if(any(conrows.lower==0)) {
- lin.l <- c(lin.l,rep(0,nrow(conrows)))
- } else {
- if(length(conrows.lower)!=nrow(conrows)) stop("'conrows.lower does not have correct length")
- lin.l <- c(lin.l,conrows.lower)
- }
- }
-
- # select only those columns of the constraint matrix that correspond to non-fixed parameters
- linconFull <- lincon
- lincon <- lincon[,!fixed,drop=FALSE]
-
- # remove redundant rows in lincon (all zeroes)
- allzero <- which(apply(lincon,1,function(y) all(y==0)))
- if(length(allzero)>0) {
- lincon <- lincon[-allzero,,drop=FALSE]
- lin.u <- lin.u[-allzero]
- lin.l <- lin.l[-allzero]
- }
-
- # TODO: remove rows of lincon with inequality constraints!!!!
-
- # make loglike function that only depends on pars
- logl <- function(pars) {
- allpars[!fixed] <- pars
- object <- setpars(object,allpars)
- ans = -as.numeric(logLik(object))
- if(is.na(ans)) ans = 100000 # remove magic number here!!!!!!!!
- ans
- }
-
- fdh <- fdHess(pars,logl)
-
- hess <- hessian2vcov(fdh$Hessian,lincon)
-
- return(hess)
-}
-)
\ No newline at end of file
Copied: pkg/depmixS4/R/hessian.R (from rev 670, pkg/depmixS4/R/fdHessHmm.R)
===================================================================
--- pkg/depmixS4/R/hessian.R (rev 0)
+++ pkg/depmixS4/R/hessian.R 2018-10-17 10:42:07 UTC (rev 671)
@@ -0,0 +1,108 @@
+
+setMethod("hessian", "mix",
+ function(object,fixed=NULL,equal=NULL,
+ conrows=NULL,conrows.upper=NULL,conrows.lower=NULL,
+ method="finiteDifferences", ...) {
+
+ if(is.nan(logLik(object))) stop("Log likelihood is 'NaN'; cannot compute hessian. ")
+
+ # check for presence of constraints
+ fi <- !is.null(fixed)
+ cr <- !is.null(conrows)
+ eq <- !is.null(equal)
+
+ constr <- any(c(fi,cr,eq))
+
+ # determine which parameters are fixed
+ if(fi) {
+ if(length(fixed)!=npar(object)) stop("'fixed' does not have correct length")
+ } else {
+ if(eq) {
+ if(length(equal)!=npar(object)) stop("'equal' does not have correct length")
+ fixed <- !pa2conr(equal)$free
+ } else {
+ fixed <- getpars(object,"fixed")
+ }
+ }
+
+ # set those fixed parameters in the appropriate submodels
+ object <- setpars(object,fixed,which="fixed")
+
+ constraints <- getConstraints(object)
+
+ lincon=constraints$lincon
+ lin.u=constraints$lin.u
+ lin.l=constraints$lin.l
+ par.u=constraints$par.u
+ par.l=constraints$par.l
+
+ # incorporate equality constraints provided with the hessian function, if any
+ if(eq) {
+ if(length(equal)!=npar(object)) stop("'equal' does not have correct length")
+ equal <- pa2conr(equal)$conr
+ lincon <- rbind(lincon,equal)
+ lin.u <- c(lin.u,rep(0,nrow(equal)))
+ lin.l <- c(lin.l,rep(0,nrow(equal)))
+ }
+
+ # incorporate general linear constraints, if any
+ if(cr) {
+ if(ncol(conrows)!=npar(object)) stop("'conrows' does not have the right dimensions")
+ lincon <- rbind(lincon,conrows)
+ if(any(conrows.upper==0)) {
+ lin.u <- c(lin.u,rep(0,nrow(conrows)))
+ } else {
+ if(length(conrows.upper)!=nrow(conrows)) stop("'conrows.upper does not have correct length")
+ lin.u <- c(lin.u,conrows.upper)
+ }
+ if(any(conrows.lower==0)) {
+ lin.l <- c(lin.l,rep(0,nrow(conrows)))
+ } else {
+ if(length(conrows.lower)!=nrow(conrows)) stop("'conrows.lower does not have correct length")
+ lin.l <- c(lin.l,conrows.lower)
+ }
+ }
+
+ # get the full set of parameters
+ allpars <- getpars(object)
+
+ # get the reduced set of parameters, ie the ones that the hessian will be computed for
+ # only non-fixed parameters
+ pars <- allpars[!fixed]
+
+ # TODO: now also remove parameters that are on their boundary
+
+
+ # select only those columns of the constraint matrix that correspond to non-fixed parameters
+ linconFull <- lincon
+ lincon <- lincon[,!fixed,drop=FALSE]
+
+ # remove redundant rows in lincon (all zeroes)
+ allzero <- which(apply(lincon,1,function(y) all(y==0)))
+ if(length(allzero)>0) {
+ lincon <- lincon[-allzero,,drop=FALSE]
+ lin.u <- lin.u[-allzero]
+ lin.l <- lin.l[-allzero]
+ }
+
+ # TODO: remove rows of lincon with inequality constraints!!!!
+
+
+ # make loglike function that only depends on pars
+ logl <- function(pars) {
+ allpars[!fixed] <- pars
+ object <- setpars(object,allpars)
+ ans = -as.numeric(logLik(object))
+ if(is.na(ans)) ans = 100000 # remove magic number here!!!!!!!!
+ ans
+ }
+
+ fdh <- fdHess(pars,logl)
+
+ # also return list of length npar that specifies for which parameters
+ # the hessian has been computed and for which this has been skipped due
+ # to being 1) fixed or 2) on the boundary
+
+ return(list(hessian=fdh$Hessian,lincon=lincon))
+}
+)
\ No newline at end of file
More information about the depmix-commits
mailing list