[Gmm-commits] r233 - pkg/momentfit/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 27 20:38:44 CET 2024
Author: chaussep
Date: 2024-03-27 20:38:43 +0100 (Wed, 27 Mar 2024)
New Revision: 233
Modified:
pkg/momentfit/R/gel.R
pkg/momentfit/R/momentModel-methods.R
pkg/momentfit/R/rModel-methods.R
Log:
improving error messages when GEL lambdas cannot be computed
Modified: pkg/momentfit/R/gel.R
===================================================================
--- pkg/momentfit/R/gel.R 2024-03-25 21:02:23 UTC (rev 232)
+++ pkg/momentfit/R/gel.R 2024-03-27 19:38:43 UTC (rev 233)
@@ -137,15 +137,6 @@
}
algo <- match.arg(algo)
gmat <- as.matrix(gmat)
- chk1 <- any(apply(gmat, 2, function(x) all(x>0) | all(x<0)))
- chk2 <- any(is.na(gmat))
- chk3 <- any(!is.finite(gmat))
- if (chk1 | chk2 | chk3)
- {
- return(list(lambda = as.numeric(rep(NA, ncol(gmat))),
- convergence = list(convergence=1, message='gt has some wrong values'),
- obj= NA))
- }
if (length(restrictedLam))
{
if (length(restrictedLam) > ncol(gmat))
@@ -157,6 +148,21 @@
} else {
restrictedLam <- integer()
}
+ mes <- character()
+ chk1 <- any(apply(gmat, 2, function(x) all(x>0) | all(x<0)))
+ if (chk1)
+ mes <- c(mes, "0 is not inside the convex hull of gt")
+ chk2 <- any(is.na(gmat))
+ if (chk2)
+ mes <- c(mes, "Some values of the moment matrix gt are NA's")
+ chk3 <- any(!is.finite(gmat))
+ if (chk3)
+ mes <- c(mes, "Some values of the moment matrix gt are not finite")
+ if (length(mes))
+ {
+ return(list(lambda = as.numeric(rep(NA, ncol(gmat))),
+ convergence = list(convergence=1, message=mes), obj= NA))
+ }
if (is.null(lambda0))
{
lambda0 <- rep(0, ncol(gmat))
Modified: pkg/momentfit/R/momentModel-methods.R
===================================================================
--- pkg/momentfit/R/momentModel-methods.R 2024-03-25 21:02:23 UTC (rev 232)
+++ pkg/momentfit/R/momentModel-methods.R 2024-03-27 19:38:43 UTC (rev 233)
@@ -1317,6 +1317,10 @@
}
if (is.null(lamSlv))
lamSlv <- getLambda
+ if (modelDims(object)$k == 0)
+ return(evalGel(object, theta=numeric(), gelType=gelType,
+ rhoFct=rhoFct, lambda0=lambda0, lamSlv=lamSlv,
+ lControl=lControl))
if (coefSlv == "nlminb")
{
args <- c(list(start=theta0, objective=f, gelType=gelType,
@@ -1328,12 +1332,27 @@
slv=lamSlv, lcont=lControl, gelType=gelType,
rhoFct=rhoFct, restrictedLam=.restrictedLam), tControl)
}
- res <- do.call(get(coefSlv), args)
- resl <- f(res$par, object, lambda0, lamSlv, gelType=gelType,
- rhoFct=rhoFct, lControl, TRUE, .restrictedLam)
- names(resl$lambda) <- modelDims(object)$momNames
- theta <- res$par
- names(theta) <- modelDims(object)$parNames
+ res <- suppressWarnings(try(do.call(get(coefSlv), args), silent=TRUE))
+ if (inherits(res, "try-error"))
+ {
+ theta <- as.numeric(rep(NA), length(theta0))
+ resl <- f(theta0, object, lambda0, lamSlv, gelType=gelType,
+ rhoFct=rhoFct, lControl, TRUE, .restrictedLam)
+ warning(paste("Failed to estimate the model\n",
+ "The error message from the the solver is:\n\t",
+ res, "\n",
+ ifelse(resl$convergence$convergence==0, "",
+ paste("Error from the Lambda solver at the initial parameter value:\n",
+ paste(resl$convergence$message, collapse="\n")))))
+
+ res <- list(convergence=12)
+ } else {
+ resl <- f(res$par, object, lambda0, lamSlv, gelType=gelType,
+ rhoFct=rhoFct, lControl, TRUE, .restrictedLam)
+ names(resl$lambda) <- modelDims(object)$momNames
+ theta <- res$par
+ names(theta) <- modelDims(object)$parNames
+ }
list(theta=theta, convergence=res$convergence,
lambda=resl$lambda, lconvergence=resl$convergence,
restrictedLam=.restrictedLam)
@@ -1405,12 +1424,18 @@
k <- model at sSpec@k
args <- c(list(gmat=gt, gelType=gelType,
rhoFct=rhoFct, restrictedLam=.restrictedLam),
- lControl, k=k[1]/k[2])
+ lControl, k=k[1]/k[2], list(...))
if (is.null(lamSlv))
lamSlv <- getLambda
res <- do.call(lamSlv, args)
lambda <- res$lambda
+ mes <- res$convergence$message
lconvergence <- res$convergence$convergence
+ if (lconvergence != 0)
+ warning(paste("Failed to solve for the Lambdas\n",
+ ifelse(is.null(mes), "",
+ paste("Error from the Lambda solver:\n",
+ paste(mes, collapse="\n")))))
type <- paste(type, " with optimal lambda", sep="")
} else {
lconvergence <- 1
@@ -1419,7 +1444,7 @@
}
names(lambda) <- spec$momNames
if (!is.null(rhoFct))
- gelType <- "Other"
+ gelType <- "Other"
new("gelfit", theta=theta, convergence=1, lconvergence=lconvergence,
lambda=lambda, call=Call, gelType=list(name=gelType, rhoFct=rhoFct),
vcov=list(), model=model, restrictedLam = .restrictedLam)
Modified: pkg/momentfit/R/rModel-methods.R
===================================================================
--- pkg/momentfit/R/rModel-methods.R 2024-03-25 21:02:23 UTC (rev 232)
+++ pkg/momentfit/R/rModel-methods.R 2024-03-27 19:38:43 UTC (rev 233)
@@ -811,7 +811,8 @@
Call <- NULL
k <- modelDims(model)$k
if (k == 0)
- return(evalGel(model, numeric(), ...))
+ return(evalGel(model=model, theta=numeric(), gelType=gelType,
+ rhoFct=rhoFct, ...))
initTheta <- match.arg(initTheta)
if (is.null(theta0))
{
More information about the Gmm-commits
mailing list