Allow ComputeIterate to test maximum absolute change
[openmx:openmx.git] / R / MxExpectationBA81.R
1 #
2 #   Copyright 2012 The OpenMx Project
3 #
4 #   Licensed under the Apache License, Version 2.0 (the "License");
5 #   you may not use this file except in compliance with the License.
6 #   You may obtain a copy of the License at
7
8 #        http://www.apache.org/licenses/LICENSE-2.0
9
10 #   Unless required by applicable law or agreed to in writing, software
11 #   distributed under the License is distributed on an "AS IS" BASIS,
12 #   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 #   See the License for the specific language governing permissions and
14 #   limitations under the License.
15
16
17 setClass(Class = "MxExpectationBA81",
18          representation = representation(
19            ItemSpec = "list",
20            ItemParam = "MxCharOrNumber",
21            EItemParam = "MxOptionalMatrix",
22            CustomPrior = "MxOptionalCharOrNumber",
23            design = "MxOptionalMatrix",
24            qpoints = "numeric",
25            qwidth = "numeric",
26            cache = "logical",
27            scores = "character",
28            scores.out = "matrix",
29            mean = "MxCharOrNumber",
30            cov = "MxCharOrNumber",
31            empirical.mean = "numeric",
32            empirical.cov = "matrix",
33            patternLikelihood = "numeric",
34            em.expected = "numeric",
35            dims = "character",
36            numStats = "numeric",
37            verbose = "logical"),
38          contains = "MxBaseExpectation")
39
40 setMethod("initialize", "MxExpectationBA81",
41           function(.Object, ItemSpec, ItemParam, EItemParam, CustomPrior, design,
42                    qpoints, qwidth, cache, mean, cov, scores, verbose,
43                    name = 'expectation') {
44             .Object@name <- name
45             .Object@ItemSpec <- ItemSpec
46             .Object@ItemParam <- ItemParam
47             .Object@EItemParam <- EItemParam
48             .Object@CustomPrior <- CustomPrior
49             .Object@design <- design
50             .Object@qpoints <- qpoints
51             .Object@qwidth <- qwidth
52             .Object@cache <- cache
53             .Object@scores <- scores
54             .Object@data <- as.integer(NA)
55             .Object@mean <- mean
56             .Object@cov <- cov
57             .Object@scores.out <- matrix()
58             .Object@verbose <- verbose
59             return(.Object)
60           }
61 )
62
63 setMethod("genericExpDependencies", signature("MxExpectationBA81"),
64           function(.Object, dependencies) {
65                   sources <- c(.Object@mean, .Object@cov,
66                                .Object@ItemParam, .Object@CustomPrior)
67                   dependencies <- imxAddDependency(sources, .Object@name, dependencies)
68                   return(dependencies)
69           })
70
71 setMethod("genericExpFunConvert", signature("MxExpectationBA81"), 
72           function(.Object, flatModel, model, labelsData, defVars, dependencies) {
73                   modelname <- imxReverseIdentifier(model, .Object@name)[[1]]
74                   if(is.na(.Object@data)) {
75                           msg <- paste(typeof(.Object),
76                                        "does not have a dataset associated with it in model",
77                                        omxQuotes(modelname))
78                           stop(msg, call.=FALSE)
79                   }
80                   name <- .Object@name
81                   for (s in c("data", "ItemParam", "CustomPrior",
82                               "mean", "cov")) {
83                           if (is.null(slot(.Object, s))) next;
84                           slot(.Object, s) <-
85                             imxLocateIndex(flatModel, slot(.Object, s), name)
86                   }
87                   .Object@dims <- colnames(flatModel@datasets[[.Object@data + 1]]@observed)
88                   return(.Object)
89           })
90
91 setMethod("qualifyNames", signature("MxExpectationBA81"), 
92         function(.Object, modelname, namespace) {
93                 .Object@name <- imxIdentifier(modelname, .Object@name)
94                 for (s in c("ItemParam", "CustomPrior", "mean", "cov")) {
95                         if (is.null(slot(.Object, s))) next;
96                         slot(.Object, s) <-
97                           imxConvertIdentifier(slot(.Object, s), modelname, namespace)
98                 }
99                 return(.Object)
100 })
101
102 setMethod("genericExpRename", signature("MxExpectationBA81"),
103         function(.Object, oldname, newname) {
104           # not sure what goes here yet
105                 return(.Object)
106 })
107
108 ##' Create a Bock & Aitkin (1981) expectation
109 ##'
110 ##' The standard Normal distribution of the quadrature acts like a
111 ##' prior distribution for difficulty. It is not necessary to impose
112 ##' any additional Bayesian prior on difficulty estimates (Baker &
113 ##' Kim, 2004, p. 196).
114 ##' 
115 ##' @param ItemParam one column for each item with parameters starting
116 ##' at row 1 and extra rows filled with NA
117 ##' @param design one column per item, assignment of person abilities
118 ##' to item dimensions (optional)
119 ##' @param qpoints number of points to use for rectangular quadrature integrations (default 49)
120 ##' See Seong (1990) for some considerations on specifying this parameter.
121 ##' @param cache whether to cache part of the expectation calculation
122 ##' (enabled by default).
123 ##' @references
124 ##' Bock, R. D., & Aitkin, M. (1981). Marginal maximum likelihood estimation of item
125 ##' parameters: Application of an EM algorithm. Psychometrika, 46, 443-459.
126 ##'
127 ##' Cai, L. (2010). A two-tier full-information item factor analysis
128 ##' model with applications. Psychometrika, 75, 581-612.
129 ##'
130 ##' Seong, T. J. (1990). Sensitivity of marginal maximum likelihood
131 ##' estimation of item and ability parameters to the characteristics
132 ##' of the prior ability distributions. Applied Psychological
133 ##' Measurement, 14(3), 299-311.
134
135 # change default to cache=FALSE or just remove cache? TODO
136 mxExpectationBA81 <- function(ItemSpec, ItemParam, CustomPrior=NULL, design=NULL,
137                               qpoints=NULL, qwidth=6.0, cache=TRUE, mean=NULL, cov=NULL,
138                               scores="omit", verbose=FALSE, EItemParam=NULL) {
139
140         if (missing(qpoints)) qpoints <- 49
141         if (qpoints < 3) {
142                 stop("qpoints should be 3 or greater")
143         }
144         if (qpoints %% 2 == 0) {
145                 warning(paste("An even number of qpoints can obtain a better than true fit",
146                               "in a single group model; Pick an odd number of qpoints"))
147         }
148         if (missing(qwidth)) qwidth <- 6
149         if (qwidth <= 0) {
150                 stop("qwidth must be positive")
151         }
152   
153         score.options <- c("omit", "unique", "full")
154         if (!match(scores, score.options)) {
155                 stop(paste("Valid score options are", deparse(score.options)))
156         }
157
158         if (!missing(design) && !is.integer(design)) {
159                 stop("Design must be an integer matrix")
160         }
161
162         return(new("MxExpectationBA81", ItemSpec, ItemParam, EItemParam, CustomPrior, design,
163                    qpoints, qwidth, cache, mean, cov, scores, verbose))
164 }