-
Notifications
You must be signed in to change notification settings - Fork 2
/
shiny-module.R
182 lines (153 loc) · 5.66 KB
/
shiny-module.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
### shiny module that implements the state machine ###
#' Run a quiz in 'shiny'
#'
#' @description A 'shiny' module to implement a quiz. These are the core functions to implement the quiz with a 'shiny' application.
#'
#' @param quiz an object of class `quiz`. See [create_quiz()]
#' @author Joseph Marlo
#' @export
#'
#' @seealso [create_quiz()] [preview_app()]
#'
#' @examplesIf interactive()
#' quiz <- create_quiz(
#' create_question(
#' 'Lorem ipsum dolor sit amet, consectetur adipiscing elit. Select nulla.',
#' add_choice('auctor'),
#' add_choice('nulla', correct = TRUE)
#' ),
#' create_question(
#' 'Mauris congue aliquet dui, ut dapibus lorem porttitor sed. Select 600.',
#' add_choice('600', correct = TRUE),
#' add_choice('800')
#' )
#' )
#'
#' ui <- shiny::fluidPage(
#' htmltools::div(
#' style = "max-width: 700px",
#' quiz_ui(quiz)
#' )
#' )
#' server <- function(input, output, session) {
#' quiz_server(quiz)
#' }
#' shinyApp(ui, server)
#' @describeIn quiz_ui UI side function
quiz_ui <- function(quiz){
verify_quiz_structure(quiz)
ns <- quiz@options$ns
htmltools::tagList(
add_external_resources(),
htmltools::div(
id = ns('quiz-container'),
class = 'quiz-container',
shiny::uiOutput(outputId = ns('UI_quiz'))
)
)
}
#' @param quiz an object of class `quiz`. See [create_quiz()]
#' @export
#' @return a reactive object showing the current results of the quiz
#'
#' @describeIn quiz_ui Server side function
quiz_server <- function(quiz){
verify_quiz_structure(quiz)
ns <- quiz@options$ns
id <- ns(NULL)
if (!isTRUE(stringr::str_count(id, '-') <= 1)) cli::cli_abort('namespace id is invalid. Too many hyphens. Remove any hyphens in your id. Otherwise, are you trying to nest modules more than two deep?')
id <- stringr::str_remove_all(id, "^.*?-") # remove any prefixes due to parent modules; this is fragile but works
shiny::moduleServer(id, function(input, output, session){
# add css class to the quiz container
if (is_truthy(quiz@options$class)) shinyjs::addClass(id = 'quiz-container', class = quiz@options$class)
# add headers to question texts
quiz <- sm_ui_format_prompts(quiz)
# set the current state and potential values
store <- sm_create_reactive_store(quiz)
# reset quiz
shiny::observeEvent(input$restart_button, {
# reset the state to the first question
store <- sm_set_state(store, variable = 'current-state', value = 'quiz-question-1')
# remove any responses
store$questions <- quiz@questions
store <- sm_set_state(store, variable = 'quiz-skipped', value = FALSE)
store$is_correct <- rep(NA, length(quiz@questions))
})
# skip quiz / finish quiz
shiny::observeEvent(input$skip_button, {
store <- sm_set_state(store, variable = 'current-state', value = 'quiz-complete')
store <- sm_set_state(store, variable = 'quiz-skipped', value = TRUE)
})
# control state behavior
shiny::observeEvent(store$state, {
# scroll to top of quiz container
scroll_to_div(ns = ns, id = 'quiz-container')
# state behavior
if (store$state == 'quiz-complete'){
# determine the UI
store$ui_html <- sm_ui_quiz_complete(
store,
ns = ns,
messages = quiz@options$messages
)
} else {
# determine the UI
store$ui_html <- sm_ui_question(store, ns = ns)
}
})
# on button submit, record answer and change the state
shiny::observeEvent(input$submit_button, {
# disable submit button to prevent double clicks
shinyjs::disable(id = 'submit_button')
# scroll to top of quiz container
scroll_to_div(ns = ns, id = 'quiz-container')
# record answers
store <- sm_set_state(store, variable = 'current-response', value = input$answers)
# is the answer correct and record it
is_correct <- sm_is_current_correct(store)
store <- sm_set_state(store, 'current-correct', is_correct)
# grade it
delay_in_ms <- 2000
if (is_correct){
# add UI indicator
add_checkmark(ns = ns, id = 'quiz-container')
# change the state
shinyjs::delay(delay_in_ms, {
new_state <- sm_get_state(store, variable = 'next-state')
store <- sm_set_state(store, variable = 'current-state', value = new_state)
})
} else {
# add UI indicator
add_red_x(ns = ns, id = 'quiz-container')
# change the state
# depending on options, go to next question otherwise end here
shinyjs::delay(delay_in_ms, {
if (sm_logic_end_on_first_wrong(store)){
store <- sm_set_state(store, variable = 'current-state', value = 'quiz-complete')
} else {
new_state <- sm_get_state(store, variable = 'next-state')
store <- sm_set_state(store, variable = 'current-state', value = new_state)
}
})
}
})
# render the UI
output$UI_quiz <- shiny::renderUI(store$ui_html)
# return the quiz summary
return(shiny::reactive(sm_summary(store, quiz)))
})
}
#' External resources to include in the app
#'
#' Examples include `shinyjs::useShinyjs` or `fontawesome::fa_html_dependency`. These objects are raised to the head of html document.
#'
#' @return an invisible object of class shiny.tag
#' @noRd
#' @author Joseph Marlo
add_external_resources <- function(){
htmltools::tags$head(
shinyjs::useShinyjs(),
fontawesome::fa_html_dependency(),
htmltools::includeCSS(system.file('shinyquiz.css', package = "shinyquiz")),
)
}