Revive latent distribution gradients
[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, 2*3221.826, .01)
58 omxCheckCloseEnough(fivenum(testDeriv@output$gradient), 2*c(-128.034, -8.294, 10.7, 25.814, 107.966), .01)
59 omxCheckCloseEnough(fivenum(testDeriv@output$hessian[testDeriv@output$hessian != 0]),
60                     2*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               mxComputeEM('expectation',
71                           mxComputeNewtonRaphson(free.set='itemParam'),
72                           mxComputeOnce('fitfunction', free.set=c("mean","cov"), fit=TRUE)))
73
74 #       m2 <- mxOption(m2, "Analytic Gradients", 'Yes')
75 #       m2 <- mxOption(m2, "Verify level", '-1')
76 # m2 <- mxOption(m2, "Function precision", '1.0E-5')
77 m2 <- mxRun(m2)
78
79 #print(m2@matrices$itemParam@values)
80 #print(correct.mat)
81 omxCheckCloseEnough(m2@fitfunction@result, 6216.272, .01)
82 got <- cor(c(m2@matrices$itemParam@values[1:2,]),
83            c(correct.mat[1:2,]))
84 omxCheckCloseEnough(got, .988, .01)
85 scores <- m2@expectation@scores.out
86 omxCheckCloseEnough(scores[1:5,1], c(0.6783773, 0.2848123, -0.3438632, -0.1026575, -1.0820213), .001)
87 omxCheckCloseEnough(scores[1:5,2], c(0.6769653, 0.6667262, 0.6629124, 0.6624804, 0.6796952), 1e-4)
88 omxCheckCloseEnough(scores[,1], as.vector(ability), 3.5*max(scores[,2]))
89 omxCheckCloseEnough(cor(c(scores[,1]), ability), .737, .01)
90
91 #mxOption(NULL, 'loglikelihoodScale', -2)
92 i1 <- mxModel(m2,
93               mxComputeSequence(steps=list(
94                 mxComputeOnce('expectation', context="EM"),
95                 mxComputeOnce('fitfunction', information=TRUE, info.method="hessian"),
96                 mxComputeStandardError(),
97                 mxComputeHessianQuality())))
98 i1 <- mxRun(i1)
99
100 #cat(deparse(round(i1@output$standardErrors,3)))
101 se <- c(0.11, 0.102, 0.141, 0.131, 0.109, 0.097, 0.118, 0.099,  0.095, 0.092, 0.124,
102         0.112, 0.105, 0.095, 0.118, 0.108, 0.102,  0.094, 0.111, 0.11)
103 omxCheckCloseEnough(c(i1@output$standardErrors), se, .01)
104
105 i1 <- mxModel(m2,
106               mxComputeSequence(steps=list(
107                 mxComputeOnce('expectation', context="EM"),
108                 mxComputeOnce('fitfunction', information=TRUE, info.method="meat"),
109                 mxComputeStandardError(),
110                 mxComputeHessianQuality())))
111 i1 <- mxRun(i1)
112 se <- c(0.166, 0.111, 0.253, 0.17, 0.171, 0.104, 0.199, 0.11,  0.138, 0.095,
113         0.195, 0.128, 0.158, 0.102, 0.192, 0.123, 0.149,  0.099, 0.153, 0.114)
114 omxCheckCloseEnough(c(i1@output$standardErrors), se, .01)
115 em.meat <- i1@output$hessian
116
117 i1 <- mxModel(m2,
118               mxComputeSequence(steps=list(
119                 mxComputeOnce('expectation'),
120                 mxComputeOnce('fitfunction', information=TRUE, info.method="meat"),
121                 mxComputeStandardError(),
122                 mxComputeHessianQuality())))
123 i1 <- mxRun(i1)
124 omxCheckCloseEnough(max(abs(i1@output$hessian - em.meat)), 0, .01)