[Gmm-commits] r21 - in pkg/gmm: . R inst/doc man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Feb 3 21:31:32 CET 2010
Author: chaussep
Date: 2010-02-03 21:31:28 +0100 (Wed, 03 Feb 2010)
New Revision: 21
Added:
pkg/gmm/man/bread.Rd
pkg/gmm/man/estfun.Rd
Removed:
pkg/gmm/R/HAC.R
pkg/gmm/man/HAC.Rd
pkg/gmm/man/kweights2.Rd
pkg/gmm/man/weightsAndrews2.Rd
Modified:
pkg/gmm/DESCRIPTION
pkg/gmm/NAMESPACE
pkg/gmm/NEWS
pkg/gmm/R/FinRes.R
pkg/gmm/R/Methods.gel.R
pkg/gmm/R/Methods.gmm.R
pkg/gmm/R/gel.R
pkg/gmm/R/getModel.R
pkg/gmm/R/gmm.R
pkg/gmm/R/momentEstim.R
pkg/gmm/inst/doc/empir.bib
pkg/gmm/inst/doc/gmm_with_R.pdf
pkg/gmm/inst/doc/gmm_with_R.rnw
pkg/gmm/man/gel.Rd
pkg/gmm/man/gmm.Rd
pkg/gmm/man/smoothG.Rd
Log:
Many changes including integrating sandwich package
Modified: pkg/gmm/DESCRIPTION
===================================================================
--- pkg/gmm/DESCRIPTION 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/DESCRIPTION 2010-02-03 20:31:28 UTC (rev 21)
@@ -1,11 +1,19 @@
Package: gmm
-Version: 1.3-0
-Date: 2010-01-08
-Title: Generalized Method of Moments and Generalized Empirical Likelihood
+Version: 1.3-2
+Date: 2010-02-03
+Title: Generalized Method of Moments and Generalized Empirical
+ Likelihood
Author: Pierre Chausse <pierre.chausse at uqam.ca>
Maintainer: Pierre Chausse <pierre.chausse at uqam.ca>
-Description: It is a complete suite to estimate models based on moment conditions. It includes the two step Generalized method of moments (GMM) of Hansen(1982), the iterated GMM and continuous updated estimator (CUE) of Hansen-Eaton-Yaron(1996) and several methods that belong to the Generalized Empirical Likelihood (GEL) family of estimators, as presented by Smith(1997), Kitamura(1997), Newey-Smith(2004) and Anatolyev(2005).
-Depends: R (>= 2.0.0)
+Description: It is a complete suite to estimate models based on moment
+ conditions. It includes the two step Generalized method of
+ moments (GMM) of Hansen(1982), the iterated GMM and continuous
+ updated estimator (CUE) of Hansen-Eaton-Yaron(1996) and several
+ methods that belong to the Generalized Empirical Likelihood
+ (GEL) family of estimators, as presented by Smith(1997),
+ Kitamura(1997), Newey-Smith(2004) and Anatolyev(2005).
+Depends: R (>= 2.0.0), sandwich
Suggests: mvtnorm, car, fBasics, MASS, timeDate, timeSeries
Imports: stats
License: GPL (>= 2)
+
Modified: pkg/gmm/NAMESPACE
===================================================================
--- pkg/gmm/NAMESPACE 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/NAMESPACE 2010-02-03 20:31:28 UTC (rev 21)
@@ -1,6 +1,6 @@
Import(stats)
-export(HAC,gmm,weightsAndrews2,bwAndrews2,summary.gmm,rho,smoothG,getDat,bwNeweyWest2,summary.gel,getLamb,gel,
+export(gmm,summary.gmm,rho,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,
@@ -41,5 +41,12 @@
S3method(momentEstim, baseGmm.cue)
S3method(momentEstim, baseGel.mod)
S3method(momentEstim, baseGel.modFormula)
+S3method(estfun, gmmFct)
+S3method(estfun, gmm)
+S3method(estfun, gel)
+S3method(bread, gmm)
+S3method(bread, gel)
+
+
Modified: pkg/gmm/NEWS
===================================================================
--- pkg/gmm/NEWS 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/NEWS 2010-02-03 20:31:28 UTC (rev 21)
@@ -1,3 +1,12 @@
+Changes in version 1.3-2
+
+ o The functions HAC, weightsAndrews2, bwAndrews2 and all the others to compute the HAC matrix have been removed. The sandwich package is
+ now used to compute these matrices.
+ o The option centeredVcov has beed added to the gmm function. It allows to compute the covariance matrix using a centered moment function.
+ o The option weightsMatrix has beed added to the gmm function. It allows to fixe the matrix of weights.
+ o The methods bread() and estfun() are now available for gmm objects. It allows to compute a sandwich covariance matrix which
+ is required if the weighting matrix is not the optimal one.
+
Changes in version 1.3-0
o The method "getModel", "momentEstim" is now used also for the gel procedure.
@@ -7,8 +16,6 @@
For the former, the optimal bandwidth of Andrews(91) for Bartlett is used and for the latter, it is the bandwidth proposed
for the Parzen. See Smith(2004) for more details. Also, the option vcov as been removed since it is irrelevant for GEL. By setting smooth to
FALSE, it is implied that the data are iid.
- o It is now possible to give names to the parameters when the model is nonlinear. It is done through the starting values. For example
- res <- gmm(..., t0 = c(mu=0,sig=1) ,...
Changes in version 1.2-0
Modified: pkg/gmm/R/FinRes.R
===================================================================
--- pkg/gmm/R/FinRes.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/FinRes.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -39,28 +39,46 @@
G <- gradv(z$coefficients, x, g = object$g)
if (P$vcov == "iid")
- v <- iid(z$coefficients, x, z$g)/n
+ v <- iid(z$coefficients, x, z$g, P$centeredVcov)/n
else
{
- v <- HAC(z$gt, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
- ar.method = P$ar.method, approx = P$approx, tol = P$tol)/n
+ if(P$centeredVcov)
+ gmat <- lm(z$gt~1)
+ else
+ {
+ gmat <- z$gt
+ class(gmat) <- "gmmFct"
+ }
+ v <- kernHAC(gmat, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol, sandwich = FALSE)/n
}
- if (P$wmatrix == "optimal")
+
+ z$vcov <- try(solve(crossprod(G, solve(v, G))), silent = TRUE)
+ if(class(z$vcov) == "try-error")
{
- z$vcov <- try(solve(crossprod(G, solve(v, G))))
- if(class(z$vcov) == "try-error")
- z$vcov <- matrix(Inf,length(z$coef),length(z$coef))
+ z$vcov <- matrix(Inf,ncol(z$gt),ncol(z$gt))
+ warning("The covariance matrix of the coefficients is singular")
}
- else
+
+ dimnames(z$vcov) <- list(names(z$coefficients), names(z$coefficients))
+ z$call <- P$call
+
+
+ if(is.null(P$weightsMatrix))
{
- GGG <- try(solve(crossprod(G), t(G)))
- if(class(GGG) == "try-error")
- z$vcov <- matrix(Inf,length(z$coef),length(z$coef))
+ if(P$wmatrix == "ident")
+ z$w <- diag(ncol(z$gt))
else
- z$vcov <- GGG %*% v %*% t(GGG)
+ {
+ z$w <- try(solve(v), silent = TRUE)
+ if(class(z$w) == "try-error")
+ warning("The covariance matrix of the moment function is singular")
+ }
}
- dimnames(z$vcov) <- list(names(z$coefficients), names(z$coefficients))
- z$call <- P$call
+ else
+ z$w <- P$weightsMatrix
+
+ z$G <- G
z$met <- P$type
z$kernel <- P$kernel
z$coefficients <- c(z$coefficients)
Deleted: pkg/gmm/R/HAC.R
===================================================================
--- pkg/gmm/R/HAC.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/HAC.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -1,204 +0,0 @@
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# A copy of the GNU General Public License is available at
-# http://www.r-project.org/Licenses/
-
-kweights2 <- function(x, kernel = c("Truncated", "Bartlett", "Parzen",
- "Tukey-Hanning", "Quadratic Spectral"), normalize = FALSE)
-{
- kernel <- match.arg(kernel)
- if(normalize) {
- ca <- switch(kernel,
- "Truncated" = 2,
- "Bartlett" = 2/3,
- "Parzen" = .539285,
- "Tukey-Hanning" = 3/4,
- "Quadratic Spectral" = 1)
- } else ca <- 1
-
- switch(kernel,
- "Truncated" = { ifelse(ca * x > 1, 0, 1) },
- "Bartlett" = { ifelse(ca * x > 1, 0, 1 - abs(ca * x)) },
- "Parzen" = {
- ifelse(ca * x > 1, 0, ifelse(ca * x < 0.5,
- 1 - 6 * (ca * x)^2 + 6 * abs(ca * x)^3, 2 * (1 - abs(ca * x))^3))
- },
- "Tukey-Hanning" = {
- ifelse(ca * x > 1, 0, (1 + cos(pi * ca * x))/2)
- },
- "Quadratic Spectral" = {
- y <- 6 * pi * x/5
- ifelse(x < 1e-4, 1, 3 * (1/y)^2 * (sin(y)/y - cos(y)))
- })
-}
-
-
-
-bwNeweyWest2 <- function (x, kernel = c("Bartlett", "Parzen",
- "Quadratic Spectral", "Truncated", "Tukey-Hanning"),
- prewhite = 1, ar.method = "ols",...)
-{
- kernel <- match.arg(kernel)
- if (kernel %in% c("Truncated", "Tukey-Hanning"))
- stop(paste("Automatic bandwidth selection only available for ",
- dQuote("Bartlett"), ", ", dQuote("Parzen"), " and ",
- dQuote("Quadratic Spectral"), " kernel. Use ", sQuote("bwAndrews2"),
- " instead.", sep = ""))
- prewhite <- as.integer(prewhite)
- n <- nrow(x)
- k <- ncol(x)
- weights <- rep(1, k)
- if (length(weights) < 2)
- weights <- 1
- mrate <- switch(kernel, Bartlett = 2/9, Parzen = 4/25, "Quadratic Spectral" = 2/25)
- m <- floor(ifelse(prewhite > 0, 3, 4) * (n/100)^mrate)
- if (prewhite > 0) {
- x <- as.matrix(na.omit(ar(x, order.max = prewhite,
- demean = FALSE, aic = FALSE, method = ar.method)$resid))
- n <- n - prewhite
- }
- hw <- x %*% weights
- sigmaj <- function(j) sum(hw[1:(n - j)] * hw[(j + 1):n])/n
- sigma <- sapply(0:m, sigmaj)
- s0 <- sigma[1] + 2 * sum(sigma[-1])
- s1 <- 2 * sum(1:m * sigma[-1])
- s2 <- 2 * sum((1:m)^2 * sigma[-1])
- qrate <- 1/(2 * ifelse(kernel == "Bartlett", 1, 2) + 1)
- rval <- switch(kernel, Bartlett = {
- 1.1447 * ((s1/s0)^2)^qrate
- }, Parzen = {
- 2.6614 * ((s2/s0)^2)^qrate
- }, "Quadratic Spectral" = {
- 1.3221 * ((s2/s0)^2)^qrate
- })
- rval <- rval * (n + prewhite)^qrate
- return(rval)
-}
-
-
-HAC <- function (x, weights = weightsAndrews2, bw = bwAndrews2, prewhite = FALSE, ar.method = "ols", kernel=c("Quadratic Spectral", "Truncated", "Bartlett", "Parzen", "Tukey-Hanning"), approx="AR(1)",tol = 1e-7)
-{
- n.orig <- n <- nrow(x)
- k <- ncol(x)
- kernel=match.arg(kernel)
- if(prewhite > 0)
- {
- var.fit <- ar(x, order.max = prewhite, demean = FALSE, aic = FALSE, method = ar.method)
- if(k > 1) D <- solve(diag(ncol(x)) - apply(var.fit$ar, 2:3, sum))
- else D <- as.matrix(1/(1 - sum(var.fit$ar)))
- x <- as.matrix(na.omit(var.fit$resid))
- n <- n - prewhite
- }
- weights <- weights(x, ar.method = ar.method,kernel=kernel,bw=bw, approx = approx, prewhite = 1, tol = tol)
- if (length(weights) > n)
- {
- warning("more weights than observations, only first n used")
- weights <- weights[1:n]
- }
- utu <- 0.5 * crossprod(x) * weights[1]
- wsum <- n * weights[1]/2
- w2sum <- n * weights[1]^2/2
- if (length(weights) > 1) {
- for (ii in 2:length(weights)) {
- utu <- utu + weights[ii] * crossprod(x[1:(n -
- ii + 1), , drop = FALSE], x[ii:n, , drop = FALSE])
- wsum <- wsum + (n - ii + 1) * weights[ii]
- w2sum <- w2sum + (n - ii + 1) * weights[ii]^2
- }
- }
- utu <- utu + t(utu)
-
- if(prewhite > 0) {
- utu <- crossprod(t(D), utu) %*% t(D)
- }
- wsum <- 2 * wsum
- w2sum <- 2 * w2sum
- bc <- n^2/(n^2 - wsum)
- df <- n^2/w2sum
- rval <- utu/n.orig
-
- return(rval)
-}
-
-weightsAndrews2 <- function (x, bw = bwAndrews2, kernel = c("Quadratic Spectral",
- "Truncated", "Bartlett", "Parzen", "Tukey-Hanning"), approx = c("AR(1)",
- "ARMA(1,1)"), prewhite = 1, ar.method = "ols", tol = 1e-7, verbose = FALSE)
-{
- kernel <- match.arg(kernel)
- approx=match.arg(approx)
-
- if (is.function(bw))
- bw <- bw(x, kernel = kernel, prewhite = prewhite, ar.method = ar.method, approx=approx)
- n <- NROW(x)
- weights <- kweights2(0:(n - 1)/bw, kernel = kernel)
- weights <- weights[1:max(which(abs(weights) > tol))]
- return(weights)
-}
-
-
-bwAndrews2 <- function (x, kernel = c("Quadratic Spectral",
- "Truncated", "Bartlett", "Parzen", "Tukey-Hanning"), approx = c("AR(1)",
- "ARMA(1,1)"), prewhite = 1, ar.method = "ols")
-{
- kernel <- match.arg(kernel)
- approx <- match.arg(approx)
- n <- nrow(x)
- k <- ncol(x)
-
- if (approx == "AR(1)") {
- fitAR1 <- function(x) {
- rval <- ar(x, order.max = 1, aic = FALSE, method = "ols")
- rval <- c(rval$ar, sqrt(rval$var.pred))
- names(rval) <- c("rho", "sigma")
- return(rval)
- }
- ar.coef <- apply(x, 2, fitAR1)
- denum <- sum((ar.coef["sigma", ]/(1 - ar.coef["rho",
- ]))^4)
- alpha2 <- sum(4 * ar.coef["rho", ]^2 * ar.coef["sigma",
- ]^4/(1 - ar.coef["rho", ])^8)/denum
- alpha1 <- sum(4 * ar.coef["rho", ]^2 * ar.coef["sigma",
- ]^4/((1 - ar.coef["rho", ])^6 * (1 + ar.coef["rho",
- ])^2))/denum
- }
- else {
- fitARMA11 <- function(x) {
- rval <- arima(x, order = c(1, 0, 1), include.mean = FALSE)
- rval <- c(rval$coef, sqrt(rval$sigma2))
- names(rval) <- c("rho", "psi", "sigma")
- return(rval)
- }
- arma.coef <- apply(x, 2, fitARMA11)
- denum <- sum(((1 + arma.coef["psi", ]) * arma.coef["sigma",
- ]/(1 - arma.coef["rho", ]))^4)
- alpha2 <- sum(4 * ((1 + arma.coef["rho", ] *
- arma.coef["psi", ]) * (arma.coef["rho", ] + arma.coef["psi",
- ]))^2 * arma.coef["sigma", ]^4/(1 - arma.coef["rho",
- ])^8)/denum
- alpha1 <- sum(4 * ((1 + arma.coef["rho", ] *
- arma.coef["psi", ]) * (arma.coef["rho", ] + arma.coef["psi",
- ]))^2 * arma.coef["sigma", ]^4/((1 - arma.coef["rho",
- ])^6 * (1 + arma.coef["rho", ])^2))/denum
- }
- rval <- switch(kernel, Truncated = {
- 0.6611 * (n * alpha2)^(1/5)
- }, Bartlett = {
- 1.1447 * (n * alpha1)^(1/3)
- }, Parzen = {
- 2.6614 * (n * alpha2)^(1/5)
- }, "Tukey-Hanning" = {
- 1.7462 * (n * alpha2)^(1/5)
- }, "Quadratic Spectral" = {
- 1.3221 * (n * alpha2)^(1/5)
- })
- return(rval)
-}
-
Modified: pkg/gmm/R/Methods.gel.R
===================================================================
--- pkg/gmm/R/Methods.gel.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/Methods.gel.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -160,3 +160,15 @@
formula(x$terms)
}
+estfun.gel <- function(x, ...)
+ {
+ stop("estfun is not yet available for gel objects")
+ }
+
+bread.gel <- function(x, ...)
+ {
+ stop("Bread is not yet available for gel objects")
+ }
+
+
+
Modified: pkg/gmm/R/Methods.gmm.R
===================================================================
--- pkg/gmm/R/Methods.gmm.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/Methods.gmm.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -102,16 +102,36 @@
vcov.gmm <- function(object,...) object$vcov
+estfun.gmmFct <- function(x, y = NULL, theta = NULL, ...)
+ {
+ if (is(x, "function"))
+ {
+ gmat <- x(y, theta)
+ return(gmat)
+ }
+ else
+ return(x)
+ }
+estfun.gmm <- function(x, ...)
+ {
+ foc <- x$gt %*% x$w %*% x$G
+ return(foc)
+ }
+bread.gmm <- function(x, ...)
+ {
+ GWG <- crossprod(x$G, x$w %*% x$G)
+ b <- try(solve(GWG), silent = TRUE)
+ if (class(b) == "try-error")
+ stop("The bread matrix is singular")
+ return(b)
+ }
-
-
-
Modified: pkg/gmm/R/gel.R
===================================================================
--- pkg/gmm/R/gel.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/gel.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -139,7 +139,7 @@
return(z)
}
-smoothG <- function (x, bw = bwAndrews2, prewhite = 1, ar.method = "ols", weights = weightsAndrews2,
+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)
{
@@ -149,6 +149,7 @@
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)
@@ -175,7 +176,7 @@
gel <- function(g, x, tet0, gradv = NULL, smooth = FALSE, type = c("EL", "ET", "CUE", "ETEL"),
- kernel = c("Truncated", "Bartlett"), bw = bwAndrews2, approx = c("AR(1)",
+ 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("iter", "numeric"), model = TRUE, X = FALSE, Y = FALSE, TypeGel = "baseGel", ...)
@@ -184,14 +185,14 @@
type <- match.arg(type)
optfct <- match.arg(optfct)
optlam <- match.arg(optlam)
- weights <- weightsAndrews2
+ weights <- weightsAndrews
approx <- match.arg(approx)
kernel <- match.arg(kernel)
all_args <- list(g = g, x = x, tet0 = tet0, gradv = gradv, smooth = smooth, type = type,
kernel = kernel, bw = bw, approx = approx, prewhite = prewhite, ar.method = ar.method,
tol_weights = tol_weights, tol_lam = tol_lam, tol_obj = tol_obj, tol_mom = tol_mom,
- maxiterlam = maxiterlam, constraint = constraint, optfct = optfct, weights = weightsAndrews2,
+ maxiterlam = maxiterlam, constraint = constraint, optfct = optfct, weights = weights,
optlam = optlam, model = model, X = X, Y = Y, TypeGel = TypeGel, call = match.call())
class(all_args)<-TypeGel
Modified: pkg/gmm/R/getModel.R
===================================================================
--- pkg/gmm/R/getModel.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/getModel.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -22,7 +22,13 @@
{
object$gradvf <- FALSE
dat <- getDat(object$g, object$x)
- clname <- paste(class(object), ".", object$type, ".formula", sep = "")
+ 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, x, ny = dat$ny, nh = dat$nh, k = dat$k)
{
@@ -44,7 +50,10 @@
}
else
{
- clname<-paste(class(object), "." ,object$type, sep = "")
+ if(is.null(object$weightsMatrix))
+ clname <- paste(class(object), "." ,object$type, sep = "")
+ else
+ clnames <- "fixedW"
if (!is.function(object$gradv))
{
gradv <- .Gf
@@ -57,9 +66,10 @@
}
}
- iid <- function(thet, x, g)
+ iid <- function(thet, x, g, centeredVcov)
{
gt <- g(thet,x)
+ if(centeredVcov) gt <- residuals(lm(gt~1))
n <- ifelse(is.null(nrow(x)), length(x), nrow(x))
v <- crossprod(gt,gt)/n
return(v)
@@ -157,9 +167,9 @@
rgmm <- gmm(P$g, x, P$tet0, wmatrix = "ident")
- P$bwVal <- P$bw(P$g(rgmm$coefficients, x), kernel = P$wkernel, prewhite = P$prewhite,
+ P$bwVal <- P$bw(lm(P$g(rgmm$coefficients, x)~1), kernel = P$wkernel, prewhite = P$prewhite,
ar.method = P$ar.method, approx = P$approx)
- P$w <- P$weights(P$g(rgmm$coefficients, x), kernel = P$kernel, bw = P$bwVal, prewhite = P$prewhite,
+ P$w <- P$weights(lm(P$g(rgmm$coefficients, x)~1), kernel = P$kernel, bw = P$bwVal, prewhite = P$prewhite,
ar.method = P$ar.method, approx = P$approx, tol = P$tol_weights)
P$g <- function(thet, x, g1 = P$g1, w = P$w)
Modified: pkg/gmm/R/gmm.R
===================================================================
--- pkg/gmm/R/gmm.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/gmm.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -12,9 +12,9 @@
# http://www.r-project.org/Licenses/
gmm <- function(g,x,t0=NULL,gradv=NULL, type=c("twoStep","cue","iterative"), wmatrix = c("optimal","ident"), vcov=c("HAC","iid"),
- kernel=c("Quadratic Spectral","Truncated", "Bartlett", "Parzen", "Tukey-Hanning"),crit=10e-7,bw = bwAndrews2,
+ kernel=c("Quadratic Spectral","Truncated", "Bartlett", "Parzen", "Tukey-Hanning"),crit=10e-7,bw = bwAndrews,
prewhite = FALSE, ar.method = "ols", approx="AR(1)",tol = 1e-7, itermax=100,optfct=c("optim","optimize","nlminb"),
- model=TRUE, X=FALSE, Y=FALSE, TypeGmm = "baseGmm", ...)
+ model=TRUE, X=FALSE, Y=FALSE, TypeGmm = "baseGmm", centeredVcov = FALSE, weightsMatrix = NULL, ...)
{
type <- match.arg(type)
@@ -24,6 +24,7 @@
optfct <- match.arg(optfct)
all_args<-list(g = g, x = x, t0 = t0, gradv = gradv, type = type, wmatrix = wmatrix, vcov = vcov, kernel = kernel,
crit = crit, bw = bw, prewhite = prewhite, ar.method = ar.method, approx = approx,
+ weightsMatrix = weightsMatrix, centeredVcov = centeredVcov,
tol = tol, itermax = itermax, optfct = optfct, model = model, X = X, Y = Y, call = match.call())
class(all_args)<-TypeGmm
Model_info<-getModel(all_args)
@@ -119,10 +120,19 @@
gt <- P$g(thet,x)
gbar <- as.vector(colMeans(gt))
if (P$vcov == "iid")
- w2 <- P$iid(thet, x, P$g)
+ w2 <- P$iid(thet, x, P$g, P$centeredVcov)
if (P$vcov == "HAC")
- w2 <- HAC(P$g(thet,x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
- ar.method = P$ar.method, approx = P$approx, tol = P$tol)
+ {
+ if(P$centeredVcov)
+ gmat <- lm(P$g(thet,x)~1)
+ else
+ {
+ gmat <- P$g(thet,x)
+ class(gmat) <- "gmmFct"
+ }
+ w2 <- kernHAC(gmat, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol, sandwich = FALSE)
+ }
obj <- crossprod(gbar,solve(w2,gbar))
return(obj)
}
Modified: pkg/gmm/R/momentEstim.R
===================================================================
--- pkg/gmm/R/momentEstim.R 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/R/momentEstim.R 2010-02-03 20:31:28 UTC (rev 21)
@@ -55,12 +55,22 @@
else
{
if (P$vcov == "iid")
- w <- P$iid(res$par, P$x, P$g)
+ w <- P$iid(res$par, P$x, P$g, P$centeredVcov)
if (P$vcov == "HAC")
- w <- HAC(P$g(res$par, P$x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
- ar.method = P$ar.method, approx = P$approx, tol = P$tol)
+ {
+ if(P$centeredVcov)
+ gmat <- lm(P$g(res$par, P$x)~1)
+ else
+ {
+ gmat <- P$g(res$par, P$x)
+ class(gmat) <- "gmmFct"
+ }
+ w <- kernHAC(gmat, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol, sandwich = FALSE)
+ }
+
if (P$optfct == "optim")
res2 <- optim(res$par, .obj1, x = P$x, w = w, gf = P$g, ...)
@@ -79,7 +89,7 @@
z = list(coefficients = res2$par, objective = res2$value, k=k, k2=k2, n=n, q=q, df=df)
}
-
+
if(is.null(names(P$t0)))
names(z$coefficients) <- paste("Theta[" ,1:k, "]", sep = "")
else
@@ -118,11 +128,21 @@
w=diag(rep(1, q))
res1 <- .tetlin(x, w, dat$ny, dat$nh, dat$k, P$gradv, P$g)
if (P$vcov == "iid")
- w <- P$iid(res1$par, x, g)
- if (P$vcov == "HAC")
- w <- HAC(g(res1$par, x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
- ar.method = P$ar.method, approx = P$approx, tol = P$tol)
- res2 <- .tetlin(x, w, dat$ny, dat$nh, dat$k, P$gradv, g)
+ w <- P$iid(res1$par, x, g, P$centeredVcov)
+ if (P$vcov == "HAC")
+ {
+ if(P$centeredVcov)
+ gmat <- lm(g(res1$par, x)~1)
+ else
+ {
+ gmat <- g(res1$par, x)
+ class(gmat) <- "gmmFct"
+ }
+ w <- kernHAC(gmat, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol, sandwich = FALSE)
+
+ }
+ res2 <- .tetlin(x, w, dat$ny, dat$nh, dat$k, P$gradv, g)
z = list(coefficients = res2$par, objective = res2$value, dat=dat, k=k, k2=k2, n=n, q=q, df=df)
}
z$gt <- g(z$coefficients, x)
@@ -190,9 +210,19 @@
{
tet <- res$par
if (P$vcov == "iid")
- w <- P$iid(tet, x, g)
+ w <- P$iid(tet, x, g, P$centeredVcov)
if (P$vcov == "HAC")
- w <- HAC(g(tet, x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite, ar.method = P$ar.method, approx = P$approx, tol = P$tol)
+ {
+ if (P$centeredVcov)
+ gmat <- lm(g(tet, x)~1)
+ else
+ {
+ gmat <- g(tet, x)
+ class(gmat) <- "gmmFct"
+ }
+ w <- kernHAC(gmat, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite, ar.method = P$ar.method,
+ approx = P$approx, tol = P$tol, sandwich = FALSE)
+ }
res <- .tetlin(x, w, dat$ny, dat$nh, dat$k, P$gradv, g)
ch <- crossprod(abs(tet- res$par)/tet)^.5
if (j>P$itermax)
@@ -286,10 +316,19 @@
{
tet <- res$par
if (P$vcov == "iid")
- w <- P$iid(tet, P$x, P$g)
+ w <- P$iid(tet, P$x, P$g, P$centeredVcov)
if (P$vcov == "HAC")
- w <- HAC(P$g(tet, P$x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
- ar.method = P$ar.method, approx = P$approx, tol = P$tol)
+ {
+ if (P$centeredVcov)
+ gmat <- lm(P$g(tet, P$x)~1)
+ else
+ {
+ gmat <- P$g(tet, P$x)
+ class(gmat) <- "gmmFct"
+ }
+ w <- kernHAC(gmat, kernel = P$kernel, bw = P$bw, prewhite = P$prewhite, ar.method = P$ar.method,
+ approx = P$approx, tol = P$tol, sandwich = FALSE)
+ }
if (P$optfct == "optim")
res <- optim(tet, .obj1, x = P$x, w = w, gf = P$g, ...)
@@ -464,7 +503,7 @@
names(z$coefficients) <- paste("Theta[" ,1:k, "]", sep = "")
else
names(z$coefficients) <- names(P$t0)
-
+
z$x <- P$x
z$gradv <- P$gradv
z$gt <- P$g(z$coefficients, P$x)
@@ -685,3 +724,126 @@
class(z) <- paste(P$TypeGel, ".res", sep = "")
return(z)
}
+
+momentEstim.fixedW.formula <- function(object, ...)
+ {
+ P <- object
+ g <- P$g
+ dat <- getDat(P$gform, P$x)
+ x <- dat$x
+ k <- dat$k
+ k2 <- k*dat$ny
+ n <- nrow(x)
+ q <- dat$ny*dat$nh
+ df <- q-k*dat$ny
+ w <- P$weightsMatrix
+ if(!all(dim(w) == c(q,q)))
+ stop("The matrix of weights must be qxq")
+ if(!is.real(eigen(w)$values))
+ stop("The matrix of weights must be strictly positive definite")
+ if(is.real(eigen(w)$values))
+ {
+ if(sum(eigen(w)$values<=0)!=0)
+ stop("The matrix of weights must be strictly positive definite")
+ }
+
+ res2 <- .tetlin(x, w, dat$ny, dat$nh, dat$k, P$gradv, g)
+ z = list(coefficients = res2$par, objective = res2$value, dat=dat, k=k, k2=k2, n=n, q=q, df=df)
+
+ z$gt <- g(z$coefficients, x)
+ b <- z$coefficients
+ y <- as.matrix(model.response(dat$mf, "numeric"))
+ ny <- dat$ny
+ b <- t(matrix(b, nrow = dat$ny))
+ x <- as.matrix(model.matrix(dat$mt, dat$mf, NULL))
+ yhat <- x %*% b
+ z$dat <- dat
+ z$fitted.values <- yhat
+ z$residuals <- y - yhat
+ z$terms <- dat$mt
+ if(P$model) z$model <- dat$mf
+ if(P$X) z$x <- x
+ if(P$Y) z$y <- y
+ z$gradv <- P$gradv
+ z$iid <- P$iid
+ z$g <- P$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])
+ names(z$coefficients) <- paste(rep(namey, dat$k), "_", rep(namex, rep(dat$ny, dat$k)), sep = "")
+ colnames(z$gt) <- paste(rep(namey, dat$nh), "_", rep(nameh, rep(dat$ny, dat$nh)), sep = "")
+ }
+
+ if (dat$ny == 1)
+ {
+ names(z$coefficients) <- namex
+ colnames(z$gt) <- nameh
+ }
+ class(z) <- paste(P$TypeGmm,".res",sep="")
+ return(z)
+ }
+
+momentEstim.fixedW <- function(object, ...)
+ {
+ P <- object
+ x <- P$x
+ if (P$optfct == "optimize")
+ {
+ n = nrow(P$g(P$t0[1], x))
+ q = ncol(P$g(P$t0[1], x))
+ k = 1
+ }
+ else
+ {
+ n = nrow(P$g(P$t0, x))
+ q = ncol(P$g(P$t0, x))
+ k = length(P$t0)
+ }
+ k2 <- k
+ df <- q - k
+ w <- P$weightsMatrix
+ if(!all(dim(w) != c(q,q)))
+ stop("The matrix of weights must be qxq")
+ if(!is.real(eigen(w)$values))
+ stop("The matrix of weights must be strictly positive definite")
+ if(is.real(eigen(w)$values))
+ {
+ if(sum(eigen(w)$values<=0)!=0)
+ stop("The matrix of weights must be strictly positive definite")
+ }
+
+ if (P$optfct == "optim")
+ res2 <- optim(P$t0, .obj1, x = P$x, w = w, gf = P$g, ...)
+
+ if (P$optfct == "nlminb")
+ {
+ res2 <- nlminb(P$t0, .obj1, x = P$x, w = w, gf = P$g, ...)
+ res2$value <- res2$objective
+ }
+ if (P$optfct == "optimize")
+ {
+ res2 <- optimize(.obj1, P$t0, x = P$x, w = w, gf = P$g, ...)
+ res2$par <- res2$minimum
+ res2$value <- res2$objective
+ }
+ z = list(coefficients = res2$par, objective = res2$value, k=k, k2=k2, n=n, q=q, df=df)
+
+ if(is.null(names(P$t0)))
+ names(z$coefficients) <- paste("Theta[" ,1:k, "]", sep = "")
+ else
+ names(z$coefficients) <- names(P$t0)
+
+ z$x <- P$x
+ z$gt <- P$g(z$coefficients, P$x)
+ z$gradv <- P$gradv
+ z$iid <- P$iid
+ z$g <- P$g
+
+ class(z) <- paste(P$TypeGmm,".res",sep="")
+ return(z)
+ }
+
Modified: pkg/gmm/inst/doc/empir.bib
===================================================================
--- pkg/gmm/inst/doc/empir.bib 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/inst/doc/empir.bib 2010-02-03 20:31:28 UTC (rev 21)
@@ -1,3 +1,4 @@
+
@article{jagannathan-skoulakis02,
AUTHOR={Jagannathan, R. and Skoulakis, G.},
TITLE={Generalized Method of Moments: Applications in Finance},
@@ -161,7 +162,8 @@
VOLUME={16},
PAGES={1-16},
YEAR={2006},
- Number={9}
+ Number={9},
+ url={http://www.jstatsoft.org/v16/i09/}
}
@Book{luenberger97,
Modified: pkg/gmm/inst/doc/gmm_with_R.pdf
===================================================================
--- pkg/gmm/inst/doc/gmm_with_R.pdf 2010-01-30 15:04:54 UTC (rev 20)
+++ pkg/gmm/inst/doc/gmm_with_R.pdf 2010-02-03 20:31:28 UTC (rev 21)
@@ -1,70 +1,76 @@
%PDF-1.4
%ÐÔÅØ
-5 0 obj
+1 0 obj
<< /S /GoTo /D (Section.0.Introduction.1) >>
endobj
-8 0 obj
+4 0 obj
(Introduction)
endobj
-9 0 obj
+5 0 obj
<< /S /GoTo /D (Section.1.Generalized\040method\040of\040moments.1) >>
endobj
-12 0 obj
+8 0 obj
(Generalized method of moments)
endobj
-13 0 obj
+9 0 obj
<< /S /GoTo /D (Section.2.GMM\040with\040R.1) >>
endobj
-16 0 obj
+12 0 obj
(GMM with R)
endobj
-17 0 obj
+13 0 obj
<< /S /GoTo /D (Subsection.3.0.Estimating\040the\040parameters\040of\040a\040normal\040distribution.2) >>
endobj
-20 0 obj
+16 0 obj
(Estimating the parameters of a normal distribution)
endobj
-21 0 obj
+17 0 obj
<< /S /GoTo /D (Subsection.3.1.Estimating\040the\040parameters\040of\040a\040stable\040distribution.2) >>
endobj
-24 0 obj
+20 0 obj
(Estimating the parameters of a stable distribution)
endobj
-25 0 obj
+21 0 obj
<< /S /GoTo /D (Subsection.3.2.A\040linear\040model\040with\040iid\040moment\040conditions.2) >>
endobj
-28 0 obj
+24 0 obj
(A linear model with iid moment conditions)
endobj
-29 0 obj
+25 0 obj
<< /S /GoTo /D (Subsection.3.3.Estimating\040the\040AR\040coefficients\040of\040an\040ARMA\040process.2) >>
endobj
-32 0 obj
+28 0 obj
(Estimating the AR coefficients of an ARMA process)
endobj
-33 0 obj
+29 0 obj
<< /S /GoTo /D (Subsection.3.4.Estimating\040a\040system\040of\040equations:\040CAPM.2) >>
endobj
-36 0 obj
+32 0 obj
(Estimating a system of equations: CAPM)
endobj
-37 0 obj
+33 0 obj
<< /S /GoTo /D (Subsection.3.5.Testing\040the\040CAPM\040using\040the\040stochastic\040discount\040factor\040representation.2) >>
endobj
-40 0 obj
+36 0 obj
(Testing the CAPM using the stochastic discount factor representation)
endobj
+37 0 obj
+<< /S /GoTo /D (Subsection.3.6.Estimating\040continuous\040time\040processes\040by\040discrete\040time\040approximation.2) >>
+endobj
+40 0 obj
+(Estimating continuous time processes by discrete time approximation)
+endobj
41 0 obj
-<< /S /GoTo /D (Subsection.3.6.Estimating\040continuous\040time\040processes\040using\040discrete\040time\040approximation.2) >>
+<< /S /GoTo /D (Subsection.3.7.Comments\040on\040models\040with\040panel\040data.2) >>
endobj
44 0 obj
-(Estimating continuous time processes using discrete time approximation)
+(Comments on models with panel data)
endobj
45 0 obj
-<< /S /GoTo /D (Subsection.3.7.Comments\040on\040models\040with\040panel\040data.2) >>
+<< /S /GoTo /D (Subsection.3.8.GMM\040and\040the\040sandwich\040package.2) >>
endobj
48 0 obj
-(Comments on models with panel data)
+(GMM and the sandwich package)
endobj
49 0 obj
<< /S /GoTo /D (Section.3.Generalized\040empirical\040likelihood.1) >>
@@ -111,1100 +117,1221 @@
77 0 obj
<< /S /GoTo /D [78 0 R /Fit ] >>
endobj
-91 0 obj <<
-/Length 3260
+93 0 obj <<
+/Length 2696
/Filter /FlateDecode
>>
stream
-xÚÙrÛFò]_G°*„1ƒÁ1yKR¶ÖY»v7ÖnÕ–ˆ„DVx -{¿~ûš$¤¨\2æìéé»{˜'IžÜÞäòýùîæÍ»*OTiUšäî!±:3E“ÔZeÊØän|NY¨ô¸‡ÿNçq ŸÃãbYÔezÛa§ë[øìàoû? XóäÇn„Îæ=?v„‘™Æöž ,`Á8à°IÔa½øýîפ¨2SÉ0±ªfL^<ñ-¡¸íq|Å+hüÀß ‹B§ m#´òt‚ÜNÎx<Ð¥ŒéRE¦
-
-d#D~“5@;@¯,5®Yê\g¶®’¥ÑYe*^úO„Û!V}Ç—üeƒØøoXè*ý’ëbQuÚ!Ô›·w7Þ(8 €'Jª"Ï€ Éjóù÷<YÃø¯Iž¶IžhÕ>1×ï’O7ÿòÌ0¹Ö‰Íl¥+ÄS×6+mTy“™\˜üÓ=¡¬@TÛÕH¸\{ó®‰ -UYe -K€ St·zK
-Ðõ„àN‹%\¨ C& pÉq¡ëôià‘
-÷¸3Ò,mî#¸o±ÕñÌžÁ®u'Ò Þ/t“~ 6 · YxíN@:ùÁù=Kl€ËÃÇ™>Š¸ÂÔH§¡”.•É¬1ð%9`´‘ÊJy °ý8ß±ã¼Ì®Ú Oí¼Ãå:×Û0¦ ߢÊY®¶ˆªi¥Sw«Že¶¶±(€v•Us!Ö1Užåºv ˆ™+$Á ‹²JÛGÚäÑ–¢Î
-ÐÙò¸ß_CÅcY’-–¥¶éO|UÄ~K³¹€±5 ÔÊ«
-vžÛfh›g¥n„¢€Ç/¹*:Ö?&µ*x³Ò=¡
-iå8áÌ·ƒˆ1âA Q<à=M ™Ø4‚̼)ÙÔ Ö×Ç?œQ:VÑÉǃ“Q„šp¸Þ|B®4+´0P&Ÿ
-èÉQc˜ˆt‡XAbú#¢ôˆ÷)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 21
More information about the Gmm-commits
mailing list