[Gmm-commits] r147 - in pkg: causalGel causalGel/R causalGel/man gmm4 gmm4/R gmm4/man gmm4/vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 1 21:16:17 CET 2019
Author: chaussep
Date: 2019-11-01 21:16:16 +0100 (Fri, 01 Nov 2019)
New Revision: 147
Added:
pkg/causalGel/R/causalfitMethods.R
pkg/causalGel/man/causalGelfit-class.Rd
pkg/causalGel/man/subsetting.Rd
pkg/gmm4/R/rGelModel-methods.R
pkg/gmm4/man/confint-class.Rd
pkg/gmm4/man/confint-methods.Rd
pkg/gmm4/man/gmmToGel-methods.Rd
pkg/gmm4/man/restModel-methods.Rd
pkg/gmm4/man/rformulaGel-class.Rd
pkg/gmm4/man/rfunctionGel-class.Rd
pkg/gmm4/man/rgelModels-class.Rd
pkg/gmm4/man/rlinearGel-class.Rd
pkg/gmm4/man/rnonlinearGel-class.Rd
Removed:
pkg/gmm4/man/restGmmModel-methods.Rd
Modified:
pkg/causalGel/DESCRIPTION
pkg/causalGel/NAMESPACE
pkg/causalGel/R/allClasses.R
pkg/causalGel/R/causalGel.R
pkg/causalGel/R/causalMethods.R
pkg/causalGel/man/causalData-class.Rd
pkg/causalGel/man/causalModel.Rd
pkg/gmm4/DESCRIPTION
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/gmmData.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/rsysGmmModels-methods.R
pkg/gmm4/R/sysGmmModel.R
pkg/gmm4/R/sysGmmModels-methods.R
pkg/gmm4/man/ConsumptionG.Rd
pkg/gmm4/man/coef-methods.Rd
pkg/gmm4/man/evalDMoment-methods.Rd
pkg/gmm4/man/evalModel-methods.Rd
pkg/gmm4/man/evalMoment-methods.Rd
pkg/gmm4/man/formulaGel-class.Rd
pkg/gmm4/man/functionGel-class.Rd
pkg/gmm4/man/gelModel.Rd
pkg/gmm4/man/getRestrict-methods.Rd
pkg/gmm4/man/gmm4.Rd
pkg/gmm4/man/gmmModel.Rd
pkg/gmm4/man/hypothesisTest-methods.Rd
pkg/gmm4/man/linearGel-class.Rd
pkg/gmm4/man/merge-methods.Rd
pkg/gmm4/man/model.matrix-methods.Rd
pkg/gmm4/man/modelDims-methods.Rd
pkg/gmm4/man/modelFit-methods.Rd
pkg/gmm4/man/modelResponse-methods.Rd
pkg/gmm4/man/nonlinearGel-class.Rd
pkg/gmm4/man/print-methods.Rd
pkg/gmm4/man/printRestrict-methods.Rd
pkg/gmm4/man/rformulaGmm-class.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/show-methods.Rd
pkg/gmm4/man/specTest-methods.Rd
pkg/gmm4/man/subsetting.Rd
pkg/gmm4/man/sysGmmModel.Rd
pkg/gmm4/man/systemGmm.Rd
pkg/gmm4/man/union-class.Rd
pkg/gmm4/man/update-methods.Rd
pkg/gmm4/vignettes/gmmS4.Rnw
pkg/gmm4/vignettes/gmmS4.pdf
Log:
Major changes mostly for GEL
Modified: pkg/causalGel/DESCRIPTION
===================================================================
--- pkg/causalGel/DESCRIPTION 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/DESCRIPTION 2019-11-01 20:16:16 UTC (rev 147)
@@ -9,7 +9,7 @@
Depends: R (>= 3.0.0), gmm4
Imports: stats, methods
Suggests: lmtest, knitr, texreg
-Collate: 'allClasses.R' 'causalMethods.R' 'causalGel.R'
+Collate: 'allClasses.R' 'causalMethods.R' 'causalGel.R' 'causalfitMethods.R'
License: GPL (>= 2)
NeedsCompilation: no
VignetteBuilder: knitr
Modified: pkg/causalGel/NAMESPACE
===================================================================
--- pkg/causalGel/NAMESPACE 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/NAMESPACE 2019-11-01 20:16:16 UTC (rev 147)
@@ -1,6 +1,7 @@
import("gmm4")
-importFrom("stats", "lm", "model.response", "terms")
+importFrom("stats", "lm", "model.response", "terms", "model.frame", "reformulate")
+importFrom("utils", "head", "tail")
importFrom("methods", is, new, show, "slot<-", "slotNames", "validObject",
"getClassDef", "selectMethod", "callNextMethod", "as", "setAs",
@@ -9,9 +10,9 @@
### S4 Methods and Classes
exportClasses()
-exportClasses("causalData", "causalGel")
+exportClasses("causalData", "causalGel", "causalGelfit")
-exportMethods("causalMomFct", "causalDmomFct")
+exportMethods("causalMomFct")
export("causalModel")
Modified: pkg/causalGel/R/allClasses.R
===================================================================
--- pkg/causalGel/R/allClasses.R 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/R/allClasses.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -7,10 +7,11 @@
setClass("causalGel", contains="functionGel")
setClass("causalData", representation(momType="character",
- popMom="numericORNULL",
+ balCov="character",
+ balMom="numericORNULL",
ACTmom="integer",
reg="data.frame",
bal="data.frame"))
+setClass("causalGelfit", contains="gelfit")
-
Modified: pkg/causalGel/R/causalGel.R
===================================================================
--- pkg/causalGel/R/causalGel.R 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/R/causalGel.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -1,7 +1,7 @@
## Model builder
causalModel <- function(g, balm, data,theta0=NULL,
- momType=c("ACE","ACT","uncondBal","fixedMom"),
+ momType=c("ACE","ACT","ACC", "uncondBal","fixedMom"),
popMom = NULL, rhoFct=NULL,ACTmom=1L,
gelType = c("EL", "ET", "EEL", "ETEL", "HD", "ETHD","REEL"))
{
@@ -21,8 +21,12 @@
stop("You cannot remove the intercept from balm")
k <- tmp_model$k
ncoef <- 1+2*(k-1)
- name_coef <- c("control",paste("treat", 1:(k-1), sep=""),
- paste("ptreat", 1:(k-1), sep=""))
+ if (k>2)
+ treatInd <- 1:(k-1)
+ else
+ treatInd <- ""
+ name_coef <- c("control",paste("causalEffect", treatInd, sep=""),
+ paste("probTreatment", treatInd, sep=""))
if (!is.null(theta0))
{
if (length(theta0) != ncoef)
@@ -43,14 +47,23 @@
popMom <- colMeans(X[,-1, drop=FALSE])
} else if (momType == "ACT") {
popMom <- colMeans(X[Z[,1+ACTmom]==1,-1, drop=FALSE])
+ } else if (momType == "ACC") {
+ popMom <- colMeans(X[rowSums(Z)==1,-1, drop=FALSE])
}
}
modData <- new("causalData", reg=tmp_model$modelF, bal=tmp_model$instF,
- momType=momType, popMom=popMom, ACTmom=ACTmom)
+ momType=momType, balMom=popMom, ACTmom=ACTmom,
+ balCov=tmp_model$momNames[-1])
mod <- gelModel(g=causalMomFct, x=modData, gelType=gelType, rhoFct=rhoFct,
- tet0=theta0, grad=causalDmomFct,vcov="MDS", vcovOptions=list(),
+ theta0=theta0, grad=NULL,vcov="MDS", vcovOptions=list(),
centeredVcov=TRUE, data=NULL)
- mod at momNames <- c(names(theta0), paste("Bal", 1:(mod at q-mod@k), sep=""))
+ momNames <- lapply(treatInd, function(i)
+ paste("treat", i, "_", tmp_model$momNames[-1], sep=""))
+ momNames <- do.call("c", momNames)
+ if (momType == "uncondBal")
+ mod at momNames <- c(names(theta0), momNames)
+ else
+ mod at momNames <- c(names(theta0), momNames, tmp_model$momNames[-1])
new("causalGel", mod)
}
Modified: pkg/causalGel/R/causalMethods.R
===================================================================
--- pkg/causalGel/R/causalMethods.R 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/R/causalMethods.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -15,32 +15,193 @@
m2 <- sapply(1:ncol(X), function(i) e*X[,i])
if (object at momType == "uncondBal")
return(cbind(m1,m2))
- m3 <- sweep(X[,-1,drop=FALSE], 2, object at popMom, "-")
+ m3 <- sweep(X[,-1,drop=FALSE], 2, object at balMom, "-")
cbind(m1,m2,m3)
})
-## DMoment functions
+## evalDMoment functions
-setGeneric("causalDmomFct", function(theta, object, ...) standardGeneric("causalDmomFct"))
-
-setMethod("causalDmomFct", signature("numeric", "causalData"),
- function(theta, object, pt=NULL) {
- Z <- model.matrix(terms(object at reg), object at reg)
- X <- model.matrix(terms(object at bal), object at bal)
+setMethod("evalDMoment", signature("causalGel"),
+ function(object, theta, impProb=NULL, augmented=FALSE) {
+ dat <- object at X
+ Z <- model.matrix(terms(dat at reg), dat at reg)
+ X <- model.matrix(terms(dat at bal), dat at bal)
k <- ncol(Z)
n <- nrow(Z)
ntet <- length(theta)
- if (is.null(pt))
- pt <- rep(1/n, n)
+ if (is.null(impProb))
+ impProb <- rep(1/n, n)
ZT <- c(Z%*%theta[1:k])
q <- 2*k + (k-1)*(ncol(X)-1) - 1
G <- matrix(0, q, ntet)
- G11 <- lapply(1:k, function(i) -colSums(pt*Z[,i]*Z))
+ G11 <- lapply(1:k, function(i) -colSums(impProb*Z[,i]*Z))
G[1:k, 1:k] <- do.call(rbind, G11)
- G[(k+1):ntet, (k+1):ntet] <- -sum(pt)*diag(k-1)
- uK <- colSums(pt*X[,-1,drop=FALSE])
+ G[(k+1):ntet, (k+1):ntet] <- -sum(impProb)*diag(k-1)
+ uK <- colSums(impProb*X[,-1,drop=FALSE])
G[(2*k):q, (k+1):ntet] <- -kronecker(diag(k-1), uK)
- if (object at momType != "uncondBal" | object at momType=="fixedMon")
- G <- rbind(G, matrix(0, ncol(X)-1, ntet))
+ if (dat at momType != "uncondBal" | dat at momType=="fixedMon")
+ {
+ G <- rbind(G, matrix(0, ncol(X)-1, ntet))
+ if (augmented)
+ {
+ ncov <- length(object at X@balCov)
+ q <- nrow(G)- ncov
+ tmp <- rbind(matrix(0, q, ncov),
+ -sum(impProb)*diag(ncov))
+ G <- cbind(G, tmp)
+ }
+ }
G
})
+
+
+## Print
+
+setMethod("print", "causalGel",
+ function(x, printBalCov=FALSE, ...) {
+ cat("Causal Model using GEL Methods\n")
+ cat("*******************************\n")
+ cat("GEL Type: ", x at gelType$name, "\n")
+ momType <- switch(x at X@momType,
+ uncondBal = "Unconditional balancing",
+ ACT = "Causal effect on the treated",
+ ACE = "Average causal effect",
+ ACC = "Causal effect on the control",
+ fixedMom = "Balancing based on fixed Moments")
+ if (x at X@momType == "ACT" & x at X@ACTmom > 1)
+ momType <- paste(momType, "(treatment group ",
+ x at X@ACTmom, ")")
+ cat("Model type: ", momType, "\n", sep="")
+ d <- modelDims(x)
+ cat("Number of treatments: ", (d$k-1)/2, "\n", sep="")
+ cat("Number of moment conditions: ", d$q, "\n", sep="")
+ cat("Number of balancing covariates: ", length(x at X@balCov), "\n", sep="")
+ cat("Sample size: ", d$n, "\n")
+ if (printBalCov)
+ {
+ cat("Balancing covariates:\n ")
+ bal <- x at X@balCov
+ while (length(bal))
+ {
+ cat("\t", paste(head(bal,3), collapse=", "), "\n", sep="")
+ bal <- bal[-(1:min(3, length(bal)))]
+ }
+ }
+ invisible()
+ })
+
+## modelFit
+
+setMethod("modelFit", signature("causalGel"), valueClass="causalGelfit",
+ definition = function(object, gelType=NULL, rhoFct=NULL,
+ initTheta=c("gmm", "theta0"), start.tet=NULL,
+ start.lam=NULL, vcov=FALSE, ...)
+ {
+ res <- callNextMethod()
+ new("causalGelfit", res)
+ })
+
+## model.matrix and modelResponse
+
+setMethod("model.matrix", signature("causalGel"),
+ function(object, type=c("regressors","balancingCov"))
+ {
+ type <- match.arg(type)
+ if (type == "regressors")
+ {
+ ti <- attr(object at X@reg, "terms")
+ mat <- as.matrix(model.matrix(ti, object at X@reg)[,])
+ } else {
+ ti <- attr(object at X@bal, "terms")
+ mat <- as.matrix(model.matrix(ti, object at X@bal)[,-1])
+ }
+ mat
+ })
+
+setMethod("modelResponse", signature("causalGel"),
+ function(object)
+ {
+ model.response(object at X@reg)
+ })
+
+
+## Residuals
+# Not sure we will need it, but the residuals are well defined in this case
+
+setMethod("residuals", signature("causalGel"), function(object, theta){
+ X <- model.matrix(object)
+ Y <- modelResponse(object)
+ e <- Y-c(X%*%theta[1:ncol(X)])
+ e
+})
+
+## Dresiduals
+# Same comment as for residuals
+
+setMethod("Dresiduals", signature("causalGel"),
+ function(object, theta) {
+ -model.matrix(object)
+ })
+
+## modelDims
+
+setMethod("modelDims", "causalGel",
+ function(object) {
+ res <- callNextMethod()
+ res$balCov <- object at X@balCov
+ res$momType <- object at X@momType
+ res$balMom <- object at X@balMom
+ res$ACTmom <- object at X@ACTmom
+ res
+ })
+
+## subset for observations selection
+
+setMethod("subset", "causalGel",
+ function(x, i) {
+ x at X@reg <- x at X@reg[i,,drop=FALSE]
+ x at X@bal <- x at X@bal[i,,drop=FALSE]
+ x at n <- nrow(x at X@reg)
+ x})
+
+
+## "["
+## balancing moment selection
+
+setMethod("[", c("causalGel", "numeric", "missing"),
+ function(x, i, j){
+ i <- unique(as.integer(i))
+ spec <- modelDims(x)
+ balCov <- spec$balCov
+ nbal <- length(balCov)
+ if (!all(abs(i) %in% (1:nbal)))
+ stop(paste("Sub-balancing must be between 1 and ", nbal, sep=""))
+ balCov <- balCov[i]
+ if (length(balCov)<1)
+ stop("The number of balancing covariates cannot be 0")
+ momInd <- c(matrix((spec$k+1):spec$q, nrow=nbal)[i,])
+ momNames <- x at momNames[c(1:spec$k, momInd)]
+ q <- length(momNames)
+ f <- reformulate(balCov, NULL, TRUE)
+ x at X@bal <- model.frame(f, x at X@bal)
+ x at q <- q
+ x at momNames <- momNames
+ x at X@balCov <- balCov
+ if (!is.null(x at X@balMom))
+ x at X@balMom <- x at X@balMom[i]
+ x
+ })
+
+setMethod("[", c("causalGel", "numeric", "numeric"),
+ function(x, i, j){
+ x <- x[j]
+ subset(x, i)
+ })
+
+setMethod("[", c("causalGel", "missing", "numeric"),
+ function(x, i, j){
+ x[j]
+ })
+
+
+
Added: pkg/causalGel/R/causalfitMethods.R
===================================================================
--- pkg/causalGel/R/causalfitMethods.R (rev 0)
+++ pkg/causalGel/R/causalfitMethods.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -0,0 +1,131 @@
+### Hidden functions
+
+### Helper for Covariance in the misspecified case
+
+.psiGam <- function(object)
+{
+ spec <- modelDims(object at model)
+ n <- spec$n
+ q <- spec$q
+ k <- spec$k
+ ncov <- length(spec$balCov)
+ Wk <- object at model@wSpec$k
+ lam <- object at lambda
+ theta <- coef(object)
+ gt <- evalMoment(object at model, theta)
+ rhoFct <- object at model@gelType
+ if (is.null(rhoFct$fct))
+ {
+ rhoFct <- get(paste("rho", rhoFct$name, sep = ""))
+ } else {
+ rhoFct <- rhoFct$fct
+ }
+ rho1 <- rhoFct(gmat=gt, lambda=lam, derive=1, k=Wk[1]/Wk[2])
+ rho2 <- rhoFct(gmat=gt, lambda=lam, derive=2, k=Wk[1]/Wk[2])
+ Z <- model.matrix(object at model)
+ l <- ncol(Z)
+ ZT <- c(Z%*%theta[1:l])
+ X <- model.matrix(object at model, "balancingCov")
+ momType <- spec$momType
+ balMom <- spec$balMom
+ lG1 <- sapply(1:l, function(i) -(Z[,i]*Z)%*%lam[1:l])
+ q2 <- ncov*(l-1)+2*l-1
+ lamM <- matrix(lam[(2*l):q2], ncol=(l-1))
+ lG2 <- sapply(1:(l-1), function(i) -lam[l+i]-X%*%lamM[,i])
+ lG <- cbind(lG1, lG2)
+ G <- evalDMoment(object at model, theta, rho1, TRUE)
+ G22 <- crossprod(rho2*gt, gt)/n
+ if (momType %in% c("uncondBal", "fixedMom"))
+ {
+ Psi <- cbind(rho1*lG, rho1*gt)
+ G11 <- crossprod(rho2*lG, lG)/n
+ G12 <- t(G)/n + crossprod(rho2*lG, gt)/n
+ Gamma <- rbind(cbind(G11, G12),
+ cbind(t(G12), G22))
+ addPar <- 0
+ } else {
+ lG <- cbind(lG, matrix(-tail(lam, ncov), n, ncov, byrow=TRUE))
+ G11 <- crossprod(rho2*lG, lG)/n
+ G12 <- t(G)/n + crossprod(rho2*lG, gt)/n
+ if (momType == "ACE")
+ {
+ Xi <- rep(1,n)
+ } else if (momType == "ACT") {
+ Xi <- Z[,spec$ACTmom+1]
+ } else if (momType == "ACC") {
+ Xi <- as.numeric(rowSums(Z)==1)
+ } else {
+ stop("Wrong balancing type")
+ }
+ nj <- sum(Xi)
+ lam2 <- -sum(rho1)*tail(lam,ncov)/nj
+ theta4 <- colSums(Xi*X)/nj
+ G13 <- rbind(matrix(0, 2*l-1, ncov), -nj/n*diag(ncov))
+ G23 <- matrix(0,q, ncov)
+ G33 <- matrix(0, ncov, ncov)
+ Psi <- cbind(rho1*lG, rho1*gt,
+ Xi*sweep(X, 2, theta4, "-"))
+ Psi[,(2*l):(2*l+ncov-1)] <- Psi[,(2*l):(2*l+ncov-1)]-Xi%*%t(lam2)
+ Gamma <- rbind(cbind(G11, G12, G13),
+ cbind(t(G12), G22, G23),
+ cbind(t(G13), t(G23), G33))
+ addPar <- ncov
+ }
+ list(Psi=Psi, Gamma=Gamma, k=length(theta), q=q, addPar=addPar, n=n,
+ qrGt= qr(gt/sqrt(n)))
+}
+
+
+#### Methods for causalGelfit class
+####################################
+
+
+## print
+
+setMethod("print", "causalGelfit",
+ function(x, model=TRUE, lambda=FALSE, ...) {
+ theta <- coef(x)
+ if (model)
+ print(x at model)
+ type <- x at type
+ spec <- modelDims(x at model)
+ cat("Convergence Theta: ", x at convergence, "\n")
+ cat("Convergence Lambda: ", x at lconvergence, "\n")
+ cat("coefficients:\n")
+ print.default(format(theta, ...), print.gap=2L, quote=FALSE)
+ if (lambda)
+ {
+ cat("lambdas:\n")
+ print.default(format(x at lambda, ...), print.gap=2L, quote=FALSE)
+ }
+ })
+
+## vcov
+
+setMethod("vcov", "causalGelfit",
+ function(object, robToMiss = TRUE, withImpProb=FALSE, tol=1e-10) {
+ if (!robToMiss)
+ {
+ allV <- getMethod("vcov","gelfit")(object, withImpProb, tol)
+ return(allV)
+ }
+ res <- .psiGam(object)
+ k <- res$k
+ q <- res$q
+ addPar <- res$addPar
+ qrPsi <- qr(res$Psi/sqrt(res$n))
+ piv <- sort.int(qrPsi$pivot, index.return=TRUE)$ix
+ R <- qr.R(qrPsi)[,piv]
+ T1 <- solve(res$Gamma, t(R))
+ V <- T1%*%t(T1)/res$n
+ allV <- list()
+ allV$vcov_par <- V[1:k, 1:k]
+ allV$vcov_lambda <- V[(k+addPar+1):(k+addPar+q), (k+addPar+1):(k+addPar+q)]
+ if (addPar > 0)
+ {
+ allV$vcov_Allpar <- V[1:(k+addPar), 1:(k+addPar)]
+ allV$vcov_Alllambda <- V[-(1:(k+addPar)), -(1:(k+addPar))]
+ }
+ allV$gtR <- qr.R(res$qrGt)
+ allV
+ })
Modified: pkg/causalGel/man/causalData-class.Rd
===================================================================
--- pkg/causalGel/man/causalData-class.Rd 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/man/causalData-class.Rd 2019-11-01 20:16:16 UTC (rev 147)
@@ -15,7 +15,8 @@
\section{Slots}{
\describe{
\item{\code{momType}:}{Object of class \code{"character"} ~~ }
- \item{\code{popMom}:}{Object of class \code{"numericORNULL"} ~~ }
+ \item{\code{balCov}:}{Object of class \code{"character"} ~~ }
+ \item{\code{balMom}:}{Object of class \code{"numericORNULL"} ~~ }
\item{\code{ACTmom}:}{Object of class \code{"integer"} ~~ }
\item{\code{reg}:}{Object of class \code{"data.frame"} ~~ }
\item{\code{bal}:}{Object of class \code{"data.frame"} ~~ }
Added: pkg/causalGel/man/causalGelfit-class.Rd
===================================================================
--- pkg/causalGel/man/causalGelfit-class.Rd (rev 0)
+++ pkg/causalGel/man/causalGelfit-class.Rd 2019-11-01 20:16:16 UTC (rev 147)
@@ -0,0 +1,32 @@
+\name{causalGelfit-class}
+\docType{class}
+\alias{causalGelfit-class}
+
+\title{Class \code{"causalGelfit"}}
+\description{
+A class model causal models based on GEL methods.
+}
+\section{Objects from the Class}{
+Objects can be created by calls of the form \code{new("causalGelfit",
+ ...)}, but it mainly created using the \code{modelFit} method.
+}
+\section{Slots}{
+ \describe{
+ \item{\code{theta}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{convergence}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{lambda}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{lconvergence}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{call}:}{Object of class \code{"callORNULL"} ~~ }
+ \item{\code{type}:}{Object of class \code{"character"} ~~ }
+ \item{\code{vcov}:}{Object of class \code{"list"} ~~ }
+ \item{\code{model}:}{Object of class \code{"gelModels"} ~~ }
+ }
+}
+\section{Extends}{
+Class \code{"\linkS4class{gelfit}"}, directly.
+}
+
+\examples{
+showClass("causalGelfit")
+}
+\keyword{classes}
Modified: pkg/causalGel/man/causalModel.Rd
===================================================================
--- pkg/causalGel/man/causalModel.Rd 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/causalGel/man/causalModel.Rd 2019-11-01 20:16:16 UTC (rev 147)
@@ -10,8 +10,8 @@
before running any estimation algorithm.
}
\usage{
-causalModel(g, balm, data, theta0=NULL,
- momType=c("ACE","ACT","uncondBal","fixedMom"),
+causalModel(g, balm, data,theta0=NULL,
+ momType=c("ACE","ACT","ACC", "uncondBal","fixedMom"),
popMom = NULL, rhoFct=NULL,ACTmom=1L,
gelType = c("EL", "ET", "EEL", "ETEL", "HD", "ETHD","REEL"))
}
@@ -27,11 +27,12 @@
\item{theta0}{A vector of starting values (optional). If not provided,
the least squares method is use to generate them}
- \item{momType}{How the moments of the covariates should be balanced. By
- default, it is balanced using the sample mean of the covariates,
- which corresponds to the ACE. Alternatively, to the sample
- moments of the treated group (ACT), or to a known population mean. The
- option 'uncondBal' means that it is unconditionally balanced.}
+ \item{momType}{How the moments of the covariates should be
+ balanced. By default, it is balanced using the sample mean of the
+ covariates, which corresponds to the ACE. Alternatively, to the
+ sample moments of the treated group (ACT), the control group (ACC),
+ or to a known population mean. The option 'uncondBal' means that it
+ is unconditionally balanced.}
\item{popMom}{A vector of population moments to use for balancing. It
can be used if those moments are available from a census, for
Added: pkg/causalGel/man/subsetting.Rd
===================================================================
--- pkg/causalGel/man/subsetting.Rd (rev 0)
+++ pkg/causalGel/man/subsetting.Rd 2019-11-01 20:16:16 UTC (rev 147)
@@ -0,0 +1,31 @@
+\name{[-causalGel}
+\docType{methods}
+\alias{[,causalGel,missing,numeric-method}
+\alias{[,causalGel,numeric,missing-method}
+\alias{[,causalGel,numeric,numeric-method}
+
+\title{Subsetting methods}
+\description{
+Different subsetting methods for S4 class objects of the package. The
+subset method returns an new object with observations selected by the
+second argument. See example.
+}
+\section{Methods}{
+\describe{
+
+\item{\code{signature(x = "causalGel", i = "numeric", j = "missing")}}{
+ Selects observations
+}
+
+\item{\code{signature(x = "causalGel", i = "missing", j = "numeric")}}{
+ Selects balancing moments
+}
+
+\item{\code{signature(x = "causalGel", i = "numeric", j = "numeric")}}{
+ \code{i} selects the observations and "j" selects the balancing
+ moments.
+}
+}}
+
+\keyword{methods}
+\keyword{subsetting}
Modified: pkg/gmm4/DESCRIPTION
===================================================================
--- pkg/gmm4/DESCRIPTION 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/gmm4/DESCRIPTION 2019-11-01 20:16:16 UTC (rev 147)
@@ -4,7 +4,7 @@
Title: S4 Generalized Method of Moments
Author: Pierre Chausse <pchausse at uwaterloo.ca>
Maintainer: Pierre Chausse <pchausse at uwaterloo.ca>
-Description: This is a complete restructured version of the 'gmm' package (Chausse 2010; <doi:10.18637/jss.v034.i11>) using S4 only type of classes and methods. It provides tools for estimating single equations and system of equations using the Generalized Method of Moments (Hansen 1982; <doi:10.2307/1912775>). It is in a very early stage and suggestions are welcome. See the vignette for more details.
+Description: This is a complete restructured version of the 'gmm' package (Chausse 2010; <doi:10.18637/jss.v034.i11>) using 'S4' only type of classes and methods. It provides tools for estimating single equations and system of equations using the Generalized Method of Moments (Hansen 1982; <doi:10.2307/1912775>). It is in a very early stage and suggestions are welcome. See the vignette for more details.
Depends: R (>= 3.0.0), sandwich
Imports: stats, methods
Suggests: lmtest, knitr, texreg
@@ -14,7 +14,7 @@
'rGmmModel-methods.R' 'hypothesisTest-methods.R'
'sysGmmModel.R' 'sysGmmModels-methods.R' 'rsysGmmModels-methods.R'
'sgmmfit-methods.R' 'gmm4.R' 'gel.R' 'gelModels-methods.R'
- 'gelfit-methods.R'
+ 'rGelModel-methods.R' 'gelfit-methods.R'
License: GPL (>= 2)
NeedsCompilation: yes
VignetteBuilder: knitr
Modified: pkg/gmm4/NAMESPACE
===================================================================
--- pkg/gmm4/NAMESPACE 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/gmm4/NAMESPACE 2019-11-01 20:16:16 UTC (rev 147)
@@ -10,7 +10,7 @@
"D", "numericDeriv", "sd", "optim", "lm", "pf", "coef", "update",
"fitted", "lm.fit", "pchisq", "pnorm", "printCoefmat", "anova",
"model.frame", "reformulate", "formula", "nlminb", "kernapply",
- "constrOptim", "kernel")
+ "constrOptim", "kernel", "confint", "qnorm", "uniroot", "getCall")
importFrom("sandwich", "vcovHAC", "estfun","kernHAC","vcovCL", "meatCL",
"bread","bwAndrews","bwNeweyWest","weightsAndrews",
"weightsLumley", "vcovHC")
@@ -23,15 +23,17 @@
"numericORcharacter", "tsls", "rnonlinearGmm", "rfunctionGmm",
"slinearGmm", "snonlinearGmm", "sysGmmModels",
"sgmmfit","stsls", "rslinearGmm", "rsnonlinearGmm", "rsysGmmModels",
- "formulaGmm","rfunctionGmm", "gelfit", "summaryGel")
+ "formulaGmm","rfunctionGmm", "gelfit", "summaryGel", "confint",
+ "rlinearGel", "nonlinearGel", "rfunctionGel", "rformulaGel",
+ "rgelModels","callORNULL")
exportMethods(residuals, print, show, vcovHAC, coef, vcov, bread, summary, update,
- model.matrix, hypothesisTest, "[", merge, subset)
+ model.matrix, hypothesisTest, "[", merge, subset, confint, gmmToGel)
export(gmmModel, evalMoment, Dresiduals, evalDMoment, momentVcov, estfun.gmmFct,
evalWeights, quadra, evalObjective, solveGmm, momentStrength,evalModel,
- tsls, modelFit, meatGmm, specTest, gmm4, restGmmModel, modelResponse, DWH,
+ tsls, modelFit, meatGmm, specTest, gmm4, restModel, modelResponse, DWH,
modelDims, printRestrict, getRestrict, sysGmmModel, ThreeSLS, gelModel,
- rhoET, rhoEL, rhoEEL, rhoHD, Wu_lam, EEL_lam, REEL_lam, getLambda, gmmToGel,
+ rhoET, rhoEL, rhoEEL, rhoHD, Wu_lam, EEL_lam, REEL_lam, getLambda,
smoothGel, solveGel, getImpProb)
### S3 methods ###
Modified: pkg/gmm4/R/allClasses.R
===================================================================
--- pkg/gmm4/R/allClasses.R 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/gmm4/R/allClasses.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -10,7 +10,8 @@
setClassUnion("numericORNULL", c("numeric", "NULL"))
setClassUnion("numericORmatrixORNULL", c("matrix", "numeric", "NULL"))
setClassUnion("expressionORNULL", c("expression", "NULL"))
-setClassUnion("functionORNULL", c("function", "NULL"))
+setClassUnion("functionORNULL", c("function", "NULL"))
+setClassUnion("callORNULL", c("call", "NULL"))
setClass("linearGmm", representation(modelF="data.frame", instF="data.frame",
vcov="character",n="integer", q="integer", k="integer",
parNames="character", momNames="character",
@@ -65,7 +66,7 @@
## gmmfit
setClass("gmmfit", representation(theta = "numeric", convergence = "numericORNULL",
- convIter="numericORNULL",call="call",
+ convIter="numericORNULL",call="callORNULL",
type="character", wObj="gmmWeights",niter="integer",
efficientGmm="logical", model="gmmModels"))
@@ -75,7 +76,7 @@
setClass("gelfit", representation(theta = "numeric", convergence = "numeric",
lambda = "numeric", lconvergence = "numeric",
- call="call", type="character", vcov="list",
+ call="callORNULL", type="character", vcov="list",
model="gelModels"))
## specTest
@@ -82,6 +83,11 @@
setClass("specTest", representation(test = "matrix", testname="character"))
+## confint
+
+setClass("confint", representation(interval = "matrix", type="character",
+ level="numeric"))
+
## summaryGmm
setClass("summaryGmm", representation(coef="matrix", specTest = "specTest",
@@ -112,6 +118,24 @@
setClassUnion("rgmmModels", c("rlinearGmm", "rnonlinearGmm", "rfunctionGmm",
"rformulaGmm"))
+## Restricted gel Models
+
+
+setClass("rlinearGel", representation(cstLHS="matrix", cstRHS="numeric", cstSpec="list"),
+ contains="linearGel")
+
+setClass("rnonlinearGel", representation(R="list", cstSpec="list"),
+ contains="nonlinearGel")
+
+setClass("rfunctionGel", representation(R="list", cstSpec="list"),
+ contains="functionGel")
+
+setClass("rformulaGel", representation(R="list", cstSpec="list"),
+ contains="formulaGel")
+
+setClassUnion("rgelModels", c("rlinearGel", "rnonlinearGel", "rfunctionGel",
+ "rformulaGel"))
+
## hypothesisTest
setClass("hypothesisTest", representation(test="numeric", hypothesis="character",
@@ -166,6 +190,18 @@
## Class converters
+setAs("rgelModels", "rgmmModels",
+ function(from) {
+ obj <- as(from, "gmmModels")
+ cls <- strsplit(class(from), "Gel")[[1]][1]
+ cls <- paste(cls, "Gmm", sep="")
+ if (grepl("linear", class(from)))
+ new("rlinearGmm", cstLHS=from at cstLHS, cstRHS=from at cstRHS,
+ cstSpec=from at cstSpec, obj)
+ else
+ new(cls, R=from at R, cstSpec=from at cstSpec, obj)
+ })
+
setAs("linearGmm", "nonlinearGmm",
function(from) {
spec <- modelDims(from)
@@ -281,7 +317,7 @@
function(from) {
m <- as(from, "slinearGmm")
m <- as(m, "linearGmm")
- restGmmModel(m, from at cstLHS, from at cstRHS)
+ restModel(m, from at cstLHS, from at cstRHS)
})
setAs("sysGmmWeights", "gmmWeights",
@@ -297,8 +333,8 @@
### system GMM fit
setClass("sgmmfit", representation(theta = "list", convergence = "numericORNULL",
- convIter="numericORNULL",call="call",
- type="character", wObj="sysGmmWeights",niter="integer",
+ convIter="numericORNULL",call="callORNULL",
+ type="character", wObj="sysGmmWeights",niter="integer",
efficientGmm="logical", model="sysGmmModels"))
setClass("stsls", contains="sgmmfit")
Modified: pkg/gmm4/R/gel.R
===================================================================
--- pkg/gmm4/R/gel.R 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/gmm4/R/gel.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -1,27 +1,14 @@
-gelModel <- function(g, x=NULL, gelType, rhoFct=NULL, tet0=NULL,grad=NULL,
- vcov = c("HAC", "MDS", "iid"),
+gelModel <- function(g, x=NULL, gelType, rhoFct=NULL, theta0=NULL,grad=NULL,
+ vcov = c("MDS", "iid", "HAC"),
vcovOptions=list(), centeredVcov = TRUE, data=parent.frame())
{
vcov <- match.arg(vcov)
model <- gmmModel(g=g, x=x, grad=grad, vcov=vcov, vcovOptions=vcovOptions,
centeredVcov=centeredVcov,
- tet0=tet0, data=data)
+ theta0=theta0, data=data)
gmmToGel(model, gelType, rhoFct)
}
-gmmToGel <- function(object, gelType, rhoFct=NULL)
- {
- cls <- strsplit(class(object), "Gmm")[[1]][1]
- cls <- paste(cls, "Gel", sep="")
- if (object at vcov == "HAC")
- wSpec <- smoothGel(object)
- else
- wSpec <- list(k=c(1,1), w=kernel(1), bw=1, kernel="None")
- new(cls, wSpec=wSpec, gelType=list(name=gelType, fct=rhoFct),
- object)
- }
-
-
rhoEL <- function(gmat, lambda, derive = 0, k = 1)
{
lambda <- c(lambda)*k
@@ -176,7 +163,7 @@
{
if (inherits(object, "gelModels"))
{
- gt <- evalMoment(as(object, "gmmModels"), theta)
+ gt <- evalMoment(as(object,"gmmModels"), theta)
x <- kernapply(gt, object at wSpec$w)
sx <- list(smoothx = x, w = object at wSpec$w,
bw = object at wSpec$bw, k = object at wSpec$k)
Modified: pkg/gmm4/R/gelModels-methods.R
===================================================================
--- pkg/gmm4/R/gelModels-methods.R 2019-10-18 21:31:41 UTC (rev 146)
+++ pkg/gmm4/R/gelModels-methods.R 2019-11-01 20:16:16 UTC (rev 147)
@@ -32,8 +32,9 @@
setMethod("evalMoment", "gelModels", function(object, theta)
{
if (object at vcov != "HAC")
- {
- evalMoment(as(object, "gmmModels"), theta)
+ {
+ theta <- coef(object, theta)
+ evalMoment(as(object, "gmmModels"), theta)
} else {
smoothGel(object, theta)$smoothx
}
@@ -128,7 +129,7 @@
{
if (!("theta0"%in%slotNames(object)))
stop("Theta0 must be provided")
- theta0 <- object at theta0
+ theta0 <- modelDims(object)$theta0
}
if (is.null(lamSlv))
lamSlv <- getLambda
@@ -153,32 +154,36 @@
setMethod("modelFit", signature("gelModels"), valueClass="gelfit",
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 147
More information about the Gmm-commits
mailing list