[Gmm-commits] r236 - in pkg/gmm: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Apr 26 22:01:43 CEST 2024
Author: chaussep
Date: 2024-04-26 22:01:42 +0200 (Fri, 26 Apr 2024)
New Revision: 236
Modified:
pkg/gmm/DESCRIPTION
pkg/gmm/R/Methods.sysGmm.R
pkg/gmm/R/gmm.R
pkg/gmm/R/momentEstim.R
Log:
fixed a problem with sysGmm: wmatrix had not effect and standard errors were wrong
Modified: pkg/gmm/DESCRIPTION
===================================================================
--- pkg/gmm/DESCRIPTION 2024-04-09 18:04:43 UTC (rev 235)
+++ pkg/gmm/DESCRIPTION 2024-04-26 20:01:42 UTC (rev 236)
@@ -1,6 +1,6 @@
Package: gmm
-Version: 1.8
-Date: 2023-06-04
+Version: 1.9
+Date: 2024-04-25
Title: Generalized Method of Moments and Generalized Empirical
Likelihood
Author: Pierre Chausse <pchausse at uwaterloo.ca>
Modified: pkg/gmm/R/Methods.sysGmm.R
===================================================================
--- pkg/gmm/R/Methods.sysGmm.R 2024-04-09 18:04:43 UTC (rev 235)
+++ pkg/gmm/R/Methods.sysGmm.R 2024-04-26 20:01:42 UTC (rev 236)
@@ -42,7 +42,8 @@
{
dimnames(ans$coefficients[[i]]) <- list(names(z$coefficients[[i]]),
c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
- names(ans$initTheta[[i]]) <- names(z$coefficients[[i]])
+ if (!is.null(ans$initTheta))
+ names(ans$initTheta[[i]]) <- names(z$coefficients[[i]])
}
ans$specMod <- object$specMod
ans$bw <- attr(object$w0,"Spec")$bw
Modified: pkg/gmm/R/gmm.R
===================================================================
--- pkg/gmm/R/gmm.R 2024-04-09 18:04:43 UTC (rev 235)
+++ pkg/gmm/R/gmm.R 2024-04-26 20:01:42 UTC (rev 236)
@@ -240,6 +240,60 @@
return(list(x=x,nh=nh,ny=ny,k=k,mf=mf,mt=mt,cl=cl,termsh=termsh,termsx=mt))
}
+.fsResOnly <- function(dat)
+{
+ x <- dat$x
+ g <- .momentFct
+ gradv <- .DmomentFct
+ ny <- dat$ny
+ nh <- dat$nh
+ k <- dat$k
+ n <- nrow(x)
+ ym <- as.matrix(x[,1:ny])
+ xm <- as.matrix(x[,(ny+1):(ny+k)])
+ hm <- as.matrix(x[,(ny+k+1):(ny+k+nh)])
+ if (!is.null(attr(dat, "eqConst")))
+ {
+ resTet <- attr(dat,"eqConst")$eqConst
+ y2 <- xm[, resTet[,1],drop=FALSE]%*%resTet[,2]
+ ym <- ym-c(y2)
+ xm <- xm[,-resTet[,1],drop=FALSE]
+ k <- ncol(xm)
+ }
+ includeExo <- which(colnames(xm)%in%colnames(hm))
+ if (length(includeExo) > 0)
+ {
+ endo <- xm[, -includeExo, drop = FALSE]
+ endoName <- colnames(endo)
+ if (ncol(endo) != 0)
+ {
+ if (attr(dat$termsh, "intercept") == 1)
+ restsls <- lm(endo~hm[,-1])
+ else
+ restsls <- lm(endo~hm-1)
+ fsls <- xm
+ fsls[, -includeExo] <- restsls$fitted
+ } else {
+ fsls <- xm
+ restsls <- NULL
+ }
+ } else {
+ if (attr(dat$termsh, "intercept") == 1)
+ restsls <- lm(xm~hm[,-1])
+ else
+ restsls <- lm(xm~hm-1)
+ endoName <- colnames(xm)
+ }
+ if (!is.null(restsls))
+ {
+ chk <- .chkPerfectFit(restsls)
+ fsRes <- suppressWarnings(summary(restsls))[!chk]
+ attr(fsRes, "Endo") <- endoName[!chk]
+ }
+ return(fsRes)
+}
+
+
.tetlin <- function(dat, w, type=NULL)
{
x <- dat$x
Modified: pkg/gmm/R/momentEstim.R
===================================================================
--- pkg/gmm/R/momentEstim.R 2024-04-09 18:04:43 UTC (rev 235)
+++ pkg/gmm/R/momentEstim.R 2024-04-26 20:01:42 UTC (rev 236)
@@ -18,64 +18,74 @@
}
momentEstim.sysGmm.twoStep.formula <- function(object, ...)
+{
+ dat <- object$x
+ y <- lapply(1:length(dat), function(i) dat[[i]]$x[,1])
+ y <- do.call(c, y)
+ z <- lapply(1:length(dat), function(i)
+ dat[[i]]$x[,(2+dat[[i]]$k):ncol(dat[[i]]$x), drop=FALSE])
+ z <- .diagMatrix(z)
+ x <- lapply(1:length(dat), function(i) dat[[i]]$x[,2:(dat[[i]]$k+1), drop=FALSE])
+ if (attr(dat, "sysInfo")$commonCoef)
{
- dat <- object$x
- y <- lapply(1:length(dat), function(i) dat[[i]]$x[,1])
- y <- do.call(c, y)
- z <- lapply(1:length(dat), function(i)
- dat[[i]]$x[,(2+dat[[i]]$k):ncol(dat[[i]]$x), drop=FALSE])
- z <- .diagMatrix(z)
- x <- lapply(1:length(dat), function(i) dat[[i]]$x[,2:(dat[[i]]$k+1), drop=FALSE])
- if (attr(dat, "sysInfo")$commonCoef)
- {
- x <- do.call(rbind, x)
- } else if (!is.null(attr(dat, "sysInfo")$crossEquConst)) {
- k <- attr(dat, "k")[[1]]
- x <- .diagMatrix(x, (1:k)[-attr(dat, "sysInfo")$crossEquConst])
- } else {
- x <- .diagMatrix(x)
- }
- names(y) <- rownames(x) <- rownames(z) <- 1:length(y)
- data <- list(y=y, x=x, z=z)
- dat2 <- getDat(y~x-1, ~z-1, data=data)
- attr(dat2, "ModelType") <- "linear"
+ x <- do.call(rbind, x)
+ } else if (!is.null(attr(dat, "sysInfo")$crossEquConst)) {
+ k <- attr(dat, "k")[[1]]
+ x <- .diagMatrix(x, (1:k)[-attr(dat, "sysInfo")$crossEquConst])
+ } else {
+ x <- .diagMatrix(x)
+ }
+ names(y) <- rownames(x) <- rownames(z) <- 1:length(y)
+ df <- ncol(z) - ncol(x)
+ k <- ncol(x)
+ q <- ncol(z)
+ n <- nrow(dat[[1]]$x)
+ df.residuals <- n - k
+ data <- list(y=y, x=x, z=z)
+ dat2 <- getDat(y~x-1, ~z-1, data=data)
+ attr(dat2, "ModelType") <- "linear"
+ if (!is.null(object$weightsMatrix))
+ {
+ w <- object$weightsMatrix
+ attr(w, "inv") <- FALSE
+ tet0 <- NULL
+ fsRes <- .fsResOnly(dat2)
+ } else if (object$wmatrix == "ident") {
+ w <- diag(q)
+ attr(w, "inv") <- FALSE
+ tet0 <- NULL
+ fsRes <- .fsResOnly(dat2)
+ } else {
res0 <- .tetlin(dat2, 1, "2sls")
tet0 <- .getThetaList(res0$par, dat)
fsRes <- res0$fsRes
w <- .weightFct_Sys(tet=tet0, dat=dat, type=object$vcov)
- #return(list(w=w,tet0=tet0,dat=dat,dat2=dat2))
- res <- .tetlin(dat2, w)
- par <- .getThetaList(res$par, dat)
- names(par) <- names(dat)
- df <- ncol(z) - ncol(x)
- k <- ncol(x)
- q <- ncol(z)
- n <- nrow(x)
- df.residuals <- n - k
- z = list(coefficients = par, objective = res$value, dat=dat, k=k, q=q, df=df, df.residual=df.residual, n=n)
- z$gt <- object$g(z$coefficients, dat)
- z$initTheta <- tet0
- tmp <- lapply(1:length(dat), function(i) .residuals(z$coefficients[[i]], dat[[i]]))
- z$fitted.values <- lapply(1:length(dat), function(i) tmp[[i]]$yhat)
- z$residuals <- lapply(1:length(dat), function(i) tmp[[i]]$residuals)
- z$terms <- lapply(1:length(dat), function(i) dat[[i]]$mt)
- if(object$model) z$model <- lapply(1:length(dat), function(i) dat[[i]]$mf)
- if(object$X) z$x <- lapply(1:length(dat), function(i)
- as.matrix(dat[[i]]$x[,(dat[[i]]$ny+1):(dat[[i]]$ny+dat[[i]]$k)]))
- if(object$Y) z$y <- lapply(1:length(dat), function(i) as.matrix(dat[[i]]$x[,1:dat[[i]]$ny]))
- z$gradv <- object$gradv
- z$g <- object$g
- z$WSpec <- object$WSpec
- z$w0 <- w
- colnames(z$gt) <- do.call(c, object$namesgt)
- z$fsRes <- fsRes
- class(z) <- "sysGmm.res"
- z$specMod <- object$specMod
- return(z)
}
+ res <- .tetlin(dat2, w)
+ par <- .getThetaList(res$par, dat)
+ names(par) <- names(dat)
+ z = list(coefficients = par, objective = res$value, dat=dat, k=k, q=q, df=df, df.residual=df.residual, n=n)
+ z$gt <- object$g(z$coefficients, dat)
+ z$initTheta <- tet0
+ tmp <- lapply(1:length(dat), function(i) .residuals(z$coefficients[[i]], dat[[i]]))
+ z$fitted.values <- lapply(1:length(dat), function(i) tmp[[i]]$yhat)
+ z$residuals <- lapply(1:length(dat), function(i) tmp[[i]]$residuals)
+ z$terms <- lapply(1:length(dat), function(i) dat[[i]]$mt)
+ if(object$model) z$model <- lapply(1:length(dat), function(i) dat[[i]]$mf)
+ if(object$X) z$x <- lapply(1:length(dat), function(i)
+ as.matrix(dat[[i]]$x[,(dat[[i]]$ny+1):(dat[[i]]$ny+dat[[i]]$k)]))
+ if(object$Y) z$y <- lapply(1:length(dat), function(i) as.matrix(dat[[i]]$x[,1:dat[[i]]$ny]))
+ z$gradv <- object$gradv
+ z$g <- object$g
+ z$WSpec <- object$WSpec
+ z$w0 <- w
+ colnames(z$gt) <- do.call(c, object$namesgt)
+ z$fsRes <- fsRes
+ class(z) <- "sysGmm.res"
+ z$specMod <- object$specMod
+ return(z)
+}
-
-
momentEstim.baseGmm.eval <- function(object, ...)
{
P <- object
More information about the Gmm-commits
mailing list