[Gmm-commits] r162 - in pkg: causalGel gmm4 gmm4/R gmm4/man gmm4/vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Dec 5 23:35:50 CET 2019
Author: chaussep
Date: 2019-12-05 23:35:49 +0100 (Thu, 05 Dec 2019)
New Revision: 162
Modified:
pkg/causalGel/DESCRIPTION
pkg/gmm4/DESCRIPTION
pkg/gmm4/NAMESPACE
pkg/gmm4/R/allClasses.R
pkg/gmm4/R/gel.R
pkg/gmm4/R/gel4.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/rGelModel-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/R/validity.R
pkg/gmm4/man/ThreeSLS-methods.Rd
pkg/gmm4/man/confint-class.Rd
pkg/gmm4/man/evalModel-methods.Rd
pkg/gmm4/man/gmm4.Rd
pkg/gmm4/man/mconfint-class.Rd
pkg/gmm4/man/modelFit-methods.Rd
pkg/gmm4/man/plot-methods.Rd
pkg/gmm4/man/tsls-methods.Rd
pkg/gmm4/vignettes/gelS4.Rnw
pkg/gmm4/vignettes/gelS4.pdf
pkg/gmm4/vignettes/gmmS4.Rnw
pkg/gmm4/vignettes/gmmS4.pdf
Log:
many bugs fixed
Modified: pkg/causalGel/DESCRIPTION
===================================================================
--- pkg/causalGel/DESCRIPTION 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/causalGel/DESCRIPTION 2019-12-05 22:35:49 UTC (rev 162)
@@ -6,7 +6,7 @@
Author: Pierre Chausse <pchausse at uwaterloo.ca>
Maintainer: Pierre Chausse <pchausse at uwaterloo.ca>
Description: Methods for causal inference in which covariates are balanced using generalized empirical likelihod methods.
-Depends: R (>= 3.0.0), gmm4 (>= 0.1.0)
+Depends: R (>= 3.0.0), gmm4 (>= 0.2.0)
Imports: stats, methods
Suggests: lmtest, knitr, texreg
Collate: 'allClasses.R' 'causalMethods.R' 'causalGel.R' 'causalfitMethods.R'
Modified: pkg/gmm4/DESCRIPTION
===================================================================
--- pkg/gmm4/DESCRIPTION 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/DESCRIPTION 2019-12-05 22:35:49 UTC (rev 162)
@@ -1,6 +1,6 @@
Package: gmm4
-Version: 0.1-0
-Date: 2019-11-15
+Version: 0.2-0
+Date: 2019-12-05
Title: S4 Generalized Method of Moments
Author: Pierre Chausse <pchausse at uwaterloo.ca>
Maintainer: Pierre Chausse <pchausse at uwaterloo.ca>
Modified: pkg/gmm4/NAMESPACE
===================================================================
--- pkg/gmm4/NAMESPACE 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/NAMESPACE 2019-12-05 22:35:49 UTC (rev 162)
@@ -5,7 +5,7 @@
importFrom("parallel", mclapply)
-importFrom("graphics", plot, polygon, grid, points)
+importFrom("graphics", plot, polygon, grid, points, text)
importFrom("grDevices", rgb, col2rgb)
Modified: pkg/gmm4/R/allClasses.R
===================================================================
--- pkg/gmm4/R/allClasses.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/allClasses.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -87,11 +87,12 @@
## confint
setClass("confint", representation(interval = "matrix", type="character",
- level="numeric"))
+ level="numeric", theta="numeric"))
setClass("mconfint",
- representation(areaPoints="matrix", type="character", level="numeric"))
+ representation(areaPoints="matrix", type="character", level="numeric",
+ theta="numeric"))
## summaryGmm
@@ -199,7 +200,7 @@
obj <- as(from, "gmmModels")
cls <- strsplit(class(from), "Gel")[[1]][1]
cls <- paste(cls, "Gmm", sep="")
- if (grepl("linear", class(from)))
+ if (grepl("rlinear", class(from)))
new("rlinearGmm", cstLHS=from at cstLHS, cstRHS=from at cstRHS,
cstSpec=from at cstSpec, obj)
else
Modified: pkg/gmm4/R/gel.R
===================================================================
--- pkg/gmm4/R/gel.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gel.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -110,7 +110,7 @@
lam=double(q),pt=double(n),
obj=double(1)
), silent=TRUE)
- if (class(res) == "try-error")
+ if (inherits(res,"try-error"))
return(list(lambda=rep(0,q), obj=0, pt=rep(1/n,n),
convergence=list(convergence=3)))
list(lambda=res$lam, obj=res$obj, pt=res$pt,
Modified: pkg/gmm4/R/gel4.R
===================================================================
--- pkg/gmm4/R/gel4.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gel4.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -32,9 +32,9 @@
model <- restModel(model, cstLHS, cstRHS)
spec <- modelDims(model)
if (!is.null(theta0))
- theta0 <- theta0[(names(theta0) %in% spec at parNames)]
+ theta0 <- theta0[(names(theta0) %in% spec$parNames)]
}
- fit <- modelFit(object=model, initTheta=initTheta, theta0=theta0,
+ fit <- modelFit(model=model, initTheta=initTheta, theta0=theta0,
lambda0=lambda0, vcov=getVcov, coefSlv=coefSlv,
lamSlv=lamSlv, tControl=tControl, lControl=lControl)
fit at call <- Call
Modified: pkg/gmm4/R/gelModels-methods.R
===================================================================
--- pkg/gmm4/R/gelModels-methods.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gelModels-methods.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -160,15 +160,15 @@
######################### modelFit #########################
setMethod("modelFit", signature("linearGel"), valueClass="gelfit",
- definition = function(object, gelType=NULL, rhoFct=NULL,
+ definition = function(model, gelType=NULL, rhoFct=NULL,
initTheta=c("gmm", "modelTheta0"), theta0=NULL,
lambda0=NULL, vcov=FALSE, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
met <- getMethod("modelFit","gelModels")
- obj <- met(object, gelType, rhoFct, initTheta, theta0,
+ obj <- met(model, gelType, rhoFct, initTheta, theta0,
lambda0, vcov, ...)
obj at call <- Call
obj
@@ -175,15 +175,15 @@
})
setMethod("modelFit", signature("nonlinearGel"), valueClass="gelfit",
- definition = function(object, gelType=NULL, rhoFct=NULL,
+ definition = function(model, gelType=NULL, rhoFct=NULL,
initTheta=c("gmm", "modelTheta0"), theta0=NULL,
lambda0=NULL, vcov=FALSE, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
met <- getMethod("modelFit","gelModels")
- obj <- met(object, gelType, rhoFct, initTheta, theta0,
+ obj <- met(model, gelType, rhoFct, initTheta, theta0,
lambda0, vcov, ...)
obj at call <- Call
obj
@@ -190,15 +190,15 @@
})
setMethod("modelFit", signature("formulaGel"), valueClass="gelfit",
- definition = function(object, gelType=NULL, rhoFct=NULL,
+ definition = function(model, gelType=NULL, rhoFct=NULL,
initTheta=c("gmm", "modelTheta0"), theta0=NULL,
lambda0=NULL, vcov=FALSE, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
met <- getMethod("modelFit","gelModels")
- obj <- met(object, gelType, rhoFct, initTheta, theta0,
+ obj <- met(model, gelType, rhoFct, initTheta, theta0,
lambda0, vcov, ...)
obj at call <- Call
obj
@@ -205,15 +205,15 @@
})
setMethod("modelFit", signature("functionGel"), valueClass="gelfit",
- definition = function(object, gelType=NULL, rhoFct=NULL,
+ definition = function(model, gelType=NULL, rhoFct=NULL,
initTheta=c("gmm", "modelTheta0"), theta0=NULL,
lambda0=NULL, vcov=FALSE, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
met <- getMethod("modelFit","gelModels")
- obj <- met(object, gelType, rhoFct, initTheta, theta0,
+ obj <- met(model, gelType, rhoFct, initTheta, theta0,
lambda0, vcov, ...)
obj at call <- Call
obj
@@ -222,33 +222,33 @@
setMethod("modelFit", signature("gelModels"), valueClass="gelfit",
- definition = function(object, gelType=NULL, rhoFct=NULL,
+ definition = function(model, gelType=NULL, rhoFct=NULL,
initTheta=c("gmm", "modelTheta0"), theta0=NULL,
lambda0=NULL, vcov=FALSE, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
- spec <- modelDims(object)
+ spec <- modelDims(model)
initTheta = match.arg(initTheta)
if (!is.null(gelType))
- object at gelType$name <- gelType
+ model at gelType$name <- gelType
if (!is.null(rhoFct))
- object at gelType$rhoFct <- rhoFct
+ model at gelType$rhoFct <- rhoFct
if (is.null(theta0))
{
if (initTheta == "gmm")
- theta0 <- modelFit(as(object, "gmmModels"))@theta
+ theta0 <- modelFit(as(model, "gmmModels"))@theta
else if (!is.null(spec$theta0))
theta0 <- spec$theta0
else
stop("starting values is missing for the coefficient vector")
}
- res <- solveGel(object, theta0=theta0, lambda0=lambda0, ...)
+ res <- solveGel(model, theta0=theta0, lambda0=lambda0, ...)
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)
+ lambda=res$lambda, call=Call, type=model at gelType$name,
+ vcov=list(), model=model)
if (vcov)
gelfit at vcov <- vcov(gelfit)
gelfit
@@ -258,14 +258,14 @@
#### evalModel
setMethod("evalModel", signature("gelModels"),
- function(object, theta, lambda=NULL, gelType=NULL, rhoFct=NULL,
+ function(model, theta, lambda=NULL, gelType=NULL, rhoFct=NULL,
lamSlv=NULL, lControl=list(), ...) {
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
if (!is.null(gelType))
- object <- gmmToGel(as(object, "gmmModels"), gelType, rhoFct)
- spec <- modelDims(object)
+ model <- gmmToGel(as(model, "gmmModels"), gelType, rhoFct)
+ spec <- modelDims(model)
if (!is.null(names(theta)))
{
if (!all(names(theta) %in% spec$parNames))
@@ -272,16 +272,16 @@
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"))
+ if (class(model) %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="")
+ type <- paste("Eval-", model at gelType$name, sep="")
if (is.null(lambda))
{
- gt <- evalMoment(object, theta)
- gelt <- object at gelType
- k <- object at wSpec$k
+ gt <- evalMoment(model, theta)
+ gelt <- model at gelType
+ k <- model at wSpec$k
args <- c(list(gmat=gt, gelType=gelt$name,
rhoFct=gelt$fct), lControl, k=k[1]/k[2])
if (is.null(lamSlv))
@@ -296,7 +296,7 @@
}
names(lambda) <- spec$momNames
new("gelfit", theta=theta, convergence=1, lconvergence=lconvergence,
- lambda=lambda, call=Call, type=type, vcov=list(), model=object)
+ lambda=lambda, call=Call, type=type, vcov=list(), model=model)
})
### coef
Modified: pkg/gmm4/R/gelfit-methods.R
===================================================================
--- pkg/gmm4/R/gelfit-methods.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gelfit-methods.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -42,7 +42,7 @@
r <- try(uniroot(f, c(0,fact), pti=p[i,], obj=object, which=which, type=type,
test0=test0, level=level), silent=TRUE)
b <- coef(object)[which]
- if (class(r) == "try-error")
+ if (inherits(r, "try-error"))
c(NA,NA)
else
b*(1-r$root) + p[i,]*r$root
@@ -70,15 +70,14 @@
coef <- coef(object)[which]
int1 <- c(coef, coef + fact*sdcoef)
int2 <- c(coef - fact*sdcoef, coef)
- fct <- function(coef, which, type, fit, level, test0, corr=NULL, rang)
+ fct <- function(coef, which, type, fit, level, test0, corr=NULL)
{
spec <- modelDims(fit at model)
ncoef <- spec$parNames[which]
R <- paste(ncoef, "=", coef)
- if (fit at call[[1]] == "gel4")
+ if (fit at call[[1]] != "modelFit")
{
- fit2 <- suppressWarnings(update(fit, cstLHS=R,
- theta0=coef(fit)[-which]))
+ fit2 <- suppressWarnings(update(fit, cstLHS=R))
} else {
model <- restModel(fit at model, R)
fit2 <- suppressWarnings(update(fit, newModel=model,
@@ -85,7 +84,7 @@
theta0=coef(fit)[-which]))
}
test <- specTest(fit2, type=type, ...)@test[1] - test0
- if (is.null(corr))
+ if (is.null(corr))
level - pchisq(test, 1)
else
level - pchisq(test/corr, 1)
@@ -100,9 +99,9 @@
{
test <- c(NA,NA)
mess <- "Could not compute the confidence interval because: \n"
- if (class(res1) == "try-error")
+ if (inherits(res1,"try-error"))
mess <- paste(mess, "(1) ", res1[1], "\n", sep="")
- if (class(res2) == "try-error")
+ if (inherits(res2,"try-error"))
mess <- paste(mess, "(2) ", res2[1], "\n", sep="")
warning(mess)
} else {
@@ -315,7 +314,7 @@
dimnames(ans) <- list(nlam,
c((1 - level)/2, 0.5 + level/2))
return(new("confint", interval=ans,
- type=ntest, level=level))
+ type=ntest, level=level, theta=lam[parm]))
}
if (type == "Wald")
{
@@ -346,9 +345,9 @@
}
}
if (!area)
- new("confint", interval=ans, type=ntest, level=level)
+ new("confint", interval=ans, type=ntest, level=level, theta=theta[parm])
else
- new("mconfint", areaPoints=ans, type=ntest, level=level)
+ new("mconfint", areaPoints=ans, type=ntest, level=level, theta=theta[parm])
})
setMethod("confint", "numeric",
@@ -357,7 +356,7 @@
fact = 3, vcov="iid", ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
type <- match.arg(type)
object <- as.data.frame(object)
@@ -445,7 +444,7 @@
setMethod("plot", "mconfint", function(x, y, main=NULL, xlab=NULL, ylab=NULL,
pch=21, bg=1, Pcol=1, ylim=NULL, xlim=NULL,
- add=FALSE, ...)
+ add=FALSE, addEstimates=TRUE, ...)
{
v <- colnames(x at areaPoints)
if (!add)
@@ -464,6 +463,11 @@
plot(x at areaPoints, xlab=xlab, ylab=ylab, main=main, pch=pch, bg=bg,
ylim=ylim, xlim=xlim, col=Pcol)
grid()
+ if (addEstimates)
+ {
+ points(x at theta[1], x at theta[2], pch=20)
+ text(x at theta[1], x at theta[2], expression(hat(theta)), pos=3)
+ }
} else {
points(x at areaPoints[,1],x at areaPoints[,2],pch=pch, bg=bg, col=Pcol)
}
@@ -551,7 +555,6 @@
## update
-
setMethod("update", "gelfit",
function(object, newModel=NULL, ..., evaluate=TRUE)
{
@@ -561,7 +564,7 @@
ev <- new.env(parent.frame())
theta0 <- arg$theta0
- if (object at call[[1]] != "gel4")
+ if (object at call[[1]] == "modelFit")
{
model <- if(is.null(newModel))
object at model
@@ -569,9 +572,11 @@
newModel
model <- update(model, ...)
ev[["model"]] <- model
- call[["object"]] <- quote(model)
+ call[["model"]] <- quote(model)
arg <- arg[which(is.na(match(names(arg),
c("rhoFct", slotNames(model)))))]
+ } else {
+ return(stats::update(object, ..., evaluate=evaluate))
}
spec <- modelDims(model)
if (!is.null(call[["theta0"]]))
@@ -590,7 +595,45 @@
else
call
})
-
+setMethod("update", "gelfit",
+ function(object, newModel=NULL, ..., evaluate=TRUE)
+ {
+ if (is.null(call <- getCall(object)))
+ stop("No call argument")
+ if (call[[1]] != "modelFit")
+ return(stats::update(object, ..., evaluate=evaluate))
+ if (!is.null(newModel))
+ return(stats::update(object, model=newModel, ..., evaluate=evaluate))
+ arg <- list(...)
+ ev <- new.env(parent.frame())
+ theta0 <- arg$theta0
+ model <- if(is.null(newModel))
+ object at model
+ else
+ newModel
+ model <- update(model, ...)
+ ev[["model"]] <- model
+ call[["model"]] <- quote(model)
+ arg <- arg[which(is.na(match(names(arg),
+ c("rhoFct", slotNames(model)))))]
+ spec <- modelDims(model)
+ if (!is.null(call[["theta0"]]))
+ {
+ call[["theta0"]] <- if (is.null(theta0))
+ spec$theta0
+ else
+ theta0
+ } else if (!is.null(theta0)) {
+ call[["theta0"]] <- theta0
+ }
+ if (length(arg) > 0)
+ for (n in names(arg)) call[[n]] <- arg[[n]]
+ if (evaluate)
+ eval(call, ev)
+ else
+ call
+ })
+
Modified: pkg/gmm4/R/gmm4.R
===================================================================
--- pkg/gmm4/R/gmm4.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gmm4.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -17,7 +17,7 @@
if (vcov == "TrueFixed")
{
if (!is.matrix(weights) ||
- !(class(weights) %in% c("gmmWeights", "sysGmmWeigths")))
+ !inherits(weights,c("gmmWeights", "sysGmmWeigths")))
stop("With TrueFixed vcov the weights must be provided")
efficientWeights <- TRUE
vcov2 <- "iid"
@@ -49,7 +49,7 @@
}
if (!is.null(cstLHS))
model <- restModel(model, cstLHS, cstRHS)
- fit <- modelFit(object=model, type=type, itertol=itertol, initW=initW,
+ fit <- modelFit(model=model, type=type, itertol=itertol, initW=initW,
weights=weights, itermaxit=itermaxit,
efficientWeights=efficientWeights, ...)
fit at call <- Call
@@ -58,13 +58,13 @@
setMethod("tsls", "formula",
- function(object, x, vcov = c("iid", "HAC", "MDS", "CL"),
+ function(model, x, vcov = c("iid", "HAC", "MDS", "CL"),
vcovOptions=list(), survOptions=list(), centeredVcov = TRUE,
data = parent.frame())
{
Call <- match.call(call=sys.call(sys.parent()-1L))
vcov <- match.arg(vcov)
- model <- gmmModel(g = object, x = x, vcov = vcov,
+ model <- gmmModel(g = model, x = x, vcov = vcov,
vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov = centeredVcov, data = data)
obj <- tsls(model)
@@ -73,13 +73,13 @@
})
setMethod("tsls", "list",
- function(object, x=NULL, vcov = c("iid", "HAC", "MDS", "CL"),
+ function(model, x=NULL, vcov = c("iid", "HAC", "MDS", "CL"),
vcovOptions=list(), survOptions=list(), centeredVcov = TRUE,
data = parent.frame())
{
Call <- match.call(call=sys.call(sys.parent()-1L))
vcov <- match.arg(vcov)
- model <- sysGmmModel(g = object, h = x, vcov = vcov,
+ model <- sysGmmModel(g = model, h = x, vcov = vcov,
vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov = centeredVcov, data = data)
obj <- tsls(model)
@@ -89,13 +89,13 @@
setMethod("ThreeSLS", "list",
- function(object, x=NULL, vcov = c("iid", "HAC", "MDS", "CL"),
+ function(model, x=NULL, vcov = c("iid", "HAC", "MDS", "CL"),
vcovOptions=list(), survOptions=list(), centeredVcov = TRUE,
data = parent.frame())
{
Call <- match.call(call=sys.call(sys.parent()-1L))
vcov <- match.arg(vcov)
- model <- sysGmmModel(g = object, h = x, vcov = vcov,
+ model <- sysGmmModel(g = model, h = x, vcov = vcov,
vcovOptions=vcovOptions,survOptions=survOptions,
centeredVcov = centeredVcov, data = data)
obj <- ThreeSLS(model)
Modified: pkg/gmm4/R/gmmModel.R
===================================================================
--- pkg/gmm4/R/gmmModel.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gmmModel.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -42,7 +42,7 @@
{
fn <- all.vars(option$cluster[[length(option$cluster)]])
option$cluster <- try(data[fn], silent=TRUE)
- if (class(option$cluster) == "try-error")
+ if (inherits(option$cluster,"try-error"))
stop("variables in the cluster formula are not in data")
}
option$cluster <- as.data.frame(option$cluster)
@@ -74,7 +74,7 @@
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")
+ if (inherits(opt$weights,"try-error"))
stop("variable in the weights formula is not in data")
}
opt
Modified: pkg/gmm4/R/gmmModels-methods.R
===================================================================
--- pkg/gmm4/R/gmmModels-methods.R 2019-12-04 17:35:21 UTC (rev 161)
+++ pkg/gmm4/R/gmmModels-methods.R 2019-12-05 22:35:49 UTC (rev 162)
@@ -723,24 +723,24 @@
## modelFit
-setGeneric("modelFit", function(object, ...) standardGeneric("modelFit"))
+setGeneric("modelFit", function(model, ...) standardGeneric("modelFit"))
setMethod("modelFit", signature("formulaGmm"), valueClass="gmmfit",
- definition = function(object, type=c("twostep", "iter","cue", "onestep"),
+ definition = function(model, type=c("twostep", "iter","cue", "onestep"),
itertol=1e-7, initW=c("ident", "tsls"), weights="optimal",
itermaxit=100, efficientWeights=FALSE, theta0=NULL, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
- if (object at isMDE && object at centeredVcov)
+ if (model at isMDE && model at centeredVcov)
{
if (is.character(weights) && weights == "optimal")
{
- spec <- modelDims(object)
- wObj <- evalWeights(object, spec$theta0, "optimal")
+ spec <- modelDims(model)
+ wObj <- evalWeights(model, spec$theta0, "optimal")
met <- getMethod("modelFit", "gmmModels")
- res <- met(object, weights=wObj, efficientWeights=TRUE, ...)
+ res <- met(model, weights=wObj, efficientWeights=TRUE, ...)
res at type <- "mde"
} else {
res <- callNextMethod()
@@ -753,35 +753,35 @@
})
setMethod("modelFit", signature("gmmModels"), valueClass="gmmfit",
- definition = function(object, type=c("twostep", "iter","cue", "onestep"),
+ definition = function(model, type=c("twostep", "iter","cue", "onestep"),
itertol=1e-7, initW=c("ident", "tsls"), weights="optimal",
itermaxit=100, efficientWeights=FALSE, theta0=NULL, ...)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-error"))
Call <- NULL
- chk <- validObject(object)
+ chk <- validObject(model)
type <- match.arg(type)
initW <- match.arg(initW)
i <- 1L
- chk <- validObject(object, TRUE)
+ chk <- validObject(model, TRUE)
if (!chk)
- stop("object is not a valid gmmModels object")
- if (initW == "tsls" && class(object) != "linearGmm")
+ stop("model is not a valid gmmModels object")
+ if (initW == "tsls" && class(model) != "linearGmm")
stop("initW='tsls' is for linear models only")
if (is.character(weights) && !(weights%in%c("optimal","ident")))
stop("weights is a matrix or one of 'optimal' or 'ident'")
- spec <- modelDims(object)
+ spec <- modelDims(model)
if (spec$q==spec$k)
{
## This allow to weight the moments in case of
## large scale difference.
- if (!is.matrix(weights) && class(weights)!="gmmWeights")
+ if (!is.matrix(weights) && !inherits(weights,"gmmWeights"))
weights <- "ident"
type <- "onestep"
} else if (type == "onestep" && !is.matrix(weights)) {
weights <- "ident"
- } else if (is.matrix(weights) || class(weights)=="gmmWeights") {
+ } else if (is.matrix(weights) || inherits(weights,"gmmWeights")) {
type <- "onestep"
} else if (weights == "ident") {
type <- "onestep"
@@ -788,26 +788,26 @@
}
if (type == "onestep")
{
- if (class(weights)=="gmmWeights")
+ if (inherits(weights,"gmmWeights"))
wObj <- weights
else
- wObj <- evalWeights(object, w=weights)
- res <- solveGmm(object, wObj, theta0, ...)
+ wObj <- evalWeights(model, w=weights)
+ res <- solveGmm(model, wObj, theta0, ...)
convergence <- res$convergence
efficientGmm <- ifelse(is.character(weights), FALSE,
efficientWeights)
ans <- new("gmmfit", theta=res$theta,
convergence=convergence, convIter=NULL, type=type,
- wObj=wObj, model=object, call=Call, niter=i,
+ wObj=wObj, model=model, call=Call, niter=i,
efficientGmm=efficientGmm)
return(ans)
}
- if (class(object) == "linearGmm")
+ if (class(model) == "linearGmm")
{
- if (object at vcov == "iid")
+ if (model at vcov == "iid")
if (is.character(weights) && weights == "optimal")
{
- res <- tsls(object)
+ res <- tsls(model)
res at call <- Call
return(res)
}
@@ -818,20 +818,20 @@
}
if (initW=="tsls")
{
- theta0 <- coef(tsls(object))
+ theta0 <- coef(tsls(model))
} else {
- wObj <- evalWeights(object, NULL, "ident")
- theta0 <- solveGmm(object, wObj, theta0, ...)$theta
+ wObj <- evalWeights(model, NULL, "ident")
+ theta0 <- solveGmm(model, wObj, theta0, ...)$theta
}
- bw <- object at vcovOptions$bw
+ bw <- model at vcovOptions$bw
if (type != "cue")
{
while(TRUE)
{
- wObj <- evalWeights(object, theta0, "optimal")
- if (object at vcov=="HAC" && is.character(bw))
- object at vcovOptions$bw <- wObj at wSpec$bw
- res <- solveGmm(object, wObj, theta0, ...)
+ wObj <- evalWeights(model, theta0, "optimal")
+ if (model at vcov=="HAC" && is.character(bw))
+ model at vcovOptions$bw <- wObj at wSpec$bw
+ res <- solveGmm(model, wObj, theta0, ...)
theta1 <- res$theta
convergence <- res$convergence
crit <- sqrt( sum((theta1-theta0)^2)/(1+sqrt(sum(theta0^2))))
@@ -853,44 +853,44 @@
}
} else {
convIter <- NULL
- if (object at vcov=="HAC" && is.character(bw))
+ if (model at vcov=="HAC" && is.character(bw))
{
- w <- momentVcov(object, theta0)
- object at vcovOptions$bw <- attr(w, "Spec")$bw
+ w <- momentVcov(model, theta0)
+ model at vcovOptions$bw <- attr(w, "Spec")$bw
}
- obj <- function(theta, object)
+ obj <- function(theta, model)
{
- wObj <- evalWeights(object, theta, "optimal")
- evalObjective(object, theta, wObj)
+ wObj <- evalWeights(model, theta, "optimal")
+ evalObjective(model, theta, wObj)
}
- res <- optim(theta0, obj, object=object,
+ res <- optim(theta0, obj, model=model,
...)
theta1 <- res$par
convergence <- res$convergence
- wObj <- evalWeights(object, theta1, "optimal")
+ wObj <- evalWeights(model, theta1, "optimal")
}
- object at vcovOptions$bw <- bw
+ model at vcovOptions$bw <- bw
names(theta1) <- spec$parNames
new("gmmfit", theta=theta1, convergence=convergence, type=type,
- wObj=wObj, model=object, convIter=convIter, call=Call,
+ wObj=wObj, model=model, convIter=convIter, call=Call,
niter=i, efficientGmm=TRUE)
})
## tsls
-setGeneric("tsls", function(object, ...) standardGeneric("tsls"))
+setGeneric("tsls", function(model, ...) standardGeneric("tsls"))
setMethod("tsls", signature("linearGmm"), valueClass="tsls",
- function(object)
+ function(model)
{
Call <- try(match.call(call=sys.call(sys.parent())), silent=TRUE)
- if (class(Call)=="try-error")
+ if (inherits(Call,"try-errors"))
Call <- NULL
- chk <- validObject(object)
- X <- model.matrix(object)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 162
More information about the Gmm-commits
mailing list