Revive latent distribution gradients
[openmx:openmx.git] / models / nightly / ifa-dLL.R
1 #options(digits=20)
2 library(OpenMx)
3 library(rpf)
4 library(numDeriv)
5 #options(error = utils::recover)
6
7 mxOption(NULL, 'loglikelihoodScale', -1)
8
9 unpackHession <- function(deriv, np) {
10   hess <- matrix(NA, nrow=np, ncol=np)
11   dx <- np+1
12   for (hr in 1:np) {
13     hess[1:hr,hr] <- hess[hr,1:hr] <- deriv[dx:(dx+hr-1)]
14     dx <- dx + hr
15   }
16   hess
17 }
18
19 #myseed <- as.integer(runif(1) * 1e7)
20 #print(paste("set.seed =",myseed))
21 #set.seed(myseed)
22 set.seed(1)
23
24 items <- list()
25 items[[1]] <- rpf.drm(factors=2)
26 items[[2]] <- rpf.grm(outcomes=5, factors=2)
27 items[[3]] <- rpf.nrm(outcomes=4, factors=2,
28                       T.a=diag(3), T.c=diag(3))
29 numItems <- length(items)
30
31 params <- lapply(items, rpf.rparam)
32 data <- rpf.sample(5000, items, params)
33
34 starting <- list(c(1.4, 1, 0, .1, .9),
35                  c(1.4, 1, seq(2,-2, length.out=4)),
36                  c(1.4,  1,  rep(0,6)))
37 starting.len <- max(vapply(starting, length, 0))
38
39 ip.mat <- mxMatrix(name="itemParam", nrow=starting.len, ncol=numItems,
40                    values=0, free=FALSE)
41
42 for (sx in 1:length(starting)) {
43   v <- starting[[sx]]
44   ip.mat@values[1:length(v),sx] <- v
45   ip.mat@free[1:length(v),sx] <- TRUE
46 }
47 starting.free <- ip.mat@free
48 starting.values <- ip.mat@values
49
50 m.mat <- mxMatrix(name="mean", nrow=1, ncol=2, values=0, free=FALSE)
51 cov.mat <- mxMatrix(name="cov", nrow=2, ncol=2, values=diag(2), free=FALSE)
52 m2 <- mxModel(model="drm1", ip.mat, m.mat, cov.mat,
53               mxData(observed=data, type="raw"),
54               mxExpectationBA81(mean="mean", cov="cov",
55                                 ItemSpec=items,
56                                 ItemParam="itemParam",
57                                 EItemParam=starting.values,
58                 qwidth=5, qpoints=21),
59               mxFitFunctionML())
60
61 if (0) {   # enable to generate answer file
62   samples.per.item <- 100
63   ans <- list()
64   for (ii in 1:numItems) {  # 
65     spi <- 0
66     while (spi < samples.per.item) {
67       m2@matrices$itemParam@values <- starting.values
68       m2@matrices$itemParam@free[,] <- FALSE
69       
70       spoint <- rpf.rparam(items[[ii]])
71       # exclude GRM with close adjacent intercepts, too much curvature for numDeriv
72       if (ii==2 && min(abs(diff(spoint[3:6]/max(spoint[1:2])))) < .3) next
73
74       np <- length(spoint)
75       m2@matrices$itemParam@values[1:np,ii] <- spoint
76       
77       deriv <- genD(function(param) {
78         np <- length(param)
79         m2@matrices$itemParam@values[1:np,ii] <- param
80         lModel <- mxModel(m2,
81                           mxComputeSequence(steps=list(
82                             mxComputeOnce('expectation', context='EM'),
83                             mxComputeOnce('fitfunction', fit=TRUE)
84                           )))
85         fit <- mxRun(lModel, silent=TRUE)
86         fit@output$minimum
87       }, spoint, method.args=list(d=.01, r=2))
88       
89       # Our gradients are too flat for the default higher precision settings.
90       
91       if (any(is.na(deriv$D))) next
92
93       print(c(ii, spoint))
94       ans[[length(ans)+1]] <- c(ii, spoint, deriv$D)
95       spi <- spi + 1
96     }
97   }
98   
99   ans.len <- max(sapply(ans, length))
100   ans.padded <- lapply(ans, function (elem) elem <- c(elem, rep(NA, ans.len-length(elem))))
101   write.table(t(simplify2array(ans.padded)), file="data/dLL.csv", row.names=FALSE, col.names=FALSE)
102 }
103
104 ans <- suppressWarnings(try(read.table("models/nightly/data/dLL.csv"), silent=TRUE))
105 if (is(ans, "try-error")) ans <- read.table("data/dLL.csv")
106
107 m2 <- mxModel(m2,
108               mxComputeSequence(steps=list(
109                 mxComputeOnce('expectation', context='EM'),
110                 mxComputeOnce('fitfunction', gradient=TRUE, hessian=TRUE)
111               )))
112
113 if (1) {  # enable to examine the RMSE by item model
114   for (ix in 1:numItems) {
115     np <- rpf.numParam(items[[ix]])
116     diff.grad <- rep(0, np)
117     diff.hess <- matrix(0, np, np)
118     diff.count <- 0
119     skip <- c()
120     
121     for (tx in 1:dim(ans)[1]) {
122       ii <- ans[tx,1]
123       if (ii != ix) next
124       
125       m2@matrices$itemParam@values <- starting.values
126       m2@matrices$itemParam@free[,] <- FALSE
127       
128       spoint <- ans[tx,2:(np+1)]
129       m2@matrices$itemParam@values[1:np,ii] <- simplify2array(spoint)
130       m2@matrices$itemParam@free[,ii] <- starting.free[,ii]
131       
132       m2 <- mxRun(m2, silent=TRUE)
133       
134       grad1 <- m2@output$gradient
135       names(grad1) <- NULL
136       hess <- m2@output$hessian
137       
138       emp.grad <- simplify2array(ans[tx,(2+np):(1+2*np)])
139       emp.hess <- unpackHession(simplify2array(ans[tx, -1:-(1+np)]), np)
140       
141       if (any(abs(emp.hess - hess) > .01)) {
142         skip <- c(skip,tx)
143       }
144       diff.grad <- diff.grad + (emp.grad - grad1)^2
145       diff.hess <- diff.hess + (emp.hess - hess)^2
146       diff.count <- diff.count+1
147     }
148
149     if (diff.count > 0 && FALSE) {
150       if(length(skip)) print(skip)
151       diff.grad <- sqrt(diff.grad / diff.count)
152       diff.hess <- sqrt(diff.hess / diff.count)
153       print(diff.grad)
154       print(max(diff.grad))
155       print(diff.hess)
156       print(max(diff.hess))
157     }
158 #     print(max(diff.grad))
159 #     print(max(diff.hess))
160     # The poor accuracy here is probably due to numDeriv, not the
161     # math for analytic derivs.
162     omxCheckTrue(all(diff.grad < .003))
163     omxCheckTrue(all(diff.hess < .11))
164   }
165 }
166
167 if (0) {
168   kat <- c()
169   badest <-  c(6, 15, 40, 55, 67, 82, 84, 85, 87, 94)
170  # badest <- c(107, 114, 121, 126, 132, 138, 139, 164, 172, 177, 182, 199)
171       for (tx in badest) {
172     ii <- ans[tx,1]
173 #    print(params[[ii]])
174     np <- rpf.numParam(items[[ii]])
175     
176     m2@matrices$itemParam@values <- starting.values
177     m2@matrices$itemParam@free[,] <- FALSE
178     
179     spoint <- simplify2array(ans[tx,2:(np+1)])
180     print(spoint)
181       next;
182   
183     m2@matrices$itemParam@values[1:np,ii] <- spoint
184     m2@matrices$itemParam@free[,ii] <- starting.free[,ii]
185       
186     m2 <- mxRun(m2, silent=TRUE)
187       
188     grad1 <- m2@output$gradient
189     names(grad1) <- NULL
190     hess <- m2@output$hessian
191     
192     if (0) {
193       print(paste("Item", ii))
194       print(grad1)
195       print(deriv$D[1:np])
196       cat("T.a=",deparse(T.a),"\n")
197       cat("T.c=",deparse(T.c),"\n")
198       cat("an=",deparse(hess),"\n")
199       cat("emp=",deparse(emp.hess),"\n")
200       print(round(hess - emp.hess, 2))
201     }
202     
203     emp.grad <- simplify2array(ans[tx,(2+np):(1+2*np)])
204     emp.hess <- unpackHession(simplify2array(ans[tx, -1:-(1+np)]), np)
205
206 #    print(grad1)
207 #    print(grad1 - emp.grad)
208 #    print(emp.hess)
209 #    print(hess)
210 #    print(hess - emp.hess)
211     
212     evalLL <- function(param) {
213       np <- length(param)
214       m2@matrices$itemParam@values[1:np,ii] <- param
215       lModel <- mxModel(m2,
216                         mxComputeSequence(steps=list(
217                           mxComputeOnce('expectation', context='EM'),
218                           mxComputeOnce('fitfunction', fit=TRUE)
219                         )))
220       fit <- mxRun(lModel, silent=TRUE)
221       ll <- fit@output$minimum
222       ll
223     }
224     deriv <- genD(evalLL, spoint, method.args=list(d=.1, r=3))
225     print(round(hess - unpackHession(deriv$D, np), 2))
226     
227     if (0) {
228       grid <- expand.grid(x=seq(.07,-.05,-.01))
229       for (pp in grid$x) {
230         spoint[5] <- pp
231         grid$LL <- evalLL(spoint)
232       }
233     }
234   }
235 }