Disentangle Ramsay1975 caution settings (maybe improves dynamic behavior)
[openmx:openmx.git] / models / passing / ifa-drm-mg2.R
1 library(OpenMx)
2 library(rpf)
3
4 set.seed(9)
5
6 numItems <- 20
7 i1 <- rpf.grm(outcomes=2)
8 items <- list()
9 items[1:numItems] <- i1
10 correct <- matrix(NA, 2, numItems)
11 for (x in 1:numItems) correct[,x] <- rpf.rparam(i1)
12
13 data.g1 <- rpf.sample(500, items, correct)
14 data.g2 <- rpf.sample(500, items, correct, mean=-1, cov=matrix(5,1,1))
15 data.g3 <- rpf.sample(500, items, correct, mean=1, cov=matrix(.5,1,1))
16
17 if (0) {
18   # for flexMIRT, write CSV
19   write.table(sapply(data.g1, unclass)-1, file="drm-mg2-g1.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
20   write.table(sapply(data.g2, unclass)-1, file="drm-mg2-g2.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
21   write.table(sapply(data.g3, unclass)-1, file="drm-mg2-g3.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
22 }
23
24 # This create an IFA model for each group. Item parameters are
25 # constrained equal across groups.
26 mkgroup <- function(model.name, data, latent.free) {
27   ip.mat <- mxMatrix(name="ItemParam", nrow=2, ncol=numItems,
28                      values=c(1,0), free=TRUE)
29   
30   for (ix in 1:numItems) {
31     for (px in 1:2) {
32       name <- paste(c('p',ix,',',px), collapse='')
33       ip.mat@labels[px,ix] <- name
34     }
35   }
36   
37   dims <- 1
38   m.mat <- mxMatrix(name="mean", nrow=1, ncol=dims, values=0)
39   cov.mat <- mxMatrix(name="cov", nrow=dims, ncol=dims, values=diag(dims))
40
41   mean <- "mean"
42   cov <- "cov"
43   if (latent.free) {
44     lm <- paste(model.name, "latent", sep="")
45     mean <- paste(lm, "expMean", sep=".")
46     cov <- paste(lm, "expCov", sep=".")
47   }
48   
49   m1 <- mxModel(model=model.name, ip.mat, m.mat, cov.mat,
50                 mxData(observed=data, type="raw"),
51                 mxExpectationBA81(ItemSpec=items, ItemParam="ItemParam", mean=mean, cov=cov,
52                                   verbose=ifelse(latent.free, 0L, 0L)),
53                 mxFitFunctionML())
54   m1
55 }
56
57 g1 <- mkgroup("g1", data.g1, FALSE)
58 g2 <- mkgroup("g2", data.g2, TRUE)
59 g3 <- mkgroup("g3", data.g3, TRUE)
60
61 groups <- paste("g", 1:3, sep="")
62
63 # Cannot test derivatives at starting values because Hessian starts very close to singular.
64
65 if(0) {
66   # for S-EM debugging
67   plan <- mxComputeEM(paste(groups, 'expectation', sep='.'),
68                       mxComputeNewtonRaphson(free.set=paste(groups,'ItemParam',sep=".")),
69                       mxComputeOnce('fitfunction', 'fit',
70                                     free.set=apply(expand.grid(groups, c('mean','cov')), 1, paste, collapse='.')),
71                       information=TRUE, info.method="meat", semDebug=TRUE, semMethod=seq(.001, .02, length.out=30))
72 }
73
74 # This create a latent distribution model that can be used to impose
75 # equality constraints on latent distribution parameters.
76 mklatent <- function(name) {
77   m1 <- mxModel(paste(name, "latent", sep=""),
78           mxMatrix(nrow=1, ncol=1, free=T, values=0, name="expMean"),
79           mxMatrix(type="Symm", nrow=1, ncol=1, free=T, values=1, name="expCov"))
80   if (0) {
81     m1 <- mxModel(m1,
82                   mxData(observed=paste(name, "expectation", sep="."), type="cov"),
83                   mxExpectationNormal(covariance="expCov", means="expMean"),
84                   mxFitFunctionML())
85   }
86   m1
87 }
88
89 latent <- mxModel("latent",
90                   mxFitFunctionMultigroup(paste(paste(groups[-1],"latent",sep=""), "fitfunction", sep=".")))
91
92 g2.latent <- mklatent("g2")
93 g3.latent <- mklatent("g3")
94
95 latent.vargroup <- apply(expand.grid(paste(groups[-1], "latent", sep=""), c('expMean','expCov')),
96                          1, paste, collapse='.')
97
98 latent.plan <- NULL  # need a plan for latent distribution parameters
99
100 if (1) {
101   # Copy latent distribution parameters from current estimates without transformation.
102   latent.plan <- mxComputeSequence(list(mxComputeOnce(paste(groups, 'expectation', sep='.'),
103                                                       "latentDistribution", "copy"),  # c('mean','covariance')
104                                         mxComputeOnce('fitfunction', "starting")),
105                                    free.set=latent.vargroup)
106   # reaches -2LL 30112.522171 (with parameters far away from the flexMIRT solution)
107 } else {
108   # Obtain latent distribution parameters via mxExpectationNormal.
109   # This permits equality constraints (and potentially more complex latent structure).
110   latent.plan <- mxComputeGradientDescent(latent.vargroup, fitfunction="latent.fitfunction")
111   # reaches -2LL 30114.960469 (with parameters close to the flexMIRT solution)
112 }
113
114 grpModel <- mxModel(model="groupModel", g1, g2, g3, g2.latent, g3.latent, #latent,
115                     mxFitFunctionMultigroup(paste(groups, "fitfunction", sep=".")),
116                     mxComputeSequence(list(
117                       mxComputeEM(paste(groups, 'expectation', sep='.'), 'scores',
118                                   mxComputeNewtonRaphson(free.set=paste(groups,'ItemParam',sep=".")),
119                                   latent.plan,
120                                   mxComputeOnce('fitfunction', 'fit'),
121                                   information=TRUE, tolerance=1e-4),
122                       mxComputeStandardError(),
123                       mxComputeHessianQuality())))
124
125   #grpModel <- mxOption(grpModel, "Number of Threads", 1)
126   
127 grpModel <- mxRun(grpModel)
128
129 #dm <- grpModel@compute@steps[[1]]@debug$rateMatrix
130
131 plot_em_map <- function(model, cem) {   # for S-EM debugging
132   require(ggplot2)
133   phl <- cem@debug$paramHistLen
134   probeOffset <- cem@debug$probeOffset
135   semDiff <- cem@debug$semDiff
136
137   modelfit <- NULL
138   result <- data.frame()
139   for (vx in 1:length(model@output$estimate)) {
140     len <- phl[vx]
141     offset <- probeOffset[1:len, vx]
142     dd <- semDiff[1:(len-1), vx]
143     mid <- offset[1:(len-1)] + diff(offset)/2
144     upper <- 20
145     mask <- abs(diff(offset)) < .01 & dd < upper
146     df <- data.frame(mid=mid[mask], diff=dd[mask])
147     m1 <- lm(diff ~ 1 + I(1/mid^2), data=df)
148     modelfit <- c(modelfit, summary(m1)$r.squ)
149     df$model <- predict(m1)
150     result <- rbind(result, cbind(vx=vx, vname=names(model@output$estimate)[vx], df))
151   }
152   print(mean(modelfit))
153   ggplot(subset(result, vx %in% order(modelfit)[1:9])) +
154     geom_point(aes(mid, diff), size=2) + geom_line(aes(mid, model), color="green") +
155     facet_wrap(~vname) + labs(x="x midpoint") + ylim(0,5)
156 }
157
158 if (0) {
159   plot_em_map(grpModel, grpModel@compute)
160 }
161
162 omxCheckCloseEnough(grpModel@output$minimum, 30114.94, .01)
163   omxCheckCloseEnough(grpModel@submodels$g2latent@matrices$expMean@values, -.834, .01)
164   omxCheckCloseEnough(grpModel@submodels$g2latent@matrices$expCov@values, 3.93, .01)
165   omxCheckCloseEnough(grpModel@submodels$g3latent@matrices$expMean@values, .933, .01)
166   omxCheckCloseEnough(grpModel@submodels$g3latent@matrices$expCov@values, .444, .01)
167
168 emstat <- grpModel@compute@steps[[1]]@output
169 omxCheckCloseEnough(emstat$EMcycles, 88, 2)
170 omxCheckCloseEnough(emstat$totalMstep, 303, 10)
171 omxCheckCloseEnough(emstat$semProbeCount, 100, 10)
172   
173 #  cat(deparse(round(grpModel@output$standardErrors, 3)))
174   semse <- c(0.069, 0.077, 0.074, 0.077, 0.094, 0.097, 0.125,  0.111, 0.069, 0.074,
175              0.132, 0.116, 0.08, 0.081, 0.209, 0.163,  0.102, 0.133, 0.114, 0.107,
176              0.205, 0.151, 0.068, 0.077, 0.073,  0.138, 0.078, 0.081, 0.088, 0.087,
177              0.061, 0.068, 0.125, 0.11,  0.084, 0.09, 0.094, 0.094, 0.092, 0.089,
178              0.11, 0.399, 0.068,  0.055)
179   omxCheckCloseEnough(c(grpModel@output$standardErrors), semse, .02)
180   omxCheckCloseEnough(grpModel@output$conditionNumber, 158, 10)
181   
182 i1 <- mxModel(grpModel,
183                 mxComputeSequence(steps=list(
184                   mxComputeOnce(paste(groups, 'expectation', sep='.')),
185                   mxComputeOnce('fitfunction', 'information', "meat"),
186                 mxComputeStandardError(),
187                 mxComputeHessianQuality())))
188 i1 <- mxRun(i1)
189   
190   #cat(deparse(round(i1@output$standardErrors,3)))
191   se <- c(0.071, 0.078, 0.076, 0.079, 0.097, 0.099, 0.132,  0.117, 0.075,
192           0.077, 0.135, 0.121, 0.081, 0.083, 0.215, 0.169,  0.111, 0.141,
193           0.121, 0.113, 0.213, 0.159, 0.074, 0.082, 0.077,  0.139, 0.084,
194           0.087, 0.095, 0.09, 0.064, 0.07, 0.135, 0.115,  0.091, 0.095, 0.097,
195           0.098, 0.096, 0.093, 0.12, 0.512, 0.072,  0.057)
196   omxCheckCloseEnough(c(i1@output$standardErrors), se, .01)
197   omxCheckCloseEnough(log(i1@output$conditionNumber), 5.6, .2)
198
199 if (0) {
200   library(mirt)
201   rdata <- sapply(data, unclass)-1
202   # for flexMIRT, write CSV
203   #write.table(rdata, file="ifa-drm-mg.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
204   pars <- mirt(rdata, 1, itemtype="2PL", D=1, quadpts=49, pars='values')
205   pars[pars$name=="a1",'value'] <- 1
206   pars[pars$name=="a1",'est'] <- FALSE
207   pars[pars$name=="COV_11",'est'] <- TRUE
208   fit <- mirt(rdata, 1, itemtype="2PL", D=1, quadpts=49, pars=pars)
209   # LL -7064.519 * -2 = 14129.04
210   got <- coef(fit)
211   print(got$GroupPars)
212   # COV 4.551
213   got$GroupPars <- NULL
214   round(m2@matrices$itemParam@values - simplify2array(got), 2)
215 }