[Gmm-commits] r85 - in pkg/gmm: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 28 20:28:31 CET 2015
Author: chaussep
Date: 2015-10-28 20:28:30 +0100 (Wed, 28 Oct 2015)
New Revision: 85
Modified:
pkg/gmm/NAMESPACE
pkg/gmm/R/FinRes.R
pkg/gmm/R/Methods.gel.R
pkg/gmm/R/gel.R
pkg/gmm/R/getModel.R
pkg/gmm/R/momentEstim.R
Log:
see NEWS
Modified: pkg/gmm/NAMESPACE
===================================================================
--- pkg/gmm/NAMESPACE 2015-10-28 16:07:46 UTC (rev 84)
+++ pkg/gmm/NAMESPACE 2015-10-28 19:28:30 UTC (rev 85)
@@ -12,7 +12,7 @@
momentEstim.baseGmm.cue, getModel.baseGmm, getModel.baseGel, getModel.constGmm, getModel.constGel,
FinRes.baseGmm.res, momentEstim.baseGel.mod, momentEstim.baseGel.modFormula,tsls,summary.tsls, print.summary.tsls,
KTest, print.gmmTests, gmmWithConst, estfun.tsls, model.matrix.tsls,vcov.tsls, bread.tsls, evalGmm, momentEstim.baseGmm.eval,
- momentEstim.baseGel.eval, evalGel)
+ momentEstim.baseGel.eval, evalGel, confint.gmm)
S3method(summary, gmm)
S3method(summary, tsls)
Modified: pkg/gmm/R/FinRes.R
===================================================================
--- pkg/gmm/R/FinRes.R 2015-10-28 16:07:46 UTC (rev 84)
+++ pkg/gmm/R/FinRes.R 2015-10-28 19:28:30 UTC (rev 85)
@@ -45,7 +45,7 @@
z$k <- z$k+nrow(eqConst)
z$k2 <- z$k2+nrow(eqConst)
attr(x, "eqConst") <- NULL
- z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values **\n\n")
+ z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values \n Tests non-valid**\n\n")
}
z$G <- z$gradv(z$coefficients, x)
G <- z$G
Modified: pkg/gmm/R/Methods.gel.R
===================================================================
--- pkg/gmm/R/Methods.gel.R 2015-10-28 16:07:46 UTC (rev 84)
+++ pkg/gmm/R/Methods.gel.R 2015-10-28 19:28:30 UTC (rev 85)
@@ -11,67 +11,74 @@
# A copy of the GNU General Public License is available at
# http://www.r-project.org/Licenses/
+
confint.gel <- function(object, parm, level = 0.95, lambda = FALSE, ...)
- {
- z <- object
- n <- nrow(z$gt)
-
- se_par <- sqrt(diag(z$vcov_par))
- par <- z$coefficients
- tval <- par/se_par
+ {
+ z <- object
+ n <- nrow(z$gt)
+
+ se_par <- sqrt(diag(z$vcov_par))
+ par <- z$coefficients
+ tval <- par/se_par
+
+ se_parl <- sqrt(diag(z$vcov_lambda))
+ lamb <- z$lambda
+
+ zs <- qnorm((1 - level)/2, lower.tail=FALSE)
+ ch <- zs*se_par
+
+ if(!lambda)
+ {
+ ans <- cbind(par-ch, par+ch)
+ dimnames(ans) <- list(names(par), c((1 - level)/2, 0.5+level/2))
+ }
+ if(lambda)
+ {
+ if (length(z$coefficients) == length(z$lambda))
+ {
+ cat("\nNo confidence intervals for lambda when the model is just identified.\n")
+ return(NULL)
+ } else {
+ chl <- zs*se_parl
+ ans <- cbind(lamb - chl, lamb + chl)
+ dimnames(ans) <- list(names(lamb), c((1 - level)/2, 0.5 + level/2))
+ }
+ }
+ if(!missing(parm))
+ ans <- ans[parm,]
+ ans
+ }
- se_parl <- sqrt(diag(z$vcov_lambda))
- lamb <- z$lambda
-
- zs <- qnorm((1 - level)/2, lower.tail=FALSE)
- ch <- zs*se_par
-
- if(!lambda)
- {
- ans <- cbind(par-ch, par+ch)
- dimnames(ans) <- list(names(par), c((1 - level)/2, 0.5+level/2))
- }
- if(lambda)
- {
- chl <- zs*se_parl
- ans <- cbind(lamb - chl, lamb + chl)
- dimnames(ans) <- list(names(lamb), c((1 - level)/2, 0.5 + level/2))
- }
- if(!missing(parm))
- ans <- ans[parm,]
- ans
- }
-
coef.gel <- function(object, lambda = FALSE, ...)
- {
+ {
if(!lambda)
- object$coefficients
+ object$coefficients
else
- object$lambda
- }
+ object$lambda
+ }
vcov.gel <- function(object, lambda = FALSE, ...)
- {
+ {
if(!lambda)
- object$vcov_par
+ object$vcov_par
else
- object$vcov_lambda
- }
+ object$vcov_lambda
+ }
print.gel <- function(x, digits = 5, ...)
- {
+ {
if (is.null(x$CGEL))
- cat("Type de GEL: ", x$typeDesc, "\n")
+ cat("Type de GEL: ", x$typeDesc, "\n")
else
- cat("CGEL of type: ", x$typeDesc, " (alpha = ", x$CGEL, ")\n")
+ cat("CGEL of type: ", x$typeDesc, " (alpha = ", x$CGEL, ")\n")
if (!is.null(attr(x$dat,"smooth")))
- {
+ {
cat("Kernel: ", attr(x$dat,"smooth")$kernel," (bw=",
- attr(x$dat,"smooth")$bw,")\n\n")
- }
+ attr(x$dat,"smooth")$bw,")\n\n")
+ }
else
- cat("\n")
-
+ cat("\n")
+
cat("Coefficients:\n")
print.default(format(coef(x), digits = digits),
print.gap = 2, quote = FALSE)
@@ -81,49 +88,48 @@
print.gap = 2, quote = FALSE)
cat("\n")
cat("Convergence code for the coefficients: ", x$conv_par,"\n")
- if (length(x$coefficients)<length(x$lambda))
- cat("Convergence code for Lambda: ", x$conv_lambda$convergence,"\n")
+ cat("Convergence code for Lambda: ", x$conv_lambda$convergence,"\n")
cat(x$specMod)
invisible(x)
- }
+ }
print.summary.gel <- function(x, digits = 5, ...)
- {
+ {
cat("\nCall:\n")
cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "")
if (is.null(x$CGEL))
- cat("Type of GEL: ", x$typeDesc, "\n")
+ cat("Type of GEL: ", x$typeDesc, "\n")
else
- cat("CGEL of type: ", x$typeDesc, " (alpha = ", x$CGEL, ")\n")
-
+ cat("CGEL of type: ", x$typeDesc, " (alpha = ", x$CGEL, ")\n")
+
if (!is.null(x$smooth))
- {
+ {
cat("Kernel: ", x$smooth$kernel," (bw=", x$smooth$bw,")\n\n")
- }
- else
+ }else {
cat("\n")
-
+ }
+
cat("Coefficients:\n")
print.default(format(x$coefficients, digits = digits),
print.gap = 2, quote = FALSE)
-
+
if (length(x$coefficients)<length(x$lambda))
{
cat("\nLambdas:\n")
print.default(format(x$lambda, digits=digits),
print.gap = 2, quote = FALSE)
-
- cat("\n", x$stest$ntest, "\n")
- print.default(format(x$stest$test, digits=digits),
- print.gap = 2, quote = FALSE)
+ } else {
+ cat("\nNo table for Lambda when the model is just identified\n")
}
- cat(x$specMod)
- cat("\nConvergence code for the coefficients: ", x$conv_par, "\n")
- if (length(x$coefficients)<length(x$lambda))
- cat("\nConvergence code for the lambdas: ", x$conv_lambda$convergence, "\n")
-
- invisible(x)
- }
+ cat("\n", x$stest$ntest, "\n")
+ print.default(format(x$stest$test, digits=digits),
+ print.gap = 2, quote = FALSE)
+ cat("\n",x$specMod)
+ cat("\nConvergence code for the coefficients: ", x$conv_par, "\n")
+ cat("\nConvergence code for the lambdas: ", x$conv_lambda$convergence, "\n")
+
+ invisible(x)
+ }
summary.gel <- function(object, ...)
{
@@ -161,6 +167,8 @@
ans$conv_moment <- cbind(z$conv_moment)
ans$conv_lambda <- z$conv_lambda
ans$CGEL <- z$CGEL
+ ans$typeDesc <- z$typeDesc
+ ans$specMod <- z$specMod
if (!is.null(attr(object$dat,"smooth")))
ans$smooth <- attr(object$dat,"smooth")
names(ans$conv_pt) <- "Sum_of_pt"
Modified: pkg/gmm/R/gel.R
===================================================================
--- pkg/gmm/R/gel.R 2015-10-28 16:07:46 UTC (rev 84)
+++ pkg/gmm/R/gel.R 2015-10-28 19:28:30 UTC (rev 85)
@@ -243,7 +243,7 @@
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, weights = weights,
- optlam = optlam, model = model, X = X, Y = Y, TypeGel = TypeGel, call = match.call(),
+ optlam = optlam, model = model, X = X, Y = Y, TypeGel = TypeGel, call = match.call(),
Lambdacontrol = Lambdacontrol, alpha = alpha, data = data, eqConst = eqConst, eqConstFullVcov = eqConstFullVcov)
class(all_args)<-TypeGel
Modified: pkg/gmm/R/getModel.R
===================================================================
--- pkg/gmm/R/getModel.R 2015-10-28 16:07:46 UTC (rev 84)
+++ pkg/gmm/R/getModel.R 2015-10-28 19:28:30 UTC (rev 85)
@@ -164,7 +164,7 @@
obj$eqConst <- object$eqConst
attr(obj$x, "k") <- attr(obj$x, "k")-nrow(object$eqConst)
obj$namesCoef <- obj$namesCoef[-object$eqConst[,1]]
- obj$type <- paste(obj$type,"(with equality constraints)",sep=" ")
+ obj$typeDesc <- paste(obj$typeDesc,"(with equality constraints)",sep=" ")
mess <- paste(rownames(object$eqConst), " = " , object$eqConst[,2], "\n",collapse="")
mess <- paste("#### Equality constraints ####\n",mess,"##############################\n\n",sep="")
obj$specMod <- mess
@@ -288,6 +288,7 @@
}
object$g <- .momentFct
object$CGEL <- object$alpha
+ object$typeDesc <- object$type
class(object) <- clname
return(object)
}
Modified: pkg/gmm/R/momentEstim.R
===================================================================
--- pkg/gmm/R/momentEstim.R 2015-10-28 16:07:46 UTC (rev 84)
+++ pkg/gmm/R/momentEstim.R 2015-10-28 19:28:30 UTC (rev 85)
@@ -619,7 +619,6 @@
if(P$constraint)
res <- constrOptim(P$tet0, .thetf, grad = NULL, P = P, l0Env = l0Env, ...)
-
All <- .thetf(res$par, P, "all",l0Env = l0Env)
gt <- All$gt
rlamb <- All$lambda
@@ -662,7 +661,7 @@
z$coefficients <- coef
attr(P$x, "k") <- attr(P$x, "k") + nrow(eqConst)
attr(P$x,"eqConst") <- NULL
- z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values **\n\n")
+ z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values \n Tests non-valid**\n\n")
}
if(P$gradvf)
@@ -670,11 +669,14 @@
else
G <- P$gradv(z$coefficients, P$x, z$pt)
khat <- crossprod(c(z$pt)*z$gt,z$gt)/(P$k2)*P$bwVa
-
+ z$G <- G
G <- G/P$k1
kg <- solve(khat, G)
z$vcov_par <- solve(crossprod(G, kg))/n
- z$vcov_lambda <- solve(khat, ( diag(ncol(khat)) - G %*% (z$vcov_par*n) %*% t(kg) ))/n*P$bwVal^2
+ if (dim(G)[1] == dim(G)[2])
+ z$vcov_lambda <- matrix(0, dim(G))
+ else
+ z$vcov_lambda <- solve(khat, ( diag(ncol(khat)) - G %*% (z$vcov_par*n) %*% t(kg) ))/n*P$bwVal^2
z$weights <- P$w
z$bwVal <- P$bwVal
@@ -691,6 +693,7 @@
if(P$Y) z$y <- as.matrix(P$x$x[,1:P$x$ny])
z$khat <- khat
class(z) <- paste(P$TypeGel, ".res", sep = "")
+ z$allArg <- P$allArg
return(z)
}
@@ -752,27 +755,23 @@
z$coefficients <- coef
attr(x, "k") <- attr(x, "k") + nrow(eqConst)
attr(x,"eqConst") <- NULL
- z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values **\n\n")
+ z$specMod <- paste(z$specMod, "** Note: Covariance matrix computed for all coefficients based on restricted values \n Tests non-valid**\n\n")
}
if(P$gradvf)
G <- P$gradv(z$coefficients, x)
else
G <- P$gradv(z$coefficients, x, z$pt)
-
+ z$G <- G
khat <- crossprod(c(z$pt)*z$gt, z$gt)/(P$k2)*P$bwVal
G <- G/P$k1
-
+
kg <- solve(khat, G)
z$vcov_par <- solve(crossprod(G, kg))/n
- if (length(z$lambda) == length(z$coefficients))
- {
- z$vcov_lambda <- matrix(NA, rep(length(z$lambda), 2))
- z$lambda <- rep(NA, length(z$lambda))
- z$specMod <- paste(z$specMod, "\n Just identified model; no lambda nor specification test needed\n", sep="")
- } else {
- z$vcov_lambda <- solve(khat, ( diag(ncol(khat)) - G %*% (z$vcov_par*n) %*% t(kg) ))/n*P$bwVal^2
- }
+ if (dim(G)[1] == dim(G)[2])
+ z$vcov_lambda <- matrix(0, dim(G))
+ else
+ z$vcov_lambda <- solve(khat, ( diag(ncol(khat)) - G %*% (z$vcov_par*n) %*% t(kg) ))/n*P$bwVal^2
z$weights <- P$w
z$bwVal <- P$bwVal
@@ -787,6 +786,7 @@
z$khat <- khat
z$CGEL <- P$CGEL
z$typeDesc <- P$typeDesc
+ z$allArg <- P$allArg
class(z) <- paste(P$TypeGel, ".res", sep = "")
return(z)
}
@@ -813,6 +813,7 @@
warning("The matrix of weights is not strictly positive definite")
}
res2 <- .tetlin(dat, w)
+
z = list(coefficients = res2$par, objective = res2$value, dat=dat, k=k, k2=k2, n=n, q=q, df=df, df.residual = (n-k))
z$gt <- g(z$coefficients, dat)
@@ -956,7 +957,7 @@
z$k1 <- P$k1
z$k2 <- P$k2
z$CGEL <- P$CGEL
- z$typeDesc <- P$typeDesc
+ z$typeDesc <- paste(P$typeDesc, " (Eval only, tests non-valid) ", sep="")
z$specMod <- P$specMod
names(z$coefficients) <- P$namesCoef
if (!is.null(object$namesgt))
@@ -971,18 +972,15 @@
else
G <- P$gradv(z$coefficients, P$x, z$pt)
khat <- crossprod(c(z$pt)*z$gt,z$gt)/(P$k2)*P$bwVa
-
+
+ z$G <- G
G <- G/P$k1
kg <- solve(khat, G)
z$vcov_par <- solve(crossprod(G, kg))/n
- if (length(z$lambda) == length(z$coefficients))
- {
- z$vcov_lambda <- matrix(NA, rep(length(z$lambda), 2))
- z$lambda <- rep(NA, length(z$lambda))
- z$specMod <- paste(z$specMod, "\n Just identified model; no lambda nor specification test needed\n", sep="")
- } else {
- z$vcov_lambda <- solve(khat, ( diag(ncol(khat)) - G %*% (z$vcov_par*n) %*% t(kg) ))/n*P$bwVal^2
- }
+ if (dim(G)[1] == dim(G)[2])
+ z$vcov_lambda <- matrix(0, dim(G)[1], dim(G)[2])
+ else
+ z$vcov_lambda <- solve(khat, ( diag(ncol(khat)) - G %*% (z$vcov_par*n) %*% t(kg) ))/n*P$bwVal^2
z$weights <- P$w
z$bwVal <- P$bwVal
More information about the Gmm-commits
mailing list