[Gmm-commits] r81 - in pkg/gmm: . R man vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Oct 27 18:46:15 CET 2015
Author: chaussep
Date: 2015-10-27 18:46:15 +0100 (Tue, 27 Oct 2015)
New Revision: 81
Modified:
pkg/gmm/DESCRIPTION
pkg/gmm/NAMESPACE
pkg/gmm/NEWS
pkg/gmm/R/FinRes.R
pkg/gmm/R/Methods.gel.R
pkg/gmm/R/gel.R
pkg/gmm/R/getModel.R
pkg/gmm/R/gmm.R
pkg/gmm/R/gmmTests.R
pkg/gmm/R/momentEstim.R
pkg/gmm/man/gel.Rd
pkg/gmm/man/getLamb.Rd
pkg/gmm/man/getModel.Rd
pkg/gmm/man/gmm.Rd
pkg/gmm/man/momentEstim.Rd
pkg/gmm/vignettes/gmm_with_R.rnw
Log:
See NEWS for details
Modified: pkg/gmm/DESCRIPTION
===================================================================
--- pkg/gmm/DESCRIPTION 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/DESCRIPTION 2015-10-27 17:46:15 UTC (rev 81)
@@ -1,6 +1,6 @@
Package: gmm
-Version: 1.5-3
-Date: 2015-09-25
+Version: 1.6-0
+Date: 2015-10-23
Title: Generalized Method of Moments and Generalized Empirical
Likelihood
Author: Pierre Chausse <pchausse at uwaterloo.ca>
@@ -14,6 +14,6 @@
Kitamura(1997), Newey-Smith(2004) and Anatolyev(2005).
Depends: R (>= 2.10.0), sandwich
Suggests: mvtnorm, car, stabledist, MASS, timeDate, timeSeries
-Imports: stats
+Imports: stats, methods, grDevices, graphics
License: GPL (>= 2)
Modified: pkg/gmm/NAMESPACE
===================================================================
--- pkg/gmm/NAMESPACE 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/NAMESPACE 2015-10-27 17:46:15 UTC (rev 81)
@@ -1,15 +1,17 @@
import(stats)
importFrom(sandwich, estfun, bread, kernHAC, weightsAndrews, vcovHAC, bwAndrews, meatHC)
+importFrom(methods, is)
+importFrom(graphics, abline, legend, lines, panel.smooth, par, plot, points)
+importFrom(grDevices, dev.interactive, devAskNewPage, extendrange)
-
export(gmm,summary.gmm,smoothG,getDat,summary.gel,getLamb,gel, estfun.gmmFct, estfun.gmm, estfun.gel, bread.gel, bread.gmm,
- print.gmm,coef.gmm,vcov.gmm,print.summary.gmm, confint.gel, print.gel, print.summary.gel, vcov.gel, coef.gel, fitted.gmm,
- residuals.gmm, fitted.gel, residuals.gel, plot.gmm, plot.gel,formula.gmm, formula.gel, charStable, specTest,
- specTest.gmm, specTest.gel, print.specTest, momentEstim.baseGmm.twoStep, momentEstim.baseGmm.twoStep.formula,
- momentEstim.baseGmm.iterative.formula, momentEstim.baseGmm.iterative, momentEstim.baseGmm.cue.formula,
- momentEstim.baseGmm.cue, getModel.baseGmm, getModel.baseGel, getModel.constGmm, FinRes.baseGmm.res, momentEstim.baseGel.mod,
- momentEstim.baseGel.modFormula,tsls,summary.tsls, print.summary.tsls, KTest, print.gmmTests, gmmWithConst, estfun.tsls,
- model.matrix.tsls,vcov.tsls, bread.tsls)
+ print.gmm,coef.gmm,vcov.gmm,print.summary.gmm, confint.gel, print.gel, print.summary.gel, vcov.gel, coef.gel, fitted.gmm,
+ residuals.gmm, fitted.gel, residuals.gel, plot.gmm, plot.gel,formula.gmm, formula.gel, charStable, specTest,
+ specTest.gmm, specTest.gel, print.specTest, momentEstim.baseGmm.twoStep, momentEstim.baseGmm.twoStep.formula,
+ momentEstim.baseGmm.iterative.formula, momentEstim.baseGmm.iterative, momentEstim.baseGmm.cue.formula,
+ momentEstim.baseGmm.cue, getModel.baseGmm, getModel.baseGel, getModel.constGmm, getModel.constGel,
+ FinRes.baseGmm.res, momentEstim.baseGel.mod, momentEstim.baseGel.modFormula,tsls,summary.tsls, print.summary.tsls,
+ KTest, print.gmmTests, gmmWithConst, estfun.tsls, model.matrix.tsls,vcov.tsls, bread.tsls, evalGmm, momentEstim.baseGmm.eval)
S3method(summary, gmm)
S3method(summary, tsls)
@@ -42,7 +44,9 @@
S3method(getModel, baseGmm)
S3method(getModel, baseGel)
S3method(getModel, constGmm)
+S3method(getModel, constGel)
S3method(momentEstim, baseGmm.twoStep)
+S3method(momentEstim, baseGmm.eval)
S3method(momentEstim, baseGmm.twoStep.formula)
S3method(momentEstim, baseGmm.iterative.formula)
S3method(momentEstim, baseGmm.iterative)
Modified: pkg/gmm/NEWS
===================================================================
--- pkg/gmm/NEWS 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/NEWS 2015-10-27 17:46:15 UTC (rev 81)
@@ -1,8 +1,17 @@
-Changes in version 1.5-3
+Changes in version 1.6-0
o Fixed a typo in FinRes.R file. It was preventing to compute the proper vcov matrix for a very special case (fixed weights)
o Added Helinger distance and Exponentially tilted Helinger estimator to gel()
o Fixed the LR test of ETEL in gel()
+o Cleaned a lot of the codes. In particular, a single moment function and its gradiant function is used now.
+ There is also a common weighting matrix generator function. The main goal is to make it more flexible and give the possibility
+ of creating weighting matrix based on other assumption such as clustering.
+o For GEL with smooth=TRUE, the weights were not fixed which was creating problems of convergence.
+o Add the option of fixing the value of some coefficient in gel as it as already the case for gmmm.
+o It is no possible to provide gmm with the gradiant function when constrOptim is used.
+o There is now an evalGmm() function to create a gmm object with a given fixed vector. Not estimation is done, but the bandwidth and weights
+ for the HAC estimator are generated. It is possible to give a different vector os parameters for the moment function and the weighting matrix.
+o Fixed NAMESPACE to avoid the notes given by CRAN.
Changes in version 1.5-2
Modified: pkg/gmm/R/FinRes.R
===================================================================
--- pkg/gmm/R/FinRes.R 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/R/FinRes.R 2015-10-27 17:46:15 UTC (rev 81)
@@ -42,36 +42,15 @@
initTheta[-eqConst[,1]] <- z$initTheta
z$initTheta <- initTheta
}
- z$df <- z$df+nrow(eqConst)
- z$k <- z$k2+nrow(eqConst)
- z$k2 <- z$k+nrow(eqConst)
- z$gradv <- attr(x,"eqConst")$unConstgradv
- z$g <- attr(x,"eqConst")$unConstg
+ z$k <- z$k+nrow(eqConst)
+ z$k2 <- z$k2+nrow(eqConst)
+ attr(x, "eqConst") <- NULL
z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values **\n\n")
- }
-
- if (length(as.list(args(z$gradv))) == 2)
- z$G <- z$gradv(x)
- else if (length(as.list(args(z$gradv))) == 3)
- z$G <- z$gradv(z$coefficients, x)
- else
- z$G <- z$gradv(z$coefficients, x, g = z$g)
-
- G <- z$G
- iid <- z$iid
-
- if (P$vcov == "iid")
- {
- v <- iid(z$coefficients, x, z$g, P$centeredVcov)
- z$v <- v
}
- else if(P$vcov == "HAC")
- {
- if (!is.null(attr(z$w0,"Spec")))
- object$WSpec$sandwich$bw <- attr(z$w0,"Spec")$bw
- v <- .myKernHAC(z$gt, object)
- z$v <- v
- }
+ z$G <- z$gradv(z$coefficients, x)
+ G <- z$G
+ v <- .weightFct(z$coefficient, x, P$vcov)
+ z$v <- v
if (P$vcov == "TrueFixed")
{
z$vcov=try(solve(crossprod(G, P$weightsMatrix) %*% G)/n, silent = TRUE)
@@ -108,7 +87,7 @@
}
else
z$vcov <- T1%*%v%*%t(T1)/n
- }
+ }
dimnames(z$vcov) <- list(names(z$coefficients), names(z$coefficients))
z$call <- P$call
Modified: pkg/gmm/R/Methods.gel.R
===================================================================
--- pkg/gmm/R/Methods.gel.R 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/R/Methods.gel.R 2015-10-27 17:46:15 UTC (rev 81)
@@ -61,9 +61,9 @@
print.gel <- function(x, digits = 5, ...)
{
if (is.null(x$CGEL))
- cat("Type de GEL: ", x$type, "\n")
+ cat("Type de GEL: ", x$typeDesc, "\n")
else
- cat("CGEL of type: ", x$type, " (alpha = ", x$CGEL, ")\n")
+ cat("CGEL of type: ", x$typeDesc, " (alpha = ", x$CGEL, ")\n")
if (!is.null(attr(x$dat,"smooth")))
{
cat("Kernel: ", attr(x$dat,"smooth")$kernel," (bw=",
@@ -75,13 +75,18 @@
cat("Coefficients:\n")
print.default(format(coef(x), digits = digits),
print.gap = 2, quote = FALSE)
- cat("\n")
- cat("Lambdas:\n")
- print.default(format(coef(x, lambda = TRUE), digits = digits),
- print.gap = 2, quote = FALSE)
- cat("\n")
+ if (length(x$coefficients)<length(x$lambda))
+ {
+ cat("\n")
+ cat("Lambdas:\n")
+ print.default(format(coef(x, lambda = TRUE), digits = digits),
+ print.gap = 2, quote = FALSE)
+ }
+ cat("\n")
cat("Convergence code for the coefficients: ", x$conv_par,"\n")
- cat("Convergence code for Lambda: ", x$conv_lambda$convergence,"\n")
+ if (length(x$coefficients)<length(x$lambda))
+ cat("Convergence code for Lambda: ", x$conv_lambda$convergence,"\n")
+ cat(x$specMod)
invisible(x)
}
@@ -90,9 +95,9 @@
cat("\nCall:\n")
cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "")
if (is.null(x$CGEL))
- cat("Type of GEL: ", x$type, "\n")
+ cat("Type of GEL: ", x$typeDesc, "\n")
else
- cat("CGEL of type: ", x$type, " (alpha = ", x$CGEL, ")\n")
+ cat("CGEL of type: ", x$typeDesc, " (alpha = ", x$CGEL, ")\n")
if (!is.null(x$smooth))
{
@@ -105,16 +110,20 @@
print.default(format(x$coefficients, digits = digits),
print.gap = 2, quote = FALSE)
- cat("\nLambdas:\n")
- print.default(format(x$lambda, digits=digits),
- print.gap = 2, quote = FALSE)
-
- cat("\n", x$stest$ntest, "\n")
- print.default(format(x$stest$test, digits=digits),
- print.gap = 2, quote = FALSE)
-
+ if (length(x$coefficients)<length(x$lambda))
+ {
+ cat("\nLambdas:\n")
+ print.default(format(x$lambda, digits=digits),
+ print.gap = 2, quote = FALSE)
+
+ cat("\n", x$stest$ntest, "\n")
+ print.default(format(x$stest$test, digits=digits),
+ print.gap = 2, quote = FALSE)
+ }
+ cat(x$specMod)
cat("\nConvergence code for the coefficients: ", x$conv_par, "\n")
- cat("\nConvergence code for the lambdas: ", x$conv_lambda$convergence, "\n")
+ if (length(x$coefficients)<length(x$lambda))
+ cat("\nConvergence code for the lambdas: ", x$conv_lambda$convergence, "\n")
invisible(x)
}
Modified: pkg/gmm/R/gel.R
===================================================================
--- pkg/gmm/R/gel.R 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/R/gel.R 2015-10-27 17:46:15 UTC (rev 81)
@@ -184,50 +184,48 @@
smoothG <- function (x, bw = bwAndrews, prewhite = 1, ar.method = "ols", weights = weightsAndrews,
kernel = c("Bartlett", "Parzen", "Truncated", "Tukey-Hanning"), approx = c("AR(1)", "ARMA(1,1)"),
tol = 1e-7)
- {
+ {
kernel <- match.arg(kernel)
approx <- match.arg(approx)
-
+
n <- nrow(x)
if (is.function(weights))
- {
- class(x) <- "gmmFct"
- w <- weights(x, bw = bw, kernel = kernel,
- prewhite = prewhite, ar.method = ar.method, tol = tol,
- verbose = FALSE, approx = approx)
- }
- else
- w <- weights
+ {
+ class(x) <- "gmmFct"
+ w <- weights(x, bw = bw, kernel = kernel,
+ prewhite = prewhite, ar.method = ar.method, tol = tol,
+ verbose = FALSE, approx = approx)
+ } else {
+ w <- weights
+ }
+ if (is.numeric(w))
+ {
+ rt <- length(w)
+ if (rt >= 2)
+ {
+ w <- c(w[rt:2], w)
+ w <- w / sum(w)
+ w <- kernel(w[rt:length(w)])
+ } else {
+ w <- kernel(1)
+ }
+ } else {
+ if (class(w) != "tskernel")
+ stop("Provided weights must be a numeric vector or an object of class 'tskernel'")
+ }
+ if (length(w$coef)>1)
+ x <- kernapply(x, w)
+ sx <- list("smoothx" = x, "kern_weights" = w, bw = bw)
+ return(sx)
+ }
+
-
- rt <- length(w)
- if (rt >= 2)
- {
- rt <- length(w)
- if (rt>1)
- {
- w <- c(w[rt:2], w)
- w <- w / sum(w)
- w <- kernel(w[rt:length(w)])
- }
- else
- w <- kernel(1)
-
- x <- kernapply(x,w)
- sx <- list("smoothx" = x, "kern_weights" = w)
- return(sx)
- }
- else
- sx <- list("smoothx" = x,"kern_weights" = kernel(1))
- return(sx)
- }
-
-
-gel <- function(g, x, tet0, gradv = NULL, smooth = FALSE, type = c("EL", "ET", "CUE", "ETEL", "HD", "ETHD"),
+gel <- function(g, x, tet0 = NULL, gradv = NULL, smooth = FALSE, type = c("EL", "ET", "CUE", "ETEL", "HD", "ETHD"),
kernel = c("Truncated", "Bartlett"), bw = bwAndrews, approx = c("AR(1)",
"ARMA(1,1)"), prewhite = 1, ar.method = "ols", tol_weights = 1e-7, tol_lam = 1e-9, tol_obj = 1e-9,
tol_mom = 1e-9, maxiterlam = 100, constraint = FALSE, optfct = c("optim", "optimize", "nlminb"),
- optlam = c("nlminb", "optim", "iter"), data, Lambdacontrol = list(), model = TRUE, X = FALSE, Y = FALSE, TypeGel = "baseGel", alpha = NULL, ...)
+ optlam = c("nlminb", "optim", "iter"), data, Lambdacontrol = list(), model = TRUE, X = FALSE, Y = FALSE, TypeGel = "baseGel", alpha = NULL,
+ eqConst = NULL, eqConstFullVcov = FALSE, ...)
{
type <- match.arg(type)
@@ -236,6 +234,9 @@
weights <- weightsAndrews
approx <- match.arg(approx)
kernel <- match.arg(kernel)
+ if (!is.null(eqConst))
+ TypeGel <- "constGel"
+
if(missing(data))
data<-NULL
all_args <- list(g = g, x = x, tet0 = tet0, gradv = gradv, smooth = smooth, type = type,
@@ -243,7 +244,7 @@
tol_weights = tol_weights, tol_lam = tol_lam, tol_obj = tol_obj, tol_mom = tol_mom,
maxiterlam = maxiterlam, constraint = constraint, optfct = optfct, weights = weights,
optlam = optlam, model = model, X = X, Y = Y, TypeGel = TypeGel, call = match.call(),
- Lambdacontrol = Lambdacontrol, alpha = alpha, data = data)
+ Lambdacontrol = Lambdacontrol, alpha = alpha, data = data, eqConst = eqConst, eqConstFullVcov = eqConstFullVcov)
class(all_args)<-TypeGel
Model_info<-getModel(all_args)
@@ -256,44 +257,47 @@
.thetf <- function(tet, P, output=c("obj","all"), l0Env)
{
- output <- match.arg(output)
- gt <- P$g(tet, P$dat)
- l0 <- get("l0",envir=l0Env)
- if (is.null(P$CGEL))
- {
- if (P$optlam != "optim" & P$type == "EL")
- {
- lamb <- try(getLamb(gt, l0, type = P$type, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam,
- tol_obj = P$tol_obj, k = P$k1/P$k2, control = P$Lambdacontrol,
- method = P$optlam), silent = TRUE)
- if(class(lamb) == "try-error")
- lamb <- getLamb(gt, l0, type = P$type, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam,
- tol_obj = P$tol_obj, k = P$k1/P$k2, control = P$Lambdacontrol, method = "optim")
- }
- else
+ output <- match.arg(output)
+ gt <- P$g(tet, P$x)
+ l0 <- get("l0",envir=l0Env)
+ if (((P$type=="ETEL")|(P$type=="ETHD"))&(!is.null(P$CGEL)))
+ {
+ P$CGEL <- NULL
+ warning("CGEL not implemented for ETEL no for ETHD")
+ }
+ if (is.null(P$CGEL))
+ {
+ if (P$optlam != "optim" & P$type == "EL")
+ {
+ lamb <- try(getLamb(gt, l0, type = P$type, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam,
+ tol_obj = P$tol_obj, k = P$k1/P$k2, control = P$Lambdacontrol,
+ method = P$optlam), silent = TRUE)
+ if(class(lamb) == "try-error")
+ lamb <- getLamb(gt, l0, type = P$type, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam,
+ tol_obj = P$tol_obj, k = P$k1/P$k2, control = P$Lambdacontrol, method = "optim")
+ }
+ else
lamb <- getLamb(gt, l0, type = P$type, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam,
- tol_obj = P$tol_obj, k = P$k1/P$k2, control = P$Lambdacontrol, method = P$optlam)
- }
- else
- {
- if ((P$type=="ETEL")|(P$type=="ETHD"))
- stop("CGEL not implemented for ETEL nor for ETHD")
- lamb <- try(.getCgelLam(gt, l0, type = P$type, method = "nlminb", control=P$Lambdacontrol,
- k = P$k1/P$k2, alpha = P$CGEL),silent=TRUE)
- if (class(lamb) == "try-error")
- lamb <- try(.getCgelLam(gt, l0, type = P$type, method = "constrOptim", control=P$Lambdacontrol,
- k = P$k1/P$k2, alpha = P$CGEL),silent=TRUE)
- }
- if (P$type != "ETHD")
- obj <- mean(.rho(gt, lamb$lambda, type = P$type, derive = 0, k = P$k1/P$k2)-
- .rho(1, 0, type = P$type, derive = 0, k = P$k1/P$k2))
- else
- obj <- sum(.rho(gt, lamb$lambda, type = P$type, derive = 0, k = P$k1/P$k2)-
- .rho(1, 0, type = P$type, derive = 0, k = P$k1/P$k2))
- assign("l0",lamb$lambda,envir=l0Env)
- if(output == "obj")
+ tol_obj = P$tol_obj, k = P$k1/P$k2, control = P$Lambdacontrol, method = P$optlam)
+ }
+ else
+ {
+ lamb <- try(.getCgelLam(gt, l0, type = P$type, method = "nlminb", control=P$Lambdacontrol,
+ k = P$k1/P$k2, alpha = P$CGEL),silent=TRUE)
+ if (class(lamb) == "try-error")
+ lamb <- try(.getCgelLam(gt, l0, type = P$type, method = "constrOptim", control=P$Lambdacontrol,
+ k = P$k1/P$k2, alpha = P$CGEL),silent=TRUE)
+ }
+ if (P$type != "ETHD")
+ obj <- mean(.rho(gt, lamb$lambda, type = P$type, derive = 0, k = P$k1/P$k2)-
+ .rho(1, 0, type = P$type, derive = 0, k = P$k1/P$k2))
+ else
+ obj <- sum(.rho(gt, lamb$lambda, type = P$type, derive = 0, k = P$k1/P$k2)-
+ .rho(1, 0, type = P$type, derive = 0, k = P$k1/P$k2))
+ assign("l0",lamb$lambda,envir=l0Env)
+ if(output == "obj")
return(obj)
- else
+ else
return(list(obj = obj, lambda = lamb, gt = gt))
}
Modified: pkg/gmm/R/getModel.R
===================================================================
--- pkg/gmm/R/getModel.R 2015-09-22 19:53:58 UTC (rev 80)
+++ pkg/gmm/R/getModel.R 2015-10-27 17:46:15 UTC (rev 81)
@@ -12,342 +12,282 @@
# http://www.r-project.org/Licenses/
getModel <- function(object, ...)
- {
- UseMethod("getModel")
- }
+ {
+ UseMethod("getModel")
+ }
getModel.constGmm <- function(object, ...)
- {
- class(object) <- "baseGmm"
- obj <- getModel(object)
- if (!is.null(object$t0))
- {
- if (!is.null(dim(object$eqConst)))
- stop("When t0 is provided, eqConst must be a vector")
- if (length(object$eqConst)>=length(object$t0))
- stop("Too many constraints")
- if (is.character(object$eqConst))
- {
- if (is.null(names(object$t0)))
- stop("t0 must be a named vector if you want eqConst to be names")
- if (any(!(object$eqConst %in% names(object$t0))))
- stop("Wrong coefficient names in eqConst")
- object$eqConst <- sort(match(object$eqConst,names(object$t0)))
- }
- restTet <- object$t0[object$eqConst]
- obj$t0 <- object$t0[-object$eqConst]
- object$eqConst <- cbind(object$eqConst,restTet)
- } else {
- if (is.null(dim(object$eqConst)))
- stop("When t0 is not provided, eqConst must be a 2xq matrix")
- }
- rownames(object$eqConst) <- obj$namesCoef[object$eqConst[,1]]
- if(is(object$g, "formula"))
- {
- if (obj$x$ny>1)
- stop("Constrained GMM not implemented yet for system of equations")
- obj$g2 <- function(tet, dat)
- {
- x <- attr(dat,"eqConst")$Xunc
- y <- attr(dat,"eqConst")$Yunc
- ny <- 1
- nh <- dat$nh
- tet <- matrix(tet, ncol = ncol(x))
- e <- y - x %*% t(tet)
- gt <- e * dat$x[, ny+dat$k+1]
- if(nh > 1)
- for (i in 2:nh) gt <- cbind(gt, e*x[, (ny+dat$k+i)])
- return(gt)
- }
- obj$gradv2 <- function(dat)
- {
- x <- attr(dat,"eqConst")$Xunc
- y <- attr(dat,"eqConst")$Yunc
- nh <- dat$nh
- k <- ncol(x)
- ny <- 1
- dat$x <- cbind(y,x,dat$x[, dat$ny+dat$k+(1:nh)])
- dgb <- -(t(dat$x[,(ny+k+1):(ny+k+nh)]) %*% dat$x[,(ny+1):(ny+k)]) %x% diag(rep(1,ny))/nrow(x)
- return(dgb)
- }
- attr(obj$x,"eqConst") <- list(unConstg = obj$g2, unConstgradv = obj$gradv2, eqConst = object$eqConst,
- Yunc = obj$x$x[,1], Xunc = as.matrix(obj$x$x[,1+(1:obj$x$k)]))
- x <- as.matrix(obj$x$x[,1+(object$eqConst[,1])])%*%object$eqConst[,2]
- obj$x$x <- obj$x$x[,-(1+(object$eqConst[,1]))]
- obj$x$x[,1] <- obj$x$x[,1]-x
- obj$x$k <- obj$x$k-nrow(object$eqConst)
- if (obj$x$k<=0)
- stop("Nothing to estimate")
- } else {
- attr(obj$x,"eqConst") <- list(unConstg = obj$g, unConstgradv = obj$gradv, eqConst = object$eqConst)
- obj$g <- function(tet, dat)
- {
- resTet <- attr(dat,"eqConst")$eqConst
- tet2 <- vector(length=length(tet)+nrow(resTet))
- tet2[resTet[,1]] <- resTet[,2]
- tet2[-resTet[,1]] <- tet
- attr(dat,"eqConst")$unConstg(tet2, dat)
- }
- obj$gradv <- function(tet, dat)
- {
- resTet <- attr(dat,"eqConst")$eqConst
- tet2 <- vector(length=length(tet)+nrow(resTet))
- tet2[resTet[,1]] <- resTet[,2]
- tet2[-resTet[,1]] <- tet
- if (!is.null(as.list(args(attr(dat,"eqConst")$unConstgradv))$g))
- attr(dat,"eqConst")$unConstgradv(tet2, dat, g=attr(dat,"eqConst")$unConstg)[,-resTet[,1]]
- else
- attr(dat,"eqConst")$unConstgradv(tet2, dat)[,-resTet[,1]]
- }
- }
-
- obj$eqConst <- object$eqConst
- obj$namesCoef <- obj$namesCoef[-object$eqConst[,1]]
- obj$type <- paste(obj$type,"(with equality constraints)",sep=" ")
- mess <- paste(rownames(object$eqConst), " = " , object$eqConst[,2], "\n",collapse="")
- mess <- paste("#### Equality constraints ####\n",mess,"##############################\n\n",sep="")
- obj$specMod <- mess
- return(obj)
- }
+ {
+ class(object) <- "baseGmm"
+ obj <- getModel(object)
+ if (!is.null(object$t0))
+ {
+ if (!is.null(dim(object$eqConst)))
+ stop("When t0 is provided, eqConst must be a vector which indicates which parameters to fix")
+ if (length(object$eqConst)>=length(object$t0))
+ stop("Too many constraints; use evalGmm() if all coefficients are fixed")
+ if (is.character(object$eqConst))
+ {
+ if (is.null(names(object$t0)))
+ stop("t0 must be a named vector if you want eqConst to be names")
+ if (any(!(object$eqConst %in% names(object$t0))))
+ stop("Wrong coefficient names in eqConst")
+ object$eqConst <- sort(match(object$eqConst,names(object$t0)))
+ }
+ restTet <- object$t0[object$eqConst]
+ obj$t0 <- object$t0[-object$eqConst]
+ object$eqConst <- cbind(object$eqConst,restTet)
+ } else {
+ if (is.null(dim(object$eqConst)))
+ stop("When t0 is not provided, eqConst must be a 2xq matrix")
+ }
+ attr(obj$x, "eqConst") <- list(eqConst = object$eqConst)
+ rownames(attr(obj$x, "eqConst")$eqConst) <- obj$namesCoef[object$eqConst[,1]]
+ object$eqConst <- attr(obj$x, "eqConst")$eqConst
+ if(is(object$g, "formula"))
+ {
+ if (obj$x$ny>1)
+ stop("Constrained GMM not implemented yet for system of equations")
+ if (obj$x$k<=0)
+ stop("Nothing to estimate")
+ }
+ obj$eqConst <- object$eqConst
+ attr(obj$x, "k") <- attr(obj$x, "k")-nrow(object$eqConst)
+ obj$namesCoef <- obj$namesCoef[-object$eqConst[,1]]
+ obj$type <- paste(obj$type,"(with equality constraints)",sep=" ")
+ mess <- paste(rownames(object$eqConst), " = " , object$eqConst[,2], "\n",collapse="")
+ mess <- paste("#### Equality constraints ####\n",mess,"##############################\n\n",sep="")
+ obj$specMod <- mess
+ return(obj)
+ }
getModel.baseGmm <- function(object, ...)
- {
- object$allArg <- c(object, list(...))
- if(is(object$g, "formula"))
{
- object$gradvf <- FALSE
- if (is.null(object$data))
- dat <- getDat(object$g, object$x)
- else
- dat <- getDat(object$g, object$x, object$data)
-
- if(is.null(object$weightsMatrix))
- {
- clname <- paste(class(object), ".", object$type, ".formula", sep = "")
- }
- else
- {
- clname <- "fixedW.formula"
- object$type <- "One step GMM with fixed W"
- }
- object$gform<-object$g
- g <- function(tet, dat)
- {
- x <- dat$x
- ny <- dat$ny
- nh <- dat$nh
- k <- dat$k
- tet <- matrix(tet, ncol = k)
- e <- x[,1:ny] - x[,(ny+1):(ny+k)] %*% t(tet)
- gt <- e * x[, ny+k+1]
- if(nh > 1)
- for (i in 2:nh) gt <- cbind(gt, e*x[, (ny+k+i)])
- return(gt)
- }
- gradv <- function(dat)
- {
- x <- dat$x
- ny <- dat$ny
- nh <- dat$nh
- k <- dat$k
- dgb <- -(t(x[,(ny+k+1):(ny+k+nh)]) %*% x[,(ny+1):(ny+k)]) %x% diag(rep(1,ny))/nrow(x)
- return(dgb)
- }
-
- namex <- colnames(dat$x[,(dat$ny+1):(dat$ny+dat$k)])
- nameh <- colnames(dat$x[,(dat$ny+dat$k+1):(dat$ny+dat$k+dat$nh)])
-
- if (dat$ny > 1)
- {
- namey <- colnames(dat$x[,1:dat$ny])
- object$namesCoef <- paste(rep(namey, dat$k), "_", rep(namex, rep(dat$ny, dat$k)), sep = "")
- object$namesgt <- paste(rep(namey, dat$nh), "_", rep(nameh, rep(dat$ny, dat$nh)), sep = "")
- } else {
- object$namesCoef <- namex
- object$namesgt <- nameh
- }
- object$g <- g
- object$x <- dat
- attr(object$x,"ModelType") <- "linear"
+ object$allArg <- c(object, list(...))
+ if(is(object$g, "formula"))
+ {
+ object$gradv <- .DmomentFct
+ object$gradvf <- FALSE
+ if (is.null(object$data))
+ dat <- getDat(object$g, object$x)
+ else
+ dat <- getDat(object$g, object$x, object$data)
+ if(is.null(object$weightsMatrix))
+ {
+ clname <- paste(class(object), ".", object$type, ".formula", sep = "")
+ } else {
+ clname <- "fixedW.formula"
+ object$type <- "One step GMM with fixed W"
+ }
+ object$x <- dat
+ object$gform<-object$g
+ namex <- colnames(dat$x[,(dat$ny+1):(dat$ny+dat$k)])
+ nameh <- colnames(dat$x[,(dat$ny+dat$k+1):(dat$ny+dat$k+dat$nh)])
+ if (dat$ny > 1)
+ {
+ namey <- colnames(dat$x[,1:dat$ny])
+ object$namesCoef <- paste(rep(namey, dat$k), "_", rep(namex, rep(dat$ny, dat$k)), sep = "")
+ object$namesgt <- paste(rep(namey, dat$nh), "_", rep(nameh, rep(dat$ny, dat$nh)), sep = "")
+ } else {
+ object$namesCoef <- namex
+ object$namesgt <- nameh
+ }
+ attr(object$x,"ModelType") <- "linear"
+ attr(object$x, "k") <- object$x$k
+ attr(object$x, "q") <- object$x$ny*object$x$nh
+ attr(object$x, "n") <- NROW(object$x$x)
+ } else {
+ attr(object$x,"ModelType") <- "nonlinear"
+ attr(object$x, "momentfct") <- object$g
+ attr(object$x, "k") <- length(object$t0)
+ attr(object$x, "q") <- NCOL(object$g(object$t0, object$x))
+ attr(object$x, "n") <- NROW(object$x)
+ if(is.null(names(object$t0)))
+ object$namesCoef <- paste("Theta[" ,1:attr(object$x, "k"), "]", sep = "")
+ else
+ object$namesCoef <- names(object$t0)
+ if(is.null(object$weightsMatrix))
+ {
+ clname <- paste(class(object), "." ,object$type, sep = "")
+ } else {
+ clname <- "fixedW"
+ object$type <- "One step GMM with fixed W"
+ attr(object$x, "weight")$w <- object$weightsMatrix
+ }
+ if (!is.function(object$gradv))
+ {
+ object$gradvf <- FALSE
+ } else {
+ attr(object$x, "gradv") <- object$gradv
+ object$gradvf <- TRUE
+ }
+ object$gradv <- .DmomentFct
+ }
+ object$TypeGmm <- class(object)
+ attr(object$x, "weight") <- list(w=object$weightsMatrix,
+ centeredVcov=object$centeredVcov)
+ attr(object$x, "weight")$WSpec <- list()
+ attr(object$x, "weight")$WSpec$sandwich <- list(kernel = object$kernel, bw = object$bw,
+ prewhite = object$prewhite,
+ ar.method = object$ar.method,
+ approx = object$approx, tol = object$tol)
+ attr(object$x, "weight")$vcov <- object$vcov
+ object$g <- .momentFct
+ class(object) <- clname
+ return(object)
}
- else
- {
- attr(object$x,"ModelType") <- "nonlinear"
- k <- length(object$t0)
- if(is.null(names(object$t0)))
- object$namesCoef <- paste("Theta[" ,1:k, "]", sep = "")
- else
- object$namesCoef <- names(object$t0)
- if(is.null(object$weightsMatrix))
- {
- clname <- paste(class(object), "." ,object$type, sep = "")
- }
- else
- {
- clname <- "fixedW"
- object$type <- "One step GMM with fixed W"
- }
- if (!is.function(object$gradv))
- {
- gradv <- .Gf
- object$gradvf <- FALSE
- }
- else
- {
- gradv <- object$gradv
- object$gradvf <- TRUE
- }
- }
-
- iid <- function(thet, x, g, centeredVcov)
+getModel.constGel <- function(object, ...)
{
- gt <- g(thet,x)
- if(centeredVcov) gt <- residuals(lm(gt~1))
- n <- ifelse(is.null(nrow(gt)), length(gt), nrow(gt))
- v <- crossprod(gt,gt)/n
- return(v)
+ class(object) <- "baseGel"
+ obj <- getModel(object)
+ if (!is.null(dim(object$eqConst)))
+ stop("eqConst must be a vector which indicates which parameters to fix")
+ if (length(object$eqConst)>=length(object$tet0))
+ stop("Too many constraints; use evalGel() if all coefficients are fixed")
+ if (is.character(object$eqConst))
+ {
+ if (is.null(names(object$tet0)))
+ stop("tet0 must be a named vector if you want eqConst to be names")
+ if (any(!(object$eqConst %in% names(object$tet0))))
+ stop("Wrong coefficient names in eqConst")
+ object$eqConst <- sort(match(object$eqConst,names(object$tet0)))
+ }
+ restTet <- object$tet0[object$eqConst]
+ obj$tet0 <- object$tet0[-object$eqConst]
+ object$eqConst <- cbind(object$eqConst,restTet)
+ attr(obj$x, "eqConst") <- list(eqConst = object$eqConst)
+ rownames(attr(obj$x, "eqConst")$eqConst) <- obj$namesCoef[object$eqConst[,1]]
+ object$eqConst <- attr(obj$x, "eqConst")$eqConst
+ if(is(object$g, "formula"))
+ {
+ if (obj$x$ny>1)
+ stop("Constrained GMM not implemented yet for system of equations")
+ }
+ obj$eqConst <- object$eqConst
+ attr(obj$x, "k") <- attr(obj$x, "k")-nrow(object$eqConst)
+ obj$namesCoef <- obj$namesCoef[-object$eqConst[,1]]
+ obj$type <- paste(obj$type,"(with equality constraints)",sep=" ")
+ mess <- paste(rownames(object$eqConst), " = " , object$eqConst[,2], "\n",collapse="")
+ mess <- paste("#### Equality constraints ####\n",mess,"##############################\n\n",sep="")
+ obj$specMod <- mess
+ return(obj)
}
-
-
- object$iid<-iid
- object$TypeGmm <- class(object)
- object$gradv <- gradv
- object$WSpec <- list(vcov = object$vcov, sandwich = list(kernel = object$kernel, bw = object$bw, prewhite = object$prewhite,
- ar.method = object$ar.method, approx = object$approx, tol = object$tol))
- class(object) <- clname
- return(object)
- }
getModel.baseGel <- function(object, ...)
- {
-
- P <- object
- if(P$optfct == "optim" | P$optfct == "nlminb")
- P$k <- length(P$tet0)
- else
- P$k <- 1
-
- if (is(P$g, "formula"))
{
- clname <- paste(class(P), ".modFormula", sep = "")
- if (is.null(P$data))
- dat <- getDat(P$g, P$x)
- else
- dat <- getDat(P$g, P$x, P$data)
- if (P$k != dat$k)
- stop("The length of tet0 does not match the number of regressors")
-
- g <- function(tet, dat)
- {
- x <- dat$x
- ny <- dat$ny
- nh <- dat$nh
- k <- dat$k
- tet <- matrix(tet, ncol = k)
- e <- x[,1:ny] - x[, (ny+1):(ny+k)]%*%t(tet)
- gt <- e*x[, ny+k+1]
- if (nh > 1)
- {
- for (i in 2:nh)
- {
- gt <- cbind(gt, e*x[,(ny+k+i)])
- }
+ object$allArg <- c(object, list(...))
+ if(is(object$g, "formula"))
+ {
+ dat <- getDat(object$g, object$x, data = object$data)
+ k <- dat$k
+ if (is.null(object$tet0))
+ {
+ if (!is.null(object$eqConst))
+ stop("You have to provide tet0 with equality constrains")
+ if (object$optfct == "optimize")
+ stop("For optimize, you must provide the 2x1 vector tet0")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 81
More information about the Gmm-commits
mailing list