Allow ComputeIterate to test maximum absolute change
[openmx:openmx.git] / models / passing / ifa-drm1.R
1 #options(error = utils::recover)
2 library(OpenMx)
3 library(rpf)
4
5 set.seed(9)
6
7 numItems <- 10
8 i1 <- rpf.drm(multidimensional=TRUE)
9 items <- vector("list", numItems)
10 correct <- vector("list", numItems)
11 for (ix in 1:numItems) {
12   items[[ix]] <- i1
13   correct[[ix]] <- rpf.rparam(i1)
14   correct[[ix]][3] <- 0
15   correct[[ix]][4] <- 1
16 }
17 correct.mat <- simplify2array(correct)
18 correct.mat[2,] <- correct.mat[2,] * -correct.mat[1,]
19
20 ability <- rnorm(500)
21 data <- rpf.sample(ability, items, correct.mat)
22
23 ip.mat <- mxMatrix(name="itemParam", nrow=4, ncol=numItems,
24                    values=c(1,0,0, 1),
25                    free=c(TRUE, TRUE, FALSE, FALSE))
26
27 m.mat <- mxMatrix(name="mean", nrow=1, ncol=1, values=0, free=FALSE)
28 cov.mat <- mxMatrix(name="cov", nrow=1, ncol=1, values=1, free=FALSE)
29
30 m2 <- mxModel(model="drm1", ip.mat, m.mat, cov.mat,
31               mxData(observed=data, type="raw"),
32               mxExpectationBA81(
33                 ItemSpec=items, ItemParam="itemParam",
34                 mean="mean", cov="cov", qpoints=31),
35               mxFitFunctionML(),
36               mxComputeOnce('expectation', context='EM'))
37 m2 <- mxRun(m2)
38 omxCheckCloseEnough(sum(m2@expectation@patternLikelihood), -2032.9, .1)
39 omxCheckCloseEnough(fivenum(m2@expectation@patternLikelihood),
40                     c(-7.5454472, -7.3950031, -7.3950031, -6.9391761, -3.5411989), .001)
41 omxCheckCloseEnough(sum(m2@expectation@em.expected), 5000, .01)
42 omxCheckCloseEnough(fivenum(m2@expectation@em.expected),
43                     c(0, 5.86e-05, 0.0687802, 7.1582354, 74.1583248), .01)
44
45 em.ex <- array(c(m2@expectation@em.expected), dim=c(2,31,20))
46 em.tbl <- rbind(apply(em.ex[1,,], 2, sum)[1:numItems],
47                 apply(em.ex[2,,], 2, sum)[1:numItems])
48 omxCheckCloseEnough(apply(sapply(data, unclass)-1, 2, table), em.tbl, .01)
49
50 testDeriv <- mxModel(m2,
51               mxComputeIterate(steps=list(
52                                  mxComputeOnce('expectation', context='EM'),
53                                  mxComputeOnce('fitfunction', fit=TRUE,
54                                                gradient=TRUE, hessian=TRUE, ihessian=TRUE)
55                                  )))
56 testDeriv <- mxRun(testDeriv)
57 omxCheckCloseEnough(testDeriv@fitfunction@result, 3221.826, .01)
58 omxCheckCloseEnough(fivenum(testDeriv@output$gradient), c(-128.034, -8.294, 10.7, 25.814, 107.966), .01)
59 omxCheckCloseEnough(fivenum(testDeriv@output$hessian[testDeriv@output$hessian != 0]),
60                     c(6.559, 6.559, 32.976, 83.554, 107.714), .01)
61 omxCheckCloseEnough(solve(testDeriv@output$hessian), testDeriv@output$ihessian, 1e-2)
62
63 m2 <- mxModel(m2,
64               mxData(observed=data, type="raw"),  # got sorted, add it again unsorted
65               mxExpectationBA81(
66                 ItemSpec=items, ItemParam="itemParam",
67                 mean="mean", cov="cov",
68                 qpoints=31,
69                 scores="full"),
70               mxComputeSequence(steps=list(
71                                   mxComputeIterate(steps=list(
72                                                      mxComputeOnce('expectation', context='EM'),
73                                                      mxComputeNewtonRaphson(free.set='itemParam'),
74                                                      mxComputeOnce('expectation'),
75                                                      mxComputeOnce('fitfunction', free.set=c("mean","cov"),
76                                                                    maxAbsChange=TRUE))),
77                                   mxComputeOnce('expectation'),
78                                   mxComputeOnce('fitfunction', free.set=c("mean","cov"), fit=TRUE))))
79
80         m2 <- mxOption(m2, "Analytic Gradients", 'Yes')
81         m2 <- mxOption(m2, "Verify level", '-1')
82 m2 <- mxOption(m2, "Function precision", '1.0E-5')
83 m2 <- mxRun(m2)
84
85 #print(m2@matrices$itemParam@values)
86 #print(correct.mat)
87 omxCheckCloseEnough(m2@fitfunction@result, 6216.272, .01)
88 got <- cor(c(m2@matrices$itemParam@values[1:2,]),
89            c(correct.mat[1:2,]))
90 omxCheckCloseEnough(got, .988, .01)
91 scores <- m2@expectation@scores.out
92 omxCheckCloseEnough(scores[1:5,1], c(0.6783773, 0.2848123, -0.3438632, -0.1026575, -1.0820213), .001)
93 omxCheckCloseEnough(scores[1:5,2], c(0.6769653, 0.6667262, 0.6629124, 0.6624804, 0.6796952), 1e-4)
94 omxCheckCloseEnough(scores[,1], as.vector(ability), 3.5*max(scores[,2]))
95 omxCheckCloseEnough(cor(c(scores[,1]), ability), .737, .01)