[Gmm-commits] r239 - in pkg/momentfit: . R man vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 31 23:00:05 CEST 2024
Author: chaussep
Date: 2024-05-31 23:00:05 +0200 (Fri, 31 May 2024)
New Revision: 239
Added:
pkg/momentfit/R/minAlgo.R
pkg/momentfit/man/algoObj.Rd
pkg/momentfit/man/minAlgo-class.Rd
pkg/momentfit/man/minAlgoNlm-class.Rd
pkg/momentfit/man/minAlgoStd-class.Rd
pkg/momentfit/man/minFit.Rd
Modified:
pkg/momentfit/DESCRIPTION
pkg/momentfit/NAMESPACE
pkg/momentfit/R/allClasses.R
pkg/momentfit/R/gmm4.R
pkg/momentfit/R/gmmfit-methods.R
pkg/momentfit/R/momentModel-methods.R
pkg/momentfit/R/rModel-methods.R
pkg/momentfit/R/rsysMomentModel-methods.R
pkg/momentfit/R/sgmmfit-methods.R
pkg/momentfit/R/summary-methods.R
pkg/momentfit/R/sysMomentModel-methods.R
pkg/momentfit/R/validity.R
pkg/momentfit/man/gmmfit-class.Rd
pkg/momentfit/man/print-methods.Rd
pkg/momentfit/man/sgmmfit-class.Rd
pkg/momentfit/man/show-methods.Rd
pkg/momentfit/man/solveGmm-methods.Rd
pkg/momentfit/man/summaryGmm-class.Rd
pkg/momentfit/man/summarySysGmm-class.Rd
pkg/momentfit/vignettes/empir.bib
pkg/momentfit/vignettes/gmmS4.Rnw
pkg/momentfit/vignettes/gmmS4.pdf
Log:
add the options for other solvers and return more convergence message
Modified: pkg/momentfit/DESCRIPTION
===================================================================
--- pkg/momentfit/DESCRIPTION 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/DESCRIPTION 2024-05-31 21:00:05 UTC (rev 239)
@@ -7,7 +7,7 @@
Description: Several classes for moment-based models are defined. The classes are defined for moment conditions derived from a single equation or a system of equations. The conditions can also be expressed as functions or formulas. Several methods are also offered to facilitate the development of different estimation techniques. The methods that are currently provided are the Generalized method of moments (Hansen 1982; <doi:10.2307/1912775>), for single equations and systems of equation, and the Generalized Empirical Likelihood (Smith 1997; <doi:10.1111/j.0013-0133.1997.174.x>, Kitamura 1997; <doi:10.1214/aos/1069362388>, Newey and Smith 2004; <doi:10.1111/j.1468-0262.2004.00482.x>, and Anatolyev 2005 <doi:10.1111/j.1468-0262.2005.00601.x>).Some work is being done to add tools to deal with weak and/or many instruments. This include K-Class estimators (LIML and Fuller), Anderson and Rubin statistics test, etc.
Depends: R (>= 3.5), sandwich
Imports: stats, methods, parallel
-Suggests: lmtest, knitr, texreg, rmarkdown, ivmodel
+Suggests: lmtest, knitr, texreg, rmarkdown, ivmodel, nloptr
Collate: 'allClasses.R' 'validity.R' 'momentData.R' 'momentModel-methods.R'
'momentModel.R' 'momentWeights-methods.R' 'gmmfit-methods.R'
'specTest-methods.R' 'summary-methods.R' 'rModel-methods.R'
@@ -14,6 +14,7 @@
'hypothesisTest-methods.R' 'sysMomentModel.R'
'sysMomentModel-methods.R' 'rsysMomentModel-methods.R'
'sgmmfit-methods.R' 'gmm4.R' 'gel.R' 'gelfit-methods.R' 'gel4.R' 'weak.R'
+ 'minAlgo.R'
License: GPL (>= 2)
NeedsCompilation: yes
VignetteBuilder: knitr
Modified: pkg/momentfit/NAMESPACE
===================================================================
--- pkg/momentfit/NAMESPACE 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/NAMESPACE 2024-05-31 21:00:05 UTC (rev 239)
@@ -33,7 +33,8 @@
"rsysModel", "formulaModel","rfunctionModel", "sSpec",
"summaryGmm", "specTest", "confint", "mconfint",
"hypothesisTest", "stsls", "sgmmfit", "gelfit", "summaryGel",
- "tsls", "lsefit", "kclassfit", "summaryKclass")
+ "tsls", "lsefit", "kclassfit", "summaryKclass",
+ "minAlgo", "minAlgoStd", "minAlgoNlm")
exportMethods(print, show, kernapply, coef, model.matrix, bread, summary,
residuals, "[", vcovHAC, subset, update, vcov, plot, confint, merge)
@@ -45,7 +46,7 @@
rhoET, rhoEL, rhoEEL, rhoHD, Wu_lam, EEL_lam, REEL_lam, getLambda,
solveGel, rhoETEL, rhoETHD, ETXX_lam, gelFit, evalGel, getImpProb,
evalGelObj, momFct, gel4, setCoef, lse, getK, kclassfit, CDtest,
- SYTables, SWtest, MOPtest, LewMertest)
+ SYTables, SWtest, MOPtest, LewMertest, minFit, algoObj)
### S3 methods ###
Modified: pkg/momentfit/R/allClasses.R
===================================================================
--- pkg/momentfit/R/allClasses.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/allClasses.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -146,7 +146,7 @@
## gmmfit
-setClass("gmmfit", representation(theta = "numeric", convergence = "numericORNULL",
+setClass("gmmfit", representation(theta = "numeric", convergence = "list",
convIter="numericORNULL",call="callORNULL",
type="character", wObj="momentWeights",niter="integer",
efficientGmm="logical", model="momentModel"))
@@ -156,7 +156,7 @@
setClass("summaryGmm", representation(coef="matrix", specTest = "specTest",
strength="list", model="momentModel",sandwich="logical",
- type="character", convergence = "numericORNULL",
+ type="character", convergence = "list",
convIter="numericORNULL", wSpec="list",niter="integer",
df.adj="logical", breadOnly="logical"))
@@ -172,7 +172,7 @@
setClass("summarySysGmm",
representation(coef="list", specTest = "specTest",
strength="list", model="sysModel",sandwich="logical",
- type="character", convergence = "numericORNULL",
+ type="character", convergence = "list",
convIter="numericORNULL", wSpec="list",niter="integer",
df.adj="logical", breadOnly="logical"))
@@ -196,7 +196,7 @@
### system GMM fit
-setClass("sgmmfit", representation(theta = "list", convergence = "numericORNULL",
+setClass("sgmmfit", representation(theta = "list", convergence = "list",
convIter="numericORNULL",call="callORNULL",
type="character", wObj="sysMomentWeights",niter="integer",
efficientGmm="logical", model="sysModel"))
@@ -234,6 +234,24 @@
contains="summaryGmm")
+## Classes for minimization solver
+
+setClass("minAlgoStd", representation(algo="character", start="character", fct="character",
+ grad="character", solution="character", value="character",
+ message="character", convergence="character"),
+ prototype=list(algo="optim", start="par", fct="fn", grad="gr", solution="par",
+ value="value", message="message", convergence="convergence"))
+
+setClass("minAlgoNlm", representation(algo="character", start="character", fct="character",
+ solution="character",
+ value="character",
+ message="character", convergence="character"),
+ prototype=list(algo="nlm", start="p", fct="f",
+ solution="estimate", value="minimum", message=as.character(NA),
+ convergence="code"))
+### They are all common
+setClassUnion("minAlgo", c("minAlgoStd", "minAlgoNlm"))
+
## class converted
setAs("linearModel", "nonlinearModel",
Modified: pkg/momentfit/R/gmm4.R
===================================================================
--- pkg/momentfit/R/gmm4.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/gmm4.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -1,5 +1,5 @@
################### the main gmm functions ###################
-########## These functions ar to avoid having to builf model objects
+########## These functions are to avoid having to build model objects
gmm4 <- function (g, x, theta0 = NULL, grad = NULL,
type = c("twostep", "iter", "cue", "onestep"),
Modified: pkg/momentfit/R/gmmfit-methods.R
===================================================================
--- pkg/momentfit/R/gmmfit-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/gmmfit-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -29,8 +29,14 @@
cat("\nEstimation: ", type,"\n")
if (length(theta))
{
- if (!is.null(x at convergence))
- cat("Convergence Optim: ", x at convergence, "\n")
+ if (length(x at convergence))
+ {
+ cat("Convergence code: ", x at convergence$code,
+ " (see help(", x at convergence$algo, "))\n", sep="")
+ if (!is.null(x at convergence$message))
+ cat("Convergence message: ", x at convergence$message,
+ "\n", sep="")
+ }
if (!is.null(x at convIter))
cat("Convergence Iteration: ", x at convIter, "\n")
cat("coefficients:\n")
Added: pkg/momentfit/R/minAlgo.R
===================================================================
--- pkg/momentfit/R/minAlgo.R (rev 0)
+++ pkg/momentfit/R/minAlgo.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -0,0 +1,106 @@
+algoObj <- function(algo, start, fct, grad, solution, value, message, convergence)
+{
+ if (algo %in% c("optim", "nlminb", "constrOptim"))
+ {
+ obj <- switch(algo,
+ optim = new("minAlgoStd"),
+ nlminb = new("minAlgoStd",
+ algo="nlminb", start="start", fct="objective",
+ grad="gradient", value="objective"),
+ constrOptim = new("minAlgoStd", algo="constrOptim", start="theta",
+ fct="f", grad="grad"))
+ return(obj)
+ } else if (algo == "nlm") {
+ obj <- new("minAlgoNlm")
+ } else {
+ if (missing(start) | missing(fct))
+ stop("You must provide the name of the arguments representing the function to minimize and the starting values")
+ if (missing(value) | missing(solution) | missing(message) | missing(convergence))
+ stop("You must provide the name of the output representing the solution, the function value, the convergence code and message.")
+ obj <- new("minAlgoStd", algo=algo, start=start, fct=fct, grad=grad,
+ solution=solution,
+ value=value, message=message, convergence=convergence)
+ }
+ obj
+}
+
+setGeneric("minFit",
+ def = function(object, start, fct, gr, ...) "Unknown algorithm")
+
+setMethod("minFit", signature("minAlgoNlm"),
+ function(object, start, fct, gr, ...)
+ {
+ solver <- object at algo
+ arg <- list()
+ if (missing(gr))
+ {
+ f <- fct
+ } else {
+ if (!is.function(gr))
+ stop("gr must be a function")
+ if (!isTRUE(all.equal(formals(fct), formals(gr))))
+ stop("Arguments in fct must be identical to arguments in gr")
+ f <- function()
+ {
+ arg <- as.list(match.call)[-1]
+ structure(do.call("fct", arg),
+ gradient=do.call("gr", arg))
+ }
+ formals(f) <- formals(fct)
+ }
+ arg[[object at fct]] <- fct
+ arg[[object at start]] <- start
+ arg <- c(arg, list(...))
+ res <- do.call(solver, arg)
+ ans <- list(solution = res[[object at solution]],
+ value = res[[object at value]])
+ if (!is.na(object at convergence))
+ ans$convergence <- res[[object at convergence]]
+ if (!is.na(object at message))
+ ans$message <- res[[object at message]]
+ ans
+ })
+
+
+
+setMethod("minFit", signature("minAlgoStd"),
+ function(object, start, fct, gr, ...)
+ {
+ solver <- object at algo
+ arg <- list()
+ arg[[object at fct]] <- fct
+ if (!is.na(object at grad))
+ {
+ if (!missing(gr))
+ {
+ if (!is.function(gr))
+ stop("gr must be a function")
+ if (!isTRUE(all.equal(formals(fct), formals(gr))))
+ stop("Arguments in fct must be identical to arguments in gr")
+ arg[[object at grad]] <- gr
+ }
+ }
+ arg[[object at start]] <- start
+ arg <- c(arg, list(...))
+ res <- do.call(solver, arg)
+ ans <- list(solution = res[[object at solution]],
+ value = res[[object at value]])
+ if (!is.na(object at convergence))
+ ans$convergence <- res[[object at convergence]]
+ if (!is.na(object at message))
+ ans$message <- res[[object at message]]
+ ans
+ })
+
+
+
+setMethod("print", "minAlgo",
+ function(x, ...)
+ {
+ cat("Optimization algorithm\n")
+ cat("**********************\n")
+ cat("Name of the function: ", x at algo, "\n")
+ invisible()
+ })
+
+setMethod("show", "minAlgo", function(object) print(object))
Modified: pkg/momentfit/R/momentModel-methods.R
===================================================================
--- pkg/momentfit/R/momentModel-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/momentModel-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -659,7 +659,8 @@
######################### solveGmm #########################
-setGeneric("solveGmm", function(object, wObj, ...) standardGeneric("solveGmm"))
+setGeneric("solveGmm", function(object, wObj, theta0=NULL, ...)
+ standardGeneric("solveGmm"))
setMethod("solveGmm", signature("linearModel", "momentWeights"),
function(object, wObj, theta0=NULL, ...)
@@ -681,44 +682,40 @@
}
theta <- c(solve(T1, T2))
names(theta) <- d$parNames
- list(theta=theta, convergence=NULL)
+ list(theta=theta, convergence=list())
})
setMethod("solveGmm", signature("allNLModel", "momentWeights"),
- function(object, wObj, theta0=NULL, algo=c("optim","nlminb"), ...)
+ function(object, wObj, theta0=NULL, algo=algoObj("optim"), ...)
{
- algo <- match.arg(algo)
- if (is.null(theta0))
- theta0 <- modelDims(object)$theta0
- g <- function(theta, wObj, object)
- evalGmmObj(object, theta, wObj)
- dg <- function(theta, wObj, object)
- {
- gt <- evalMoment(object, theta)
- n <- nrow(gt)
- gt <- colMeans(gt)
- G <- evalDMoment(object, theta)
- obj <- 2*n*quadra(wObj, G, gt)
- obj
- }
- if (algo == "optim")
- {
- if ("method" %in% names(list(...)))
- res <- optim(par=theta0, fn=g, gr=dg,
- object=object, wObj=wObj, ...)
- else
- res <- optim(par=theta0, fn=g, gr=dg, method="BFGS",
- object=object, wObj=wObj, ...)
- } else {
- res <- nlminb(start=theta0, objective=g, gradient=dg,
- object=object, wObj=wObj, ...)
- }
- theta <- res$par
- names(theta) <- modelDims(object)$parNames
- list(theta=theta, convergence=res$convergence)
- })
+ if (!inherits(algo, "minAlgo"))
+ stop("algo must be an object of class algoObj created by the algoObj function")
+ if (is.null(theta0))
+ theta0 <- modelDims(object)$theta0
+ g <- function(theta, wObj, model)
+ evalGmmObj(model, theta, wObj)
+ dg <- function(theta, wObj, model)
+ {
+ gt <- evalMoment(model, theta)
+ n <- nrow(gt)
+ gt <- colMeans(gt)
+ G <- evalDMoment(model, theta)
+ obj <- 2*n*quadra(wObj, G, gt)
+ obj
+ }
+ if (algo at algo == "optim" & !("method" %in% names(list(...))))
+ {
+ sol <- minFit(object=algo, start=theta0, fct=g, gr=dg, wObj=wObj,
+ model=object, method="BFGS", ...)
+ } else {
+ sol <- minFit(object=algo, start=theta0, fct=g, gr=dg, wObj=wObj,
+ model=object, ...)
+ }
+ list(theta=sol$solution, convergence=list(message=sol$message,
+ code=sol$convergence,
+ algo=algo at algo))
+ })
-
##################### momentStrength ####################
setGeneric("momentStrength", function(object, ...) standardGeneric("momentStrength"))
@@ -1041,10 +1038,21 @@
wObj <- evalWeights(model, theta, "optimal")
evalGmmObj(model, theta, wObj)
}
- res <- optim(theta0, obj, model=model,
- ...)
- theta1 <- res$par
- convergence <- res$convergence
+ dots <- list(...)
+ if (is.null(dots$algo))
+ {
+ algo <- algoObj("optim")
+ } else {
+ algo <- dots$algo
+ dots$algo <- NULL
+ }
+ if (algo at algo == "optim" & !("method" %in% names(dots)))
+ dots$method <- "BFGS"
+ dots <- c(dots, list(object=algo, start=theta0, fct=obj, model=model))
+ res <- do.call("minFit", dots)
+ theta1 <- res$solution
+ convergence <- list(message=res$message, code=res$convergence,
+ algo=algo at algo)
wObj <- evalWeights(model, theta1, "optimal")
}
model at vcovOptions$bw <- bw
@@ -1082,7 +1090,7 @@
efficientGmm <- vcov == "iid"
wObj <- evalWeights(model, theta, "optimal")
model at vcov <- vcov
- obj <- new("tsls", theta=theta, convergence=NULL, type="tsls",
+ obj <- new("tsls", theta=theta, convergence=list(), type="tsls",
wObj=wObj, model=model, convIter=NULL, call=Call,
niter=1L, efficientGmm=efficientGmm)
obj
@@ -1102,7 +1110,7 @@
theta <- setCoef(model, theta)
if (is.null(wObj))
wObj <- evalWeights(model, theta)
- new("gmmfit", theta=theta, convergence=NULL, convIter=NULL,
+ new("gmmfit", theta=theta, convergence=list(), convIter=NULL,
call=Call, type="eval", wObj=wObj, niter=0L, efficientGmm=FALSE,
model=model)
})
Modified: pkg/momentfit/R/rModel-methods.R
===================================================================
--- pkg/momentfit/R/rModel-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/rModel-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -427,7 +427,7 @@
for (i in 1:length(object at R))
{
cat("\t")
- print(object at R[[i]])
+ print(object at R[[i]], FALSE)
}
})
@@ -437,7 +437,7 @@
for (i in 1:length(object at R))
{
cat("\t")
- print(object at R[[i]])
+ print(object at R[[i]], FALSE)
}
})
@@ -446,7 +446,7 @@
cat("Constraints:\n")
for (i in 1:length(object at R)) {
cat("\t")
- print(object at R[[i]])
+ print(object at R[[i]], FALSE)
}})
## print
@@ -719,7 +719,7 @@
wObj <- evalWeights(model2, theta=theta, w=weights)
## obj <- evalGmm(model, theta, wObj)
## Not really evalGmm. it is a model without estimation
- obj <- new("gmmfit", theta=numeric(), convergence=as.numeric(NA),
+ obj <- new("gmmfit", theta=numeric(), convergence=list(),
convIter=NULL, call=Call,
type="No estimation needed",
wObj=wObj, niter=1L, efficientGmm=FALSE, model=model)
@@ -748,7 +748,7 @@
wObj <- evalWeights(model2, theta=theta, w=weights)
## obj <- evalGmm(model, theta, wObj)
## Not really evalGmm. it is a model without estimation
- obj <- new("gmmfit", theta=numeric(), convergence=as.numeric(NA),
+ obj <- new("gmmfit", theta=numeric(), convergence=list(),
convIter=NULL, call=Call,
type="No estimation needed",
wObj=wObj, niter=1L, efficientGmm=FALSE, model=model)
@@ -777,7 +777,7 @@
wObj <- evalWeights(model2, theta=theta, w=weights)
## obj <- evalGmm(model, theta, wObj)
## Not really evalGmm. it is a model without estimation
- obj <- new("gmmfit", theta=numeric(), convergence=as.numeric(NA),
+ obj <- new("gmmfit", theta=numeric(), convergence=list(),
convIter=NULL, call=Call,
type="No estimation needed",
wObj=wObj, niter=1L, efficientGmm=FALSE, model=model)
@@ -806,7 +806,7 @@
wObj <- evalWeights(model2, theta=theta, w=weights)
## obj <- evalGmm(model, theta, wObj)
## Not really evalGmm. it is a model without estimation
- obj <- new("gmmfit", theta=numeric(), convergence=as.numeric(NA),
+ obj <- new("gmmfit", theta=numeric(), convergence=list(),
convIter=NULL, call=Call,
type="No estimation needed",
wObj=wObj, niter=1L, efficientGmm=FALSE, model=model)
Modified: pkg/momentfit/R/rsysMomentModel-methods.R
===================================================================
--- pkg/momentfit/R/rsysMomentModel-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/rsysMomentModel-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -554,7 +554,7 @@
## solveGmm
setMethod("solveGmm", c("rslinearModel","sysMomentWeights"),
- function (object, wObj, theta0 = NULL)
+ function (object, wObj, theta0 = NULL, ...)
{
if (object at cstSpec$crossEquRest)
{
@@ -572,13 +572,13 @@
G <- evalDMoment(object)
Syz <- lapply(1:length(Y), function(i) colMeans(Y[[i]]*Z[[i]]))
Syz <- do.call("c", Syz)
- G <- momentfit:::.GListToMat(G)
+ G <- .GListToMat(G)
T1 <- quadra(wObj, G)
T2 <- quadra(wObj, G, Syz)
theta <- -solve(T1, T2)
spec <- modelDims(object)
- theta <- momentfit:::.tetReshape(theta, object at eqnNames, spec$parNames)
- list(theta = theta, convergence = NULL)
+ theta <- .tetReshape(theta, object at eqnNames, spec$parNames)
+ list(theta = theta, convergence = list())
})
Modified: pkg/momentfit/R/sgmmfit-methods.R
===================================================================
--- pkg/momentfit/R/sgmmfit-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/sgmmfit-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -43,8 +43,13 @@
if (all(spec$q == spec$k) && x at type != "eval")
type <- "Equation by Equation One-Step: Just-Identified"
cat("\nEstimation: ", type, "\n", sep="")
- if (!is.null(x at convergence))
- cat("Convergence Optim: ", x at convergence, "\n")
+ if (length(x at convergence))
+ {
+ cat("Convergence code: ", x at convergence$code,
+ " (see help(", x at convergence$algo, "))\n", sep="")
+ if (!is.null(x at convergence$message))
+ cat("Convergence message: ", x at convergence$message, "\n", sep="")
+ }
if (!is.null(x at convIter))
cat("Convergence Iteration: ", x at convIter, "\n")
cat("coefficients:")
Modified: pkg/momentfit/R/summary-methods.R
===================================================================
--- pkg/momentfit/R/summary-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/summary-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -20,8 +20,13 @@
cat("\nEstimation: ", type, "\n")
if (nrow(x at coef))
{
- if (!is.null(x at convergence))
- cat("Convergence Optim: ", x at convergence, "\n")
+ if (length(x at convergence))
+ {
+ cat("Convergence code: ", x at convergence$code,
+ " (see help(", x at convergence$algo, "))\n", sep="")
+ if (!is.null(x at convergence$message))
+ cat("Convergence message: ", x at convergence$message, "\n", sep="")
+ }
if (!is.null(x at convIter))
cat("Convergence Iteration: ", x at convIter, "\n")
if (x at type == "iter")
@@ -104,8 +109,14 @@
"\n", sep = "")
else cat(x at model@vcovOptions$bw, " Bandwidth: ",
round(x at wSpec$bw, 3), "\n", sep = "")
- if (!is.null(x at convergence))
- cat("Convergence Optim: ", x at convergence, "\n")
+ if (length(x at convergence))
+ {
+ cat("Convergence code: ", x at convergence$code,
+ " (see help(", x at convergence$algo, "))\n", sep="")
+ if (!is.null(x at convergence$message))
+ cat("Convergence message: ",
+ x at convergence$message, "\n", sep="")
+ }
}
}
if (x at breadOnly) {
@@ -139,8 +150,15 @@
else cat(x at model@bw, " Bandwidth: ",
round(x at wSpec$bw, 3), "\n", sep = "")
}
- if (!is.null(x at convergence))
- cat("Convergence Optim: ", x at convergence[i], "\n")
+ if (length(x at convergence[[i]]))
+ {
+ cat("Convergence code: ", x at convergence[[i]]$code,
+ " (see help(", x at convergence[[i]]$algo,
+ "))\n", sep="")
+ if (!is.null(x at convergence[[i]]$message))
+ cat("Convergence message: ",
+ x at convergence[[i]]$message, "\n", sep="")
+ }
}
printCoefmat(x at coef[[i]], digits = digits, signif.legend=sleg, ...)
if (!is.null(str$strength)) {
Modified: pkg/momentfit/R/sysMomentModel-methods.R
===================================================================
--- pkg/momentfit/R/sysMomentModel-methods.R 2024-05-27 17:34:51 UTC (rev 238)
+++ pkg/momentfit/R/sysMomentModel-methods.R 2024-05-31 21:00:05 UTC (rev 239)
@@ -604,7 +604,7 @@
theta <- setCoef(model, theta)
if (is.null(wObj))
wObj <- evalWeights(model, theta)
- new("sgmmfit", theta=theta, convergence=NULL, convIter=NULL,
+ new("sgmmfit", theta=theta, convergence=list(), convIter=NULL,
call=Call, type="eval", wObj=wObj, niter=0L, efficientGmm=FALSE,
model=model)
})
@@ -663,7 +663,7 @@
setMethod("solveGmm", c("slinearModel", "sysMomentWeights"),
- function(object, wObj, theta0 = NULL) {
+ function(object, wObj, theta0 = NULL, ...) {
if (wObj at type=="iid" && object at sameMom)
return(ThreeSLS(object, Sigma=wObj at Sigma, qrZ=wObj at w, coefOnly=TRUE))
spec <- modelDims(object)
@@ -678,30 +678,30 @@
T2 <- quadra(wObj, G, Syz)
theta <- -solve(T1, T2)
theta <- .tetReshape(theta, object at eqnNames, object at parNames)
- list(theta=theta, convergence=NULL)
+ list(theta=theta, convergence=list())
})
setMethod("solveGmm", signature("snonlinearModel", "sysMomentWeights"),
- function (object, wObj, theta0 = NULL, ...)
+ function (object, wObj, theta0 = NULL, algo=algoObj("optim"), ...)
{
if (is.null(theta0))
theta0 <- modelDims(object)$theta0
else
theta0 <- setCoef(object, theta0)
- g <- function(theta, wObj, object){
- spec <- modelDims(object)
- theta <- .tetReshape(theta, object at eqnNames, spec$parNames)
- evalGmmObj(object, theta, wObj)
+ g <- function(theta, wObj, model){
+ spec <- modelDims(model)
+ theta <- .tetReshape(theta, model at eqnNames, spec$parNames)
+ evalGmmObj(model, theta, wObj)
}
- dg <- function(theta, wObj, object) {
- spec <- modelDims(object)
- theta <- .tetReshape(theta, object at eqnNames, spec$parNames)
- gt <- evalMoment(object, theta)
+ dg <- function(theta, wObj, model) {
+ spec <- modelDims(model)
+ theta <- .tetReshape(theta, model at eqnNames, spec$parNames)
+ gt <- evalMoment(model, theta)
gt <- do.call(cbind, gt)
n <- nrow(gt)
gt <- colMeans(gt)
- G <- evalDMoment(object, theta)
+ G <- evalDMoment(model, theta)
full <- all(sapply(1:length(G), function(i) ncol(G[[i]])==sum(spec$k)))
G <- .GListToMat(G, full)
obj <- 2 * n * quadra(wObj, G, gt)
@@ -709,19 +709,27 @@
}
spec <- modelDims(object)
theta0 <- .tetReshape(theta0, object at eqnNames, spec$parNames)
- res <- optim(par = theta0, fn = g, gr = dg, method = "BFGS",
- object = object, wObj = wObj, ...)
- theta <- .tetReshape(res$par, spec$eqnNames, spec$parNames)
- list(theta = theta, convergence = res$convergence)
+ if (algo at algo == "optim" & !("method" %in% names(list(...))))
+ {
+ sol <- minFit(object=algo, start=theta0, fct=g, gr=dg, wObj=wObj,
+ model=object, method="BFGS", ...)
+ } else {
+ sol <- minFit(object=algo, start=theta0, fct=g, gr=dg, wObj=wObj,
+ model=object, ...)
+ }
+ sol$solution <- .tetReshape(sol$solution, spec$eqnNames, spec$parNames)
+ list(theta=sol$solution, convergence=list(message=sol$message,
+ code=sol$convergence,
+ algo=algo at algo))
})
setMethod("solveGmm", signature("sfunctionModel", "sysMomentWeights"),
- function (object, wObj, theta0 = NULL, ...)
+ function (object, wObj, theta0 = NULL, algo=algoObj("optim"), ...)
{
met <- getMethod("solveGmm",
c("snonlinearModel", "sysMomentWeights"))
- met(object, wObj, theta0, ...)
+ met(object, wObj, theta0, algo, ...)
})
## vcovHAC
@@ -820,7 +828,7 @@
wObj <- evalWeights(model, w=w)
theta <- lapply(res, coef)
names(theta) <- model at eqnNames
- new("stsls", theta=theta, convergence=NULL, convIter=NULL,
+ new("stsls", theta=theta, convergence=list(), convIter=NULL,
call=Call, type="tsls", wObj=wObj, niter=1L,
efficientGmm=FALSE, model=model)
})
@@ -882,11 +890,11 @@
C <- rowSums(C)
theta <- .tetReshape(solve(A, C), model at eqnNames, spec$parNames)
if (coefOnly)
- return(list(theta=theta, convergence=NULL))
+ return(list(theta=theta, convergence=list()))
wObj <- new("sysMomentWeights", w=qrZ, Sigma=Sigma, type="iid",
momNames=spec$momNames,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 239
More information about the Gmm-commits
mailing list