Revive latent distribution gradients
[openmx:openmx.git] / models / nightly / ifa-cai2009.R
1 # This data is from an email:
2 #
3 # Date: Wed, 06 Feb 2013 19:49:24 -0800
4 # From: Li Cai <lcai@ucla.edu>
5 # To: Joshua N Pritikin <jpritikin@pobox.com>
6 # Subject: Re: how did you control item bias in Cai (2010, p. 592) ?
7
8 #options(error = utils::recover)
9 library(OpenMx)
10 library(rpf)
11
12 correct.LL <- 29995.30418  # from flexMIRT
13
14 # read data
15 data.raw <- suppressWarnings(try(read.csv("models/nightly/data/cai2009.csv"), silent=TRUE))
16 if (is(data.raw, "try-error")) data.raw <- read.csv("data/cai2009.csv")
17 data.g1 <- as.data.frame(data.raw[data.raw$G==1, 2:13])
18 data.g2 <- as.data.frame(data.raw[data.raw$G==2, 2:17])
19
20 if (0) {
21   # for flexmirt
22   write.table(data.g1, "cai2009-g1.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
23   write.table(data.g2, "cai2009-g2.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)  
24   fm <- read.flexmirt("~/irt/cai2009/cai2009-prm.txt")
25   fm$G1$spec <- NULL
26   fm$G2$spec <- NULL
27 }
28
29 # from flexMIRT
30 fm <- structure(list(G1 = structure(list(param = structure(c(0.992675,  0.646717, 0, 0, 0.876469, 1.41764, 1.25402, 0, 0, 0.0826927,  1.76547, 1.20309, 0, 0, -0.346706, 2.1951, 0.844399, 0, 0, -0.978301,  1.37774, 0, 1.06694, 0, 0.992373, 1.80365, 0, 0.814109, 0, 0.213559,  2.15718, 0, 1.58086, 0, -0.418129, 1.18201, 0, 1.56533, 0, -1.24173,  1.80474, 0, 0, 1.0774, 0.810718, 2.60754, 0, 0, 1.23507, 0.0598008,  1.01874, 0, 0, 0.724402, -0.294029, 1.68916, 0, 0, 1.37546, -1.13333 ), .Dim = c(5L, 12L), .Dimnames = list(NULL, c("i1", "i2", "i3",  "i4", "i5", "i6", "i7", "i8", "i9", "i10", "i11", "i12"))), mean = structure(c(0.822622,  -0.290462, 0.19672, 0.733993), .Names = c("X6", "X7", "X8", "X9" )), cov = structure(c(0.826046, 0, 0, 0, 0, 1.656, 0, 0, 0, 0,  1.11263, 0, 0, 0, 0, 1.07878), .Dim = c(4L, 4L))), .Names = c("param",  "mean", "cov")),
31                      G2 = structure(list(param = structure(c(0.992675,  0.646717, 0, 0, 0, 0.876469, 1.41764, 1.25402, 0, 0, 0, 0.0826927,  1.76547, 1.20309, 0, 0, 0, -0.346706, 2.1951, 0.844399, 0, 0,  0, -0.978301, 1.37774, 0, 1.06694, 0, 0, 0.992373, 1.80365, 0,  0.814109, 0, 0, 0.213559, 2.15718, 0, 1.58086, 0, 0, -0.418129,  1.18201, 0, 1.56533, 0, 0, -1.24173, 1.80474, 0, 0, 1.0774, 0,  0.810718, 2.60754, 0, 0, 1.23507, 0, 0.0598008, 1.01874, 0, 0,  0.724402, 0, -0.294029, 1.68916, 0, 0, 1.37546, 0, -1.13333,  1.75531, 0, 0, 0, 1.20652, 0.875564, 1.26308, 0, 0, 0, 1.25013,  0.196607, 1.44526, 0, 0, 0, 0.990354, -0.351181, 1.89461, 0,  0, 0, 0.85611, -1.09382), .Dim = c(6L, 16L), .Dimnames = list(     NULL, c("i1", "i2", "i3", "i4", "i5", "i6", "i7", "i8", "i9",      "i10", "i11", "i12", "i13", "i14", "i15", "i16"))), mean = structure(c(0,  0, 0, 0, 0), .Names = c("X6", "X7", "X8", "X9", "X10")), cov = structure(c(1,  0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0,  0, 0, 1), .Dim = c(5L, 5L))), .Names = c("param", "mean", "cov" ))), .Names = c("G1", "G2"))
32
33 for (col in colnames(data.g1)) data.g1[[col]] <- mxFactor(data.g1[[col]], levels=0:1)
34 for (col in colnames(data.g2)) data.g2[[col]] <- mxFactor(data.g2[[col]], levels=0:1)
35
36 # This function creates a model for a single group.
37 mk.model <- function(model.name, data, latent.free) {
38   numItems <- dim(data)[2]
39   numPersons <- dim(data)[1]
40   spec <- list()
41   spec[1:numItems] <- rpf.grm(factors = 2)
42   
43   dims <- (1 + numItems/4)
44   design <- matrix(c(rep(1L,numItems),
45                      as.integer(kronecker(2:dims,rep(1,4)))), byrow=TRUE, ncol=numItems)
46   
47   ip.mat <- mxMatrix(name="ItemParam", nrow=3, ncol=numItems,
48                      values=c(1.4,1,0),
49                      free=c(TRUE,TRUE,TRUE))
50   
51   for (ix in 1:numItems) {
52     for (px in 1:3) {
53       name <- paste(c('p',ix,',',px), collapse='')
54       ip.mat@labels[px,ix] <- name
55     }
56   }
57
58   m.mat <- mxMatrix(name="mean", nrow=1, ncol=dims, values=0, free=latent.free)
59   cov.mat.free <- FALSE
60   if (latent.free) {
61     cov.mat.free <- diag(dims)==1
62   }
63   cov.mat <- mxMatrix(name="cov", nrow=dims, ncol=dims, values=diag(dims),
64                       free=cov.mat.free)
65   
66   m1 <- mxModel(model=model.name, ip.mat, m.mat, cov.mat,
67                 mxData(observed=data, type="raw"),
68                 mxExpectationBA81(
69                   ItemSpec=spec,
70                   design=design,
71                   ItemParam="ItemParam",
72                   mean="mean", cov="cov",
73                   qpoints=21, qwidth=5),
74                 mxFitFunctionML())
75   m1
76 }
77
78 groups <- paste("g", 1:2, sep="")
79
80 if (1) {
81         # Before fitting the model, check EAP score output against flexMIRT
82   g1 <- mk.model("g1", data.g1, TRUE)
83   g2 <- mk.model("g2", data.g2, FALSE)
84   g1@matrices$ItemParam@values <-
85     rbind(fm$G1$param[1,], apply(fm$G1$param[2:4,], 2, sum), fm$G1$param[5,])
86   g1@matrices$mean@values <- t(fm$G1$mean)
87   g1@matrices$cov@values <- fm$G1$cov
88   g2@matrices$ItemParam@values <-
89     rbind(fm$G2$param[1,], apply(fm$G2$param[2:5,], 2, sum), fm$G2$param[6,])
90   
91   cModel <- mxModel(model="cModel", g1,g2,
92                     mxComputeOnce(paste(groups, 'expectation', sep='.'), context='EM'))
93 #  cModel <- mxOption(cModel, "Number of Threads", 1)
94   for (grp in groups) cModel@submodels[[grp]]@expectation@scores <- 'full'
95   cModel.eap <- mxRun(cModel)
96
97   fm.sco.g1 <- suppressWarnings(try(read.table("models/nightly/data/cai2009-sco-g1.txt"), silent=TRUE))
98   if (is(fm.sco.g1, "try-error")) fm.sco.g1 <- read.table("data/cai2009-sco-g1.txt")
99   fm.sco.g2 <- suppressWarnings(try(read.table("models/nightly/data/cai2009-sco-g2.txt"), silent=TRUE))
100   if (is(fm.sco.g2, "try-error")) fm.sco.g2 <- read.table("data/cai2009-sco-g2.txt")
101   colnames(fm.sco.g1) <- c("grp","id",colnames(cModel.eap@submodels$g1@expectation@scores.out))
102   colnames(fm.sco.g2) <- c("grp","id",colnames(cModel.eap@submodels$g2@expectation@scores.out))
103   
104   scores.g1 <- cModel.eap@submodels$g1@expectation@scores.out
105   omxCheckCloseEnough(as.matrix(fm.sco.g1[,-1:-2]),
106                       scores.g1, 1e-3)
107   omxCheckCloseEnough(as.matrix(fm.sco.g2[,-1:-2]),
108                       cModel.eap@submodels$g2@expectation@scores.out, 1e-3)
109
110   # Also check whether we compute the LL correctly given flexMIRT's parameters.
111     cModel <- mxModel(cModel,
112                       mxFitFunctionMultigroup(paste(groups, "fitfunction", sep=".")),
113                       mxComputeSequence(steps=list(
114                         mxComputeOnce(paste(groups, 'expectation', sep=".")),
115                         mxComputeOnce('fitfunction', fit=TRUE,
116                                       free.set=apply(expand.grid(groups, c('mean','cov')), 1, paste, collapse='.')))))
117     cModel.fit <- mxRun(cModel)
118     omxCheckCloseEnough(cModel.fit@fitfunction@result, correct.LL, 1e-4)
119   
120   i1 <- mxModel(cModel,
121                 mxComputeSequence(steps=list(
122                   mxComputeOnce(paste(groups, 'expectation', sep='.'), context="EM"),
123                   mxComputeOnce('fitfunction', information=TRUE, info.method="meat"),
124                   mxComputeStandardError(),
125                   mxComputeHessianQuality())))
126   i1 <- mxRun(i1)
127   
128 #  cat(deparse(round(i1@output$standardErrors,3)))
129   se <- c(0.085, 0.109, 0.078, 0.131, 0.199, 0.098, 0.148,  0.183, 0.104, 0.165,
130           0.134, 0.123, 0.109, 0.149, 0.095, 0.13,  0.123, 0.097, 0.186, 0.23,
131           0.124, 0.125, 0.25, 0.138, 0.135,  0.169, 0.101, 0.199, 0.188, 0.127,
132           0.084, 0.122, 0.078, 0.146,  0.232, 0.14, 0.104, 0.17, 0.128, 0.174, 0.093,
133           0.432, 0.254,  0.324, 0.175, 0.242, 0.125, 0.146, 0.265, 0.1, 0.141, 0.201,
134           0.101, 0.189, 0.192, 0.13)
135   omxCheckCloseEnough(c(i1@output$standardErrors), se, .01)
136   omxCheckCloseEnough(i1@output$conditionNumber, 199, 1) 
137 }
138
139 omxIFAComputePlan <- function(groups) {
140   mxComputeEM(paste(groups, 'expectation', sep='.'),
141               mstep.fit = mxComputeNewtonRaphson(free.set=paste(groups, 'ItemParam', sep=".")),
142               fit = mxComputeOnce('fitfunction', fit=TRUE,
143                   free.set=apply(expand.grid(groups, c('mean','cov')), 1, paste, collapse='.')), verbose=1L)
144 }
145
146 if(1) {
147         # Now actually fit the model.
148   g1 <- mk.model("g1", data.g1, TRUE)
149   g2 <- mk.model("g2", data.g2, FALSE)
150   grpModel <- mxModel(model="groupModel", g1, g2,
151                       mxFitFunctionMultigroup(paste(groups, "fitfunction", sep=".")),
152                       omxIFAComputePlan(groups))
153   
154   #grpModel <- mxOption(grpModel, "Number of Threads", 1)
155   
156   # NPSOL options:
157   grpModel <- mxOption(grpModel, "Analytic Gradients", 'Yes')
158   grpModel <- mxOption(grpModel, "Verify level", '-1')
159   grpModel <- mxOption(grpModel, "Function precision", '1.0E-7')
160   
161   grpModel <- mxRun(grpModel)
162     
163   omxCheckCloseEnough(grpModel@output$minimum, correct.LL, .01)
164   omxCheckCloseEnough(grpModel@submodels$g2@matrices$ItemParam@values,
165                       rbind(fm$G2$param[1,], apply(fm$G2$param[2:5,], 2, sum), fm$G2$param[6,]), .01)
166   omxCheckCloseEnough(grpModel@submodels$g1@matrices$mean@values, t(fm$G1$mean), .01)
167   omxCheckCloseEnough(grpModel@submodels$g1@matrices$cov@values, fm$G1$cov, .01)
168   print(grpModel@output$backendTime)
169 }