[Splm-commits] r260 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 29 17:33:26 CEST 2025
Author: gpiras
Date: 2025-04-29 17:33:26 +0200 (Tue, 29 Apr 2025)
New Revision: 260
Modified:
pkg/ChangeLog
pkg/DESCRIPTION
pkg/R/ivplm.b2sls.R
pkg/R/ivplm.ec2sls.R
pkg/R/ivplm.g2sls.R
pkg/R/ivplm.w2sls.R
pkg/R/ivsplm.R
pkg/R/spgm.R
pkg/R/utilities_GM.R
Log:
commit changes mail from K. Fourrey
Modified: pkg/ChangeLog
===================================================================
--- pkg/ChangeLog 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/ChangeLog 2025-04-29 15:33:26 UTC (rev 260)
@@ -1,3 +1,6 @@
+Changes in Version 1.6-6
+ o See mail Kevin Fourrey
+
Changes in Version 1.5-0
o Fixed effects methods (spfeml) are now based on the data transformation infrastructure of plm, so that (as already happens in spreml) calls to panel functions in the formula are supported: e.g., to slag() to do Spatial Durbin models
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/DESCRIPTION 2025-04-29 15:33:26 UTC (rev 260)
@@ -1,7 +1,7 @@
Package: splm
Title: Econometric Models for Spatial Panel Data
-Version: 1.6-5
-Date: 2023-12-11
+Version: 1.6-6
+Date: 2025-04-29
Authors at R: c(person(given = "Giovanni", family = "Millo", role = c("aut", "cre"), email = "giovanni.millo at deams.units.it"),
person(given = "Gianfranco", family = "Piras", role = c("aut"), email = "gpiras at mac.com"),
person("Roger", "Bivand", role = c("ctb"), email = "Roger.Bivand at nhh.no", comment=c(ORCID="0000-0003-2392-6140")))
Modified: pkg/R/ivplm.b2sls.R
===================================================================
--- pkg/R/ivplm.b2sls.R 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/R/ivplm.b2sls.R 2025-04-29 15:33:26 UTC (rev 260)
@@ -19,7 +19,13 @@
colnmx <- colnames(X)
colnamesbx <- paste("lag_", colnames(xdur), sep="")
- wx <- listw %*% xdur
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ #wx <- listw %*% xdur
X <- cbind(X, wx)
Xbetween <- panel.transformations(X, indic, type= "between")
colnames(Xbetween) <- c(colnmx, colnamesbx)
@@ -40,8 +46,13 @@
colnmx <- colnames(X)
if(colnmx[1] == "(Intercept)"){
-
- wx <- listw %*% X[,-1]
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ wx <- wx[,-1]
colnameswx <- paste("lag_", colnames(X)[-1], sep = "")
xdu <- cbind(xdu, wx)
colnames(xdu) <- c(colnmx, colnameswx)
@@ -48,8 +59,14 @@
}
else{
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% X[idx, ]
+ }))
+
- wx <- listw %*% X
+ #wx <- listw %*% X
colnameswx <- paste("lag_", colnames(X), sep = "")
xdu <- cbind(xdu, wx)
colnames(xdu) <- c(colnmx, colnameswx)
Modified: pkg/R/ivplm.ec2sls.R
===================================================================
--- pkg/R/ivplm.ec2sls.R 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/R/ivplm.ec2sls.R 2025-04-29 15:33:26 UTC (rev 260)
@@ -24,7 +24,14 @@
colnmx <- colnames(X)
colnameswx <- paste("lag_", colnames(xdur), sep="")
- wx <- listw %*% xdur
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+
+ #wx <- listw %*% xdur
X <- cbind(X, wx)
transx <- panel.transformations(X,indic, type= "both")
@@ -48,11 +55,23 @@
colnmx <- colnames(X)
if(colnames(X)[1] == "(Intercept)"){
- wx <- listw %*% X[,-1]
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% X[idx, ]
+ }))
+
+ wx <- wx[,-1]
colnameswx <- paste("lag_", colnames(X)[-1], sep="")
}
else {
- wx <- listw %*% X
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% X[idx, ]
+ }))
+
+ #wx <- listw %*% X
colnameswx <- paste("lag_", colnames(X), sep="")
}
@@ -133,9 +152,11 @@
else{
- wy <- listw %*% Y
- wywithin <- listw %*% ywithin
- wywithin <- as.matrix(wywithin)
+ wy <- matrix(listw %*% matrix(Y, nrow = N, ncol = t), ncol = 1)
+ #wy <- listw %*% Y
+ wywithin <- matrix(listw %*% matrix(ywithin, nrow = N, ncol = t), ncol = 1)
+ #wywithin <- listw %*% ywithin
+ #wywithin <- as.matrix(wywithin)
colnames(wywithin)<-"lambda"
wybetween <- listwnn %*% as.matrix(ybetween)
colnames(wybetween) <- ("lambda")
@@ -150,12 +171,38 @@
if(twow){
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
- W2Xwithin <- listw2 %*% Xwithin
- W2WXwithin <- listw2 %*% WXwithin
- W2WWXwithin <- listw2 %*% WWXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ W2Xwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% Xwithin[idx, ]
+ }))
+
+ W2WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WXwithin[idx, ]
+ }))
+
+ W2WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WWXwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
+ #W2Xwithin <- listw2 %*% Xwithin
+ #W2WXwithin <- listw2 %*% WXwithin
+ #W2WWXwithin <- listw2 %*% WWXwithin
+
WXbetween <- listwnn %*% Xbetween
WWXbetween <- listwnn %*% WXbetween
W2Xbetween <- listw2nn %*% Xbetween
@@ -168,8 +215,19 @@
}
else{
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
Hwithin <-cbind(as.matrix(WXwithin), as.matrix(WWXwithin))
WXbetween <- listwnn %*% Xbetween
@@ -219,12 +277,38 @@
if(twow){
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
- W2Xwithin <- listw2 %*% Xwithin
- W2WXwithin <- listw2 %*% WXwithin
- W2WWXwithin <- listw2 %*% WWXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ W2Xwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% Xwithin[idx, ]
+ }))
+
+ W2WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WXwithin[idx, ]
+ }))
+
+ W2WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WWXwithin[idx, ]
+ }))
+
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
+ #W2Xwithin <- listw2 %*% Xwithin
+ #W2WXwithin <- listw2 %*% WXwithin
+ #W2WWXwithin <- listw2 %*% WWXwithin
+
WXbetween <- listwnn %*% Xbetween
WWXbetween <- listwnn %*% WXbetween
W2Xbetween <- listw2nn %*% Xbetween
@@ -237,8 +321,19 @@
}
else{
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
Hwithin <-cbind(Hwithin, as.matrix(WXwithin), as.matrix(WWXwithin))
WXbetween <- listwnn %*% Xbetween
Modified: pkg/R/ivplm.g2sls.R
===================================================================
--- pkg/R/ivplm.g2sls.R 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/R/ivplm.g2sls.R 2025-04-29 15:33:26 UTC (rev 260)
@@ -23,7 +23,13 @@
colnmx <- colnames(X)
colnameswx <- paste("lag_", colnames(xdur), sep="")
- wx <- listw %*% xdur
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ #wx <- listw %*% xdur
X <- cbind(X, wx)
transx <- panel.transformations(X,indic, type= "both")
@@ -47,11 +53,23 @@
colnmx <- colnames(X)
if(colnames(X)[1] == "(Intercept)"){
- wx <- listw %*% X[,-1]
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ wx <- wx[,-1]
colnameswx <- paste("lag_", colnames(X)[-1], sep="")
}
else {
- wx <- listw %*% X
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% X[idx, ]
+ }))
+
+ #wx <- listw %*% X
colnameswx <- paste("lag_", colnames(X), sep="")
}
@@ -133,11 +151,14 @@
}
else{
- wy <- listw %*% Y
- wy <- as.matrix(wy)
+
+ wy <- matrix(listw %*% matrix(Y, nrow = N, ncol = t), ncol = 1)
+ #wy <- listw %*% Y
+ #wy <- as.matrix(wy)
colnames(wy)<-"lambda"
- wywithin <- listw %*% ywithin
- wywithin <- as.matrix(wywithin)
+ wywithin <- matrix(listw %*% matrix(ywithin, nrow = N, ncol = t), ncol = 1)
+ #wywithin <- listw %*% ywithin
+ #wywithin <- as.matrix(wywithin)
colnames(wywithin)<-"lambda"
wybetween <- listwnn %*% as.matrix(ybetween)
colnames(wybetween) <- "lambda"
@@ -152,12 +173,38 @@
if(twow){
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
- W2Xwithin <- listw2 %*% Xwithin
- W2WXwithin <- listw2 %*% WXwithin
- W2WWXwithin <- listw2 %*% WWXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ W2Xwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% Xwithin[idx, ]
+ }))
+
+ W2WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WXwithin[idx, ]
+ }))
+
+ W2WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WWXwithin[idx, ]
+ }))
+
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
+ #W2Xwithin <- listw2 %*% Xwithin
+ #W2WXwithin <- listw2 %*% WXwithin
+ #W2WWXwithin <- listw2 %*% WWXwithin
+
WXbetween <- listwnn %*% Xbetween
WWXbetween <- listwnn %*% WXbetween
W2Xbetween <- listw2nn %*% Xbetween
@@ -170,8 +217,20 @@
}
else{
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
Hwithin <-cbind(as.matrix(WXwithin), as.matrix(WWXwithin))
WXbetween <- listwnn %*% Xbetween
@@ -225,12 +284,38 @@
if(twow){
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
- W2Xwithin <- listw2 %*% Xwithin
- W2WXwithin <- listw2 %*% WXwithin
- W2WWXwithin <- listw2 %*% WWXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ W2Xwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% Xwithin[idx, ]
+ }))
+
+ W2WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WXwithin[idx, ]
+ }))
+
+ W2WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WWXwithin[idx, ]
+ }))
+
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
+ #W2Xwithin <- listw2 %*% Xwithin
+ #W2WXwithin <- listw2 %*% WXwithin
+ #W2WWXwithin <- listw2 %*% WWXwithin
+
WXbetween <- listwnn %*% Xbetween
WWXbetween <- listwnn %*% WXbetween
W2Xbetween <- listw2nn %*% Xbetween
@@ -243,8 +328,18 @@
}
else{
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
Hwithin <-cbind(Hwithin, as.matrix(WXwithin), as.matrix(WWXwithin))
WXbetween <- listwnn %*% Xbetween
Modified: pkg/R/ivplm.w2sls.R
===================================================================
--- pkg/R/ivplm.w2sls.R 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/R/ivplm.w2sls.R 2025-04-29 15:33:26 UTC (rev 260)
@@ -17,7 +17,13 @@
colnmx <- colnames(X)
colnameswx <- paste("lag_", colnames(xdur), sep="")
- wx <- listw %*% xdur
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ #wx <- listw %*% xdur
colnames(wx) <- colnameswx
X <- cbind(X, wx)
Xwithin <- panel.transformations(X, indic, type = "within")
@@ -31,7 +37,13 @@
else{
colnmx <- colnames(X)
- wx <- listw %*% X
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% X[idx, ]
+ }))
+
+ #wx <- listw %*% X
colnameswx <- paste("lag_", colnames(X), sep="")
X <- cbind(X, wx)
Xwithin <- panel.transformations(X, indic, type = "within")
@@ -88,7 +100,8 @@
else{
- wywithin <- listw %*% as.matrix(ywithin)
+ wywithin <- matrix(listw %*% matrix(ywithin, nrow = N, ncol = t), ncol = 1)
+ #wywithin <- listw %*% as.matrix(ywithin)
wywithin <- as.matrix(wywithin)
colnames(wywithin)<-"lambda"
@@ -99,19 +112,61 @@
if(twow){
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
- W2Xwithin <- listw2 %*% Xwithin
- W2WXwithin <- listw2 %*% WXwithin
- W2WWXwithin <- listw2 %*% WWXwithin
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ #WWXwithin <- listw %*% WXwithin
+
+ W2Xwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% Xwithin[idx, ]
+ }))
+
+ W2WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WXwithin[idx, ]
+ }))
+
+ W2WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WWXwithin[idx, ]
+ }))
+
+
+ # W2Xwithin <- listw2 %*% Xwithin
+ # W2WXwithin <- listw2 %*% WXwithin
+ #W2WWXwithin <- listw2 %*% WWXwithin
Hwithin <-cbind(as.matrix(WXwithin), as.matrix(WWXwithin), as.matrix(W2Xwithin), as.matrix(W2WXwithin), as.matrix(W2WWXwithin))
}
else{
+
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
Hwithin <-cbind(as.matrix(WXwithin), as.matrix(WWXwithin))
}
@@ -136,20 +191,61 @@
Hwithin <-panel.transformations(H, indic, type= "within")
if(twow){
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ #WWXwithin <- listw %*% WXwithin
+
+ W2Xwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% Xwithin[idx, ]
+ }))
+
+ W2WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WXwithin[idx, ]
+ }))
+
+ W2WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% WWXwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+ #WWXwithin <- listw %*% WXwithin
+ #W2Xwithin <- listw2 %*% Xwithin
+ #W2WXwithin <- listw2 %*% WXwithin
+ #W2WWXwithin <- listw2 %*% WWXwithin
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
- W2Xwithin <- listw2 %*% Xwithin
- W2WXwithin <- listw2 %*% WXwithin
- W2WWXwithin <- listw2 %*% WWXwithin
-
Hwithin <-cbind(Hwithin, as.matrix(WXwithin), as.matrix(WWXwithin), as.matrix(W2Xwithin), as.matrix(W2WXwithin), as.matrix(W2WWXwithin))
}
else{
- WXwithin <- listw %*% Xwithin
- WWXwithin <- listw %*% WXwithin
+
+ WXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% Xwithin[idx, ]
+ }))
+
+ #WXwithin <- listw %*% Xwithin
+
+ WWXwithin <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% WXwithin[idx, ]
+ }))
+
+ # WXwithin <- listw %*% Xwithin
+ # WWXwithin <- listw %*% WXwithin
Hwithin <-cbind(Hwithin, as.matrix(WXwithin), as.matrix(WWXwithin))
}
Modified: pkg/R/ivsplm.R
===================================================================
--- pkg/R/ivsplm.R 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/R/ivsplm.R 2025-04-29 15:33:26 UTC (rev 260)
@@ -55,17 +55,17 @@
#### creating the block diagonal matrix for the lag model and for additional instruments
- I_T <- Diagonal(t)
- Ws <- kronecker(I_T, listw)
+# I_T <- Diagonal(t)
+ # Ws <- kronecker(I_T, listw)
- if(twow) W2 <- kronecker(I_T, listw2)
- else W2 <- NULL
+ if(twow) listw2 <- listw2
+ else listw2 <- NULL
}
else{
- Ws <- NULL
- W2 <- NULL
+ listw <- NULL
+ listw2 <- NULL
}
#if not lag, check if there are endogenous
@@ -82,14 +82,42 @@
if(lag.instruments){
instruments <- as.matrix(lm(instruments, data, na.action = na.fail, method = "model.frame"))
- winst <- Ws %*% instruments
- wwinst <- Ws %*% winst
+ winst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% instruments[idx, ]
+ }))
+ wwinst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% winst[idx, ]
+ }))
+
+
+ #winst <- Ws %*% instruments
+ #wwinst <- Ws %*% winst
+
if(twow){
- W2 <- kronecker(I_T, listw2)
- w2inst <- Ws %*% instruments
- w2ws.inst <- W2 %*% winst
- w2ww.inst <- W2 %*% wwinst
+
+ w2inst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% instruments[idx, ]
+ }))
+
+ w2ws.inst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% winst[idx, ]
+ }))
+
+ w2ww.inst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw2 %*% wwinst[idx, ]
+ }))
+
+
+ #W2 <- kronecker(I_T, listw2)
+ #w2inst <- Ws %*% instruments
+ #w2ws.inst <- W2 %*% winst
+ #w2ww.inst <- W2 %*% wwinst
instruments <- cbind(instruments, winst, wwinst, w2inst, w2ws.inst, w2ww.inst)
}
@@ -109,7 +137,7 @@
w2sls = {
result <- ivplm.w2sls(Y = y, X = x, H = instruments, endog = endog,
- twow = twow, lag = lag, listw = Ws, listw2 = W2,
+ twow = twow, lag = lag, listw = listw, listw2 = listw2,
lag.instruments = lag.instruments,
t = t, N = N, NT = NT,
Durbin = Durbin, xdur = xdur)
@@ -116,7 +144,7 @@
},
b2sls = {
result <- ivplm.b2sls(Y = y, X = x, H = instruments, endog = endog,
- twow = twow, lag = lag, listw = Ws, listw2 = W2,
+ twow = twow, lag = lag, listw = listw, listw2 = listw2,
lag.instruments = lag.instruments,
t = t, N = N, NT = NT,
Durbin = Durbin, xdur = xdur)
@@ -123,7 +151,7 @@
},
ec2sls = {
result <- ivplm.ec2sls(Y = y, X = x, H = instruments, endog = endog,
- twow = twow, lag = lag, listw = Ws, listw2 = W2,
+ twow = twow, lag = lag, listw = listw, listw2 = listw2,
lag.instruments = lag.instruments,
t = t, N = N, NT = NT,
Durbin = Durbin, xdur = xdur)
@@ -130,7 +158,7 @@
},
g2sls = {
result <-ivplm.g2sls(Y = y, X = x, H = instruments, endog = endog,
- twow = twow, lag = lag, listw = Ws, listw2 = W2,
+ twow = twow, lag = lag, listw = listw, listw2 = listw2,
lag.instruments = lag.instruments,
t = t, N = N, NT = NT,
Durbin = Durbin, xdur = xdur)
Modified: pkg/R/spgm.R
===================================================================
--- pkg/R/spgm.R 2023-12-11 15:04:29 UTC (rev 259)
+++ pkg/R/spgm.R 2025-04-29 15:33:26 UTC (rev 260)
@@ -257,8 +257,10 @@
balanced<-N*t==NT
if(!balanced) stop("Estimation method unavailable for unbalanced panels")
-I_T <- Diagonal(t)
-Ws <- kronecker(I_T, listw)
+
+ #N.B. listw to be replaced everywhere
+#I_T <- Diagonal(t)
+#Ws <- kronecker(I_T, listw)
if(!is.null(endog)){
@@ -268,8 +270,19 @@
}
if(lag.instruments){
- winst <- Ws %*% instruments
- wwinst <- Ws %*% winst
+
+ winst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% instruments[idx, ]
+ }))
+
+ wwinst <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% winst[idx, ]
+ }))
+
+ # winst <- Ws %*% instruments
+ # wwinst <- Ws %*% winst
instruments <- cbind(instruments, winst, wwinst)
}
@@ -295,7 +308,13 @@
xdur <- as.matrix(lm(Durbin, data, na.action = na.fail, method="model.frame"))
colnmx <- colnames(x)
colnameswx <- paste("lag_", colnames(xdur), sep="")
- wx <- Ws %*% xdur
+
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ # wx <- Ws %*% xdur
x <- as.matrix(cbind(x, wx))
colnames(x) <- c(colnmx, colnameswx)
@@ -306,13 +325,21 @@
if(colnmx[1] == "(Intercept)"){
- wx <- Ws %*% x[,-1]
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% x[idx, ]
+ }))
+ wx <- wx[,-1]
+ #wx <- Ws %*% x[,-1]
colnameswx <- paste("lag_", colnames(x)[-1], sep = "")
}
else{
-
- wx <- Ws %*% x
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% x[idx, ]
+ }))
+ #wx <- Ws %*% x
colnameswx <- paste("lag_", colnames(x), sep = "")
}
@@ -332,7 +359,7 @@
else {
result <- ivplm.w2sls(Y = y, X = x, H = instruments, endog = endog,
- twow = FALSE, lag = FALSE, listw = Ws, listw2 = NULL,
+ twow = FALSE, lag = FALSE, listw = listw, listw2 = NULL,
lag.instruments = lag.instruments, t = t, N = N, NT = NT,
Durbin = Durbin, xdur = xdur)
@@ -342,13 +369,18 @@
}
res <- as.matrix(residuals(result))
+##check this
+Gg <- fswithin(listw, res, N, t)
-Gg<-fswithin(Ws, res, N, t)
if(is.null(pars)) {
-
- wres <- as.matrix(Ws %*% res)
+
+ wres <- matrix(listw %*% matrix(res, nrow = N, ncol = t), ncol = 1)
+
+
+ # wres <- as.matrix(Ws %*% res)
r.init <- solve(crossprod(res),crossprod(res,wres))
+
if(is.null(endog)) v.init <- crossprod(res)/NT
else v.init <- result$sigmav
pars <- c(r.init, v.init)
@@ -364,9 +396,20 @@
finrho=estim1$par[1]
finsigmaV=estim1$par[2]
- wy <- as.matrix(Ws %*% y)
+
+ wy <- matrix(listw %*% matrix(y, nrow = N, ncol = t), ncol = 1)
+
+
+ #wy <- as.matrix(Ws %*% y)
yt <- y-finrho*wy
- xl<- as.matrix(Ws %*% x)
+
+ xl <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% x[idx, ]
+ }))
+
+
+ #xl<- as.matrix(Ws %*% x)
#print(head(xl))
xt <- x-finrho*xl
@@ -376,7 +419,14 @@
xf<-xf[,-del]
xf<-as.matrix(xf)
colnames(xf) <- colnames(x)[-del]
- wxf <- as.matrix(Ws %*% xf)
+
+ wxf <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xf[idx, ]
+ }))
+
+
+ #wxf <- as.matrix(Ws %*% xf)
if (is.null(endog)){
@@ -402,8 +452,14 @@
}
else{
-
- endogl <- as.matrix(Ws %*% endog)
+
+ endogl <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% endog[idx, ]
+ }))
+
+
+ #endogl <- as.matrix(Ws %*% endog)
endogt <- endog - finrho* endogl
endogf <- panel.transformations(endogt,indic, type= "within")
@@ -451,7 +507,14 @@
xdur <- as.matrix(lm(Durbin, data, na.action = na.fail, method="model.frame"))
colnmx <- colnames(x)
colnameswx <- paste("lag_", colnames(xdur), sep="")
- wx <- Ws %*% xdur
+
+ ###### restart from here!
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% xdur[idx, ]
+ }))
+
+ #wx <- Ws %*% xdur
x <- as.matrix(cbind(x, wx))
colnames(x) <- c(colnmx, colnameswx)
@@ -462,13 +525,23 @@
if(colnmx[1] == "(Intercept)"){
- wx <- Ws %*% x[,-1]
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% x[idx, ]
+ }))
+
+ wx <- wx[,-1]
colnameswx <- paste("lag_", colnames(x)[-1], sep = "")
}
else{
- wx <- Ws %*% x
+ wx <- do.call(rbind, lapply(1:t, function(i) {
+ idx <- ((i - 1) * N + 1):(i * N)
+ listw %*% x[idx, ]
+ }))
+
+ #wx <- Ws %*% x
colnameswx <- paste("lag_", colnames(x), sep = "")
}
@@ -481,12 +554,16 @@
result<-lm(y~x-1)
#print(coefficients((result)))
-res<-as.matrix(residuals(result))
-Gg<-fs(Ws,res,N,t)
+res <- as.matrix(residuals(result))
+Gg <- fs(listw, res, N, t)
+#print(Gg)
## parameter initial values
if(is.null(pars)) {
- wres <- as.matrix(Ws %*% res)
+
+ wres <- matrix(listw %*% matrix(res, nrow = N, ncol = t), ncol = 1)
+
+ #wres <- as.matrix(Ws %*% res)
r.init <- solve(crossprod(res),crossprod(res,wres))
v.init <- crossprod(res)/NT
pars <- c(r.init, v.init)
@@ -496,13 +573,16 @@
if (optim.method == "nlminb") estim1 <- nlminb(pars, arg, v = Gg,
verbose = verbose,
control = control,
- lower=c(-0.999,0), upper=c(0.999,Inf))
+ lower=c(-0.999,0),
+ upper=c(0.999,Inf))
+
else estim1 <- optim(pars, arg, v = Gg, verbose = verbose,
control = control, method = optim.method)
+
urub<-res- estim1$par[1]*Gg$ub
Q1urQ1ub<-Gg$Q1u - estim1$par[1]*Gg$Q1ub
-S1 <- crossprod(urub, Q1urQ1ub)/N
+S1 <- as.numeric(crossprod(urub, Q1urQ1ub)/N)
switch(moments,
@@ -517,8 +597,8 @@
weights = {
Ggw<-pw(bigG=Gg$bigG, smallg=Gg$smallg, Q1u=Gg$Q1u,Q1ub=Gg$Q1ub,Q1ubb=Gg$Q1ubb, u=res, ub=Gg$ub,ubb=Gg$ubb,N=N, TR=Gg$TR)
- pars2<-c(estim1$par[1],estim1$par[2],S1)
-
+ pars2<-c(estim1$par[1],estim1$par[2], S1)
+
if (optim.method == "nlminb") estim2 <- nlminb(pars2, arg1, v = Ggw,t=t,ss=estim1$par[2] ,SS=S1, verbose = verbose, control = control, lower=c(-0.999,0,0), upper=c(0.999,Inf,Inf))
else estim2 <- optim(pars2, arg1, v = Ggw,t=t,ss=estim1$par[2] ,SS=S1, verbose = verbose, control = control, method = optim.method)
@@ -530,11 +610,12 @@
fullweights = {
- Ggw<-pw(bigG=Gg$bigG, smallg=Gg$smallg, Q1u=Gg$Q1u,Q1ub=Gg$Q1ub,Q1ubb=Gg$Q1ubb, u=res, ub=Gg$ub,ubb=Gg$ubb,N=N, TR=Gg$TR)
- weights<-tw(listw, N)
- pars2<-c(estim1$par[1],estim1$par[2],S1)
-
- if (optim.method == "nlminb") estim3 <-nlminb(pars2, arg2, v = Ggw, t=t,
+ Ggw <- pw(bigG=Gg$bigG, smallg=Gg$smallg, Q1u=Gg$Q1u,Q1ub=Gg$Q1ub,Q1ubb=Gg$Q1ubb, u=res, ub=Gg$ub,ubb=Gg$ubb,N=N, TR=Gg$TR)
+ weights <- tw(listw, N)
+ pars2<-c(estim1$par[1],estim1$par[2], S1)
+#print(pars2)
+
+ if (optim.method == "nlminb") estim3 <-nlminb(pars2, arg2, v = Ggw, t=t,
ss=estim1$par[2] ,SS=S1, TW=weights$TW,
verbose = verbose, control = control,
lower=c(-0.999,0,0), upper=c(0.999,Inf,Inf))
@@ -558,10 +639,10 @@
else{
result1<-ivplm.w2sls(Y = y,X =x, H = instruments, endog = endog, twow = FALSE,
- lag = FALSE, listw = Ws, listw2 = NULL, lag.instruments = lag.instruments,
+ lag = FALSE, listw = listw, listw2 = NULL, lag.instruments = lag.instruments,
t, N, NT, Durbin = Durbin, xdur = xdur)
result2<-ivplm.b2sls(Y = y,X =x, H = instruments, endog = endog, twow = FALSE,
- lag = FALSE, listw = Ws, listw2 = NULL, lag.instruments = lag.instruments,
+ lag = FALSE, listw = listw, listw2 = NULL, lag.instruments = lag.instruments,
t, N, NT, Durbin = Durbin, xdur = xdur)
@@ -574,13 +655,16 @@
res1<-as.matrix(as.numeric(residuals(result1)))
res2<-as.matrix(as.numeric(residuals(result2)))
-Gg<-fswithin(Ws,res1,N,t)
+Gg<-fswithin(listw,res1,N,t)
if(is.null(pars)) {
- wres <- as.matrix(Ws %*% res1)
+
+ wres <- matrix(listw %*% matrix(res1, nrow = N, ncol = t), ncol = 1)
+
+ #wres <- as.matrix(Ws %*% res1)
r.init <- solve(crossprod(res1),crossprod(res1,wres))
- v.init <- result1$sigmav
- pars <- c(r.init, v.init)
+ v.init <- result1$sigmav
+ pars <- c(r.init, v.init)
}
@@ -595,12 +679,12 @@
control = control,
method = optim.method)
+Wres2 <- listw %*% res2
-Wres2 <- as.matrix(listw %*% res2)
+#Wres2 <- as.matrix(listw %*% res2)
urhoWu<-res2 - estim1$par[1] * Wres2
-finsigma1<-crossprod(urhoWu)/N
+finsigma1<- as.numeric(crossprod(urhoWu)/N)
-
switch(moments,
initial = {
@@ -615,6 +699,8 @@
Ggw<-pwbetween(bigG=Gg$bigG, smallg=Gg$smallg,
u=res2, N=N, t=t, TR=Gg$TR, listw = listw)
+
+ print(Ggw)
pars2<-c(estim1$par[1],estim1$par[2],finsigma1)
if (optim.method == "nlminb") estim2 <- nlminb(pars2, arg1, v = Ggw, t=t,
@@ -667,9 +753,21 @@
}
theta<- 1-(sqrt(finsigmaV)/sqrt(finsigma1))
-wy <- as.matrix(Ws %*% y)
+
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/splm -r 260
More information about the Splm-commits
mailing list