[Gmm-commits] r133 - in pkg/gmm4: . R man vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 20 23:27:30 CEST 2018
Author: chaussep
Date: 2018-09-20 23:27:29 +0200 (Thu, 20 Sep 2018)
New Revision: 133
Added:
pkg/gmm4/man/evalModel-methods.Rd
pkg/gmm4/man/summaryGel-class.Rd
Removed:
pkg/gmm4/man/evalGmm-methods.Rd
Modified:
pkg/gmm4/NAMESPACE
pkg/gmm4/R/allClasses.R
pkg/gmm4/R/gel.R
pkg/gmm4/R/gelModels-methods.R
pkg/gmm4/R/gelfit-methods.R
pkg/gmm4/R/gmm4.R
pkg/gmm4/R/gmmModel.R
pkg/gmm4/R/gmmModels-methods.R
pkg/gmm4/R/gmmfit-methods.R
pkg/gmm4/R/rGmmModel-methods.R
pkg/gmm4/R/sgmmfit-methods.R
pkg/gmm4/R/summaryGmm-methods.R
pkg/gmm4/R/sysGmmModel.R
pkg/gmm4/R/sysGmmModels-methods.R
pkg/gmm4/R/validity.R
pkg/gmm4/man/.Rhistory
pkg/gmm4/man/formulaGel-class.Rd
pkg/gmm4/man/formulaGmm-class.Rd
pkg/gmm4/man/functionGel-class.Rd
pkg/gmm4/man/functionGmm-class.Rd
pkg/gmm4/man/gelModel.Rd
pkg/gmm4/man/gelfit-class.Rd
pkg/gmm4/man/gmm4.Rd
pkg/gmm4/man/gmmModel.Rd
pkg/gmm4/man/gmmWeights-class.Rd
pkg/gmm4/man/linearGel-class.Rd
pkg/gmm4/man/linearGmm-class.Rd
pkg/gmm4/man/modelFit-methods.Rd
pkg/gmm4/man/nonlinearGel-class.Rd
pkg/gmm4/man/nonlinearGmm-class.Rd
pkg/gmm4/man/print-methods.Rd
pkg/gmm4/man/rformulaGmm-class.Rd
pkg/gmm4/man/rfunctionGmm-class.Rd
pkg/gmm4/man/rlinearGmm-class.Rd
pkg/gmm4/man/rnonlinearGmm-class.Rd
pkg/gmm4/man/rslinearGmm-class.Rd
pkg/gmm4/man/rsnonlinearGmm-class.Rd
pkg/gmm4/man/show-methods.Rd
pkg/gmm4/man/slinearGmm-class.Rd
pkg/gmm4/man/smoothGel.Rd
pkg/gmm4/man/snonlinearGmm-class.Rd
pkg/gmm4/man/specTest-methods.Rd
pkg/gmm4/man/summary-methods.Rd
pkg/gmm4/man/sysGmmModel.Rd
pkg/gmm4/man/vcovHAC-methods.Rd
pkg/gmm4/vignettes/gmmS4.Rnw
pkg/gmm4/vignettes/gmmS4.pdf
Log:
change all class definitions to be more flexible
Modified: pkg/gmm4/NAMESPACE
===================================================================
--- pkg/gmm4/NAMESPACE 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/NAMESPACE 2018-09-20 21:27:29 UTC (rev 133)
@@ -22,12 +22,12 @@
"numericORcharacter", "tsls", "rnonlinearGmm", "rfunctionGmm",
"slinearGmm", "snonlinearGmm", "sysGmmModels",
"sgmmfit","stsls", "rslinearGmm", "rsnonlinearGmm", "rsysGmmModels",
- "formulaGmm","rfunctionGmm", "gelfit")
+ "formulaGmm","rfunctionGmm", "gelfit", "summaryGel")
exportMethods(residuals, print, show, vcovHAC, coef, vcov, bread, summary, update,
model.matrix, hypothesisTest, "[", merge, subset)
export(gmmModel, evalMoment, Dresiduals, evalDMoment, momentVcov, estfun.gmmFct,
- evalWeights, quadra, evalObjective, solveGmm, momentStrength,evalGmm,
+ evalWeights, quadra, evalObjective, solveGmm, momentStrength,evalModel,
tsls, modelFit, meatGmm, specTest, gmm4, restGmmModel, modelResponse, DWH,
modelDims, printRestrict, getRestrict, sysGmmModel, ThreeSLS, gelModel,
rhoET, rhoEL, rhoEEL, rhoHD, EL.Wu, getLambda, gmmToGel, smoothGel,
Modified: pkg/gmm4/R/allClasses.R
===================================================================
--- pkg/gmm4/R/allClasses.R 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/R/allClasses.R 2018-09-20 21:27:29 UTC (rev 133)
@@ -14,48 +14,31 @@
setClass("linearGmm", representation(modelF="data.frame", instF="data.frame",
vcov="character",n="integer", q="integer", k="integer",
parNames="character", momNames="character",
- kernel="character", bw="numericORcharacter",
- prewhite="integer", ar.method="character",
- approx="character", tol="numeric",
- centeredVcov="logical", varNames="character",
- isEndo="logical"),
- prototype(vcov="MDS", kernel="Quadratic Spectral", bw="Andrews", prewhite=1L,
- ar.method="ols", approx="AR(1)", tol=1e-7))
+ vcovOptions="list", centeredVcov="logical",
+ varNames="character", isEndo="logical"))
setClass("nonlinearGmm", representation(modelF="data.frame", instF="data.frame",
vcov="character",theta0="numeric",
n="integer", q="integer",k="integer",
parNames="character", momNames="character",
fRHS="expression", fLHS="expressionORNULL",
- kernel="character", bw="numericORcharacter",
- prewhite="integer", ar.method="character",
- approx="character", tol="numeric",
+ vcovOptions="list",
centeredVcov="logical", varNames="character",
- isEndo="logical"),
- prototype(vcov="MDS", kernel="Quadratic Spectral", bw="Andrews", prewhite=1L,
- ar.method="ols", approx="AR(1)", tol=1e-7))
+ isEndo="logical"))
setClass("functionGmm", representation(X="ANY", fct="function",dfct="functionORNULL",
vcov="character",theta0="numeric",
n="integer", q="integer",k="integer",
parNames="character", momNames="character",
- kernel="character", bw="numericORcharacter",
- prewhite="integer", ar.method="character",
- approx="character", tol="numeric",
+ vcovOptions="list",
centeredVcov="logical", varNames="character",
- isEndo="logical"),
- prototype(vcov="MDS", kernel="Quadratic Spectral", bw="Andrews", prewhite=1L,
- ar.method="ols", approx="AR(1)", tol=1e-7, dfct=NULL))
+ isEndo="logical"))
setClass("formulaGmm", representation(modelF="data.frame",
vcov="character",theta0="numeric",
n="integer", q="integer",k="integer",
parNames="character", momNames="character",
fRHS="list", fLHS="list",
- kernel="character", bw="numericORcharacter",
- prewhite="integer", ar.method="character",
- approx="character", tol="numeric",
+ vcovOptions="list",
centeredVcov="logical", varNames="character",
- isEndo="logical", isMDE="logical"),
- prototype(vcov="MDS", kernel="Quadratic Spectral", bw="Andrews", prewhite=1L,
- ar.method="ols", approx="AR(1)", tol=1e-7))
+ isEndo="logical", isMDE="logical"))
setClassUnion("regGmm", c("linearGmm", "nonlinearGmm"))
setClassUnion("allNLGmm", c("nonlinearGmm", "functionGmm", "formulaGmm"))
setClassUnion("gmmModels", c("linearGmm", "nonlinearGmm", "functionGmm", "formulaGmm"))
@@ -75,8 +58,7 @@
## gmmWeights
-setClass("gmmWeights", representation(w="ANY", type="character", HAC="list"),
- prototype(HAC=list()))
+setClass("gmmWeights", representation(w="ANY", type="character", wSpec="list"))
## gmmfit
@@ -91,7 +73,8 @@
setClass("gelfit", representation(theta = "numeric", convergence = "numeric",
lambda = "numeric", lconvergence = "numeric",
- call="call", type="character", model="gelModels"))
+ call="call", type="character", vcov="list",
+ model="gelModels"))
## specTest
@@ -104,6 +87,12 @@
type="character", convergence = "numericORNULL",
convIter="numericORNULL", wSpec="list",niter="integer",
df.adj="logical", breadOnly="logical"))
+
+setClass("summaryGel", representation(coef="matrix", specTest = "specTest",
+ model="gelModels", lambda="matrix",
+ convergence="numeric",lconvergence="numeric",
+ impProb="list"))
+
## Restricted gmm Models
setClass("rlinearGmm", representation(cstLHS="matrix", cstRHS="numeric", cstSpec="list"),
@@ -132,26 +121,19 @@
vcov="character",n="integer", q="integer",
k="integer", parNames="list",
momNames="list", eqnNames="character",
- kernel="character", bw="numericORcharacter",
- prewhite="integer", ar.method="character",
- approx="character", tol="numeric",
- centeredVcov="logical", sameMom="logical", SUR="logical",
- varNames="list", isEndo="list"),
- prototype(vcov="MDS", kernel="Quadratic Spectral", bw="Andrews", prewhite=1L,
- ar.method="ols", approx="AR(1)", tol=1e-7))
+ vcovOptions="list",
+ centeredVcov="logical", sameMom="logical",
+ SUR="logical", varNames="list", isEndo="list"))
+
setClass("snonlinearGmm", representation(data="data.frame", instT="list",
vcov="character",theta0="list",
n="integer", q="integer",k="integer",
parNames="list", momNames="list",
fRHS="list", fLHS="list", eqnNames="character",
- kernel="character", bw="numericORcharacter",
- prewhite="integer", ar.method="character",
- approx="character", tol="numeric",
+ vcovOptions="list",
centeredVcov="logical", sameMom="logical",
SUR="logical",
- varNames="list", isEndo="list"),
- prototype(vcov="MDS", kernel="Quadratic Spectral", bw="Andrews", prewhite=1L,
- ar.method="ols", approx="AR(1)", tol=1e-7))
+ varNames="list", isEndo="list"))
setClassUnion("sysGmmModels", c("slinearGmm", "snonlinearGmm"))
## Restricted System GMM
@@ -166,12 +148,9 @@
### sysGmmWeights
-setClass("sysGmmWeights", representation(w="ANY", type="character", HAC="list",
+setClass("sysGmmWeights", representation(w="ANY", type="character", wSpec="list",
Sigma="ANY", momNames="list", eqnNames="character",
- sameMom="logical"),
- prototype(w="ident", type="weights", momNames=list(), eqnNames=character(),
- HAC=list(), sameMom=FALSE))
-
+ sameMom="logical"))
## summarySysGmm
setClass("summarySysGmm",
@@ -197,9 +176,8 @@
lhs <- expression(Y)
new("nonlinearGmm", modelF=X, instF=from at instF, vcov=from at vcov,
theta0=theta0, n=spec$n, q=spec$q, k=spec$k, parNames=names(theta0),
- momNames=spec$momNames, fRHS=rhs, fLHS=lhs, kernel=from at kernel,
- bw=from at bw, prewhite=from at prewhite, ar.method=from at ar.method,
- approx=from at approx, tol=from at tol, centeredVcov=from at centeredVcov,
+ momNames=spec$momNames, fRHS=rhs, fLHS=lhs,
+ vcovOptions=from at vcovOptions, centeredVcov=from at centeredVcov,
isEndo=from at isEndo, varNames=from at varNames)
})
@@ -221,9 +199,8 @@
}
new("functionGmm", X=x, fct=fct, dfct=dfct, vcov=from at vcov,
theta0=theta0, n=spec$n, q=spec$q, k=spec$k, parNames=names(theta0),
- momNames=spec$momNames, kernel=from at kernel,
- bw=from at bw, prewhite=from at prewhite, ar.method=from at ar.method,
- approx=from at approx, tol=from at tol, centeredVcov=from at centeredVcov)
+ momNames=spec$momNames,vcovOptions=from at vcovOptions,
+ centeredVcov=from at centeredVcov)
})
setAs("allNLGmm", "functionGmm",
@@ -243,9 +220,8 @@
new("functionGmm", X=x, fct=fct, dfct=dfct, vcov=from at vcov,
theta0=from at theta0, n=spec$n, q=spec$q, k=spec$k,
parNames=names(from at theta0),
- momNames=spec$momNames, kernel=from at kernel,
- bw=from at bw, prewhite=from at prewhite, ar.method=from at ar.method,
- approx=from at approx, tol=from at tol, centeredVcov=from at centeredVcov)
+ momNames=spec$momNames, vcovOptions=from at vcovOptions,
+ centeredVcov=from at centeredVcov)
})
setAs("slinearGmm", "linearGmm",
@@ -292,10 +268,8 @@
g <- formula(g, .GlobalEnv)
h <- paste("~", paste(nZ, collapse="+"), "-1")
h <- formula(h, .GlobalEnv)
- res <- gmmModel(g, h, vcov=from at vcov, kernel=from at kernel, bw=from at bw,
- prewhite=from at prewhite, ar.method=from at ar.method,
- approx=from at approx, tol=from at tol, centeredVcov=from at centeredVcov,
- data=dat)
+ res <- gmmModel(g, h, vcov=from at vcov, vcovOptions=from at vcovOptions,
+ centeredVcov=from at centeredVcov, data=dat)
})
setAs("rslinearGmm", "rlinearGmm",
@@ -310,7 +284,7 @@
w <- quadra(from)
if (is.character(w))
w <- "ident"
- new("gmmWeights", w=w, type="weights", HAC=list())
+ new("gmmWeights", w=w, type="weights", wSpec=list())
})
Modified: pkg/gmm4/R/gel.R
===================================================================
--- pkg/gmm4/R/gel.R 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/R/gel.R 2018-09-20 21:27:29 UTC (rev 133)
@@ -1,15 +1,12 @@
gelModel <- function(g, x=NULL, gelType, rhoFct=NULL, tet0=NULL,grad=NULL,
vcov = c("HAC", "MDS", "iid"),
- kernel = c("Quadratic Spectral", "Truncated", "Bartlett", "Parzen",
- "Tukey-Hanning"), crit = 1e-06,
- bw = "Andrews", prewhite = 1L, ar.method = "ols", approx = "AR(1)",
- tol = 1e-07, centeredVcov = TRUE, data=parent.frame())
+ vcovOptions=list(), centeredVcov = TRUE, data=parent.frame())
{
vcov <- match.arg(vcov)
- kernel <- match.arg(kernel)
args <- as.list(match.call())
args$rhoFct <- NULL
args$gelType <- NULL
+ args$data <- data
model <- do.call(gmmModel, args)
gmmToGel(model, gelType, rhoFct)
}
@@ -175,25 +172,26 @@
gt <- evalMoment(object, theta)
gt <- scale(gt, scale=FALSE)
class(gt) <- "gmmFct"
- if (!(object at kernel%in%c("Bartlett","Parzen")))
- object at kernel <- "Bartlett"
- kernel <- switch(object at kernel,
+ vspec <- object at vcovOptions
+ if (!(vspec$kernel%in%c("Bartlett","Parzen")))
+ object at vcovOptions$kernel <- "Bartlett"
+ kernel <- switch(object at vcovOptions$kernel,
Bartlett="Truncated",
Parzen="Bartlett")
k <- switch(kernel,
Truncated=c(2,2),
Bartlett=c(1,2/3))
- if (is.character(object at bw))
+ if (is.character(vspec$bw))
{
- bw <- get(paste("bw", object at bw, sep = ""))
- bw <- bw(gt, kernel = object at kernel, prewhite = object at prewhite,
- ar.method = object at ar.method, approx = object at approx)
+ bw <- get(paste("bw", vspec$bw, sep = ""))
+ bw <- bw(gt, kernel = vspec$kernel, prewhite = vspec$prewhite,
+ ar.method = vspec$ar.method, approx = vspec$approx)
} else {
- bw <- object at bw
+ bw <- object at vcovOptions$bw
}
- w <- weightsAndrews(gt, bw = bw, kernel = kernel, prewhite = object at prewhite,
- ar.method = object at ar.method, tol = object at tol, verbose = FALSE,
- approx = object at approx)
+ w <- weightsAndrews(gt, bw = bw, kernel = kernel, prewhite = vspec$prewhite,
+ ar.method = vspec$ar.method, tol = vspec$tol, verbose = FALSE,
+ approx = vspec$approx)
rt <- length(w)
if (rt >= 2)
{
Modified: pkg/gmm4/R/gelModels-methods.R
===================================================================
--- pkg/gmm4/R/gelModels-methods.R 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/R/gelModels-methods.R 2018-09-20 21:27:29 UTC (rev 133)
@@ -14,7 +14,7 @@
{
cat("Smoothing: ")
cat(x at wSpec$kernel, " kernel and ", sep="")
- cat(x at bw, " bandwidth", sep="")
+ cat(x at vcovOptions$bw, " bandwidth", sep="")
cat(" (", round(x at wSpec$bw, 3), ")", sep="")
} else {
cat("No Smoothing required\n")
@@ -64,6 +64,8 @@
env)
G <- attr(G, "gradient")
spec <- modelDims(object)
+ if (!is.matrix(G))
+ G <- matrix(G, spec$q, spec$k)
dimnames(G) <- list(spec$momNames, spec$parNames)
G
}
@@ -95,8 +97,7 @@
else
rhoFct <- object at gelType$fct
rho <- rhoFct(gmat=gt, lambda=lambda, derive = 0, k = k[1]/k[2])
- n <- modelDims(object)$n
- 2*n*sum(rho)*k[2]/(k[1]^2*object at wSpec$bw)
+ 2*sum(rho)*k[2]/(k[1]^2*object at wSpec$bw)
})
######################### solveGel #########################
@@ -140,7 +141,10 @@
slv=lamSlv, lcont=lControl), tControl)
res <- do.call(get(coefSlv), args)
resl <- f(res$par, object, lambda0, lamSlv, lControl, TRUE)
- list(theta=res$par, convergence=res$convergence,
+ 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)
})
@@ -150,7 +154,7 @@
setMethod("modelFit", signature("gelModels"), valueClass="gelfit",
definition = function(object, gelType=NULL, rhoFct=NULL,
initTheta=c("gmm", "theta0"), start.tet=NULL,
- start.lam=NULL, ...)
+ start.lam=NULL, vcov=FALSE, ...)
{
Call <- match.call()
initTheta = match.arg(initTheta)
@@ -167,11 +171,55 @@
}
res <- solveGel(object, theta0=start.tet, lambda0=start.lam,
...)
-
- new("gelfit", theta=res$theta, convergence=res$convergence,
- lconvergence=res$lconvergence$convergence,
- lambda=res$lambda, call=Call, type=object at gelType$name,
- model=object)
+ gelfit <- new("gelfit", theta=res$theta, convergence=res$convergence,
+ lconvergence=res$lconvergence$convergence,
+ lambda=res$lambda, call=Call, type=object at gelType$name,
+ vcov=list(), model=object)
+ if (vcov)
+ gelfit at vcov <- vcov(gelfit)
+ gelfit
})
+#### evalModel
+
+setMethod("evalModel", signature("gelModels"),
+ function(object, theta, lambda=NULL, gelType=NULL, rhoFct=NULL,
+ lamSlv=NULL, lControl=list()) {
+ Call <- match.call()
+ if (!is.null(gelType))
+ object <- gmmToGel(as(object, "gmmModels"), gelType, rhoFct)
+ spec <- modelDims(object)
+ if (!is.null(names(theta)))
+ {
+ if (!all(names(theta) %in% spec$parNames))
+ stop("You provided a named theta with wrong names")
+ theta <- theta[match(spec$parNames, names(theta))]
+ } else {
+ if (class(object) %in% c("formulaGel","nonlinearGel", "formulaGel"))
+ stop("To evaluate nonlinear models, theta must be named")
+ names(theta) <- spec$parNames
+ }
+ type <- paste("Eval-", object at gelType$name, sep="")
+ if (is.null(lambda))
+ {
+ gt <- evalMoment(object, theta)
+ gelt <- object at gelType
+ k <- object at wSpec$k
+ args <- c(list(gmat=gt, gelType=gelt$name,
+ rhoFct=gelt$fct), lControl, k=k[1]/k[2])
+ if (is.null(lamSlv))
+ lamSlv <- getLambda
+ res <- do.call(lamSlv, args)
+ lambda <- res$lambda
+ lconvergence <- res$convergence$convergence
+ type <- paste(type, " with optimal lambda", sep="")
+ } else {
+ lconvergence <- 1
+ type <- paste(type, " with fixed lambda", sep="")
+ }
+ names(lambda) <- spec$momNames
+ new("gelfit", theta=theta, convergence=1, lconvergence=lconvergence,
+ lambda=lambda, call=Call, type=type, vcov=list(), model=object)
+ })
+
Modified: pkg/gmm4/R/gelfit-methods.R
===================================================================
--- pkg/gmm4/R/gelfit-methods.R 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/R/gelfit-methods.R 2018-09-20 21:27:29 UTC (rev 133)
@@ -98,7 +98,71 @@
SigmaLam <- backsolve(R, u)/n * bw^2
diag(SigmaLam)[diag(SigmaLam) < 0] <- tol
}
- list(vcov_par = Sigma, vcov_lambda = SigmaLam)
+ list(vcov_par = Sigma, vcov_lambda = SigmaLam, gtR=R)
})
+## Summary
+
+
+setMethod("summary","gelfit",
+ function (object, ...)
+ {
+ if (length(object at vcov) == 0)
+ v <- vcov(object, ...)
+ else
+ v <- object at vcov
+ se.t <- sqrt(diag(v$vcov_par))
+ se.l <- sqrt(diag(v$vcov_lambda))
+ theta <- object at theta
+ lambda <- object at lambda
+ tval.t <- theta/se.t
+ tval.l <- lambda/se.l
+ coef <- cbind(theta, se.t, tval.t,
+ 2*pnorm(abs(tval.t), lower.tail = FALSE))
+ coefl <- cbind(lambda, se.l, tval.l,
+ 2*pnorm(abs(tval.l), lower.tail = FALSE))
+ stest <- specTest(object)
+ dimnames(coef) <- list(names(theta), c("Estimate", "Std. Error",
+ "t value", "Pr(>|t|)"))
+ dimnames(coefl) <- list(names(lambda), c("Estimate", "Std. Error",
+ "t value", "Pr(>|t|)"))
+ pt <- getImpProb(object)
+
+ ans <- new("summaryGel", coef = coef, specTest = stest,
+ model = object at model, lambda=coefl,
+ convergence=object at convergence,
+ lconvergence=object at lconvergence, impProb=pt)
+ ans})
+
+## specTest
+
+setMethod("specTest", signature("gelfit", "missing"),
+ function(object, which) {
+ spec <- modelDims(object at model)
+ q <- spec$q
+ n <-
+ if (length(object at vcov)==0)
+ v <- vcov(object)
+ else
+ v <- object at vcov
+ gt <- evalMoment(object at model, object at theta)
+ gbar <- colMeans(gt)
+ n <- nrow(gt)
+ LR <- evalObjective(object at model, object at theta, lambda=object at lambda)
+ kHat <- crossprod(v$gtR)
+ LM <- n * crossprod(object at lambda, crossprod(kHat, object at lambda))/
+ (object at model@wSpec$bw^2)
+ J <- n * crossprod(gbar, solve(kHat, gbar))/(object at model@wSpec$k[1]^2)
+ df <- q-spec$k
+ test <- c(LR,LM,J)
+ if (df == 0)
+ pv <- NA
+ else
+ pv <- 1-pchisq(test, df)
+ test <- cbind(test, df, pv)
+ dimnames(test) <- list(c("LR: ",
+ "LM: ",
+ " J: "), c("Statistics", "df", "pvalue"))
+ ans <- new("specTest", test=test, testname="Test E(g)=0")
+ ans})
Modified: pkg/gmm4/R/gmm4.R
===================================================================
--- pkg/gmm4/R/gmm4.R 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/R/gmm4.R 2018-09-20 21:27:29 UTC (rev 133)
@@ -3,18 +3,14 @@
gmm4 <- function (g, x, tet0 = NULL, grad = NULL,
type = c("twostep", "iter", "cue", "onestep"),
- vcov = c("MDS", "HAC", "iid", "TrueFixed"),
+ vcov = c("iid", "HAC", "MDS", "TrueFixed"),
initW = c("ident", "tsls", "EbyE"), weights = "optimal",
- itermaxit = 50, cstLHS=NULL, cstRHS=NULL,
- kernel = c("Quadratic Spectral", "Truncated",
- "Bartlett", "Parzen", "Tukey-Hanning"), crit = 1e-06,
- bw = "Andrews", prewhite = 1L, ar.method = "ols", approx = "AR(1)",
- kerntol = 1e-07, itertol = 1e-07, centeredVcov = TRUE,
+ itermaxit = 50, cstLHS=NULL, cstRHS=NULL,
+ vcovOptions=list(), itertol = 1e-07, centeredVcov = TRUE,
data = parent.frame(), ...)
{
Call <- match.call()
vcov <- match.arg(vcov)
- kernel <- match.arg(kernel)
type <- match.arg(type)
initW <- match.arg(initW)
if (vcov == "TrueFixed")
@@ -32,18 +28,15 @@
model <- NULL
if (is.null(x) & !is.null(tet0))
model <- try(gmmModel(g=g, x=x, tet0=tet0, grad=grad, vcov=vcov,
- kernel=kernel, crit=crit, bw=bw, prewhite=prewhite,
- ar.method=ar.method, approx=approx, tol=kerntol,
+ vcovOptions=vcovOptions,
centeredVcov=centeredVcov, data=data), silent=TRUE)
if (is.null(model) || class(model)=="try-error")
model <- sysGmmModel(g=g, h=x, tet0=tet0, vcov=vcov,
- kernel=kernel, crit=crit, bw=bw, prewhite=prewhite,
- ar.method=ar.method, approx=approx, tol=kerntol,
+ vcovOptions=vcovOptions,
centeredVcov=centeredVcov, data=data)
} else {
model <- gmmModel(g=g, x=x, tet0=tet0, grad=grad, vcov=vcov,
- kernel=kernel, crit=crit, bw=bw, prewhite=prewhite,
- ar.method=ar.method, approx=approx, tol=kerntol,
+ vcovOptions=vcovOptions,
centeredVcov=centeredVcov, data=data)
if (initW == "EbyE")
{
@@ -53,10 +46,10 @@
}
if (!is.null(cstLHS))
model <- restGmmModel(model, cstLHS, cstRHS)
-
+
fit <- modelFit(object=model, type=type, itertol=itertol, initW=initW,
- weights=weights, itermaxit=itermaxit,
- efficientWeights=efficientWeights, ...)
+ weights=weights, itermaxit=itermaxit,
+ efficientWeights=efficientWeights, ...)
fit at call <- Call
fit
}
@@ -64,17 +57,11 @@
setMethod("tsls", "formula",
function(object, x, vcov = c("iid", "HAC", "MDS"),
- kernel = c("Quadratic Spectral", "Truncated", "Bartlett",
- "Parzen", "Tukey-Hanning"), crit = 1e-06, bw = "Andrews",
- prewhite = 1L, ar.method = "ols", approx = "AR(1)", kerntol = 1e-07,
- centeredVcov = TRUE, data = parent.frame())
+ vcovOptions=list(), centeredVcov = TRUE, data = parent.frame())
{
vcov <- match.arg(vcov)
- kernel <- match.arg(kernel)
- model <- gmmModel(g = object, x = x, vcov = vcov,
- kernel = kernel, crit = crit, bw = bw,
- prewhite = prewhite, ar.method = ar.method,
- approx = approx, tol = kerntol,
+ model <- gmmModel(g = object, x = x, vcov = vcov,
+ vcovOptions=vcovOptions,
centeredVcov = centeredVcov, data = data)
tsls(model)
})
@@ -82,35 +69,23 @@
setMethod("tsls", "list",
function(object, x=NULL, vcov = c("iid", "HAC", "MDS"),
- kernel = c("Quadratic Spectral", "Truncated", "Bartlett",
- "Parzen", "Tukey-Hanning"), crit = 1e-06, bw = "Andrews",
- prewhite = 1L, ar.method = "ols", approx = "AR(1)", kerntol = 1e-07,
- centeredVcov = TRUE, data = parent.frame())
+ vcovOptions=list(), centeredVcov = TRUE, data = parent.frame())
{
vcov <- match.arg(vcov)
- kernel <- match.arg(kernel)
- model <- sysGmmModel(g = object, h = x, vcov = vcov,
- kernel = kernel, crit = crit, bw = bw,
- prewhite = prewhite, ar.method = ar.method,
- approx = approx, tol = kerntol,
- centeredVcov = centeredVcov, data = data)
+ model <- sysGmmModel(g = object, h = x, vcov = vcov,
+ vcovOptions=vcovOptions,
+ centeredVcov = centeredVcov, data = data)
tsls(model)
})
setMethod("ThreeSLS", "list",
function(object, x=NULL, vcov = c("iid", "HAC", "MDS"),
- kernel = c("Quadratic Spectral", "Truncated", "Bartlett",
- "Parzen", "Tukey-Hanning"), crit = 1e-06, bw = "Andrews",
- prewhite = 1L, ar.method = "ols", approx = "AR(1)", kerntol = 1e-07,
- centeredVcov = TRUE, data = parent.frame())
+ vcovOptions=list(), centeredVcov = TRUE, data = parent.frame())
{
vcov <- match.arg(vcov)
- kernel <- match.arg(kernel)
- model <- sysGmmModel(g = object, h = x, vcov = vcov,
- kernel = kernel, crit = crit, bw = bw,
- prewhite = prewhite, ar.method = ar.method,
- approx = approx, tol = kerntol,
+ model <- sysGmmModel(g = object, h = x, vcov = vcov,
+ vcovOptions=vcovOptions,
centeredVcov = centeredVcov, data = data)
ThreeSLS(model)
})
Modified: pkg/gmm4/R/gmmModel.R
===================================================================
--- pkg/gmm4/R/gmmModel.R 2018-09-17 20:58:42 UTC (rev 132)
+++ pkg/gmm4/R/gmmModel.R 2018-09-20 21:27:29 UTC (rev 133)
@@ -1,19 +1,57 @@
+############# Options for covariance matrix
+.getVcovOptions <- function(type, ...)
+ {
+ addO <- list(...)
+ if (type == "HAC")
+ {
+ option <- list(kernel = "Quadratic Spectral",
+ crit = 1e-06,
+ bw = "Andrews", prewhite = 1L,
+ ar.method = "ols", approx = "AR(1)",
+ tol = 1e-07)
+ if (length(addO) > 0)
+ {
+ if (!all(names(addO) %in% names(option)))
+ stop(paste("Wrong options for vcov of type", type))
+ option[names(addO)] <- addO
+ }
+ option$kernel <- match.arg(option$kernel,
+ c("Quadratic Spectral", "Truncated", "Bartlett",
+ "Parzen", "Tukey-Hanning"))
+ if (!(option$ar.method %in% eval(as.list(args(ar))$method)))
+ stop("wrong value for ar.method")
+ if (!(option$approx %in% eval(as.list(bwAndrews)$approx)))
+ stop("wrong value for approx")
+ if (is.numeric(option$bw))
+ names(option$bw) <- "Fixed"
+ } else if (type=="CL") {
+ option <- list(cluster=NULL, type="HC0", cadjust=TRUE,
+ milti0=FALSE)
+ if (length(addO) > 0)
+ {
+ if (!all(names(addO) %in% names(option)))
+ stop(paste("Wrong options for vcov of type", type))
+ option[names(addO)] <- addO
+ }
+ if (option$type != "HC0")
+ stop("Only meatCL with type HC0 is allowed for GMM")
+ } else {
+ option <- list()
+ }
+ option
+ }
-
################## Constructor for the gmmModels Classes #####################
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 133
More information about the Gmm-commits
mailing list