/
models.R
183 lines (160 loc) · 4.92 KB
/
models.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
#' @name models
#'
#' @title Probabilistic models of repeated categorical rating
#' @description Functions to set up models and change their prior
#' parameters for use in [rater()].
#'
#' @return a rater model object that can be passed to [rater()].
#'
NULL
#' @rdname models
#'
#' @param alpha prior parameter for pi
#' @param beta prior parameter for theta. This can either be a K * K matrix, in
#' which case it is interpreted as the prior parameter of all of the J
#' raters, or a J by K by K array in which case it is the fully specified
#' prior parameter for all raters. (Here K is the number of categories in the
#' data and J is the number of raters in the data.)
#'
#' @examples
#' # Model with default prior parameters:
#' default_m <- dawid_skene()
#'
#' # Changing alpha:
#' set_alpha_m <- dawid_skene(alpha = c(2, 2, 2))
#'
#' # Changing beta, single matrix:
#' # (See details for how this is interpreted.)
#' beta_mat <- matrix(1, nrow = 4, ncol = 4)
#' diag(beta_mat) <- 4
#' beta_mat_m <- dawid_skene()
#'
#' # The above is equivalent (when the model is fit - see details) to:
#' beta_array <- array(NA, dim = c(2, 4, 4))
#' for (i in 1:2) {
#' beta_array[i, , ] <- beta_mat
#' }
#' beta_array_m <- dawid_skene(beta = beta_array)
#'
#' # But you can also specify an array where each slice is different.
#' # (Again, see details for how this is interpreted.)
#' beta_array[1, , ] <- matrix(1, nrow = 4, ncol = 4)
#' beta_array_m <- dawid_skene(beta = beta_array)
#'
#' @export
#'
dawid_skene <- function(alpha = NULL, beta = NULL) {
validate_alpha(alpha)
# `beta` can either be a K * K matrix which we interpret as the prior on the
# error matrix on each of the raters as in {1.0.0} or a J * K * K array, the
# set of priors on the error matrices of the J raters.
if (!is.null(beta) && !is.matrix(beta) && !is.array(beta)) {
stop("beta must be a numeric matrix or array", call. = FALSE)
}
alpha_k <- NULL
beta_k <- NULL
# Beta as matrix case.
if (is.matrix(beta)) {
# Test if the matrix is square.
if (nrow(beta) != ncol(beta)) {
stop("beta must a square matrix", call. = FALSE)
}
beta_k <- unique(dim(beta))
}
# Beta as array case.
if (is.array(beta) && length(dim(beta)) > 2) {
if (length(dim(beta)) != 3) {
stop("`beta` must be a 3 dimensional array", call. = FALSE)
}
if (length(unique(dim(beta)[2:3])) != 1) {
stop("Subslices of `beta` must be square matrices.", call. = FALSE)
}
beta_k <- unique(dim(beta)[2:3])
}
if (is.numeric(alpha)) {
alpha_k <- length(alpha)
}
ks <- c(alpha_k, beta_k)
# ks will be NULL if both alpha and beta are not specified.
if (is.null(ks)) {
K <- NULL
} else {
if (length(unique(ks)) > 1) {
# FIXME: Make this error more informative.
stop("`alpha` and `beta` are not compatible.", call. = FALSE)
} else {
K <- unique(ks)
}
}
m <- list(parameters = list(alpha = alpha, beta = beta),
name = "Bayesian Dawid and Skene Model",
file = "dawid_skene",
K = K)
class(m) <- c("dawid_skene", "rater_model")
m
}
#' @rdname models
#'
#' @param alpha prior parameter for pi
#'
#' @examples
#' # Default:
#' hier_dawid_skene()
#'
#' # Changing alpha
#' hier_dawid_skene(alpha = c(2, 2))
#'
#' @export
#'
hier_dawid_skene <- function(alpha = NULL) {
# Note: this does not allow the user to change the N(0, 1) hyperpriors.
validate_alpha(alpha)
K <- if (!is.null(alpha)) length(alpha) else NULL
m <- list(parameters = list(alpha = alpha),
name = "Bayesian Hierarchical Dawid and Skene Model",
file = "hierarchical_dawid_skene",
K = K)
class(m) <- c("hier_dawid_skene", "rater_model")
m
}
#' @rdname models
#'
#' @param beta_1 First on diagonal prior probability parameter
#' @param beta_2 Second on diagonal prior probability parameter for theta
#'
#' @examples
#' # Default:
#' class_conditional_dawid_skene()
#'
#' # Not default:
#' class_conditional_dawid_skene(
#' alpha = c(2, 2),
#' beta_1 = c(4, 4),
#' beta_2 = c(2, 2)
#' )
#'
#' @export
#'
class_conditional_dawid_skene <- function(alpha = NULL,
beta_1 = NULL,
beta_2 = NULL) {
validate_alpha(alpha)
# length(NULL) = 0.
ks <- c(length(alpha), length(beta_1), length(beta_2))
ks <- ks[ks > 0]
if (length(unique(ks)) > 1) {
stop("Prior parameters are not compatible.", call. = FALSE)
}
K <- if (length(ks) > 0) unique(ks) else NULL
m <- list(parameters = list(alpha = alpha, beta_1 = beta_1, beta_2 = beta_2),
name = "Bayesian Class conditional Dawid and Skene Model",
file = "class_conditional_dawid_skene",
K = K)
class(m) <- c("class_conditional_dawid_skene", "rater_model")
m
}
validate_alpha <- function(alpha) {
if (!is.null(alpha) && !is.numeric(alpha)) {
stop("alpha must be a numeric vector", call. = FALSE)
}
}