[Sem-additions-commits] r4 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 2 20:59:44 CET 2010
Author: jebyrnes
Date: 2010-02-02 20:59:42 +0100 (Tue, 02 Feb 2010)
New Revision: 4
Modified:
pkg/ChangeLog
pkg/DESCRIPTION
pkg/R/browneChisq.R
pkg/R/ml.wmat.R
pkg/R/robust_se.R
pkg/R/robust_summary.R
pkg/R/sbchisq.R
Log:
A few bugfixes.
Modified: pkg/ChangeLog
===================================================================
--- pkg/ChangeLog 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/ChangeLog 2010-02-02 19:59:42 UTC (rev 4)
@@ -1,3 +1,6 @@
+2009-12-29 JEB
+ - fixed a mistaken generalized inverse in SB chisq
+ - fixed robust_summary to accomodate fixed parameters
2009-05-12 JEB
- Multiple fixes to Rd files.
- Added rmsea power test by Joerg Evermann
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/DESCRIPTION 2010-02-02 19:59:42 UTC (rev 4)
@@ -1,6 +1,6 @@
Package: sem.additions
-Version: 0.1-04
-Date: 2009-0512
+Version: 0.1-05
+Date: 2009-1229
Title: Additional Methods for Structural Equation Modelling
Author: Jarrett Byrnes <byrnes at msi.ucsb.edu>
Maintainer: Jarrett Byrnes <byrnes at msi.ucsb.edu>
Modified: pkg/R/browneChisq.R
===================================================================
--- pkg/R/browneChisq.R 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/R/browneChisq.R 2010-02-02 19:59:42 UTC (rev 4)
@@ -6,7 +6,7 @@
s<-vech(sem.obj$S)
sigma<-vech(sem.obj$C)
- adj.obj$res_u<- iw_adf - (iw_adf%*%p_deriv_mat %*% ginv(t(p_deriv_mat) %*% iw_adf %*% p_deriv_mat) %*% t(p_deriv_mat) %*% iw_adf)
+ adj.obj$res_u<- iw_adf - (iw_adf%*%p_deriv_mat %*% solve(t(p_deriv_mat) %*% iw_adf %*% p_deriv_mat) %*% t(p_deriv_mat) %*% iw_adf)
adj.obj$c<-NA
adj.obj$chisq.scaled<- adj.obj$N * t(s-sigma) %*% adj.obj$res_u %*% (s-sigma)
Modified: pkg/R/ml.wmat.R
===================================================================
--- pkg/R/ml.wmat.R 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/R/ml.wmat.R 2010-02-02 19:59:42 UTC (rev 4)
@@ -1,18 +1,19 @@
###
#Gets weight matrix from Fml
-#using calculation from Satorra and Bentler 1988
-#W = 2^-1 * Dp' * (An^-1 kronecker An^-1) * Dp
+#using calculation from Satorra 1992 Eqn 24
+#W = 2^-1 * Dp * (An^-1 kronecker An^-1) * Dp'
#where Dp is a dupplication matrix with order p
#and An is the fitted covariance matrix or the sample cov matrix
#
-# Last Updated 8/18/08
+# Adapted from Stas Kolenikov's MATA code for a weight matrices by JEB
+# Last Updated 12/12/09
###
ml.wmat<-function(sem.obj, useFit=F){
p<-length(rownames(sem.obj$C))
if(useFit){An<-sem.obj$C} else {An<-sem.obj$S}
Dp<-Ktrans(p)
- An.inv<-ginv(An)
+ An.inv<-solve(An)
w_mat<-2^-1 * t(Dp) %*% kronecker(An.inv, An.inv) %*% Dp
rownames(w_mat)<-vech(matrix.names(sem.obj$C))
colnames(w_mat)<-rownames(w_mat)
Modified: pkg/R/robust_se.R
===================================================================
--- pkg/R/robust_se.R 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/R/robust_se.R 2010-02-02 19:59:42 UTC (rev 4)
@@ -18,7 +18,7 @@
#calculate the hessian
hes<-sem_hessian(adj.obj$w_mat, adj.obj$p_deriv_mat)
- info_m<-ginv(hes)
+ info_m<-solve(hes)
acov<- info_m %*% ( t(adj.obj$p_deriv_mat) %*% adj.obj$w_mat %*% adj.obj$w_adf %*% adj.obj$w_mat %*% adj.obj$p_deriv_mat) %*% info_m
Modified: pkg/R/robust_summary.R
===================================================================
--- pkg/R/robust_summary.R 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/R/robust_summary.R 2010-02-02 19:59:42 UTC (rev 4)
@@ -1,28 +1,44 @@
-robust_summary<-function(sem.obj, adj.obj=NA, data.obj=NA, useFit=F){
- if(is.na(adj.obj[1]) && is.na(data.obj)) stop ("Need a data or adjchisq object")
-
- #get all of those matrices we'll need
- if(is.na(adj.obj[1])){ adj.obj<-sbchisq(sem.obj, data.obj, useFit=useFit)}
-
+robust_summary<-function (sem.obj, adj.obj = NA, data.obj = NA, useFit = F)
+{
+ if (is.na(adj.obj[1]) && is.na(data.obj))
+ stop("Need a data or adjchisq object")
+ if (is.na(adj.obj[1])) {
+ adj.obj <- sbchisq(sem.obj, data.obj, useFit = useFit)
+ }
+ ses <- robust_se(sem.obj, adj.obj = adj.obj)
+ se <- rep(NA, length(ses))
+ index<-0
+ for (i in 1:length(sem.obj$ram[, 1])) {
+ if (sem.obj$ram[i, 4] > 0) {cat(rownames(sem.obj$ram[i]))
+ index<-index+1
+ se[index] <- ses[index]
+ }
+ }
+
+ z <- sem.obj$coef/se
+ p <- 2 * (1 - pnorm(abs(z)))
+ print(adj.obj)
+ cat(paste("\n", "AICc", " = ", aicc.adjchisq(adj.obj), "\n",
+ sep = ""))
+ cat(paste("BIC", " = ", bic.adjchisq(adj.obj), "\n", sep = ""))
+ coef.mat <- matrix(c(sem.obj$coef, se, z, p), ncol = 4)
+ rownames(coef.mat) <- names(sem.obj$coef)
+ colnames(coef.mat) <- c("Estimate", "SE", "z value", "Pr(>|z|)")
+ print(coef.mat)
+}
- ses<-robust_se(sem.obj, adj.obj=adj.obj)
- se<-rep(NA, length(sem.obj$coef))
-
- for (i in 1:length(sem.obj$ram[,1])){
- if(sem.obj$ram[i,4] > 0){
- se[i]<-ses[i]
- }
-
+add.paths<-function(from, to, values=rep(NA, length(from)*length(to))){
+ newram<-matrix(rep(NA, 3*length(from)*length(to)), ncol=3)
+ par.index<-0
+ for (i in 1:length(to)){
+ for (j in 1:length(from)){
+ par.index<-par.index+1
+ newram[par.index,1]<-paste(from[j], "->", to[i], sep="")
+ newram[par.index,2]<-paste(from[j], ".", to[i], sep="")
+ newram[par.index,3]<-values[par.index]
}
- z <- sem.obj$coef/se
- p<-2*(1 - pnorm(abs(z)))
- #print the chisquare results
- print(adj.obj)
- cat(paste("\n", "AICc", " = ", aicc.adjchisq(adj.obj), "\n", sep=""))
- cat(paste("BIC", " = ", bic.adjchisq(adj.obj), "\n", sep=""))
- coef.mat<-matrix(c( sem.obj$coef, se, z, p), ncol=4)
- rownames(coef.mat)<-names(sem.obj$coef)
- colnames(coef.mat)<-c("Estimate", "SE", "z value", "Pr(>|z|)")
- print(coef.mat)
+ }
+ class(newram)<-"mod"
+ return(newram)
}
\ No newline at end of file
Modified: pkg/R/sbchisq.R
===================================================================
--- pkg/R/sbchisq.R 2009-05-14 19:40:22 UTC (rev 3)
+++ pkg/R/sbchisq.R 2010-02-02 19:59:42 UTC (rev 4)
@@ -20,7 +20,7 @@
p_deriv_mat<- delta_matrix(sem.obj)
#calculate the LS residual weight matrix
- res_u<- w_mat - (w_mat%*%p_deriv_mat %*% ginv(t(p_deriv_mat) %*% w_mat %*% p_deriv_mat) %*% t(p_deriv_mat) %*% w_mat)
+ res_u<- w_mat - (w_mat%*%p_deriv_mat %*% solve(t(p_deriv_mat) %*% w_mat %*% p_deriv_mat) %*% t(p_deriv_mat) %*% w_mat)
#compute scaling statistic
ug<-res_u %*% w_adf
More information about the Sem-additions-commits
mailing list