Allow ComputeIterate to test maximum absolute change
[openmx:openmx.git] / models / passing / ifa-drm-mg.R
1 library(OpenMx)
2 library(rpf)
3
4 set.seed(9)
5
6 numItems <- 30
7 i1 <- rpf.drm(multidimensional=TRUE)
8 items <- list()
9 items[1:numItems] <- i1
10 correct <- matrix(NA, 4, numItems)
11 for (x in 1:numItems) correct[,x] <- rpf.rparam(i1)
12 correct[1,] <- 1
13 correct[3,] <- 0
14 correct[4,] <- 1
15
16 data <- rpf.sample(500, items, correct, cov=matrix(5,1,1))
17
18 if(1) {
19         ip.mat <- mxMatrix(name="itemParam", nrow=4, ncol=numItems,
20                            values=c(1,0,0, 1),
21                            free=c(FALSE, TRUE, FALSE, FALSE))
22         
23         m.mat <- mxMatrix(name="mean", nrow=1, ncol=1, values=0, free=FALSE)
24         cov.mat <- mxMatrix(name="cov", nrow=1, ncol=1, values=1, free=TRUE)
25
26         m2 <- mxModel(model="drmmg", ip.mat, m.mat, cov.mat,
27                       mxData(observed=data, type="raw"),
28                       mxExpectationBA81(mean="mean", cov="cov",
29                                         ItemSpec=items, ItemParam="itemParam"),
30                       mxFitFunctionML(),
31                       mxComputeIterate(steps=list(
32                                          mxComputeOnce('expectation', context='EM'),
33                                          mxComputeNewtonRaphson(free.set='itemParam'),
34                                          mxComputeOnce('expectation'),
35            mxComputeOnce('fitfunction', free.set=c("mean", "cov"), fit=TRUE)
36 #                                        mxComputeGradientDescent(useGradient=TRUE,
37 #                                    free.set=c("mean", "cov"))
38                                          )))
39         
40         if (0) {
41                 fm <- read.flexmirt("/home/joshua/irt/ifa-drm-mg/ifa-drm-mg-prm.txt")
42                 cModel <- m2
43                 cModel@matrices$itemParam@values[2,] <- fm$G1$param[2,]
44                 cModel@matrices$cov@values <- fm$G1$cov
45                 cModel <- mxModel(cModel,
46                                   mxExpectationBA81(mean="mean", cov="cov",
47                                                     ItemSpec="ItemSpec",
48                                                     scores="full"),
49                                   mxComputeSequence(steps=list(
50                                                       mxComputeOnce('expectation'),
51                                                       mxComputeOnce('fitfunction', fit=TRUE))))
52                 cModel <- mxRun(cModel)
53                 cModel@matrices$cov@values - fm$G1$cov
54                 cModel@output$minimum
55         }
56
57         if(1) {
58                 m2 <- mxOption(m2, "Analytic Gradients", 'Yes')
59                 m2 <- mxOption(m2, "Verify level", '-1')
60                 m2 <- mxOption(m2, "Function precision", '1.0E-5')
61                 m2 <- mxRun(m2)
62                 
63                 omxCheckCloseEnough(m2@fitfunction@result, 14129.94, .01)
64                 omxCheckCloseEnough(m2@matrices$cov@values[1,1], 4.377, .01)
65                 
66                                         #print(m2@matrices$itemParam@values)
67                                         #print(correct.mat)
68                 got <- cor(c(m2@matrices$itemParam@values),
69                            c(correct))
70                 omxCheckCloseEnough(got, .994, .01)
71         }
72 }
73
74 if (1) {
75   ip.mat <- mxMatrix(name="itemParam", nrow=4, ncol=numItems,
76                      values=c(1,0,0, 1),
77                      free=c(TRUE, TRUE, FALSE, FALSE))
78   ip.mat@labels[1,] <- 'a1'
79   
80   m.mat <- mxMatrix(name="mean", nrow=1, ncol=1, values=0, free=FALSE)
81   cov.mat <- mxMatrix(name="cov", nrow=1, ncol=1, values=1, free=FALSE)
82
83   m2 <- mxModel(model="drmmg", ip.mat, m.mat, cov.mat,
84                 mxData(observed=data, type="raw"),
85                 mxExpectationBA81(mean="mean", cov="cov",
86                                   ItemSpec=items, ItemParam="itemParam"),
87                 mxFitFunctionML(),
88                 mxComputeSequence(steps=list(
89                   mxComputeOnce('expectation', context='EM'),
90                   mxComputeOnce('fitfunction', gradient=TRUE, hessian=TRUE, ihessian=TRUE)
91                 )))
92   m2 <- mxRun(m2)
93   omxCheckCloseEnough(m2@output$ihessian, solve(m2@output$hessian), 1e-4)
94   
95   m2 <- mxModel(model="drmmg", ip.mat, m.mat, cov.mat,
96                 mxData(observed=data, type="raw"),
97                 mxExpectationBA81(mean="mean", cov="cov",
98                                   ItemSpec=items, ItemParam="itemParam"),
99                 mxFitFunctionML(),
100                 mxComputeIterate(steps=list(
101                   mxComputeOnce('expectation', context='EM'),
102                   mxComputeNewtonRaphson(free.set='itemParam'),
103                   mxComputeOnce('expectation'),
104                   mxComputeOnce('fitfunction', fit=TRUE, free.set=c("mean", "cov"))
105                 )))
106   m2 <- mxRun(m2)
107   omxCheckCloseEnough(m2@fitfunction@result, 14129.04, .01)
108   omxCheckCloseEnough(m2@matrices$itemParam@values[1,], rep(2.133, numItems), .002)
109   # correct values are from flexMIRT
110   est <- c(-0.838622, -1.02653, -0.0868472, -0.251784, 0.953364,  0.735258, 0.606918,
111            1.04239, 0.466055, -2.05196, -0.0456446,  -0.320668, -0.362073, 2.02502,
112            0.635298, -0.0731132, -2.05196,  -0.0456446, -1.17429, 0.880002, -0.838622,
113            -0.838622, 1.02747,  0.424094, -0.584298, 0.663755, 0.663755, 0.064287, 1.38009,
114            1.01259 )
115   omxCheckCloseEnough(m2@matrices$itemParam@values[2,], est, .002)
116 }
117
118 if (0) {
119   library(mirt)
120   rdata <- sapply(data, unclass)-1
121   # for flexMIRT, write CSV
122   #write.table(rdata, file="ifa-drm-mg.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
123   pars <- mirt(rdata, 1, itemtype="2PL", D=1, quadpts=49, pars='values')
124   pars[pars$name=="a1",'value'] <- 1
125   pars[pars$name=="a1",'est'] <- FALSE
126   pars[pars$name=="COV_11",'est'] <- TRUE
127   fit <- mirt(rdata, 1, itemtype="2PL", D=1, quadpts=49, pars=pars)
128   # LL -7064.519 * -2 = 14129.04
129   got <- coef(fit)
130   print(got$GroupPars)
131   # COV 4.551
132   got$GroupPars <- NULL
133   round(m2@matrices$itemParam@values - simplify2array(got), 2)
134   
135   # MH-RM takes forever, not run
136   pars <- confmirt(rdata, 1, itemtype="2PL", D=1, quadpts=49, pars='values')
137   pars[pars$name=="a1",'value'] <- 1
138   pars[pars$name=="a1",'est'] <- FALSE
139   pars[pars$name=="COV_11",'est'] <- TRUE
140   fit <- confmirt(rdata, 1, itemtype="2PL", D=1, quadpts=49, pars=pars)
141   got <- coef(fit)
142   got$GroupPars <- NULL
143   round(m2@matrices$itemParam@values - sapply(got, function(l) l[1,]), 2)
144 }