Disentangle Ramsay1975 caution settings (maybe improves dynamic behavior)
[openmx:openmx.git] / models / nightly / ifa-ms.R
1 library(OpenMx)
2 library(rpf)
3
4 set.seed(1)
5 m2.data <- suppressWarnings(try(read.table("models/nightly/data/ms-data.csv"), silent=TRUE))
6 if (is(m2.data, "try-error")) m2.data <- read.table("data/ms-data.csv")
7 m2.data[m2.data==-9] <- NA
8 m2.data <- m2.data + 1
9
10 gpcm <- function(outcomes) {
11   rpf.nrm(outcomes, T.c=lower.tri(diag(outcomes-1),TRUE) * -1)
12   #   rpf.nrm(outcomes, T.c=diag(outcomes-1))
13 }
14
15 m2.spec <- list()
16 m2.spec[1:22] <- gpcm(5)
17 m2.spec[2] <- gpcm(4)
18 m2.spec[5] <- gpcm(3)
19 m2.spec[6] <- gpcm(4)
20 m2.spec[13:14] <- gpcm(4)
21
22 m2.numItems <- length(m2.spec)
23
24 for (c in 1:m2.numItems) {
25   m2.data[[c]] <- mxFactor(m2.data[[c]], levels=1:m2.spec[[c]]@outcomes)
26 }
27
28 m2.maxParam <-max(sapply(m2.spec, rpf.numParam))
29
30 ip.mat <- mxMatrix(name="ItemParam", nrow=m2.maxParam, ncol=m2.numItems,
31                    values=c(1, 1, rep(0, m2.maxParam-2)), free=FALSE)
32 ip.mat@labels[1,] <- 'a1'
33 ip.mat@free[1,] <- TRUE
34 rstart <- lapply(m2.spec, rpf.rparam)
35 for (ix in 1:m2.numItems) {
36   thr <- m2.spec[[ix]]@outcomes - 1
37   ip.mat@free[(2+thr):(1+2*thr), ix] <- TRUE
38   ip.mat@values[ip.mat@free[,ix],ix] <- rstart[[ix]][ip.mat@free[,ix]]
39 }
40 ip.mat@values[!is.na(ip.mat@labels) & ip.mat@labels == 'a1'] <-
41   sample(ip.mat@values[!is.na(ip.mat@labels) & ip.mat@labels == 'a1'], 1)
42
43 #  m2.fmfit <- read.flexmirt("~/2012/sy/fm/ms-rasch-prm.txt")
44 # cat(deparse(round(m2.fmfit$G1$param,6)))
45 fmfit <- structure(c(0.941583, 1, 0, 0, 0, -0.676556, 0.758794, -0.802595,  1.28891, 0.941583, 1, 0, 0, -0.182632, 0.897435, 1.30626, NA,  NA, 0.941583, 1, 0, 0, 0, 0.177835, -1.82185, 0.005832, -0.81109,  0.941583, 1, 0, 0, 0, -1.15962, -1.229, 0.032677, 0.4922, 0.941583,  1, 0, 0.457533, 0.324595, NA, NA, NA, NA, 0.941583, 1, 0, 0,  -2.69186, -1.04012, 1.61232, NA, NA, 0.941583, 1, 0, 0, 0, -1.38231,  0.034368, -1.214, -0.648291, 0.941583, 1, 0, 0, 0, -1.85655,  -1.17135, -0.262079, -0.531158, 0.941583, 1, 0, 0, 0, -1.29475,  -0.376539, 0.02024, 0.135187, 0.941583, 1, 0, 0, 0, -1.38279,  0.524151, -0.508742, 0.633671, 0.941583, 1, 0, 0, 0, -0.979595,  -0.048528, 0.659669, 0.544857, 0.941583, 1, 0, 0, 0, -2.09039,  -1.45472, -0.472137, -0.666386, 0.941583, 1, 0, 0, 0.174682,  0.645437, 0.907132, NA, NA, 0.941583, 1, 0, 0, -0.842216, 0.490717,  1.28034, NA, NA, 0.941583, 1, 0, 0, 0, -0.913355, -0.319602,  -0.310164, -0.15536, 0.941583, 1, 0, 0, 0, 0.567085, -1.56762,  0.884553, 0.122113, 0.941583, 1, 0, 0, 0, -0.152985, -0.341317,  -0.183837, 1.17952, 0.941583, 1, 0, 0, 0, 0.168869, -0.490354,  0.373892, 1.29714, 0.941583, 1, 0, 0, 0, -0.827385, 0.626197,  -1.52994, 0.494209, 0.941583, 1, 0, 0, 0, 0.511263, -0.750358,  1.01852, 0.840026, 0.941583, 1, 0, 0, 0, 0.968905, -0.009671,  1.52297, 1.69255, 0.941583, 1, 0, 0, 0, 1.89582, 0.051828, 2.25758,  1.52469), .Dim = c(9L, 22L), .Dimnames = list(NULL, c("i1", "i2",  "i3", "i4", "i5", "i6", "i7", "i8", "i9", "i10", "i11", "i12",  "i13", "i14", "i15", "i16", "i17", "i18", "i19", "i20", "i21",  "i22")))
46 #  ip.mat@values <- m2.fmfit$G1$param
47
48 m.mat <- mxMatrix(name="mean", nrow=1, ncol=1, values=0, free=FALSE)
49 cov.mat <- mxMatrix(name="cov", nrow=1, ncol=1, values=1, free=FALSE)
50
51 if (1) {
52   cip.mat <- ip.mat
53   cip.mat@values <- fmfit
54   cM <- mxModel(model="ms", m.mat, cov.mat, cip.mat,
55                 mxData(observed=m2.data, type="raw"),
56                 mxExpectationBA81(mean="mean", cov="cov",
57                                   ItemSpec=m2.spec,
58                                   ItemParam="ItemParam"),
59                 mxFitFunctionML(),
60                 mxComputeSequence(steps=list(
61                   mxComputeOnce('expectation'),
62                   mxComputeOnce('fitfunction', 'fit', free.set=c("mean", "cov"))
63                 )))
64   cM <- mxRun(cM, silent=TRUE)
65   omxCheckCloseEnough(cM@fitfunction@result, 50661.38, .01)
66 }
67
68 plan <- mxComputeSequence(steps=list(
69   mxComputeEM('expectation', 'scores',
70               mxComputeNewtonRaphson(free.set='ItemParam'),
71               mxComputeNothing(),
72               mxComputeOnce('fitfunction', 'fit'),
73               information=TRUE),
74   mxComputeStandardError(),
75   mxComputeHessianQuality()))
76
77 m2 <- mxModel(model="m2", m.mat, cov.mat, ip.mat,
78               mxData(observed=m2.data, type="raw"),
79               mxExpectationBA81(mean="mean", cov="cov",
80                                 ItemSpec=m2.spec,
81                                 ItemParam="ItemParam"),
82               mxFitFunctionML(),
83               plan)
84 #  m2 <- mxOption(m2, "Number of Threads", 1)
85 m2 <- mxRun(m2, silent=TRUE)
86 omxCheckCloseEnough(m2@output$minimum, 50661.377, .01)
87
88 omxCheckCloseEnough(m2@output$conditionNumber, 1640, 50)
89 #cat(deparse(round(c(m2@output$standardErrors), 3)))
90
91 semse <- c(0.022, 0.095, 0.116, 0.116, 0.108, 0.176, 0.222, 0.305, 0.382,  0.359, 0.244,
92            0.215, 0.105, 0.082, 0.067, 0.07, 0.185, 0.215,  0.134, 0.061, 0.071, 0.25,
93            0.244, 0.231, 0.155, 0.328, 0.209,  0.177, 0.16, 0.211, 0.176, 0.182, 0.185,
94            0.187, 0.189, 0.201,  0.194, 0.174, 0.161, 0.2, 0.234, 0.409, 0.236, 0.179,
95            0.154,  0.064, 0.078, 0.092, 0.084, 0.074, 0.092, 0.584, 0.493, 0.441,  0.362,
96            0.1, 0.097, 0.079, 0.085, 0.113, 0.115, 0.102, 0.111,  0.079, 0.082, 0.076,
97            0.092, 0.541, 0.607, 0.554, 0.337, 0.081,  0.083, 0.083, 0.098, 0.072, 0.084,
98            0.103, 0.138, 0.084, 0.103,  0.141, 0.178)
99 omxCheckCloseEnough(c(m2@output$standardErrors), semse, .01) # similar to flexMIRT
100
101 emstat <- m2@compute@steps[[1]]@output
102 omxCheckCloseEnough(emstat$EMcycles, 37, 2)
103 omxCheckCloseEnough(emstat$totalMstep, 205, 10)
104 omxCheckCloseEnough(emstat$semProbeCount / length(semse), 3, .1)
105
106 #print(m2@matrices$ItemParam@values - fmfit)
107 print(m2@output$backendTime)
108
109 n <- apply(!is.na(m2.data), 2, sum)
110
111 i1 <- mxModel(m2,
112               mxComputeSequence(steps=list(
113                 mxComputeOnce('expectation'),
114                 mxComputeOnce('fitfunction', 'information', "meat"),
115                 mxComputeStandardError(),
116                 mxComputeHessianQuality())))
117 i1 <- mxRun(i1, silent=TRUE)
118
119 omxCheckTrue(i1@output$infoDefinite)
120 omxCheckCloseEnough(i1@output$conditionNumber, 3644, 1)  # matches flexmirt
121
122 #cat(deparse(round(c(i1@output$standardErrors), 3)))
123 se <- c(0.019, 0.1, 0.123, 0.121, 0.119, 0.237, 0.246, 0.33, 0.417,  0.386, 0.281,
124         0.24, 0.108, 0.086, 0.072, 0.076, 0.221, 0.265,  0.138, 0.068, 0.085, 0.275,
125         0.267, 0.263, 0.196, 0.359, 0.237,  0.208, 0.203, 0.227, 0.191, 0.199, 0.225,
126         0.21, 0.215, 0.232,  0.235, 0.184, 0.179, 0.218, 0.254, 0.437, 0.26, 0.201, 0.194,
127         0.07, 0.083, 0.101, 0.089, 0.079, 0.096, 0.649, 0.549, 0.507,  0.421, 0.106, 0.102,
128         0.084, 0.093, 0.125, 0.124, 0.112, 0.127,  0.088, 0.089, 0.087, 0.109, 0.633, 0.704,
129         0.61, 0.415, 0.089,  0.089, 0.09, 0.112, 0.083, 0.092, 0.115, 0.17, 0.095, 0.11, 0.16,  0.192)
130 omxCheckCloseEnough(c(i1@output$standardErrors), se, .001)  # matches flexmirt
131
132 if (0) {
133   library(mirt)
134   rdata <- sapply(m2.data, unclass)-1
135   # for flexMIRT, write CSV
136   #write.table(rdata, file="ifa-drm-mg.csv", quote=FALSE, row.names=FALSE, col.names=FALSE)
137   pars <- mirt(rdata, 1, itemtype="Rasch", D=1, quadpts=49, pars='values')
138 #  pars[pars$name=="a1",'value'] <- 1
139 #  pars[pars$name=="a1",'est'] <- FALSE
140 #  pars[pars$name=="COV_11",'est'] <- TRUE
141   fit <- mirt(rdata, 1, itemtype="Rasch", D=1, quadpts=49, pars=pars, SE=TRUE, SE.type="crossprod")
142   # LL -25330.691 * -2 = 50661.38
143   got <- coef(fit)
144 }