[Gmm-commits] r136 - in pkg/gmm4: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 27 21:18:35 CEST 2018
Author: chaussep
Date: 2018-09-27 21:18:35 +0200 (Thu, 27 Sep 2018)
New Revision: 136
Modified:
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/sysGmmModel.R
pkg/gmm4/R/sysGmmModels-methods.R
pkg/gmm4/R/validity.R
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/gmm4.Rd
pkg/gmm4/man/gmmModel.Rd
pkg/gmm4/man/linearGel-class.Rd
pkg/gmm4/man/linearGmm-class.Rd
pkg/gmm4/man/nonlinearGel-class.Rd
pkg/gmm4/man/nonlinearGmm-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/slinearGmm-class.Rd
pkg/gmm4/man/snonlinearGmm-class.Rd
pkg/gmm4/man/sysGmmModel.Rd
pkg/gmm4/man/tsls-methods.Rd
Log:
starts to add options for clustered vcov and survey weights
Modified: pkg/gmm4/R/allClasses.R
===================================================================
--- pkg/gmm4/R/allClasses.R 2018-09-26 14:34:00 UTC (rev 135)
+++ pkg/gmm4/R/allClasses.R 2018-09-27 19:18:35 UTC (rev 136)
@@ -16,7 +16,7 @@
parNames="character", momNames="character",
vcovOptions="list", centeredVcov="logical",
varNames="character", isEndo="logical",
- omit='integer'))
+ omit='integer', survOptions="list"))
setClass("nonlinearGmm", representation(modelF="data.frame", instF="data.frame",
vcov="character",theta0="numeric",
n="integer", q="integer",k="integer",
@@ -24,14 +24,14 @@
fRHS="expression", fLHS="expressionORNULL",
vcovOptions="list",
centeredVcov="logical", varNames="character",
- isEndo="logical",omit='integer'))
+ isEndo="logical",omit='integer', survOptions="list"))
setClass("functionGmm", representation(X="ANY", fct="function",dfct="functionORNULL",
vcov="character",theta0="numeric",
n="integer", q="integer",k="integer",
parNames="character", momNames="character",
vcovOptions="list",
centeredVcov="logical", varNames="character",
- isEndo="logical",omit='integer'))
+ isEndo="logical",omit='integer', survOptions="list"))
setClass("formulaGmm", representation(modelF="data.frame",
vcov="character",theta0="numeric",
n="integer", q="integer",k="integer",
@@ -39,7 +39,8 @@
fRHS="list", fLHS="list",
vcovOptions="list",
centeredVcov="logical", varNames="character",
- isEndo="logical", isMDE="logical",omit='integer'))
+ isEndo="logical", isMDE="logical",omit='integer',
+ survOptions="list"))
setClassUnion("regGmm", c("linearGmm", "nonlinearGmm"))
setClassUnion("allNLGmm", c("nonlinearGmm", "functionGmm", "formulaGmm"))
setClassUnion("gmmModels", c("linearGmm", "nonlinearGmm", "functionGmm", "formulaGmm"))
@@ -125,7 +126,7 @@
vcovOptions="list",
centeredVcov="logical", sameMom="logical",
SUR="logical", varNames="list", isEndo="list",
- omit='integer'))
+ omit='integer', survOptions="list"))
setClass("snonlinearGmm", representation(data="data.frame", instT="list",
vcov="character",theta0="list",
@@ -136,7 +137,7 @@
centeredVcov="logical", sameMom="logical",
SUR="logical",
varNames="list", isEndo="list",
- omit='integer'))
+ omit='integer', survOptions="list"))
setClassUnion("sysGmmModels", c("slinearGmm", "snonlinearGmm"))
## Restricted System GMM
@@ -181,7 +182,8 @@
theta0=theta0, n=spec$n, q=spec$q, k=spec$k, parNames=names(theta0),
momNames=spec$momNames, fRHS=rhs, fLHS=lhs,
vcovOptions=from at vcovOptions, centeredVcov=from at centeredVcov,
- isEndo=from at isEndo, varNames=from at varNames,omit=from at omit)
+ isEndo=from at isEndo, varNames=from at varNames,omit=from at omit,
+ survOptions=from at survOptions)
})
setAs("linearGmm", "functionGmm",
@@ -203,7 +205,7 @@
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,vcovOptions=from at vcovOptions,
- centeredVcov=from at centeredVcov,omit=integer())
+ centeredVcov=from at centeredVcov,omit=integer(),survOptions=from at survOptions)
})
setAs("allNLGmm", "functionGmm",
@@ -224,7 +226,7 @@
theta0=from at theta0, n=spec$n, q=spec$q, k=spec$k,
parNames=names(from at theta0),
momNames=spec$momNames, vcovOptions=from at vcovOptions,
- centeredVcov=from at centeredVcov,omit=integer())
+ centeredVcov=from at centeredVcov,omit=integer(), survOptions=from at survOptions)
})
setAs("slinearGmm", "linearGmm",
Modified: pkg/gmm4/R/gmm4.R
===================================================================
--- pkg/gmm4/R/gmm4.R 2018-09-26 14:34:00 UTC (rev 135)
+++ pkg/gmm4/R/gmm4.R 2018-09-27 19:18:35 UTC (rev 136)
@@ -3,10 +3,11 @@
gmm4 <- function (g, x, tet0 = NULL, grad = NULL,
type = c("twostep", "iter", "cue", "onestep"),
- vcov = c("iid", "HAC", "MDS", "TrueFixed"),
+ vcov = c("iid", "HAC", "MDS", "TrueFixed", "CL"),
initW = c("ident", "tsls", "EbyE"), weights = "optimal",
itermaxit = 50, cstLHS=NULL, cstRHS=NULL,
- vcovOptions=list(), itertol = 1e-07, centeredVcov = TRUE,
+ vcovOptions=list(),survOptions=list(),
+ itertol = 1e-07, centeredVcov = TRUE,
data = parent.frame(), ...)
{
Call <- match.call()
@@ -19,24 +20,26 @@
!(class(weights) %in% c("gmmWeights", "sysGmmWeigths")))
stop("With TrueFixed vcov the weights must be provided")
efficientWeights <- TRUE
+ vcov2 <- "iid"
} else {
efficientWeights <- FALSE
+ vcov2 <- vcov
}
if (is.list(g))
{
- ## Formula of sysGMM? Need to find a better way.
+ ## Formula or sysGMM? Need to find a better way.
model <- NULL
if (is.null(x) & !is.null(tet0))
- model <- try(gmmModel(g=g, x=x, tet0=tet0, grad=grad, vcov=vcov,
- vcovOptions=vcovOptions,
+ model <- try(gmmModel(g=g, x=x, tet0=tet0, grad=grad, vcov=vcov2,
+ vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov=centeredVcov, data=data), silent=TRUE)
if (is.null(model) || class(model)=="try-error")
- model <- sysGmmModel(g=g, h=x, tet0=tet0, vcov=vcov,
- vcovOptions=vcovOptions,
+ model <- sysGmmModel(g=g, h=x, tet0=tet0, vcov=vcov2,
+ vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov=centeredVcov, data=data)
} else {
- model <- gmmModel(g=g, x=x, tet0=tet0, grad=grad, vcov=vcov,
- vcovOptions=vcovOptions,
+ model <- gmmModel(g=g, x=x, tet0=tet0, grad=grad, vcov=vcov2,
+ vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov=centeredVcov, data=data)
if (initW == "EbyE")
{
@@ -56,36 +59,38 @@
setMethod("tsls", "formula",
- function(object, x, vcov = c("iid", "HAC", "MDS"),
- vcovOptions=list(), centeredVcov = TRUE, data = parent.frame())
+ function(object, x, vcov = c("iid", "HAC", "MDS", "CL"),
+ vcovOptions=list(), survOptions=list(), centeredVcov = TRUE,
+ data = parent.frame())
{
vcov <- match.arg(vcov)
model <- gmmModel(g = object, x = x, vcov = vcov,
- vcovOptions=vcovOptions,
+ vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov = centeredVcov, data = data)
tsls(model)
})
-
setMethod("tsls", "list",
- function(object, x=NULL, vcov = c("iid", "HAC", "MDS"),
- vcovOptions=list(), centeredVcov = TRUE, data = parent.frame())
+ function(object, x=NULL, vcov = c("iid", "HAC", "MDS", "CL"),
+ vcovOptions=list(), survOptions=list(), centeredVcov = TRUE,
+ data = parent.frame())
{
vcov <- match.arg(vcov)
model <- sysGmmModel(g = object, h = x, vcov = vcov,
- vcovOptions=vcovOptions,
+ vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov = centeredVcov, data = data)
tsls(model)
})
setMethod("ThreeSLS", "list",
- function(object, x=NULL, vcov = c("iid", "HAC", "MDS"),
- vcovOptions=list(), centeredVcov = TRUE, data = parent.frame())
+ function(object, x=NULL, vcov = c("iid", "HAC", "MDS", "CL"),
+ vcovOptions=list(), survOptions=list(), centeredVcov = TRUE,
+ data = parent.frame())
{
vcov <- match.arg(vcov)
model <- sysGmmModel(g = object, h = x, vcov = vcov,
- vcovOptions=vcovOptions,
+ vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov = centeredVcov, data = data)
ThreeSLS(model)
})
Modified: pkg/gmm4/R/gmmData.R
===================================================================
--- pkg/gmm4/R/gmmData.R 2018-09-26 14:34:00 UTC (rev 135)
+++ pkg/gmm4/R/gmmData.R 2018-09-27 19:18:35 UTC (rev 136)
@@ -1,6 +1,7 @@
######### Function to arrange the data for the gmmModel objects #################
-.multiToSys <- function(formula, h, data, omit=TRUE)
+.multiToSys <- function(formula, h, data, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
modelF <- model.frame(formula, data, na.action="na.pass",
drop.unused.levels=TRUE)
@@ -40,10 +41,11 @@
h <- lapply(1:ncol(Y), function(i) formula(terms(instF), .GlobalEnv))
data <- cbind(modelF, instF)
data <- data[,!duplicated(colnames(data))]
- return(.slGmmData(g,h,data,omit))
+ return(.slGmmData(g,h,data,survOptions, vcovOptions,na.action))
}
-.lGmmData <- function(formula, h, data, omit=TRUE)
+.lGmmData <- function(formula, h, data, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
modelF <- model.frame(formula, data, na.action="na.pass",
drop.unused.levels=TRUE)
@@ -77,20 +79,37 @@
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) && omit)
+ tmpDat <- cbind(modelF, instF)
+ add <- survOptions$weights
+ if (!is.null(vcovOptions$cluster))
+ add <- cbind(as.matrix(vcovOptions$cluster), add)
+ if (!is.null(add))
+ tmpDat <- cbind(tmpDat, add)
+ na <- attr(get(na.action)(tmpDat), "na.action")[]
+ if (!is.null(na))
{
modelF <- modelF[-na,,drop=FALSE]
instF <- instF[-na,,drop=FALSE]
+ if (!is.null(vcovOptions$cluster))
+ {
+ if (is.null(dim(vcovOptions$cluster)))
+ vcovOptions$cluster <- vcovOptions$cluster[-na]
+ else
+ vcovOptions$cluster <- vcovOptions$cluster[-na,,drop=FALSE]
+ }
+ if (!is.null(survOptions$weights))
+ survOptions$weights <- survOptions$weights[-na]
}
if (is.null(na))
na <- integer()
n <- nrow(modelF)
list(modelF=modelF, instF=instF, n=n, k=k, q=q, momNames=momNames,
- parNames=parNames, isEndo=isEndo, varNames=parNames, na.action=na)
+ parNames=parNames, isEndo=isEndo, varNames=parNames, omit=na,
+ vcovOptions=vcovOptions, survOptions=survOptions)
}
-.formGmmData <- function(formula, tet0, data,omit=TRUE)
+.formGmmData <- function(formula, tet0, data, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
res <- lapply(formula, function(f) .nlGmmData(f, ~1, tet0, data))
fRHS <- lapply(res, function(r) r$fRHS)
@@ -103,9 +122,26 @@
isMDE <- all(chkLHS) | all(chkRHS)
modelF <- sapply(varNames, function(n) data[[n]])
modelF <- as.data.frame(modelF)
- na <- attr(na.omit(modelF), "na.action")[]
- if (!is.null(na) && omit)
+ tmpDat <- modelF
+ add <- survOptions$weights
+ if (!is.null(vcovOptions$cluster))
+ add <- cbind(as.matrix(vcovOptions$cluster), add)
+ if (!is.null(add))
+ tmpDat <- cbind(tmpDat, add)
+ na <- attr(get(na.action)(tmpDat), "na.action")[]
+ if (!is.null(na))
+ {
modelF <- modelF[-na,,drop=FALSE]
+ if (!is.null(vcovOptions$cluster))
+ {
+ if (is.null(dim(vcovOptions$cluster)))
+ vcovOptions$cluster <- vcovOptions$cluster[-na]
+ else
+ vcovOptions$cluster <- vcovOptions$cluster[-na,,drop=FALSE]
+ }
+ if (!is.null(survOptions$weights))
+ survOptions$weights <- survOptions$weights[-na]
+ }
if (is.null(na))
na <- integer()
k <- length(tet0)
@@ -118,12 +154,13 @@
n <- nrow(modelF)
list(modelF=modelF, fRHS=fRHS, fLHS=fLHS, n=n, k=k, q=q,
momNames=momNames, parNames=parNames, varNames=varNames, isEndo=isEndo,
- isMDE=isMDE,na.action=na)
+ isMDE=isMDE,omit=na, vcovOptions=vcovOptions, survOptions=survOptions)
}
-.nlGmmData <- function(formula, h, tet0, data, omit=TRUE)
+.nlGmmData <- function(formula, h, tet0, data, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
varNames <- all.vars(formula)
parNames <- names(tet0)
@@ -177,21 +214,37 @@
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) && omit)
+ tmpDat <- cbind(modelF, instF)
+ add <- survOptions$weights
+ if (!is.null(vcovOptions$cluster))
+ add <- cbind(as.matrix(vcovOptions$cluster), add)
+ if (!is.null(add))
+ tmpDat <- cbind(tmpDat, add)
+ na <- attr(get(na.action)(tmpDat), "na.action")[]
+ if (!is.null(na))
{
modelF <- modelF[-na,,drop=FALSE]
instF <- instF[-na,,drop=FALSE]
+ if (!is.null(vcovOptions$cluster))
+ {
+ if (is.null(dim(vcovOptions$cluster)))
+ vcovOptions$cluster <- vcovOptions$cluster[-na]
+ else
+ vcovOptions$cluster <- vcovOptions$cluster[-na,,drop=FALSE]
+ }
+ if (!is.null(survOptions$weights))
+ survOptions$weights <- survOptions$weights[-na]
}
if (is.null(na))
na <- integer()
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,
- na.action=na)
+ omit=na, vcovOptions=vcovOptions, survOptions=survOptions)
}
-.fGmmData <- function(g, x, thet0, omit=NULL)
+.fGmmData <- function(g, x, thet0, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
mom <- try(g(thet0, x))
k <- length(thet0)
@@ -199,6 +252,14 @@
parNames <- paste("tet", 1:k, sep="")
else
parNames <- names(thet0)
+ add <- survOptions$weights
+ if (!is.null(vcovOptions$cluster))
+ add <- cbind(as.matrix(vcovOptions$cluster), add)
+ if (!is.null(add))
+ {
+ if (any(is.na(add)))
+ stop("weights or cluster contains missing values")
+ }
if (any(class(mom)=="try-error"))
{
msg <- paste("Cannot evaluate the moments at thet0\n",
@@ -215,20 +276,40 @@
momNames <- paste("h", 1:q, sep="")
}
list(q=q,n=n,k=k, momNames=momNames, parNames=parNames,
- varNames=character(), isEndo=logical(), na.action=integer())
+ varNames=character(), isEndo=logical(), omit=integer(),
+ vcovOptions=vcovOptions, survOptions=survOptions)
}
-.slGmmData <- function(g,h,data,omit=TRUE)
+.slGmmData <- function(g,h,data, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
- res <- lapply(1:length(g), function(i) .lGmmData(g[[i]], h[[i]], data, FALSE))
+ res <- lapply(1:length(g), function(i) .lGmmData(g[[i]], h[[i]], data,
+ list(), list(), "na.pass"))
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))]
- allDat <- na.omit(allDat)
- na <- attr(allDat, "na.action")[]
- if (omit && !is.null(na))
- allDat <- allDat[-na,]
+ add <- survOptions$weights
+ if (!is.null(vcovOptions$cluster))
+ add <- cbind(as.matrix(vcovOptions$cluster), add)
+ if (!is.null(add))
+ tmpDat <- cbind(allDat, add)
+ else
+ tmpDat <- allDat
+ na <- attr(get(na.action)(tmpDat), "na.action")[]
+ if (!is.null(na))
+ {
+ allDat <- allDat[-na,,drop=FALSE]
+ if (!is.null(vcovOptions$cluster))
+ {
+ if (is.null(dim(vcovOptions$cluster)))
+ vcovOptions$cluster <- vcovOptions$cluster[-na]
+ else
+ vcovOptions$cluster <- vcovOptions$cluster[-na,,drop=FALSE]
+ }
+ if (!is.null(survOptions$weights))
+ survOptions$weights <- survOptions$weights[-na]
+ }
if (is.null(na))
na <- integer()
parNames <- lapply(1:length(g), function(i) res[[i]]$parNames)
@@ -244,22 +325,42 @@
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, na.action=na)
+ varNames=varNames, isEndo=isEndo, omit=na,
+ vcovOptions=vcovOptions, survOptions=survOptions)
}
-.snlGmmData <- function(g,h,tet0, data, omit=TRUE)
+.snlGmmData <- function(g,h,tet0, data, survOptions=list(), vcovOptions=list(),
+ na.action="na.omit")
{
res <- lapply(1:length(g), function(i) .nlGmmData(g[[i]], h[[i]],
- tet0[[i]], data, FALSE))
+ tet0[[i]], data, list(),
+ list(), "na.pass"))
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))]
- allDat <- na.omit(allDat)
- na <- attr(allDat, "na.action")[]
- if (omit && !is.null(na))
- allDat <- allDat[-na,]
+ add <- survOptions$weights
+ if (!is.null(vcovOptions$cluster))
+ add <- cbind(as.matrix(vcovOptions$cluster), add)
+ if (!is.null(add))
+ tmpDat <- cbind(allDat, add)
+ else
+ tmpDat <- allDat
+ na <- attr(get(na.action)(tmpDat), "na.action")[]
+ if (!is.null(na))
+ {
+ allDat <- allDat[-na,,drop=FALSE]
+ if (!is.null(vcovOptions$cluster))
+ {
+ if (is.null(dim(vcovOptions$cluster)))
+ vcovOptions$cluster <- vcovOptions$cluster[-na]
+ else
+ vcovOptions$cluster <- vcovOptions$cluster[-na,,drop=FALSE]
+ }
+ if (!is.null(survOptions$weights))
+ survOptions$weights <- survOptions$weights[-na]
+ }
if (is.null(na))
na <- integer()
parNames <- lapply(1:length(g), function(i) res[[i]]$parNames)
@@ -275,5 +376,6 @@
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, na.action=na)
+ varNames=varNames, isEndo=isEndo, omit=na,
+ vcovOptions=vcovOptions, survOptions=survOptions)
}
Modified: pkg/gmm4/R/gmmModel.R
===================================================================
--- pkg/gmm4/R/gmmModel.R 2018-09-26 14:34:00 UTC (rev 135)
+++ pkg/gmm4/R/gmmModel.R 2018-09-27 19:18:35 UTC (rev 136)
@@ -1,8 +1,7 @@
############# Options for covariance matrix
-.getVcovOptions <- function(type, ...)
+.getVcovOptions <- function(type, data, addO=list())
{
- addO <- list(...)
if (type == "HAC")
{
option <- list(kernel = "Quadratic Spectral",
@@ -34,6 +33,23 @@
stop(paste("Wrong options for vcov of type", type))
option[names(addO)] <- addO
}
+ if (!is.null(option$cluster))
+ {
+ if (!inherits(option$cluster,
+ c("vector","data.frame","formula")))
+ stop("cluster must be a data.frame, a vector or a formula")
+ if (inherits(option$cluster, "formula"))
+ {
+ fn <- all.vars(option$cluster[[length(option$cluster)]])
+ option$cluster <- try(data[fn], silent=TRUE)
+ if (class(option$cluster) == "try-error")
+ stop("variables in the cluster formula are not in data")
+ }
+ option$cluster <- as.data.frame(option$cluster)
+ if (is.null(colnames(option$cluster)))
+ colnames(option$cluster) <- paste("CL", 1:ncol(option$cluster),
+ sep="")
+ }
if (option$type != "HC0")
stop("Only meatCL with type HC0 is allowed for GMM")
} else {
@@ -42,16 +58,40 @@
option
}
+.getSurvOptions <- function(data, opt=list())
+ {
+ if (length(opt) == 0)
+ return(list())
+ type <- c("sampling", "frequency")
+ if (length(opt)>2 || !(names(opt) %in% c("type","weights")))
+ stop("survOptions list must contain only two arguments: weights and type")
+ opt$type <- match.arg(opt$type, type)
+ if (!inherits(opt$weights, c("integer", "numeric", "formula")))
+ stop("survey weights must be a numeric vector or a formula")
+ if (inherits(opt$weights, "formula"))
+ {
+ fn <- all.vars(opt$weights[[length(opt$weights)]])
+ if (length(fn)>1)
+ stop("weights must be a single variable")
+ opt$weights <- try(c(data[[fn]]), silent=TRUE)
+ if (class(opt$weights) == "try-error")
+ stop("variable in the weights formula is not in data")
+ }
+ opt
+ }
+
################## Constructor for the gmmModels Classes #####################
gmmModel <- function(g, x=NULL, tet0=NULL,grad=NULL,
- vcov = c("iid", "HAC", "MDS"),
- vcovOptions=list(), centeredVcov = TRUE, data=parent.frame())
+ vcov = c("iid", "HAC", "MDS", "CL"),
+ vcovOptions=list(), centeredVcov = TRUE, data=parent.frame(),
+ na.action="na.omit", survOptions=list())
{
vcov <- match.arg(vcov)
- if (!is.list(vcovOptions))
- stop("vcovOptions must be a list")
- vcovOptions <- do.call(.getVcovOptions, c(vcovOptions, type=vcov))
+ if (!is.list(vcovOptions) | !is.list(survOptions))
+ stop("vcovOptions and survOptions must be a list")
+ vcovOptions <- .getVcovOptions(vcov, data, vcovOptions)
+ survOptions <- .getSurvOptions(data, survOptions)
if (!is.list(data) && !is.environment(data))
stop("'data' must be a list or an environment")
if (any(class(g)=="formula"))
@@ -59,45 +99,52 @@
chk <- names(tet0) %in% all.vars(g)
if (length(chk) == 0 | all(!chk))
{
- model <- .lGmmData(g,x,data)
+ model <- .lGmmData(g,x,data, survOptions, vcovOptions, na.action)
if (!is.null(model$eqnNames))
gmodel <- new("slinearGmm", data = model$data,instT=model$instT,
modelT = model$modelT, vcov = vcov,
- vcovOptions=vcovOptions,centeredVcov=centeredVcov,
+ vcovOptions=model$vcovOptions,
+ centeredVcov=centeredVcov,
k = model$k, q = model$q, n = model$n,
parNames = model$parNames,
momNames = model$momNames,eqnNames=model$eqnNames,
sameMom = TRUE, SUR = FALSE,
varNames = model$varNames,
- isEndo = model$isEndo, omit=model$na.action)
+ isEndo = model$isEndo, omit=model$omit,
+ survOptions=model$survOptions)
else
gmodel <- new("linearGmm", modelF=model$modelF,
instF=model$instF,
- vcov=vcov, vcovOptions=vcovOptions,
+ vcov=vcov, vcovOptions=model$vcovOptions,
centeredVcov = centeredVcov, k=model$k,
q=model$q, n=model$n, parNames=model$parNames,
momNames=model$momNames, varNames=model$varNames,
- isEndo=model$isEndo, omit=model$na.action)
+ isEndo=model$isEndo, omit=model$omit,
+ survOptions=model$survOptions)
} else {
if (!all(chk))
stop("All parameters in tet0 must be in g for nl Gmm")
- model <- .nlGmmData(g, x, tet0, data)
+ model <- .nlGmmData(g, x, tet0, data, survOptions, vcovOptions,
+ na.action)
gmodel <- new("nonlinearGmm", modelF=model$modelF,
instF=model$instF,theta0=tet0,fRHS=model$fRHS,
- fLHS=model$fLHS, vcov=vcov,vcovOptions=vcovOptions,
+ fLHS=model$fLHS, vcov=vcov,
+ vcovOptions=model$vcovOptions,
centeredVcov = centeredVcov, k=model$k, q=model$q,
n=model$n, parNames=model$parNames,
momNames=model$momNames, varNames=model$varNames,
- isEndo=model$isEndo, omit=model$na.action)
+ isEndo=model$isEndo, omit=model$omit,
+ survOptions=model$survOptions)
}
} else if (class(g)=="function") {
- model <- .fGmmData(g, x, tet0)
+ model <- .fGmmData(g, x, tet0, survOptions, vcovOptions, na.action)
gmodel <- new("functionGmm", X=x, fct=g,
- theta0=tet0, vcov=vcov,vcovOptions=vcovOptions,
+ theta0=tet0, vcov=vcov,vcovOptions=model$vcovOptions,
centeredVcov = centeredVcov, k=model$k, q=model$q,
n=model$n, parNames=model$parNames,
momNames=model$momNames, varNames=model$varNames,
- isEndo=model$isEndo, omit=model$na.action)
+ isEndo=model$isEndo, omit=model$omit,
+ survOptions=model$survOptions)
} else {
if (!is.null(x))
stop("For formula GMM, x must be NULL. The moments are only defined as a list of formulas")
@@ -105,14 +152,15 @@
stop("For formula GMM, g must be a list of formulas")
if (any(sapply(g, function(gi) class(gi)) != "formula"))
stop("For formula GMM, g must be a list of formulas")
- model <- .formGmmData(g, tet0, data)
+ model <- .formGmmData(g, tet0, data, survOptions, vcovOptions, na.action)
gmodel <- new("formulaGmm", modelF=model$modelF,
vcov=vcov, theta0=tet0,fRHS=model$fRHS,
- fLHS=model$fLHS,vcovOptions=vcovOptions,
+ fLHS=model$fLHS,vcovOptions=model$vcovOptions,
centeredVcov = centeredVcov, k=model$k, q=model$q,
n=model$n, parNames=model$parNames,
momNames=model$momNames, varNames=model$varNames,
- isEndo=model$isEndo, isMDE=model$isMDE, omit=model$na.action)
+ isEndo=model$isEndo, isMDE=model$isMDE, omit=model$omit,
+ survOptions=model$survOptions)
}
gmodel
}
Modified: pkg/gmm4/R/gmmModels-methods.R
===================================================================
--- pkg/gmm4/R/gmmModels-methods.R 2018-09-26 14:34:00 UTC (rev 135)
+++ pkg/gmm4/R/gmmModels-methods.R 2018-09-27 19:18:35 UTC (rev 136)
@@ -20,6 +20,11 @@
else
cat(x at vcovOptions$bw, " bandwidth", sep="")
}
+ if (x at vcov == "CL")
+ cat("\nClustered based on: ",
+ paste(colnames(x at vcovOptions$cluster), collapse=" and "), sep="")
+ if (length(x at survOptions)>0)
+ cat("\nSurvey weights type: ", x at survOptions$type, sep="")
cat("\n")
d <- modelDims(x)
cat("Number of regressors: ", d$k, "\n", sep="")
@@ -670,6 +675,13 @@
function(x, i) {
x at modelF <- x at modelF[i,,drop=FALSE]
x at instF <- x at instF[i,,drop=FALSE]
+ if (!is.null(x at vcovOptions$cluster))
+ {
+ if (!is.null(dim(x at vcovOptions$cluster)))
+ x at vcovOptions$cluster <- x at vcovOptions$cluster[i]
+ else
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 136
More information about the Gmm-commits
mailing list