/
feedback.R
321 lines (310 loc) · 11.8 KB
/
feedback.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
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
#' Feedback graph
#'
#' This function defines a feedback page for an adaptive test
#' created with psychTestRCAT,
#' plotting the participant's results against the results of previous participants.
#'
#' Each time that this page is seen by a participant,
#' the participant's score is written to a text file in psychTestR's
#' output directory.
#' This text file is used to build the population distribution for
#' the feedback graph, once sufficiently many people have taken the test.
#'
#' @param test_label (Character scalar)
#' Identifying label for the test (e.g. 'mdt'),
#' used to identify the file where participant results are accumulated.
#'
#' @param text_finish (Character scalar)
#' Text to display to the participant, defaults to "You finished the test!".
#'
#' @param text_score (Character scalar)
#' Text to prefix to the participant's score,
#' defaults to "Your final score:".
#'
#' @param text_rank (Character scalar)
#' Text to prefix to the participant's rank,
#' defaults to "Your rank compared to previous participants:".
#'
#' @param x_axis (Character scalar)
#' Label for the x-axis, corresponding to participant scores;
#' defaults to "Score".
#'
#' @param y_axis (Character scalar)
#' Label for the y-axis, corresponding to the count of participant scores;
#' defaults to "Count".
#'
#' @param next_button
#' (NULL or a character scalar or an object of class "shiny.tag")
#' If NULL, no next button is shown
#' (typically because the test has completed).
#' Otherwise, a button to progress to the next page is created,
#' displaying the content of this argument.
#'
#' @param digits (Integerish scalar)
#' Number of digits to which participant scores should be rounded.
#'
#' @param explain_IRT (Logical scalar)
#' If TRUE, the feedback page includes an academic explanation of
#' item response theory.
#' Currently only English language is supported.
#'
#' @param i18n (Logical scalar)
#' Whether internationalisation should be enabled.
#' Defaults to \code{FALSE} to preserve back-compatibility.
#'
#' @param dict
#' Internationalisation dictionary (see \code{\link[psychTestR]{i18n_dict}}).
#'
#' @return
#' A test element (or, if \code{i18n} is TRUE, a timeline segment)
#' suitable for inclusion in a psychTestR timeline
#' directly after \code{\link{adapt_test}}.
#'
#' @export
cat.feedback.graph <- function(
test_label,
text_finish = if (!i18n) "You finished the test!" else "you_finished",
text_score = if (!i18n) "Your final score:" else "your_score",
text_rank = if (!i18n) "Your rank compared to previous participants:" else "your_rank",
x_axis = if (!i18n) "Score" else "score",
y_axis = if (!i18n) "Count" else "count",
next_button = NULL,
digits = 3L,
explain_IRT = !i18n,
i18n = FALSE,
dict = psychTestRCAT::ptrcat_dict
) {
stopifnot(is.scalar.character(test_label))
loadNamespace("plotly")
loadNamespace("ggplot2")
if (i18n && explain_IRT)
warning("Currently the IRT explanations are not internationalised.")
text <- function(x) {
if (i18n) psychTestR::i18n(x) else x
}
elts <- expression({
psychTestR::join(
cat.feedback.graph.manage_scores(test_label = test_label),
cat.feedback.graph.display_scores(text_finish = text(text_finish),
text_score = text(text_score),
text_rank = text(text_rank),
x_axis = text(x_axis),
y_axis = text(y_axis),
next_button = next_button,
digits = digits,
explain_IRT = explain_IRT)
)
})
if (i18n) {
psychTestR::new_timeline(eval(elts), dict = dict)
} else {
eval(elts)
}
}
cat.feedback.graph.manage_scores <- function(test_label) {
psychTestR::code_block(function(answer, opt, state, ...) {
score <- answer$ability
stopifnot(is.scalar.numeric(score))
file <- file.path(psychTestR::get_supplementary_results_dir(opt),
paste0(test_label, "_final_scores.txt"))
write(score, file, append = TRUE)
all_scores <- as.numeric(read.table(file)[[1]])
num_scores <- length(all_scores)
rank <- cat.feedback.graph.get_rank(all_scores)
psychTestR::set_local(key = "cat_results",
value = list(score = as.numeric(score),
all_scores = all_scores,
num_scores = num_scores,
rank = rank),
state = state)
})
}
cat.feedback.graph.get_rank <- function(all_scores) {
num_scores <- length(all_scores)
num_scores + 1L - rank(all_scores, ties.method = "max")[num_scores]
}
cat.feedback.graph.display_scores <- function(text_finish, text_score, text_rank,
x_axis, y_axis,
next_button, digits,
explain_IRT) {
stopifnot(is.scalar.character(x_axis),
is.scalar.character(y_axis),
is.scalar.character(text_finish) || is(text_finish, "shiny.tag"),
is.scalar.character(text_score) || is(text_score, "shiny.tag"),
is.scalar.character(text_rank) || is(text_rank, "shiny.tag"),
is.null(next_button) || is.scalar.character(next_button) ||
is(next_button, "shiny.tag"),
is.scalar.integerlike(digits),
is.scalar.logical(explain_IRT))
psychTestR::reactive_page(function(state, ...) {
res <- psychTestR::get_local(key = "cat_results", state = state)
psychTestR::page(
ui = shiny::div(
shiny::p(text_finish),
shiny::p(text_score, shiny::strong(round(res$score, digits = digits))),
shiny::p(text_rank, shiny::strong(sprintf("%i/%i", res$rank, res$num_scores))),
if (res$num_scores > 1L)
shiny::div(
cat.feedback.graph.plot_cat_results(res, x_axis = x_axis, y_axis = y_axis),
if (explain_IRT)
shiny::div(
shiny::p(
"Scores are plotted on an",
shiny::tags$a(href = "https://en.wikipedia.org/wiki/Item_response_theory",
"item response theory"),
"metric, where the mean score in the general population is approximately 0,",
"and the standard deviation in the population is approximately 1."),
shiny::p(
"Your score places you in the top",
shiny::strong(paste0(100 - round(100 * stats::pnorm(res$score)), "%")),
"of the general population.")
),
style = "border-style: solid; border-width: 1px; background-color: white;"),
if (!is.null(next_button))
shiny::p(psychTestR::trigger_button("next", next_button))
)
)
})
}
cat.feedback.graph.plot_cat_results <- function(res, x_axis, y_axis) {
if (!is.list(res)) stop("<cat_results> was malformed, looking like this: ",
utils::capture.output(print(res)))
num_bins <- pmax(16, ceiling(log2(res$num_scores)) + 1)
stopifnot(is.scalar.character(x_axis),
is.scalar.character(y_axis),
is.list(res),
is.numeric(res$all_scores))
plotly::ggplotly(ggplot2::ggplot(
data.frame(Score = res$all_scores), ggplot2::aes_string(x = "Score")
) + ggplot2::geom_histogram(bins = num_bins,
colour = "#004d66",
fill = "#00ace6") +
ggplot2::geom_vline(xintercept = res$score, colour = "#e60000") +
ggplot2::scale_x_continuous(x_axis) +
ggplot2::scale_y_continuous(y_axis) +
ggplot2::theme_bw() +
ggplot2::theme(panel.grid = ggplot2::element_blank()),
height = 300)
# panel.background = ggplot2::element_rect(fill = "#f7f7f7"))
# width = 300, height = 300)
}
#' Feedback on IRT score
#'
#' Displays the participant's IRT score and associated standard error
#' to the participant. Most participants won't know what these scores mean;
#' however, this feedback option can be useful to experimenters
#' conducting in-lab studies, because it means they can write down
#' the final scores manually.
#'
#' @param text (Character scalar)
#' Text to display to the participant. This text will be treated as an
#' internationalisation key for the dictionary contained in the \code{dict}
#' argument; if the key is not present in the dictionary, the text
#' will be displayed as is.
#'
#' @param digits_irt_score (Numeric scalar)
#' Number of digits to which the IRT score should be rounded.
#'
#' @param digits_irt_sem (Numeric scalar)
#' Number of digits to which the IRT standard error should be rounded.
#'
#' @return A timeline segment suitable for inclusion in a psychTestR timeline
#' directly after \code{\link{adapt_test}}.
#'
#' @inheritParams cat.feedback.graph
#'
#' @export
cat.feedback.irt <- function(
text = "feedback_irt",
dict = psychTestRCAT::ptrcat_dict,
next_button = NULL,
digits_irt_score = 3L,
digits_irt_sem = 3L
) {
psychTestR::new_timeline(psychTestR::reactive_page(function(state, ...) {
irt_score <- psychTestR::answer(state)$ability
irt_sem <- psychTestR::answer(state)$ability_sem
psychTestR::page(
ui = shiny::div(
shiny::p(
psychTestR::i18n(
text,
sub = c(
irt_score = round(irt_score, digits = digits_irt_score),
irt_sem = round(irt_sem, digits = digits_irt_sem)
)
)
),
if (!is.null(next_button))
shiny::p(psychTestR::trigger_button("next", next_button))
)
)
}),
dict = dict)
}
#' Feedback on IQ score
#'
#' Provides feedback for the adaptive test framed in terms of an
#' 'IQ' score. IQ scores are rescaling of IRT scores to a scale
#' with mean 100 and standard deviation 15.
#' The feedback also provides an interpration of the IQ score as a percentile
#' with respect to the general population.
#'
#' @param test_label (Character scalar)
#' The label for the test, e.g. "MDT". This will be used to label the IQ score,
#' e.g. "Your MDT-IQ was...".
#'
#' @param feedback_iq (Character scalar)
#' Text to display to the participant. This text will be treated as an
#' internationalisation key for the dictionary contained in the \code{dict}
#' argument; if the key is not present in the dictionary, the text
#' will be displayed as is.
#'
#' @param digits_iq (Numeric scalar)
#' Number of digits to which the IQ score should be rounded.
#'
#' @param digits_percentile (Numeric scalar)
#' Number of digits to which the percentile score should be rounded.
#'
#' @return A timeline segment suitable for inclusion in a psychTestR timeline
#' directly after \code{\link{adapt_test}}.
#'
#' @inheritParams cat.feedback.graph
#' @inheritParams cat.feedback.irt
#'
#' @export
cat.feedback.iq <- function(
test_label,
text = "feedback_iq",
dict = psychTestRCAT::ptrcat_dict,
next_button = NULL,
digits_iq = 0L,
digits_percentile = 0L
) {
checkmate::qassert(test_label, "S1")
checkmate::qassert(text, "S1")
checkmate::qassert(digits_iq, "X1")
checkmate::qassert(digits_percentile, "X1")
psychTestR::new_timeline(psychTestR::reactive_page(function(state, ...) {
irt_score <- psychTestR::answer(state)$ability
iq_score <- 100 + irt_score * 15
percentile <- stats::pnorm(irt_score)
psychTestR::page(
ui = shiny::div(
shiny::p(
psychTestR::i18n(
text,
sub = c(
test_name = test_label,
test_score = round(iq_score, digits = digits_iq),
test_threshold = round(100 * percentile, digits = digits_percentile)
)
)
),
if (!is.null(next_button))
shiny::p(psychTestR::trigger_button("next", next_button))
)
)
}),
dict = dict)
}