[Gmm-commits] r130 - in pkg/gmm4: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 14 19:54:19 CEST 2018
Author: chaussep
Date: 2018-09-14 19:54:19 +0200 (Fri, 14 Sep 2018)
New Revision: 130
Added:
pkg/gmm4/R/gel.R
pkg/gmm4/R/gelModels-methods.R
pkg/gmm4/man/formulaGel-class.Rd
pkg/gmm4/man/functionGel-class.Rd
pkg/gmm4/man/gelModel.Rd
pkg/gmm4/man/gelModels-class.Rd
pkg/gmm4/man/lambdaAlgo.Rd
pkg/gmm4/man/linearGel-class.Rd
pkg/gmm4/man/nonlinearGel-class.Rd
pkg/gmm4/man/rhoFct.Rd
pkg/gmm4/man/smoothGel.Rd
pkg/gmm4/man/solveGel-methods.Rd
Modified:
pkg/gmm4/DESCRIPTION
pkg/gmm4/NAMESPACE
pkg/gmm4/R/allClasses.R
pkg/gmm4/R/gmmModels-methods.R
pkg/gmm4/R/validity.R
pkg/gmm4/man/.Rhistory
pkg/gmm4/man/evalDMoment-methods.Rd
pkg/gmm4/man/evalMoment-methods.Rd
pkg/gmm4/man/evalObjective-methods.Rd
pkg/gmm4/man/formulaGmm-class.Rd
pkg/gmm4/man/momentVcov-methods.Rd
pkg/gmm4/man/print-methods.Rd
Log:
start adding all GEL classes and methods
Modified: pkg/gmm4/DESCRIPTION
===================================================================
--- pkg/gmm4/DESCRIPTION 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/DESCRIPTION 2018-09-14 17:54:19 UTC (rev 130)
@@ -15,7 +15,7 @@
'summaryGmm-methods.R' 'gmmWeights-methods.R' 'gmmModel.R'
'rGmmModel-methods.R' 'hypothesisTest-methods.R'
'sysGmmModel.R' 'sysGmmModels-methods.R' 'rsysGmmModels-methods.R'
- 'sgmmfit-methods.R' 'gmm4.R'
+ 'sgmmfit-methods.R' 'gmm4.R' 'gel.R' 'gelModels-methods.R'
License: GPL (>= 2)
NeedsCompilation: no
VignetteBuilder: knitr
Modified: pkg/gmm4/NAMESPACE
===================================================================
--- pkg/gmm4/NAMESPACE 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/NAMESPACE 2018-09-14 17:54:19 UTC (rev 130)
@@ -8,13 +8,16 @@
"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", "nlminb")
+ "model.frame", "reformulate", "formula", "nlminb", "kernapply",
+ "constrOptim", "kernel")
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",
+ "nonlinearGel", "linearGel", "functionGel", "gelModels",
+ "formulaGel",
"specTest", "summaryGmm", "rlinearGmm", "hypothesisTest",
"numericORcharacter", "tsls", "rnonlinearGmm", "rfunctionGmm",
"slinearGmm", "snonlinearGmm", "sysGmmModels",
@@ -26,7 +29,9 @@
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)
+ modelDims, printRestrict, getRestrict, sysGmmModel, ThreeSLS, gelModel,
+ rhoET, rhoEL, rhoEEL, rhoHD, EL.Wu, getLambda, gmmToGel, smoothGel,
+ solveGel)
### S3 methods ###
Modified: pkg/gmm4/R/allClasses.R
===================================================================
--- pkg/gmm4/R/allClasses.R 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/R/allClasses.R 2018-09-14 17:54:19 UTC (rev 130)
@@ -60,6 +60,19 @@
setClassUnion("allNLGmm", c("nonlinearGmm", "functionGmm", "formulaGmm"))
setClassUnion("gmmModels", c("linearGmm", "nonlinearGmm", "functionGmm", "formulaGmm"))
+## GEL models
+
+setClass("linearGel", representation(wSpec="list", gelType="list"),
+ contains="linearGmm")
+setClass("nonlinearGel", representation(wSpec="list", gelType="list"),
+ contains="nonlinearGmm")
+setClass("functionGel", representation(wSpec="list", gelType="list"),
+ contains="functionGmm")
+setClass("formulaGel", representation(wSpec="list", gelType="list"),
+ contains="formulaGmm")
+
+setClassUnion("gelModels", c("linearGel", "nonlinearGel", "functionGel", "formulaGel"))
+
## gmmWeights
setClass("gmmWeights", representation(w="ANY", type="character", HAC="list"),
@@ -187,36 +200,48 @@
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="")
+ x <- from
+ theta0 <- rep(0,spec$k)
+ names(theta0) <- spec$parNames
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]
+ names(theta) <- modelDims(x)$parNames
+ gt <- evalMoment(x, theta)
}
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)
+ names(theta) <- modelDims(x)$parNames
+ gt <- evalDMoment(x, theta)
}
- new("functionGmm", X=dat, fct=fct, dfct=dfct, vcov=from at vcov,
+ 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=colnames(Z), kernel=from at kernel,
+ momNames=spec$momNames, kernel=from at kernel,
bw=from at bw, prewhite=from at prewhite, ar.method=from at ar.method,
approx=from at approx, tol=from at tol, centeredVcov=from at centeredVcov)
})
+setAs("allNLGmm", "functionGmm",
+ function(from) {
+ spec <- modelDims(from)
+ x <- from
+ fct <- function(theta, x)
+ {
+ names(theta) <- modelDims(x)$parNames
+ gt <- evalMoment(x, theta)
+ }
+ dfct <- function(theta, x)
+ {
+ names(theta) <- modelDims(x)$parNames
+ gt <- evalDMoment(x, theta)
+ }
+ new("functionGmm", X=x, fct=fct, dfct=dfct, vcov=from at vcov,
+ theta0=from at theta0, n=spec$n, q=spec$q, k=spec$k,
+ parNames=names(from at theta0),
+ momNames=spec$momNames, kernel=from at kernel,
+ bw=from at bw, prewhite=from at prewhite, ar.method=from at ar.method,
+ approx=from at approx, tol=from at tol, centeredVcov=from at centeredVcov)
+ })
+
setAs("slinearGmm", "linearGmm",
function(from) {
spec <- modelDims(from)
@@ -267,7 +292,6 @@
data=dat)
})
-
setAs("rslinearGmm", "rlinearGmm",
function(from) {
m <- as(from, "slinearGmm")
Added: pkg/gmm4/R/gel.R
===================================================================
--- pkg/gmm4/R/gel.R (rev 0)
+++ pkg/gmm4/R/gel.R 2018-09-14 17:54:19 UTC (rev 130)
@@ -0,0 +1,207 @@
+gelModel <- function(g, x=NULL, gelType, rhoFct=NULL, tet0=NULL,grad=NULL,
+ vcov = c("HAC", "MDS", "iid"),
+ kernel = c("Quadratic Spectral", "Truncated", "Bartlett", "Parzen",
+ "Tukey-Hanning"), crit = 1e-06,
+ bw = "Andrews", prewhite = 1L, ar.method = "ols", approx = "AR(1)",
+ tol = 1e-07, centeredVcov = TRUE, data=parent.frame())
+ {
+ vcov <- match.arg(vcov)
+ kernel <- match.arg(kernel)
+ args <- as.list(match.call())
+ args$rhoFct <- NULL
+ args$gelType <- NULL
+ model <- do.call(gmmModel, args)
+ 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
+ gmat <- as.matrix(gmat)
+ gml <- c(gmat %*% lambda)
+ switch(derive+1,
+ log(1 - gml),
+ -1/(1 - gml),
+ -1/(1 - gml)^2)
+ }
+
+rhoET <- function(gmat, lambda, derive = 0, k = 1)
+ {
+ lambda <- c(lambda)*k
+ gmat <- as.matrix(gmat)
+ gml <- c(gmat %*% lambda)
+ switch(derive+1,
+ -exp(gml)+1,
+ -exp(gml),
+ -exp(gml))
+ }
+
+rhoEEL <- function(gmat, lambda, derive = 0, k = 1)
+ {
+ lambda <- c(lambda)*k
+ gmat <- as.matrix(gmat)
+ gml <- c(gmat %*% lambda)
+ switch(derive+1,
+ -gml - 0.5 * gml^2,
+ -1 - gml,
+ rep(-1, nrow(gmat)))
+ }
+
+rhoHD <- function(gmat, lambda, derive = 0, k = 1)
+ {
+ lambda <- c(lambda)*k
+ gmat <- as.matrix(gmat)
+ gml <- c(gmat %*% lambda)
+ switch(derive+1,
+ -1/(1 + gml)+1,
+ 1/((1 + gml)^2),
+ -2/((1 + gml)^3))
+ }
+
+EL.Wu <- function (gmat, l0=NULL, tol = 1e-08, maxiter = 50, k=1)
+ {
+ gmat <- as.matrix(gmat)*k
+ if (is.null(l0))
+ l0 <- rep(0, ncol(gmat))
+ n = nrow(gmat)
+ dif = 1
+ j = 0
+ while (dif > tol & j <= maxiter) {
+ D1 = t(gmat) %*% ((1/(1 + gmat %*% l0)))
+ DD = -t(gmat) %*% (c((1/(1 + gmat %*% l0)^2)) * gmat)
+ D2 = solve(DD, D1, tol = 1e-40)
+ dif = max(abs(D2))
+ rule = 1
+ while (rule > 0) {
+ rule = 0
+ if (min(1 + t(l0 - D2) %*% t(gmat)) <= 0)
+ rule = rule + 1
+ if (rule > 0)
+ D2 = D2/2
+ }
+ l0 = l0 - D2
+ j = j + 1
+ }
+ if (j >= maxiter) {
+ l0 = rep(0, ncol(gmat))
+ conv = list(convergence = 1)
+ } else {
+ conv = list(convergence = 0)
+ }
+ return(list(lambda = c(-l0), convergence = conv))
+ }
+
+getLambda <- function (gmat, l0=NULL, gelType, rhoFct=NULL,
+ tol = 1e-07, maxiter = 100, k = 1, method="BFGS",
+ algo = c("nlminb", "optim", "Wu"), control = list())
+ {
+ algo <- match.arg(algo)
+ gmat <- as.matrix(gmat)
+ if (is.null(l0))
+ l0 <- rep(0, ncol(gmat))
+ if (is.null(rhoFct))
+ rhoFct <- get(paste("rho",gelType,sep=""))
+ if (algo == "Wu" & gelType != "EL")
+ stop("Wu (2005) algo to compute Lambda is for EL only")
+ if (algo == "Wu")
+ return(EL.Wu(gmat, l0, tol, maxiter, k))
+
+ fct <- function(l, X, rhoFct, k) {
+ r0 <- rhoFct(X, l, derive = 0, k = k)
+ -mean(r0)
+ }
+ Dfct <- function(l, X, rhoFct, k) {
+ r1 <- rhoFct(X, l, derive = 1, k = k)
+ -colMeans(r1 * X)
+ }
+ DDfct <- function(l, X, rhoFct, k) {
+ r2 <- rhoFct(X, l, derive = 2, k = k)
+ -crossprod(X * r2, X)/nrow(X)
+ }
+ if (algo == "optim") {
+ if (gelType == "EL")
+ {
+ ci <- -rep(1, nrow(gmat))
+ res <- constrOptim(l0, fct, Dfct, -gmat, ci, control = control,
+ X = gmat, rhoFct = rhoFct, k = k)
+ } else if (gelType == "HD") {
+ ci <- -rep(1, nrow(gmat))
+ res <- constrOptim(l0, fct, Dfct, -gmat, ci, control = control,
+ X = gmat, rhoFct = rhoFct, k = k)
+ } else {
+ res <- optim(l0, fct, gr = Dfct, X = gmat, rhoFct = rhoFct,
+ k = k, method = method, control = control)
+ }
+ } else {
+ res <- nlminb(l0, fct, gradient = Dfct, hessian = DDfct,
+ X = gmat, rhoFct = rhoFct, k = k, control = control)
+ }
+ l0 <- res$par
+ if (algo == "optim")
+ conv <- list(convergence = res$convergence, counts = res$counts,
+ message = res$message)
+ else
+ conv <- list(convergence = res$convergence, counts = res$evaluations,
+ message = res$message)
+ return(list(lambda = l0, convergence = conv))
+ }
+
+smoothGel <- function (object, theta=NULL)
+{
+ if (inherits(object, "gelModels"))
+ {
+ 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)
+ return(sx)
+ }
+ if (is.null(theta))
+ theta <- gmmFit(as(object, "gmmModels"), weights="ident")@theta
+
+ gt <- evalMoment(object, theta)
+ gt <- scale(gt, scale=FALSE)
+ class(gt) <- "gmmFct"
+ if (!(object at kernel%in%c("Bartlett","Parzen")))
+ object at kernel <- "Bartlett"
+ kernel <- switch(object at kernel,
+ Bartlett="Truncated",
+ Parzen="Bartlett")
+ k <- switch(kernel,
+ Truncated=c(2,2),
+ Bartlett=c(1,2/3))
+ if (is.character(object at bw))
+ {
+ bw <- get(paste("bw", object at bw, sep = ""))
+ bw <- bw(gt, kernel = object at kernel, prewhite = object at prewhite,
+ ar.method = object at ar.method, approx = object at approx)
+ } else {
+ bw <- object at bw
+ }
+ w <- weightsAndrews(gt, bw = bw, kernel = kernel, prewhite = object at prewhite,
+ ar.method = object at ar.method, tol = object at tol, verbose = FALSE,
+ approx = object at approx)
+ rt <- length(w)
+ if (rt >= 2)
+ {
+ w <- c(w[rt:2], w)
+ w <- w/sum(w)
+ w <- kernel(w[rt:length(w)])
+ } else {
+ w <- kernel(1)
+ }
+ return(list(k=k, w=w, bw=bw, kernel=kernel))
+}
Added: pkg/gmm4/R/gelModels-methods.R
===================================================================
--- pkg/gmm4/R/gelModels-methods.R (rev 0)
+++ pkg/gmm4/R/gelModels-methods.R 2018-09-14 17:54:19 UTC (rev 130)
@@ -0,0 +1,140 @@
+####### All methods with gelModels (and its subclasses) signature
+#################################################################
+
+####################### Print ########################
+### The getGeneric for print is here only, so the file must be compiled
+### before any other files containing print
+
+setMethod("print", "gelModels",
+ function(x, ...) {
+ cat("GEL Model: Type ", x at gelType$name, "\n")
+ cat("*******************************\n")
+ cat("Moment type: ", strsplit(is(x)[1], "G")[[1]][1], "\n", sep="")
+ if (x at vcov == "HAC")
+ {
+ cat("Smoothing: ")
+ cat(x at wSpec$kernel, " kernel and ", sep="")
+ cat(x at bw, " bandwidth", sep="")
+ cat(" (", round(x at wSpec$bw, 3), ")", sep="")
+ } else {
+ cat("No Smoothing required\n")
+ }
+ 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")})
+
+################ evalMoment ##########################
+
+setMethod("evalMoment", "gelModels", function(object, theta)
+ {
+ if (object at vcov != "HAC")
+ {
+ evalMoment(as(object, "gmmModels"), theta)
+ } else {
+ smoothGel(object, theta)$smoothx
+ }
+ })
+
+################ evalDMoment ##########################
+
+setMethod("evalDMoment", "gelModels", function(object, theta)
+ {
+ if (object at vcov != "HAC")
+ {
+ evalDMoment(as(object, "gmmModels"), theta)
+ } else {
+ f <- function(theta, object)
+ colMeans(smoothGel(object, theta)$smoothx)
+ env <- new.env()
+ assign("theta", theta, envir = env)
+ assign("object", object, envir = env)
+ assign("f", f, envir = env)
+ G <- numericDeriv(quote(f(theta, object)), "theta",
+ env)
+ G <- attr(G, "gradient")
+ spec <- modelDims(object)
+ dimnames(G) <- list(spec$momNames, spec$parNames)
+ G
+ }
+ })
+
+################ momentVcov ##########################
+
+setMethod("momentVcov", signature("gelModels"),
+ function(object, theta, ...){
+ if (object at vcov != "HAC")
+ {
+ momentVcov(as(object, "gmmModels"), theta)
+ } else {
+ gt <- evalMoment(object, theta)
+ w <- crossprod(gt)/nrow(gt)
+ w
+ }
+ })
+
+############ evalObjective #################################
+
+setMethod("evalObjective", signature("gelModels", "numeric", "missing"),
+ function(object, theta, wObj, lambda, ...)
+ {
+ gt <- evalMoment(object, theta)
+ k <- object at wSpec$k
+ if (is.null(object at gelType$fct))
+ rhoFct <- get(paste("rho",object at gelType$name,sep=""))
+ else
+ rhoFct <- object at gelType$fct
+ rho <- rhoFct(gmat=gt, lambda=lambda, derive = 0, k = k[1]/k[2])
+ n <- modelDims(object)$n
+ 2*n*sum(rho)*k[2]/(k[1]^2*object at wSpec$bw)
+ })
+
+######################### solveGel #########################
+
+setGeneric("solveGel", function(object, ...) standardGeneric("solveGel"))
+
+setMethod("solveGel", signature("gelModels"),
+ function(object, theta0=NULL, lambda0=NULL, lamSlv=NULL,
+ coefSlv=c("optim","nlminb","constrOptim"),
+ lControl=list(), tControl=list())
+ {
+ coefSlv <- match.arg(coefSlv)
+ f <- function(theta, model, lambda0, slv, lcont,returnL=FALSE)
+ {
+ gt <- evalMoment(model, theta)
+ gelt <- model at gelType
+ args <- c(list(gmat=gt, l0=lambda0, gelType=gelt$name,
+ rhoFct=gelt$fct), lcont)
+ res <- do.call(slv, args)
+ if (returnL)
+ return(res)
+ evalObjective(model, theta, , res$lambda)
+ }
+ if (is.null(lambda0))
+ lambda0 <- rep(0, modelDims(object)$q)
+ if (is.null(theta0))
+ {
+ if (!("theta0"%in%slotNames(object)))
+ stop("Theta0 must be provided")
+ theta0 <- object at theta0
+ }
+ if (is.null(lamSlv))
+ lamSlv <- getLambda
+ if (coefSlv == "nlminb")
+ args <- c(list(start=theta0, objective=f,
+ model=object, lambda0=lambda0,
+ slv=lamSlv, lcont=lControl), tControl)
+ else
+ args <- c(list(par=theta0, fn=f, model=object, lambda0=lambda0,
+ slv=lamSlv, lcont=lControl), tControl)
+ res <- do.call(get(coefSlv), args)
+ resl <- f(res$par, object, lambda0, lamSlv, lControl, TRUE)
+ list(theta=res$par, convergence=res$convergence,
+ lambda=resl$lambda, lconvergence=resl$convergence)
+ })
+
+
+
Modified: pkg/gmm4/R/gmmModels-methods.R
===================================================================
--- pkg/gmm4/R/gmmModels-methods.R 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/R/gmmModels-methods.R 2018-09-14 17:54:19 UTC (rev 130)
@@ -349,7 +349,8 @@
setMethod("momentVcov", signature("gmmModels"),
function(object, theta, ...){
- if (class(object) == "functionGmm" & object at vcov == "iid")
+ if ((inherits(object, "functionGmm") || inherits(object, "formulaGmm")) &
+ object at vcov == "iid")
object at vcov <- "MDS"
if (object at vcov == "MDS")
{
Modified: pkg/gmm4/R/validity.R
===================================================================
--- pkg/gmm4/R/validity.R 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/R/validity.R 2018-09-14 17:54:19 UTC (rev 130)
@@ -473,3 +473,71 @@
}
setValidity("sysGmmWeights", .checkSysGmmWeights)
+
+
+.checkGelModels <- function(object)
+ {
+ error <- character()
+ if (!all(names(object at wSpec)%in%c("k","w","bw","kernel")))
+ {
+ msg <- "wSpec must be a list with k, w, bw, and kernel"
+ error <- c(error, msg)
+ } else {
+ s <- object at wSpec
+ if (!is.numeric(s$bw))
+ {
+ msg <- "bw must be numeric"
+ error <- c(error, msg)
+ }
+ if (class(s$w) != "tskernel")
+ {
+ msg <- "w must be an object of class 'tskernel'"
+ error <- c(error, msg)
+ }
+ if (!is.character(s$kernel))
+ {
+ msg <- "kernel must be a character"
+ error <- c(error, msg)
+ }
+ }
+ if (!all(names(object at gelType)%in%c("name","fct")))
+ {
+ msg <- "gelType must be a list with name and fct"
+ error <- c(error, msg)
+ } else {
+ gtype <- object at gelType
+ if (!is.character(gtype$name))
+ {
+ error <- c(error, "name in gelType must ba a character")
+ } else {
+ if (is.null(gtype$fct))
+ {
+ if (!(gtype$name %in% c("EL","ET","EEL","HD")))
+ {
+ msg <- "name in gelType must be ET, EL, HD or EEL"
+ error <- c(error, msg)
+ }
+ } else {
+ if (!is.function(gtype$fct))
+ {
+ msg <- "fct in getType must be a function"
+ error <- c(error, msg)
+ } else {
+ n <- names(formals(gtype$fct))
+ tn <- c("gmat", "lambda", "derive", "k")
+ if (!isTRUE(all.equal(n, tn)))
+ {
+ msg <- "rhoFct must have the four arguments gmat, lambda, derive and k"
+ error <- c(error, msg)
+ }
+ }
+ }
+ }
+ }
+ if (length(error)==0)
+ TRUE
+ else
+ error
+ }
+
+setValidity("gelModels", .checkGelModels)
Modified: pkg/gmm4/man/.Rhistory
===================================================================
--- pkg/gmm4/man/.Rhistory 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/man/.Rhistory 2018-09-14 17:54:19 UTC (rev 130)
@@ -3,3 +3,5 @@
names(simData)
q()
n
+q()
+n
Modified: pkg/gmm4/man/evalDMoment-methods.Rd
===================================================================
--- pkg/gmm4/man/evalDMoment-methods.Rd 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/man/evalDMoment-methods.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -3,6 +3,7 @@
\alias{evalDMoment}
\alias{evalDMoment-methods}
\alias{evalDMoment,functionGmm-method}
+\alias{evalDMoment,gelModels-method}
\alias{evalDMoment,formulaGmm-method}
\alias{evalDMoment,sysGmmModels-method}
\alias{evalDMoment,rslinearGmm-method}
@@ -18,6 +19,9 @@
\item{\code{signature(object = "functionGmm")}}{
}
+\item{\code{signature(object = "gelModels")}}{
+}
+
\item{\code{signature(object = "formulaGmm")}}{
}
Modified: pkg/gmm4/man/evalMoment-methods.Rd
===================================================================
--- pkg/gmm4/man/evalMoment-methods.Rd 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/man/evalMoment-methods.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -3,6 +3,7 @@
\alias{evalMoment}
\alias{evalMoment-methods}
\alias{evalMoment,functionGmm-method}
+\alias{evalMoment,gelModels-method}
\alias{evalMoment,formulaGmm-method}
\alias{evalMoment,regGmm-method}
\alias{evalMoment,sysGmmModels-method}
@@ -17,6 +18,9 @@
\item{\code{signature(object = "functionGmm")}}{
}
+\item{\code{signature(object = "gelModels")}}{
+}
+
\item{\code{signature(object = "formulaGmm")}}{
}
Modified: pkg/gmm4/man/evalObjective-methods.Rd
===================================================================
--- pkg/gmm4/man/evalObjective-methods.Rd 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/man/evalObjective-methods.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -3,6 +3,7 @@
\alias{evalObjective}
\alias{evalObjective-methods}
\alias{evalObjective,gmmModels,numeric,gmmWeights-method}
+\alias{evalObjective,gelModels,numeric,missing-method}
\alias{evalObjective,sysGmmModels,list,sysGmmWeights-method}
\title{ ~~ Methods for Function \code{evalObjective} in Package \pkg{Gmm} ~~}
\description{
@@ -12,14 +13,21 @@
\S4method{evalObjective}{gmmModels,numeric,gmmWeights}(object, theta,
wObj, \dots)
+\S4method{evalObjective}{gelModels,numeric,missing}(object, theta,
+wObj, lambda, \dots)
+
\S4method{evalObjective}{sysGmmModels,list,sysGmmWeights}(object, theta,
wObj, \dots)
}
\arguments{
- \item{object}{An object of class \code{"gmmModels"} or \code{"sysGmmModels"}.}
+ \item{object}{An object of class \code{"gmmModels"},
+ \code{"gelModels"} or \code{"sysGmmModels"}.}
\item{theta}{The vector for coefficients for single equation, or a
list of vector for system of equations.}
- \item{wObj}{An object of class \code{"gmmWeights"} or \code{"sysGmmWeights"}.}
+ \item{wObj}{An object of class \code{"gmmWeights"} or
+ \code{"sysGmmWeights"}.}
+ \item{lambda}{Vector of Lagrange multiplier for \code{"gmmModels"}
+ objects}
\item{\dots}{Arguments to pass to other methods}
}
\section{Methods}{
@@ -36,6 +44,10 @@
model1 <- gmmModel(y~x1, ~z1+z2, data=simData)
w <- evalWeights(model1, theta)
evalObjective(model1, theta, w)
+
+model2 <- gmmToGel(model1, "EL")
+evalObjective(model2, theta, lambda=c(.1,.2,.3))
+
}
\keyword{methods}
Added: pkg/gmm4/man/formulaGel-class.Rd
===================================================================
--- pkg/gmm4/man/formulaGel-class.Rd (rev 0)
+++ pkg/gmm4/man/formulaGel-class.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -0,0 +1,51 @@
+\name{formulaGel-class}
+\docType{class}
+\alias{formulaGel-class}
+
+\title{Class \code{"formulaGel"}}
+\description{
+GMM model class for moment conditions defined by formulas.
+}
+\section{Objects from the Class}{
+Objects can be created by calls of the form \code{new("formulaGel", ...)}.
+It is however, recommended to use the constructor \code{\link{gelModel}}.
+}
+\section{Slots}{
+ \describe{
+ \item{\code{wSpec}:}{Object of class \code{"list"} ~~ }
+ \item{\code{gelType}:}{Object of class \code{"list"} ~~ }
+ \item{\code{modelF}:}{Object of class \code{"data.frame"} ~~ }
+ \item{\code{vcov}:}{Object of class \code{"character"} ~~ }
+ \item{\code{theta0}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{n}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{q}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{k}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{parNames}:}{Object of class \code{"character"} ~~ }
+ \item{\code{momNames}:}{Object of class \code{"character"} ~~ }
+ \item{\code{fRHS}:}{Object of class \code{"list"} ~~ }
+ \item{\code{fLHS}:}{Object of class \code{"list"} ~~ }
+ \item{\code{kernel}:}{Object of class \code{"character"} ~~ }
+ \item{\code{bw}:}{Object of class \code{"numericORcharacter"} ~~ }
+ \item{\code{prewhite}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{ar.method}:}{Object of class \code{"character"} ~~ }
+ \item{\code{approx}:}{Object of class \code{"character"} ~~ }
+ \item{\code{tol}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{centeredVcov}:}{Object of class \code{"logical"} ~~ }
+ \item{\code{varNames}:}{Object of class \code{"character"} ~~ }
+ \item{\code{isEndo}:}{Object of class \code{"logical"} ~~ }
+ \item{\code{isMDE}:}{Object of class \code{"logical"} ~~ }
+ }
+}
+
+\section{Extends}{
+Class \code{"\linkS4class{formulaGmm}"}, directly.
+Class \code{"\linkS4class{gelModels}"}, directly.
+Class \code{"allNLGmm"}, by class \code{"formulaGmm"}, distance 2.
+Class \code{"gmmModels"}, by class \code{"formulaGmm"}, distance 2
+}
+
+
+\examples{
+showClass("formulaGel")
+}
+\keyword{classes}
Modified: pkg/gmm4/man/formulaGmm-class.Rd
===================================================================
--- pkg/gmm4/man/formulaGmm-class.Rd 2018-09-12 15:09:16 UTC (rev 129)
+++ pkg/gmm4/man/formulaGmm-class.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -35,6 +35,12 @@
}
}
+\section{Extends}{
+Class \code{"\linkS4class{gmmModels}"}, directly.
+Class \code{"allNLGmm"}, by class \code{"formulaGmm"}, distance 2.
+}
+
+
\examples{
showClass("formulaGmm")
}
Added: pkg/gmm4/man/functionGel-class.Rd
===================================================================
--- pkg/gmm4/man/functionGel-class.Rd (rev 0)
+++ pkg/gmm4/man/functionGel-class.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -0,0 +1,48 @@
+\name{functionGel-class}
+\docType{class}
+\alias{functionGel-class}
+
+\title{Class \code{"functionGel"}}
+\description{
+GEL model class when moments matrix is defined by a function.
+}
+\section{Objects from the Class}{
+Objects can be created by calls of the form \code{new("functionGel", ...)}.
+It is however, recommended to use the constructor \code{\link{gelModel}}.
+}
+\section{Slots}{
+ \describe{
+ \item{\code{wSpec}:}{Object of class \code{"list"} ~~ }
+ \item{\code{gelType}:}{Object of class \code{"list"} ~~ }
+ \item{\code{X}:}{Object of class \code{"ANY"} ~~ }
+ \item{\code{fct}:}{Object of class \code{"function"} ~~ }
+ \item{\code{dfct}:}{Object of class \code{"functionORNULL"} ~~ }
+ \item{\code{vcov}:}{Object of class \code{"character"} ~~ }
+ \item{\code{theta0}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{n}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{q}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{k}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{parNames}:}{Object of class \code{"character"} ~~ }
+ \item{\code{momNames}:}{Object of class \code{"character"} ~~ }
+ \item{\code{kernel}:}{Object of class \code{"character"} ~~ }
+ \item{\code{bw}:}{Object of class \code{"numericORcharacter"} ~~ }
+ \item{\code{prewhite}:}{Object of class \code{"integer"} ~~ }
+ \item{\code{ar.method}:}{Object of class \code{"character"} ~~ }
+ \item{\code{approx}:}{Object of class \code{"character"} ~~ }
+ \item{\code{tol}:}{Object of class \code{"numeric"} ~~ }
+ \item{\code{centeredVcov}:}{Object of class \code{"logical"} ~~ }
+ \item{\code{varNames}:}{Object of class \code{"character"} ~~ }
+ \item{\code{isEndo}:}{Object of class \code{"logical"} ~~ }
+ }
+}
+\section{Extends}{
+Class \code{"\linkS4class{functionGmm}"}, directly.
+Class \code{"\linkS4class{gelModels}"}, directly.
+Class \code{"allNLGmm"}, by class \code{"functionGmm"}, distance 2.
+Class \code{"gmmModels"}, by class \code{"functionGmm"}, distance 2
+}
+
+\examples{
+showClass("functionGmm")
+}
+\keyword{classes}
Added: pkg/gmm4/man/gelModel.Rd
===================================================================
--- pkg/gmm4/man/gelModel.Rd (rev 0)
+++ pkg/gmm4/man/gelModel.Rd 2018-09-14 17:54:19 UTC (rev 130)
@@ -0,0 +1,144 @@
+\name{gelModel}
+
+\alias{gelModel}
+\alias{gmmToGel}
+
+\title{Constructor for \code{"gelModels"} classes}
+
+\description{
+It builds the object of either class \code{"linearGel"},
+\code{"nonlinearGel"}, \code{"functionGel"} or
+\code{"formulaGel"}. This is the first step before running any
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmm -r 130
More information about the Gmm-commits
mailing list