[Gmm-commits] r120 - in pkg: . gmm4 gmm4/R gmm4/data gmm4/man gmm4/vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 20 22:58:52 CEST 2018
Author: chaussep
Date: 2018-06-20 22:58:52 +0200 (Wed, 20 Jun 2018)
New Revision: 120
Added:
pkg/gmm4/
pkg/gmm4/DESCRIPTION
pkg/gmm4/NAMESPACE
pkg/gmm4/R/
pkg/gmm4/R/allClasses.R
pkg/gmm4/R/gmm4.R
pkg/gmm4/R/gmmData.R
pkg/gmm4/R/gmmModel.R
pkg/gmm4/R/gmmModels-methods.R
pkg/gmm4/R/gmmWeights-methods.R
pkg/gmm4/R/gmmfit-methods.R
pkg/gmm4/R/hypothesisTest-methods.R
pkg/gmm4/R/rGmmModel-methods.R
pkg/gmm4/R/rsysGmmModels-methods.R
pkg/gmm4/R/sgmmfit-methods.R
pkg/gmm4/R/specTest-methods.R
pkg/gmm4/R/summaryGmm-methods.R
pkg/gmm4/R/sysGmmModel.R
pkg/gmm4/R/sysGmmModels-methods.R
pkg/gmm4/R/tsls-methods.R
pkg/gmm4/R/validity.R
pkg/gmm4/data/
pkg/gmm4/data/CigarettesSW.rda
pkg/gmm4/data/ConsumptionG.rda
pkg/gmm4/data/Griliches.rda
pkg/gmm4/data/HealthRWM.rda
pkg/gmm4/data/LabourCR.rda
pkg/gmm4/data/Mroz.rda
pkg/gmm4/data/simData.rda
pkg/gmm4/man/
pkg/gmm4/man/.Rhistory
pkg/gmm4/man/CigarettesSW.Rd
pkg/gmm4/man/ConsumptionG.Rd
pkg/gmm4/man/DWH-methods.Rd
pkg/gmm4/man/Dresiduals-methods.Rd
pkg/gmm4/man/Griliches.Rd
pkg/gmm4/man/HealthRWM.Rd
pkg/gmm4/man/LabourCR.Rd
pkg/gmm4/man/Mroz.Rd
pkg/gmm4/man/ThreeSLS-methods.Rd
pkg/gmm4/man/allNLGmm-class.Rd
pkg/gmm4/man/bread-methods.Rd
pkg/gmm4/man/coef-methods.Rd
pkg/gmm4/man/estfun-methods.Rd
pkg/gmm4/man/evalDMoment-methods.Rd
pkg/gmm4/man/evalGmm-methods.Rd
pkg/gmm4/man/evalMoment-methods.Rd
pkg/gmm4/man/evalObjective-methods.Rd
pkg/gmm4/man/evalWeights-methods.Rd
pkg/gmm4/man/functionGmm-class.Rd
pkg/gmm4/man/getRestrict-methods.Rd
pkg/gmm4/man/gmm4.Rd
pkg/gmm4/man/gmmFit-methods.Rd
pkg/gmm4/man/gmmModel.Rd
pkg/gmm4/man/gmmModels-class.Rd
pkg/gmm4/man/gmmWeights-class.Rd
pkg/gmm4/man/gmmfit-class.Rd
pkg/gmm4/man/hypothesisTest-class.Rd
pkg/gmm4/man/hypothesisTest-methods.Rd
pkg/gmm4/man/linearGmm-class.Rd
pkg/gmm4/man/meatGmm-methods.Rd
pkg/gmm4/man/merge-methods.Rd
pkg/gmm4/man/model.matrix-methods.Rd
pkg/gmm4/man/modelDims-methods.Rd
pkg/gmm4/man/modelResponse-methods.Rd
pkg/gmm4/man/momentStrength-methods.Rd
pkg/gmm4/man/momentVcov-methods.Rd
pkg/gmm4/man/nonlinearGmm-class.Rd
pkg/gmm4/man/print-methods.Rd
pkg/gmm4/man/printRestrict-methods.Rd
pkg/gmm4/man/quadra-methods.Rd
pkg/gmm4/man/regGmm-class.Rd
pkg/gmm4/man/residuals-methods.Rd
pkg/gmm4/man/restGmmModel-methods.Rd
pkg/gmm4/man/rfunctionGmm-class.Rd
pkg/gmm4/man/rgmmModels-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/rsysGmmModels-class.Rd
pkg/gmm4/man/sgmmfit-class.Rd
pkg/gmm4/man/show-methods.Rd
pkg/gmm4/man/simData.Rd
pkg/gmm4/man/slinearGmm-class.Rd
pkg/gmm4/man/snonlinearGmm-class.Rd
pkg/gmm4/man/solveGmm-methods.Rd
pkg/gmm4/man/specTest-class.Rd
pkg/gmm4/man/specTest-methods.Rd
pkg/gmm4/man/stsls-class.Rd
pkg/gmm4/man/subsetting.Rd
pkg/gmm4/man/summary-methods.Rd
pkg/gmm4/man/summaryGmm-class.Rd
pkg/gmm4/man/sysGmmModel.Rd
pkg/gmm4/man/sysGmmModels-class.Rd
pkg/gmm4/man/systemGmm.Rd
pkg/gmm4/man/tsls-class.Rd
pkg/gmm4/man/tsls-methods.Rd
pkg/gmm4/man/union-class.Rd
pkg/gmm4/man/update-methods.Rd
pkg/gmm4/man/vcov-methods.Rd
pkg/gmm4/man/vcovHAC-methods.Rd
pkg/gmm4/vignettes/
pkg/gmm4/vignettes/empir.bib
pkg/gmm4/vignettes/gmmS4.Rnw
pkg/gmm4/vignettes/gmmS4.pdf
Log:
adding a package that will eventually replace gmm
Added: pkg/gmm4/DESCRIPTION
===================================================================
--- pkg/gmm4/DESCRIPTION (rev 0)
+++ pkg/gmm4/DESCRIPTION 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,21 @@
+Package: gmm4
+Version: 0.0-2
+Date: 2018-05-29
+Title: S4 Generalized Method of Moments
+Author: Pierre Chausse <pchausse at uwaterloo.ca>
+Maintainer: Pierre Chausse <pchausse at uwaterloo.ca>
+Description: Here is a complete restructured Gmm package using S4 only type of
+ classes and methods.
+Depends: R (>= 2.10.0), sandwich
+Imports: stats, methods
+Suggests: lmtest, knitr
+Collate: 'allClasses.R' 'validity.R' 'gmmData.R' 'gmmModels-methods.R'
+ 'gmmfit-methods.R' 'tsls-methods.R' 'specTest-methods.R'
+ 'summaryGmm-methods.R' 'gmmWeights-methods.R' 'gmmModel.R'
+ 'rGmmModel-methods.R' 'gmm4.R' 'hypothesisTest-methods.R'
+ 'sysGmmModel.R' 'sysGmmModels-methods.R' 'rsysGmmModels-methods.R'
+ 'sgmmfit-methods.R'
+License: GPL (>= 2)
+NeedsCompilation: no
+VignetteBuilder: knitr
+Packaged: 2018-06-14 04:40:03 UTC; pierre
Added: pkg/gmm4/NAMESPACE
===================================================================
--- pkg/gmm4/NAMESPACE (rev 0)
+++ pkg/gmm4/NAMESPACE 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,36 @@
+importFrom("methods", is, new, show, "slot<-", "slotNames", "validObject",
+ "getClassDef", "selectMethod", "callNextMethod", "as", "setAs",
+ "getMethod")
+
+importFrom("utils", capture.output)
+
+importFrom("stats", "ar", "as.formula", "model.matrix","vcov",
+ "model.response", "na.omit", "terms", "residuals",
+ "D", "numericDeriv", "sd", "optim", "lm", "pf", "coef", "update",
+ "fitted", "lm.fit", "pchisq", "pnorm", "printCoefmat", "anova",
+ "model.frame", "reformulate", "formula")
+importFrom("sandwich", "vcovHAC", "estfun","kernHAC",
+ "bread","bwAndrews","bwNeweyWest","weightsAndrews",
+ "weightsLumley", "vcovHC")
+### S4 Methods and Classes
+exportClasses("nonlinearGmm", "linearGmm", "functionGmm", "gmmModels",
+ "regGmm", "allNLGmm", "gmmWeights", "gmmfit","rgmmModels",
+ "specTest", "summaryGmm", "rlinearGmm", "hypothesisTest",
+ "numericORcharacter", "tsls", "rnonlinearGmm", "rfunctionGmm",
+ "slinearGmm", "snonlinearGmm", "sysGmmModels",
+ "sgmmfit","stsls", "rslinearGmm", "rsnonlinearGmm", "rsysGmmModels")
+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,
+ tsls, gmmFit, meatGmm, specTest, gmm4, restGmmModel, modelResponse, DWH,
+ modelDims, printRestrict, getRestrict, sysGmmModel, ThreeSLS)
+
+### S3 methods ###
+
+### Need to find a better way
+S3method(estfun, gmmFct)
+
+
+
Added: pkg/gmm4/R/allClasses.R
===================================================================
--- pkg/gmm4/R/allClasses.R (rev 0)
+++ pkg/gmm4/R/allClasses.R 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,279 @@
+##### All S4 classes of the package are defined here
+######################################################
+
+
+## gmmModel
+
+setClassUnion("matrixORcharacter", c("matrix", "character"))
+setClassUnion("matrixORnumeric", c("matrix", "numeric"))
+setClassUnion("numericORcharacter", c("numeric", "character"))
+setClassUnion("numericORNULL", c("numeric", "NULL"))
+setClassUnion("numericORmatrixORNULL", c("matrix", "numeric", "NULL"))
+setClassUnion("expressionORNULL", c("expression", "NULL"))
+setClassUnion("functionORNULL", c("function", "NULL"))
+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))
+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",
+ 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))
+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",
+ 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))
+setClassUnion("regGmm", c("linearGmm", "nonlinearGmm"))
+setClassUnion("allNLGmm", c("nonlinearGmm", "functionGmm"))
+setClassUnion("gmmModels", c("linearGmm", "nonlinearGmm", "functionGmm"))
+
+## gmmWeights
+
+setClass("gmmWeights", representation(w="ANY", type="character", HAC="list"),
+ prototype(HAC=list()))
+
+## gmmfit
+
+setClass("gmmfit", representation(theta = "numeric", convergence = "numericORNULL",
+ convIter="numericORNULL",call="call",
+ type="character", wObj="gmmWeights",niter="integer",
+ efficientGmm="logical", model="gmmModels"))
+
+setClass("tsls", contains="gmmfit")
+
+## specTest
+
+setClass("specTest", representation(test = "matrix", testname="character"))
+
+## summaryGmm
+
+setClass("summaryGmm", representation(coef="matrix", specTest = "specTest",
+ strength="list", model="gmmModels",sandwich="logical",
+ type="character", convergence = "numericORNULL",
+ convIter="numericORNULL", wSpec="list",niter="integer",
+ df.adj="logical", breadOnly="logical"))
+## Restricted gmm Models
+
+setClass("rlinearGmm", representation(cstLHS="matrix", cstRHS="numeric", cstSpec="list"),
+ contains="linearGmm")
+
+setClass("rnonlinearGmm", representation(R="list", cstSpec="list"),
+ contains="nonlinearGmm")
+
+setClass("rfunctionGmm", representation(R="list", cstSpec="list"),
+ contains="functionGmm")
+
+setClassUnion("rgmmModels", c("rlinearGmm", "rnonlinearGmm", "rfunctionGmm"))
+
+## hypothesisTest
+
+setClass("hypothesisTest", representation(test="numeric", hypothesis="character",
+ dist="character", df="integer", pvalue="numeric",
+ type="character"))
+### System GMM
+
+setClass("slinearGmm", representation(modelT="list", instT="list",data="data.frame",
+ 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))
+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",
+ 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))
+setClassUnion("sysGmmModels", c("slinearGmm", "snonlinearGmm"))
+
+## Restricted System GMM
+
+setClass("rslinearGmm", representation(cstLHS="matrix", cstRHS="numeric", cstSpec="list"),
+ contains="slinearGmm")
+
+setClass("rsnonlinearGmm", representation(R="list", cstSpec="list"),
+ contains="snonlinearGmm")
+
+setClassUnion("rsysGmmModels", c("rslinearGmm", "rsnonlinearGmm"))
+
+### sysGmmWeights
+
+setClass("sysGmmWeights", representation(w="ANY", type="character", HAC="list",
+ Sigma="ANY", momNames="list", eqnNames="character",
+ sameMom="logical"),
+ prototype(w="ident", type="weights", momNames=list(), eqnNames=character(),
+ HAC=list(), sameMom=FALSE))
+
+## summarySysGmm
+
+setClass("summarySysGmm",
+ representation(coef="list", specTest = "specTest",
+ strength="list", model="sysGmmModels",sandwich="logical",
+ type="character", convergence = "numericORNULL",
+ convIter="numericORNULL", wSpec="list",niter="integer",
+ df.adj="logical", breadOnly="logical"))
+
+## Class converters
+
+setAs("linearGmm", "nonlinearGmm",
+ function(from) {
+ spec <- modelDims(from)
+ X <- model.matrix(from)
+ theta0 <- rep(1,ncol(X))
+ names(theta0) <- paste("theta", 1:ncol(X), sep="")
+ colnames(X) <- paste("X", 1:ncol(X), sep="")
+ rhs <- paste(names(theta0), "*", colnames(X), sep="")
+ rhs <- paste(rhs, collapse="+", sep="")
+ rhs <- parse(text=rhs)
+ X <- data.frame(Y=modelResponse(from), X)
+ 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,
+ isEndo=from at isEndo, varNames=from at varNames)
+ })
+
+setAs("linearGmm", "functionGmm",
+ function(from) {
+ spec <- modelDims(from)
+ X <- model.matrix(from)
+ theta0 <- rep(1,ncol(X))
+ names(theta0) <- paste("theta", 1:ncol(X), sep="")
+ colnames(X) <- paste("X", 1:ncol(X), sep="")
+ Z <- model.matrix(from, "instruments")
+ colnames(Z) <- paste("Z", 1:ncol(Z), sep="")
+ dat <- cbind(X, Z, Y=modelResponse(from))
+ theta0 <- rep(0,ncol(X))
+ names(theta0) <- paste("theta", 1:ncol(X), sep="")
+ fct <- function(theta, x)
+ {
+ wx <- which(strtrim(colnames(x),1) == "X")
+ wz <- which(strtrim(colnames(x),1) == "Z")
+ wy <- which(strtrim(colnames(x),1) == "Y")
+ e <- x[,wy]-c(x[,wx,drop=FALSE]%*%theta)
+ e*x[,wz]
+ }
+ dfct <- function(theta, x)
+ {
+ wx <- which(strtrim(colnames(x),1) == "X")
+ wz <- which(strtrim(colnames(x),1) == "Z")
+ -crossprod(x[,wz],x[,wx])/nrow(x)
+ }
+ new("functionGmm", X=dat, fct=fct, dfct=dfct, vcov=from at vcov,
+ theta0=theta0, n=spec$n, q=spec$q, k=spec$k, parNames=names(theta0),
+ momNames=colnames(Z), 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)
+ })
+
+setAs("slinearGmm", "linearGmm",
+ function(from) {
+ spec <- modelDims(from)
+ eqnNames <- from at eqnNames
+ neqn <- length(eqnNames)
+ datX <- lapply(1:neqn,
+ function(i) {
+ v <- from at varNames[[i]]
+ chk <- "(Intercept)" %in% v
+ v <- v[v!="(Intercept)"]
+ X <- from at data[,v]
+ colnames(X) <- paste(eqnNames[[i]],".", v, sep="")
+ if (chk)
+ {
+ X <- cbind(1, X)
+ colnames(X)[1]<-paste(eqnNames[[i]], ".Intercept", sep="")
+ }
+ X})
+ datZ <- lapply(1:neqn,
+ function(i) {
+ v <- all.vars(from at instT[[i]])
+ chk <- attr(from at instT[[i]], "intercept")==1
+ Z <- from at data[,v]
+ colnames(Z) <- paste(eqnNames[[i]],".", v, sep="")
+ if (chk)
+ {
+ Z <- cbind(1, Z)
+ colnames(Z)[1]<-paste(eqnNames[[i]], ".Intercept", sep="")
+ }
+ Z})
+ nZ <- do.call("c", lapply(datZ, colnames))
+ nX <- do.call("c", lapply(datX, colnames))
+ datZ <- .GListToMat(datZ)
+ datX <- .GListToMat(datX)
+ Y <- do.call("c", modelResponse(from))
+ colnames(datZ) <- nZ
+ colnames(datX) <- nX
+ dat <- cbind(Y, datZ, datX)
+ dat <- dat[,unique(colnames(dat))]
+ dat <- data.frame(dat, row.names=1:nrow(datZ))
+ g <- paste("Y~", paste(nX, collapse="+"), "-1")
+ 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)
+ })
+
+
+setAs("rslinearGmm", "rlinearGmm",
+ function(from) {
+ m <- as(from, "slinearGmm")
+ m <- as(m, "linearGmm")
+ restGmmModel(m, from at cstLHS, from at cstRHS)
+ })
+
+setAs("sysGmmWeights", "gmmWeights",
+ function(from) {
+ w <- quadra(from)
+ if (is.character(w))
+ w <- "ident"
+ new("gmmWeights", w=w, type="weights", HAC=list())
+ })
+
+
+
+### system GMM fit
+
+setClass("sgmmfit", representation(theta = "list", convergence = "numericORNULL",
+ convIter="numericORNULL",call="call",
+ type="character", wObj="sysGmmWeights",niter="integer",
+ efficientGmm="logical", model="sysGmmModels"))
+
+setClass("stsls", contains="sgmmfit")
Added: pkg/gmm4/R/gmm4.R
===================================================================
--- pkg/gmm4/R/gmm4.R (rev 0)
+++ pkg/gmm4/R/gmm4.R 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,26 @@
+################### the main gmm function ###################
+
+gmm4 <- function(g, x, tet0=NULL,grad=NULL, type=c("twostep", "iter","cue", "onestep"),
+ vcov = c("HAC", "MDS", "iid", "TrueFixed"),
+ initW=c("tsls","ident"), weights="optimal", itermaxit=50,
+ 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-7, centeredVcov = TRUE,
+ data=parent.frame(), ...)
+ {
+ Call <- match.call()
+ vcov <- match.arg(vcov)
+ kernel <- match.arg(kernel)
+ type <- match.arg(type)
+ initW <- match.arg(initW)
+
+ model <- gmmModel(g, x, tet0, grad, vcov, kernel, crit = 1e-06,
+ bw, prewhite, ar.method, approx, kerntol, centeredVcov, data)
+
+
+ fit <- gmmFit(model, type, itertol, initW, weights,
+ itermaxit=100, ...)
+ fit at call <- Call
+ fit
+ }
Added: pkg/gmm4/R/gmmData.R
===================================================================
--- pkg/gmm4/R/gmmData.R (rev 0)
+++ pkg/gmm4/R/gmmData.R 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,197 @@
+######### Function to arrange the data for the gmmModel objects #################
+
+.lGmmData <- function(formula, h, data)
+ {
+ mf <- match.call()
+ m <- match(c("formula", "data"), names(mf), 0L)
+ mf <- mf[c(1L, m)]
+ mf$drop.unused.levels <- TRUE
+ mf$na.action <- "na.pass"
+ mfh <- mf
+ mf[[1L]] <- quote(stats::model.frame)
+ modelF <- eval(mf, parent.frame())
+ parNames <- colnames(model.matrix(terms(modelF), modelF))
+ k <- length(parNames)
+ if (any(class(h) == "formula"))
+ {
+ mfh$formula <- h
+ mfh[[1L]] <- quote(stats::model.frame)
+ instF <- eval(mfh, parent.frame())
+ } else {
+ h <- as.data.frame(h)
+ chk <- apply(h, 2, function(x) all(x==x[1]))
+ h <- h[, !chk]
+ intercept <- any(chk)
+ if (ncol(h) == 0)
+ {
+ mfh$formula <- ~1
+ } else {
+ if (is.null(colnames(h)))
+ colnames(h) <- paste("h", 1:ncol(h), sep="")
+ formh <- paste(colnames(h), collapse="+")
+ if (!intercept)
+ formh <- paste(formh, "-1", sep="")
+ mfh$formula <- as.formula(paste("~",formh))
+ mfh$data <- quote(h)
+ }
+ mfh[[1L]] <- quote(stats::model.frame)
+ instF <- eval(mfh)
+ }
+ momNames <- colnames(model.matrix(terms(instF), instF))
+ q <- length(momNames)
+ isEndo <- !(parNames %in% momNames)
+ na <- attr(na.omit(cbind(modelF, instF)), "na.action")
+ if (!is.null(na))
+ {
+ modelF <- modelF[-na,,drop=FALSE]
+ instF <- instF[-na,,drop=FALSE]
+ }
+ n <- nrow(modelF)
+ list(modelF=modelF, instF=instF, n=n, k=k, q=q, momNames=momNames,
+ parNames=parNames, isEndo=isEndo, varNames=parNames)
+ }
+
+.nlGmmData <- function(formula, h, tet0, data)
+ {
+ varNames <- all.vars(formula)
+ parNames <- names(tet0)
+ varNames <- varNames[!(varNames %in% parNames)]
+ modelF <- try(sapply(varNames, function(n) data[[n]]), silent=TRUE)
+ if (any(class(modelF)=="try-error"))
+ stop("some variables are missing from data")
+ modelF <- as.data.frame(modelF)
+ allVar <- c(as.list(modelF), as.list(tet0))
+ k <- length(tet0)
+ if (length(formula) == 3L)
+ {
+ fLHS <- as.expression(formula[[2]])
+ chk <- try(eval(fLHS, allVar))
+ if (any(class(chk)=="try-error"))
+ stop("Cannot evaluate the LHS")
+ fRHS <- as.expression(formula[[3]])
+ chk <- try(eval(fRHS, allVar))
+ if (any(class(chk)=="try-error"))
+ stop("Cannot evaluate the RHS")
+ } else {
+ fLHS <- NULL
+ fRHS <- as.expression(formula[[2]])
+ chk <- try(eval(fRHS, allVar))
+ if (any(class(chk)=="try-error"))
+ stop("Cannot evaluate the RHS")
+ }
+ if (any(class(h) == "formula"))
+ {
+ mfh <- match.call()
+ m <- match(c("formula", "data"), names(mfh), 0L)
+ mfh <- mfh[c(1L, m)]
+ mfh$drop.unused.levels <- TRUE
+ mfh$na.action <- "na.pass"
+ mfh$formula <- h
+ mfh[[1L]] <- quote(stats::model.frame)
+ instF <- eval(mfh, parent.frame())
+ } else {
+ h <- as.data.frame(h)
+ chk <- apply(h, 2, function(x) all(x==x[1]))
+ h <- h[, !chk]
+ intercept <- any(chk)
+ if (ncol(h) == 0)
+ {
+ mfh$formula <- ~1
+ } else {
+ if (is.null(colnames(h)))
+ colnames(h) <- paste("h", 1:ncol(h), sep="")
+ formh <- paste(colnames(h), collapse="+")
+ if (!intercept)
+ formh <- paste(formh, "-1", sep="")
+ mfh$formula <- as.formula(paste("~",formh))
+ mfh$data <- quote(h)
+ }
+ mfh[[1L]] <- quote(stats::model.frame)
+ instF <- eval(mfh)
+ }
+ momNames <- colnames(model.matrix(terms(instF), instF))
+ isEndo <- !(varNames %in% momNames)
+ q <- length(momNames)
+ na <- attr(na.omit(cbind(modelF, instF)), "na.action")
+ if (!is.null(na))
+ {
+ modelF <- modelF[-na,,drop=FALSE]
+ instF <- instF[-na,,drop=FALSE]
+ }
+ n <- nrow(modelF)
+ list(modelF=modelF, instF=instF, fRHS=fRHS, fLHS=fLHS, n=n, k=k, q=q,
+ momNames=momNames, parNames=parNames, varNames=varNames, isEndo=isEndo)
+ }
+
+.fGmmData <- function(g, x, theta0)
+ {
+ mom <- try(g(theta0, x))
+ k <- length(theta0)
+ if (is.null(names(theta0)))
+ parNames <- paste("tet", 1:k, sep="")
+ else
+ parNames <- names(theta0)
+ if (any(class(mom)=="try-error"))
+ {
+ msg <- paste("Cannot evaluate the moments at theta0\n",
+ attr(mom,"conditon"))
+ stop(msg)
+ } else {
+ q <- ncol(mom)
+ n <- nrow(mom)
+ if (!is.null(colnames(mom)))
+ momNames <- colnames(mom)
+ else
+ momNames <- paste("h", 1:q, sep="")
+ }
+ list(q=q,n=n,k=k, momNames=momNames, parNames=parNames,
+ varNames=character(), isEndo=logical())
+ }
+
+.slGmmData <- function(g,h,data)
+ {
+ res <- lapply(1:length(g), function(i) .lGmmData(g[[i]], h[[i]], data))
+ modelT <- lapply(res, function(x) terms(x$modelF))
+ instT <- lapply(res, function(x) terms(x$instF))
+ allDat <- do.call(cbind, lapply(res, function(x) cbind(x$modelF, x$instF)))
+ allDat <- allDat[,!duplicated(colnames(allDat))]
+ parNames <- lapply(1:length(g), function(i) res[[i]]$parNames)
+ momNames <- lapply(1:length(g), function(i) res[[i]]$momNames)
+ isEndo <- lapply(1:length(g), function(i) res[[i]]$isEndo)
+ varNames <- lapply(1:length(g), function(i) res[[i]]$varNames)
+ k <- sapply(parNames, length)
+ q <- sapply(momNames, length)
+ n <- nrow(allDat)
+ if (!is.null(names(g)))
+ eqnNames=names(g)
+ else
+ eqnNames <- paste("Eqn", 1:length(g), sep="")
+ list(data=allDat, modelT=modelT, instT=instT, parNames=parNames,
+ momNames=momNames, k=k,q=q,n=n, eqnNames=eqnNames,
+ varNames=varNames, isEndo=isEndo)
+ }
+
+.snlGmmData <- function(g,h,tet0, data)
+ {
+ res <- lapply(1:length(g), function(i) .nlGmmData(g[[i]], h[[i]],
+ tet0[[i]], data))
+ fRHS <- lapply(res, function(x) x$fRHS)
+ fLHS <- lapply(res, function(x) x$fLHS)
+ instT <- lapply(res, function(x) terms(x$instF))
+ allDat <- do.call(cbind, lapply(res, function(x) cbind(x$modelF, x$instF)))
+ allDat <- allDat[,!duplicated(colnames(allDat))]
+ parNames <- lapply(1:length(g), function(i) res[[i]]$parNames)
+ momNames <- lapply(1:length(g), function(i) res[[i]]$momNames)
+ isEndo <- lapply(1:length(g), function(i) res[[i]]$isEndo)
+ varNames <- lapply(1:length(g), function(i) res[[i]]$varNames)
+ k <- sapply(parNames, length)
+ q <- sapply(momNames, length)
+ n <- nrow(allDat)
+ if (!is.null(names(g)))
+ eqnNames=names(g)
+ else
+ eqnNames <- paste("Eqn", 1:length(g), sep="")
+ list(data=allDat, fRHS=fRHS, fLHS=fLHS, parNames=parNames,
+ momNames=momNames, k=k,q=q,n=n, eqnNames=eqnNames, instT=instT,
+ varNames=varNames, isEndo=isEndo)
+ }
Added: pkg/gmm4/R/gmmModel.R
===================================================================
--- pkg/gmm4/R/gmmModel.R (rev 0)
+++ pkg/gmm4/R/gmmModel.R 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,62 @@
+
+
+
+################## Constructor for the gmmModels Classes #####################
+
+gmmModel <- function(g, x, 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())
+ {
+ vcov <- match.arg(vcov)
+ kernel <- match.arg(kernel)
+ if (is.numeric(bw))
+ names(bw) <- "Fixed"
+ if (!is.list(data) && !is.environment(data))
+ stop("'data' must be a list or an environment")
+ if (any(class(g)=="formula"))
+ {
+ chk <- names(tet0) %in% all.vars(g)
+ if (length(chk) == 0 | all(!chk))
+ {
+ model <- .lGmmData(g,x,data)
+ gmodel <- new("linearGmm", modelF=model$modelF,
+ instF=model$instF,
+ vcov=vcov, kernel=kernel, bw=bw,
+ prewhite=as.integer(prewhite),
+ ar.method=ar.method, approx=approx, tol=tol,
+ centeredVcov = centeredVcov, k=model$k,
+ q=model$q, n=model$n, parNames=model$parNames,
+ momNames=model$momNames, varNames=model$varNames,
+ isEndo=model$isEndo)
+ } else {
+ if (!all(chk))
+ stop("All parameters in tet0 must be in g for nl Gmm")
+ model <- .nlGmmData(g, x, tet0, data)
+ gmodel <- new("nonlinearGmm", modelF=model$modelF,
+ instF=model$instF,theta0=tet0,fRHS=model$fRHS,
+ fLHS=model$fLHS, vcov=vcov, kernel=kernel, bw=bw,
+ prewhite=as.integer(prewhite),
+ ar.method=ar.method, approx=approx, tol=tol,
+ centeredVcov = centeredVcov, k=model$k, q=model$q,
+ n=model$n, parNames=model$parNames,
+ momNames=model$momNames, varNames=model$varNames,
+ isEndo=model$isEndo)
+ }
+ } else {
+ model <- .fGmmData(g, x, tet0)
+ gmodel <- new("functionGmm", X=x, fct=g,
+ theta0=tet0, vcov=vcov, kernel=kernel, bw=bw,
+ prewhite=as.integer(prewhite),dfct=grad,
+ ar.method=ar.method, approx=approx, tol=tol,
+ centeredVcov = centeredVcov, k=model$k, q=model$q,
+ n=model$n, parNames=model$parNames,
+ momNames=model$momNames, varNames=model$varNames,
+ isEndo=model$isEndo)
+ }
+ gmodel
+ }
+
+
Added: pkg/gmm4/R/gmmModels-methods.R
===================================================================
--- pkg/gmm4/R/gmmModels-methods.R (rev 0)
+++ pkg/gmm4/R/gmmModels-methods.R 2018-06-20 20:58:52 UTC (rev 120)
@@ -0,0 +1,721 @@
+####### All methods with gmmModels (and its subclasses) signature
+#################################################################
+
+####################### Print ########################
+### The getGeneric for print is here only, so the file must be compiled
+### before any other files containing print
+
+setGeneric("print")
+setMethod("print", "gmmModels",
+ function(x, ...) {
+ cat("GMM Model\n")
+ cat("*********\n")
+ cat("Moment type: ", strsplit(is(x)[1], "G")[[1]][1], "\n", sep="")
+ cat("Covariance matrix: ", x at vcov, sep="")
+ if (x at vcov == "HAC")
+ {
+ cat(" with ", x at kernel, " kernel and ")
+ if (is.numeric(x at bw))
+ cat("Fixed bandwidth (", round(x at bw,3), ")", sep="")
+ else
+ cat(x at bw, " bandwidth", sep="")
+ }
+ cat("\n")
+ d <- modelDims(x)
+ cat("Number of regressors: ", d$k, "\n", sep="")
+ cat("Number of moment conditions: ", d$q, "\n", sep="")
+ if (!inherits(x, "functionGmm"))
+ cat("Number of Endogenous Variables: ", sum(x at isEndo), "\n", sep="")
+ cat("Sample size: ", d$n, "\n")})
+
+setMethod("show", "gmmModels", function(object) print(object))
+
+##### coef ########
+### For this, it only attach the names to theta
+
+setMethod("coef", "gmmModels",
+ function(object, theta) {
+ names(theta) <- object at parNames
+ theta})
+
+################## model.matrix and modelResponse #################
+### I did not make model.response as generic because it is not
+### a method in stats and I want different arguments
+
+setGeneric("modelResponse", function(object, ...) standardGeneric("modelResponse"))
+
+setMethod("modelResponse", signature("linearGmm"),
+ function(object)
+ {
+ model.response(object at modelF)
+ })
+
+setGeneric("model.matrix")
+setMethod("model.matrix", signature("linearGmm"),
+ function(object, type=c("regressors","instruments"))
+ {
+ type <- match.arg(type)
+ if (type == "regressors")
+ {
+ ti <- attr(object at modelF, "terms")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 120
More information about the Gmm-commits
mailing list