[Gmm-commits] r16 - in pkg/gmm: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Dec 22 16:18:34 CET 2009
Author: chaussep
Date: 2009-12-22 16:18:34 +0100 (Tue, 22 Dec 2009)
New Revision: 16
Modified:
pkg/gmm/NAMESPACE
pkg/gmm/R/gel.R
pkg/gmm/R/getModel.R
pkg/gmm/R/momentEstim.R
pkg/gmm/man/gel.Rd
pkg/gmm/man/getModel.Rd
pkg/gmm/man/momentEstim.Rd
Log:
Modification of the structure of the package
Modified: pkg/gmm/NAMESPACE
===================================================================
--- pkg/gmm/NAMESPACE 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/NAMESPACE 2009-12-22 15:18:34 UTC (rev 16)
@@ -5,7 +5,7 @@
residuals.gmm, fitted.gel, residuals.gel, plot.gmm, plot.gel,formula.gmm, formula.gel, charStable, specTest,
specTest.gmm, specTest.gel, print.specTest, momentEstim.baseGmm.twoStep, momentEstim.baseGmm.twoStep.formula,
momentEstim.baseGmm.iterative.formula, momentEstim.baseGmm.iterative, momentEstim.baseGmm.cue.formula,
- momentEstim.baseGmm.cue, getModel.baseGmm, FinRes.baseGmm.res)
+ momentEstim.baseGmm.cue, getModel.baseGmm, getModel.baseGel, FinRes.baseGmm.res, momentEstim.baseGel.mod, momentEstim.baseGel.modFormula)
S3method(summary, gmm)
S3method(summary, gel)
@@ -32,11 +32,14 @@
S3method(print, specTest)
S3method(FinRes, baseGmm.res)
S3method(getModel, baseGmm)
+S3method(getModel, baseGel)
S3method(momentEstim, baseGmm.twoStep)
S3method(momentEstim, baseGmm.twoStep.formula)
S3method(momentEstim, baseGmm.iterative.formula)
S3method(momentEstim, baseGmm.iterative)
S3method(momentEstim, baseGmm.cue.formula)
S3method(momentEstim, baseGmm.cue)
+S3method(momentEstim, baseGel.mod)
+S3method(momentEstim, baseGel.modFormula)
Modified: pkg/gmm/R/gel.R
===================================================================
--- pkg/gmm/R/gel.R 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/R/gel.R 2009-12-22 15:18:34 UTC (rev 16)
@@ -175,237 +175,77 @@
kernel = c("Bartlett", "Parzen", "Truncated", "Tukey-Hanning"), bw = bwAndrews2, approx = c("AR(1)",
"ARMA(1,1)"), prewhite = 1, ar.method = "ols", tol_weights = 1e-7, tol_lam = 1e-9, tol_obj = 1e-9,
tol_mom = 1e-9, maxiterlam = 1000, constraint = FALSE, optfct = c("optim", "optimize", "nlminb"),
- optlam = c("iter", "numeric"), model = TRUE, X = FALSE, Y = FALSE, ...)
+ optlam = c("iter", "numeric"), model = TRUE, X = FALSE, Y = FALSE, TypeGel = "baseGel", ...)
{
+
vcov <- match.arg(vcov)
type <- match.arg(type)
optfct <- match.arg(optfct)
optlam <- match.arg(optlam)
weights <- weightsAndrews2
- if (type == "ETEL")
- {
- typel <- "ET"
- typet <- "EL"
- }
- else
- {
- typel <- type
- typet <- type
- }
approx <- match.arg(approx)
kernel <- match.arg(kernel)
- if(optfct == "optim")
- k <- length(tet0)
- else
- k <- 1
- typeg=0
- if (is(g, "formula"))
- {
- typeg = 1
- dat <- getDat(g, x)
- x <- dat$x
-
- g <- function(tet, x, ny = dat$ny, nh = dat$nh, k = dat$k)
- {
- tet <- matrix(tet, ncol = k)
- e <- x[,1:ny] - x[, (ny+1):(ny+k)]%*%t(tet)
- gt <- e*x[, ny+k+1]
- if (nh > 1)
- {
- for (i in 2:nh)
- {
- gt <- cbind(gt, e*x[,(ny+k+i)])
- }
- }
- return(gt)
- }
- gradv <- function(tet, x, ny = dat$ny, nh = dat$nh, k = dat$k)
- {
- tet <- matrix(tet, ncol = k)
- dgb <- -(t(x[,(ny+k+1):(ny+k+nh)])%*%x[,(ny+1):(ny+k)])%x%diag(rep(1, ny))/nrow(x)
- return(dgb)
- }
- }
- if (typeg)
- n <- nrow(x)
- else
- n = nrow(g(tet0, x))
+ all_args <- list(g = g, x = x, tet0 = tet0, gradv = gradv, smooth = smooth, type = type, vcov = vcov,
+ kernel = kernel, bw = bw, approx = approx, prewhite = prewhite, ar.method = ar.method,
+ tol_weights = tol_weights, tol_lam = tol_lam, tol_obj = tol_obj, tol_mom = tol_mom,
+ maxiterlam = maxiterlam, constraint = constraint, optfct = optfct,
+ optlam = optlam, model = model, X = X, Y = Y, TypeGel = TypeGel, call = match.call())
- if (smooth)
- {
- g1 <- g
- rgmm <- gmm(g, x, tet0, wmatrix = "ident")
+ class(all_args)<-TypeGel
+ Model_info<-getModel(all_args)
+ z <- momentEstim(Model_info, ...)
- if (is.function(weights))
- w <- weights(g(rgmm$coefficients, x), kernel = kernel, bw = bw, prewhite = prewhite,
- ar.method = ar.method, approx = approx, tol = tol_weights)
- else
- w <- weights
- sg <- function(thet, x)
- {
- gf <- g1(thet, x)
- gt <- smoothG(gf, weights = w)$smoothx
- return(gt)
- }
- g <- sg
- }
- lll <- 1
- thetf <- function(tet)
- {
- if (optlam == "iter")
- {
- lamblist <- getLamb(g, tet, x, type = typel, tol_lam = tol_lam, maxiterlam = maxiterlam, tol_obj = tol_obj)
- lamb <- lamblist$lambda
- gt <- g(tet, x)
- pt <- -rho(gt, lamb, type = typet, derive = 1)$rhomat/nrow(gt)
- checkmom <- sum(as.numeric(pt)*gt)
- if (lamblist$singular == 0)
- p <- sum(rho(gt, lamb, type = typet)$rhomat) + abs(checkmom)/tol_mom
- if (lamblist$singular == 1)
- p <- sum(rho(gt, lamb, type = typet)$rhomat) + abs(checkmom)/tol_mom + lamblist$obj/tol_mom
- if (lamblist$singular == 2)
- p <- 1e50*lll
- lll <- lll + 1
- }
- else
- {
- gt <- g(tet, x)
- rhofct <- function(lamb)
- {
- rhof <- -sum(rho(gt, lamb, type = typel)$rhomat)
- return(rhof)
- }
- if (ncol(gt) > 1)
- rlamb <- optim(rep(0, ncol(gt)), rhofct, control = list(maxit = 1000))
- else
- {
- rlamb <- optimize(rhofct, c(-1,1))
- rlamb$par <- rlamb$minimum
- rlamb$value <- rlamb$objective
- }
- lamb <- rlamb$par
- pt <- -rho(gt, lamb, type = typet, derive = 1)$rhomat/nrow(gt)
- checkmom <- sum(as.numeric(pt)*gt)
- p <- -rlamb$value + (checkmom)^2/tol_mom + (sum(as.numeric(pt)) - 1)^2/tol_mom
- }
- return(p)
- }
+ class(z) <- "gel"
+ return(z)
+ }
- if (!constraint)
- {
- if (optfct == "optim")
- res <- optim(tet0, thetf, ...)
- if (optfct == "nlminb")
- res <- nlminb(tet0, thetf, ...)
-
- if (optfct == "optimize")
- {
- res <- optimize(thetf, tet0, ...)
- res$par <- res$minimum
- res$convergence <- "There is no convergence code for optimize"
- }
- }
- if(constraint)
- res <- constrOptim(tet0, thetf, grad = NULL, ...)
+ .thetf <- function(tet, P)
+ {
+ if(!is.null(P$gform))
+ {
+ dat <- P$dat
+ x <- dat$x
+ }
+ else
+ x <- P$x
+ if (P$optlam == "iter")
+ {
+ lamblist <- getLamb(P$g, tet, x, type = P$typel, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam, tol_obj = P$tol_obj)
+ lamb <- lamblist$lambda
+ gt <- P$g(tet, x)
+ pt <- -rho(gt, lamb, type = P$typet, derive = 1)$rhomat/nrow(gt)
+ checkmom <- sum(as.numeric(pt)*gt)
+ if (lamblist$singular == 0)
+ p <- sum(rho(gt, lamb, type = P$typet)$rhomat) + abs(checkmom)/P$tol_mom
+ if (lamblist$singular == 1)
+ p <- sum(rho(gt, lamb, type = P$typet)$rhomat) + abs(checkmom)/P$tol_mom + lamblist$obj/P$tol_mom
+ if (lamblist$singular == 2)
+ p <- 1e50*proc.time()[3]
+ }
+ else
+ {
+ gt <- P$g(tet, x)
+ rhofct <- function(lamb)
+ {
+ rhof <- -sum(rho(gt, lamb, type = P$typel)$rhomat)
+ return(rhof)
+ }
+ if (ncol(gt) > 1)
+ rlamb <- optim(rep(0, ncol(gt)), rhofct, control = list(maxit = 1000))
+ else
+ {
+ rlamb <- optimize(rhofct, c(-1,1))
+ rlamb$par <- rlamb$minimum
+ rlamb$value <- rlamb$objective
+ }
+ lamb <- rlamb$par
+ pt <- -rho(gt, lamb, type = P$typet, derive = 1)$rhomat/nrow(gt)
+ checkmom <- sum(as.numeric(pt)*gt)
+ p <- -rlamb$value + (checkmom)^2/P$tol_mom + (sum(as.numeric(pt)) - 1)^2/P$tol_mom
+ }
+ return(p)
+ }
- if (optlam=="iter")
- {
- rlamb <- getLamb(g,res$par, x, type = typel, tol_lam = tol_lam, maxiterlam = maxiterlam, tol_obj = tol_obj)
- z <- list(coefficients = res$par, lambda = rlamb$lam, conv_lambda = rlamb$conv_mes, conv_par = res$convergence)
- z$foc_lambda <- rlamb$obj
- }
- if (optlam=="numeric")
- {
- gt<-g(res$par, x)
- rhofct <- function(lamb)
- {
- rhof <- -sum(rho(gt, lamb, type = typel)$rhomat)
- return(rhof)
- }
- rlamb <- optim(rep(0, ncol(gt)), rhofct, control = list(maxit = 1000))
- z <- list(coefficients = res$par, conv_par = res$convergence, lambda = rlamb$par)
- z$conv_lambda = paste("Lambda by optim. Conv. code = ", rlamb$convergence, sep = "")
- rho1 <- as.numeric(rho(gt, z$lambda, derive = 1, type = typel)$rhomat)
- z$foc_lambda <- crossprod(colMeans(rho1*gt))
- }
-
- z$type <- type
- z$gt <- g(z$coefficients, x)
- rhom <- rho(z$gt, z$lambda, type = typet)
- z$pt <- -rho(z$gt, z$lambda, type = typet, derive = 1)$rhomat/n
- z$conv_moment <- colSums(as.numeric(z$pt)*z$gt)
- z$conv_pt <- sum(as.numeric(z$pt))
- z$objective <- sum(as.numeric(rhom$rhomat) - rho(1, 0, type = typet)$rhomat)/n
- if (type == "EL")
- {
- z$badrho <- rhom$ch
- names(z$badrho) <- "Number_of_bad_rho"
- }
-
- if (!is.function(gradv))
- G <- .Gf(z$coefficients, x, g)
- else
- G <- gradv(z$coefficients, x)
- if (vcov == "iid")
- khat <- crossprod(z$gt)
- else
- khat <- HAC(g(z$coefficients, x), kernel = kernel, bw = bw, prewhite = prewhite,
- ar.method=ar.method, approx = approx, tol = tol_weights)
-
- kg <- solve(khat, G)
- z$vcov_par <- solve(crossprod(G, kg))/n
- z$vcov_lambda <- ((solve(khat) - kg%*%z$vcov_par%*%t(kg)))/n
-
- if (smooth) z$weights <- w
-
- if (typeg ==0)
- {
- names(z$coefficients) <- paste("Theta[",1:k,"]", sep = "")
- colnames(z$gt) <- paste("gt[",1:ncol(z$gt),"]", sep = "")
- names(z$lambda) <- paste("Lambda[",1:ncol(z$gt),"]", sep = "")
- }
- if (typeg == 1)
- {
- namex <- colnames(dat$x[, (dat$ny+1):(dat$ny+dat$k)])
- nameh <- colnames(dat$x[, (dat$ny+dat$k+1):(dat$ny+dat$k+dat$nh)])
- if (dat$ny > 1)
- {
- namey <- colnames(dat$x[, 1:dat$ny])
- names(z$coefficients) <- paste(rep(namey, dat$k), "_", rep(namex, rep(dat$ny, dat$k)), sep = "")
- colnames(z$gt) <- paste(rep(namey, dat$nh), "_", rep(nameh, rep(dat$ny,dat$nh)), sep = "")
- names(z$lambda) <- paste("Lam(",rep(namey,dat$nh), "_", rep(nameh, rep(dat$ny,dat$nh)), ")", sep = "")
- }
- if (dat$ny == 1)
- {
- names(z$coefficients) <- namex
- colnames(z$gt) <- nameh
- names(z$lambda) <- nameh
- }
- }
- dimnames(z$vcov_par) <- list(names(z$coefficients), names(z$coefficients))
- dimnames(z$vcov_lambda) <- list(names(z$lambda), names(z$lambda))
- if (typeg == 1)
- {
- b <- z$coefficients
- y <- as.matrix(model.response(dat$mf, "numeric"))
- ny <- dat$ny
- b <- t(matrix(b, nrow = ny))
- x <- as.matrix(model.matrix(dat$mt, dat$mf, NULL))
- yhat <- x%*%b
- z$fitted.values <- yhat
- z$residuals <- y - yhat
- z$terms <- dat$mt
- if(model) z$model <- dat$mf
- if(X) z$x <- x
- if(Y) z$ y<- y
- }
- else
- if(X) z$x <- x
-
- z$call <- match.call()
- class(z) <- "gel"
- return(z)
- }
Modified: pkg/gmm/R/getModel.R
===================================================================
--- pkg/gmm/R/getModel.R 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/R/getModel.R 2009-12-22 15:18:34 UTC (rev 16)
@@ -73,4 +73,81 @@
return(object)
}
+getModel.baseGel <- function(object, ...)
+ {
+ P <- object
+ if (P$type == "ETEL")
+ {
+ P$typel <- "ET"
+ P$typet <- "EL"
+ }
+ else
+ {
+ P$typel <- P$type
+ P$typet <- P$type
+ }
+ if(P$optfct == "optim")
+ P$k <- length(P$tet0)
+ else
+ P$k <- 1
+
+ if (is(P$g, "formula"))
+ {
+ clname <- paste(class(P), ".modFormula", sep = "")
+ dat <- getDat(P$g, P$x)
+ x <- dat$x
+ g <- function(tet, x, ny = dat$ny, nh = dat$nh, k = dat$k)
+ {
+ tet <- matrix(tet, ncol = k)
+ e <- x[,1:ny] - x[, (ny+1):(ny+k)]%*%t(tet)
+ gt <- e*x[, ny+k+1]
+ if (nh > 1)
+ {
+ for (i in 2:nh)
+ {
+ gt <- cbind(gt, e*x[,(ny+k+i)])
+ }
+ }
+ return(gt)
+ }
+
+ gradv <- function(tet, x, ny = dat$ny, nh = dat$nh, k = dat$k)
+ {
+ tet <- matrix(tet, ncol = k)
+ dgb <- -(t(x[,(ny+k+1):(ny+k+nh)])%*%x[,(ny+1):(ny+k)])%x%diag(rep(1, ny))/nrow(x)
+ return(dgb)
+ }
+ P$dat <- dat
+ P$gform <- P$g
+ P$g <- g
+ P$gradv <- gradv
+ }
+ else
+ {
+ clname <- paste(class(P), ".mod", sep = "")
+ P$gform <- NULL
+ }
+
+ if (P$smooth)
+ {
+ P$g1 <- P$g
+ rgmm <- gmm(P$g, x, P$tet0, wmatrix = "ident")
+
+ if (is.function(P$weights))
+ P$w <- P$weights(P$g(rgmm$coefficients, x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol_weights)
+ else
+ P$w <- P$weights
+
+ P$sg <- function(thet, x, g1 = P$g1, w = P$w)
+ {
+ gf <- g1(thet, x)
+ gt <- smoothG(gf, weights = w)$smoothx
+ return(gt)
+ }
+ }
+ class(P) <- clname
+ return(P)
+ }
+
Modified: pkg/gmm/R/momentEstim.R
===================================================================
--- pkg/gmm/R/momentEstim.R 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/R/momentEstim.R 2009-12-22 15:18:34 UTC (rev 16)
@@ -459,9 +459,210 @@
z$iid <- P$iid
z$g <- P$g
- class(z) <- paste(P$TypeGmm,".res",sep="")
+ class(z) <- paste(P$TypeGmm, ".res", sep = "")
return(z)
}
+momentEstim.baseGel.modFormula <- function(object, ...)
+ {
+ P <- object
+ g <- P$g
+ dat <- getDat(P$gform, P$x)
+ x <- dat$x
+ n <- nrow(x)
+ if (!P$constraint)
+ {
+ if (P$optfct == "optim")
+ res <- optim(P$tet0, .thetf, P = P, ...)
+ if (P$optfct == "nlminb")
+ res <- nlminb(P$tet0, .thetf, P = P, ...)
+
+ if (P$optfct == "optimize")
+ {
+ res <- optimize(.thetf, P$tet0, P = P, ...)
+ res$par <- res$minimum
+ res$convergence <- "There is no convergence code for optimize"
+ }
+ }
+
+ if(P$constraint)
+ res <- constrOptim(P$tet0, .thetf, grad = NULL, P = P, ...)
+
+
+ if (P$optlam == "iter")
+ {
+ rlamb <- getLamb(P$g, res$par, x, type = P$typel, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam, tol_obj = P$tol_obj)
+ z <- list(coefficients = res$par, lambda = rlamb$lam, conv_lambda = rlamb$conv_mes, conv_par = res$convergence)
+ z$foc_lambda <- rlamb$obj
+ }
+
+ if (P$optlam == "numeric")
+ {
+ gt <- P$g(res$par, x)
+ rhofct <- function(lamb)
+ {
+ rhof <- -sum(rho(gt, lamb, type = P$typel)$rhomat)
+ return(rhof)
+ }
+ rlamb <- optim(rep(0, ncol(gt)), rhofct, control = list(maxit = 1000))
+ z <- list(coefficients = res$par, conv_par = res$convergence, lambda = rlamb$par)
+ z$conv_lambda = paste("Lambda by optim. Conv. code = ", rlamb$convergence, sep = "")
+ rho1 <- as.numeric(rho(gt, z$lambda, derive = 1, type = P$typel)$rhomat)
+ z$foc_lambda <- crossprod(colMeans(rho1*gt))
+ }
+ z$type <- P$type
+ z$gt <- P$g(z$coefficients, x)
+ rhom <- rho(z$gt, z$lambda, type = P$typet)
+ z$pt <- -rho(z$gt, z$lambda, type = P$typet, derive = 1)$rhomat/n
+ z$conv_moment <- colSums(as.numeric(z$pt)*z$gt)
+ z$conv_pt <- sum(as.numeric(z$pt))
+ z$objective <- sum(as.numeric(rhom$rhomat) - rho(1, 0, type = P$typet)$rhomat)/n
+
+ namex <- colnames(dat$x[, (dat$ny+1):(dat$ny+dat$k)])
+ nameh <- colnames(dat$x[, (dat$ny+dat$k+1):(dat$ny+dat$k+dat$nh)])
+
+ if (dat$ny > 1)
+ {
+ namey <- colnames(dat$x[, 1:dat$ny])
+ names(z$coefficients) <- paste(rep(namey, dat$k), "_", rep(namex, rep(dat$ny, dat$k)), sep = "")
+ colnames(z$gt) <- paste(rep(namey, dat$nh), "_", rep(nameh, rep(dat$ny,dat$nh)), sep = "")
+ names(z$lambda) <- paste("Lam(",rep(namey,dat$nh), "_", rep(nameh, rep(dat$ny,dat$nh)), ")", sep = "")
+ }
+ if (dat$ny == 1)
+ {
+ names(z$coefficients) <- namex
+ colnames(z$gt) <- nameh
+ names(z$lambda) <- nameh
+ }
+
+ if (P$type == "EL")
+ {
+ z$badrho <- rhom$ch
+ names(z$badrho) <- "Number_of_bad_rho"
+ }
+
+ if (!is.function(P$gradv))
+ G <- .Gf(z$coefficients, x, P$g)
+ else
+ G <- P$gradv(z$coefficients, x)
+
+ if (P$vcov == "iid")
+ khat <- crossprod(z$gt)
+ else
+ khat <- HAC(P$g(z$coefficients, x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol_weights)
+
+ kg <- solve(khat, G)
+ z$vcov_par <- solve(crossprod(G, kg))/n
+ z$vcov_lambda <- ((solve(khat) - kg%*%z$vcov_par%*%t(kg)))/n
+
+ if (P$smooth) z$weights <- P$w
+
+ dimnames(z$vcov_par) <- list(names(z$coefficients), names(z$coefficients))
+ dimnames(z$vcov_lambda) <- list(names(z$lambda), names(z$lambda))
+ b <- z$coefficients
+ y <- as.matrix(model.response(dat$mf, "numeric"))
+ ny <- dat$ny
+ b <- t(matrix(b, nrow = ny))
+ x <- as.matrix(model.matrix(dat$mt, dat$mf, NULL))
+ yhat <- x%*%b
+ z$fitted.values <- yhat
+ z$residuals <- y - yhat
+ z$terms <- dat$mt
+ if(P$model) z$model <- dat$mf
+ if(P$X) z$x <- x
+ if(P$Y) z$y <- y
+ z$call <- P$call
+
+ class(z) <- paste(P$TypeGel, ".res", sep = "")
+ return(z)
+ }
+
+momentEstim.baseGel.mod <- function(object, ...)
+ {
+ P <- object
+ x <- P$x
+ n <- ifelse(is.null(dim(x)),length(x),nrow(x))
+ if (!P$constraint)
+ {
+ if (P$optfct == "optim")
+ res <- optim(P$tet0, .thetf, P = P, ...)
+ if (P$optfct == "nlminb")
+ res <- nlminb(P$tet0, .thetf, P = P, ...)
+
+ if (P$optfct == "optimize")
+ {
+ res <- optimize(.thetf, P$tet0, P = P, ...)
+ res$par <- res$minimum
+ res$convergence <- "There is no convergence code for optimize"
+ }
+ }
+
+ if(P$constraint)
+ res <- constrOptim(P$tet0, .thetf, grad = NULL, P = P, ...)
+
+
+ if (P$optlam == "iter")
+ {
+ rlamb <- getLamb(P$g, res$par, x, type = P$typel, tol_lam = P$tol_lam, maxiterlam = P$maxiterlam, tol_obj = P$tol_obj)
+ z <- list(coefficients = res$par, lambda = rlamb$lam, conv_lambda = rlamb$conv_mes, conv_par = res$convergence)
+ z$foc_lambda <- rlamb$obj
+ }
+
+ if (P$optlam == "numeric")
+ {
+ gt <- P$g(res$par, x)
+ rhofct <- function(lamb)
+ {
+ rhof <- -sum(rho(gt, lamb, type = P$typel)$rhomat)
+ return(rhof)
+ }
+ rlamb <- optim(rep(0, ncol(gt)), rhofct, control = list(maxit = 1000))
+ z <- list(coefficients = res$par, conv_par = res$convergence, lambda = rlamb$par)
+ z$conv_lambda = paste("Lambda by optim. Conv. code = ", rlamb$convergence, sep = "")
+ rho1 <- as.numeric(rho(gt, z$lambda, derive = 1, type = P$typel)$rhomat)
+ z$foc_lambda <- crossprod(colMeans(rho1*gt))
+ }
+ z$type <- P$type
+ z$gt <- P$g(z$coefficients, x)
+ rhom <- rho(z$gt, z$lambda, type = P$typet)
+ z$pt <- -rho(z$gt, z$lambda, type = P$typet, derive = 1)$rhomat/n
+ z$conv_moment <- colSums(as.numeric(z$pt)*z$gt)
+ z$conv_pt <- sum(as.numeric(z$pt))
+ z$objective <- sum(as.numeric(rhom$rhomat) - rho(1, 0, type = P$typet)$rhomat)/n
+
+ if (P$type == "EL")
+ {
+ z$badrho <- rhom$ch
+ names(z$badrho) <- "Number_of_bad_rho"
+ }
+
+ if (!is.function(P$gradv))
+ G <- .Gf(z$coefficients, x, P$g)
+ else
+ G <- P$gradv(z$coefficients, x)
+ if (P$vcov == "iid")
+ khat <- crossprod(z$gt)
+ else
+ khat <- HAC(P$g(z$coefficients, x), kernel = P$kernel, bw = P$bw, prewhite = P$prewhite,
+ ar.method = P$ar.method, approx = P$approx, tol = P$tol_weights)
+
+ kg <- solve(khat, G)
+ z$vcov_par <- solve(crossprod(G, kg))/n
+ z$vcov_lambda <- ((solve(khat) - kg%*%z$vcov_par%*%t(kg)))/n
+
+ if (P$smooth) z$weights <- P$w
+
+ names(z$coefficients) <- paste("Theta[",1:P$k,"]", sep = "")
+ colnames(z$gt) <- paste("gt[",1:ncol(z$gt),"]", sep = "")
+ names(z$lambda) <- paste("Lambda[",1:ncol(z$gt),"]", sep = "")
+ dimnames(z$vcov_par) <- list(names(z$coefficients), names(z$coefficients))
+ dimnames(z$vcov_lambda) <- list(names(z$lambda), names(z$lambda))
+ if(P$X) z$x <- x
+ z$call <- P$call
+
+ class(z) <- paste(P$TypeGel, ".res", sep = "")
+ return(z)
+ }
Modified: pkg/gmm/man/gel.Rd
===================================================================
--- pkg/gmm/man/gel.Rd 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/man/gel.Rd 2009-12-22 15:18:34 UTC (rev 16)
@@ -12,7 +12,7 @@
kernel = c("Bartlett", "Parzen", "Truncated", "Tukey-Hanning"), bw = bwAndrews2,
approx = c("AR(1)", "ARMA(1,1)"), prewhite = 1, ar.method = "ols", tol_weights = 1e-7,
tol_lam = 1e-9, tol_obj = 1e-9, tol_mom = 1e-9, maxiterlam = 1000, constraint = FALSE,
- optfct = c("optim", "optimize", "nlminb"), optlam = c("iter","numeric"), model = TRUE, X = FALSE, Y = FALSE,...)
+ optfct = c("optim", "optimize", "nlminb"), optlam = c("iter","numeric"), model = TRUE, X = FALSE, Y = FALSE, TypeGel = "baseGel",...)
}
\arguments{
\item{g}{A function of the form \eqn{g(\theta,x)} and which returns a \eqn{n \times q} matrix with typical element \eqn{g_i(\theta,x_t)} for \eqn{i=1,...q} and \eqn{t=1,...,n}. This matrix is then used to build the q sample moment conditions. It can also be a formula if the model is linear (see details below). }
@@ -57,6 +57,8 @@
\item{model, X, Y}{logicals. If \code{TRUE} the corresponding components of the fit (the model frame, the model matrix, the response) are returned if g is a formula.}
+\item{TypeGel}{The name of the class object created by the method \code{getModel}. It allows developers to extand the package and create other GEL methods.}
+
\item{...}{More options to give to \code{\link{optim}}, \code{\link{optimize}} or \code{\link{constrOptim}}.}
}
Modified: pkg/gmm/man/getModel.Rd
===================================================================
--- pkg/gmm/man/getModel.Rd 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/man/getModel.Rd 2009-12-22 15:18:34 UTC (rev 16)
@@ -1,5 +1,6 @@
\name{getModel}
\alias{getModel.baseGmm}
+\alias{getModel.baseGel}
\title{Method for setting the properties of a model}
\description{
It collects what is needed by the method \code{momentEstim} (see details).
Modified: pkg/gmm/man/momentEstim.Rd
===================================================================
--- pkg/gmm/man/momentEstim.Rd 2009-12-21 03:44:34 UTC (rev 15)
+++ pkg/gmm/man/momentEstim.Rd 2009-12-22 15:18:34 UTC (rev 16)
@@ -5,6 +5,8 @@
\alias{momentEstim.baseGmm.iterative}
\alias{momentEstim.baseGmm.cue.formula}
\alias{momentEstim.baseGmm.cue}
+\alias{momentEstim.baseGel.mod}
+\alias{momentEstim.baseGel.modFormula}
\title{Method for estimating models based on moment conditions}
\description{
It estimates a model which is caracterized by the method \code{getModel} (see details).
More information about the Gmm-commits
mailing list