ok, thanks, what do I do if I need a dynamically changing number of reactive objects?
also, in the full version my renderUI is being called within an observeEvent, because clicking a button triggers the next set of plots to be created for the UI
source("stats_game_text_elements.R")
source("stats_game_worlddata.R")
source("basic_statistics_generator.R")
source("basic_plot_generator.R")
library(cli)
library(greekLetters)
library(RColorBrewer)
library(truncnorm)
library(TruncatedDistributions)
# library(truncdist) ## IMPORTANT: CANNOT use the truncdist package because it uses the "stats4" package which clashes with shiny and shinyjs, and you can't just load shiny and shinyjs libraries after loading truncdist, that doesn't help
# library(cascsim) # For the truncated gamma distribution functions
library(shinyvalidate)
library(rjson)
library(shinyjs)
setup_question_stats <- function() {
stats <- c("num_correct","num_attempted","num_questions","percent_correct","percent_attempted")
topics <- c("overall","basic_stats")
ntopics <- length(topics)
question_stats <- as.data.frame(matrix(rep(0,ntopics*5), nrow=ntopics, dimnames=list(topics,stats)))
}
update_question_stats <- function(question_stats, level_answers, level_topic) {
current <- unlist(question_stats['overall',])
current[1:3] <- current[1:3] +
c(sum(level_answers, na.rm=TRUE),
sum(!is.na(level_answers)),
length(level_answers))
current[4:5] <- current[1:2]/current[3]*100
question_stats['overall',] <- current
topic <- unlist(question_stats[level_topic,])
topic[1:3] <- topic[1:3] +
c(sum(level_answers, na.rm=TRUE),
sum(!is.na(level_answers)),
length(level_answers))
topic[4:5] <- topic[1:2]/topic[3]*100
question_stats[level_topic,] <- topic
question_stats
}
server <- function(input, output, session){
# Retrieving files needed
source("user.R", local=TRUE)
iv <- InputValidator$new()
iv$add_rule("username", sv_required())
iv$add_rule("username", function(value) {
if (grepl("[^A-Za-z]", value)) {
"Username can only contain letters"
}
})
max_level <- 7
first_level <- 6
# Option for whether to instantly display the question answers or not
level_answers_immediate_display <- TRUE
# Set up the world object and a few question objects at session level
world <- generate_user_world("")
level_topic <- NULL
generated_questions <- NULL
displayed <- vector
level_answers <- vector()
progress <- reactiveValues(level=first_level, done_intro=FALSE,
question_stats=setup_question_stats())
plots <- list()
nplots <- reactiveVal(0)
current_plot <- reactiveVal(1)
nquestions <- reactiveVal(0)
current_question <- reactiveVal(1)
output$introText <- renderText({intro_text})
output$endText <- renderText({"Sorry, that's the end of the game, you can't go any further yet. If you want to practise more, you can start again as a new user, and you'll get different answers for the questions."})
output$progressText <- renderText({
paste0("You have got ",round(progress$question_stats['overall','percent_correct']),
"% of the questions correct overall and ",
round(progress$question_stats['basic_stats','percent_correct']),
"% correct for the basic stats levels.")
})
observeGameStartButton <- observe({
# show("userPage")
show("levelPage")
hide("startPage")
})
bindEvent(observeGameStartButton, input$gameStartButton)
# Setup level ----
observeNewLevel <- observe({
if (progress$level <= max_level) {
levelText <- renderText({level_text[[progress$level]]})
# plots <- list()
switch(as.character(progress$level),
"1" = {
level_topic <<- "basic_stats"
samples <- generate_samples(world$seed, 2, world$streams)
generated_questions <<- generate_sample_question_set(samples, "lowest")
plots <<- prepare_summary_stat_barplots(samples)
},
"2" = {
level_topic <<- "basic_stats"
generated_questions <<- generate_variable_type_question_set(level=2)
},
"3" = {
level_topic <<- "basic_stats"
generated_questions <<- generate_weather_questions(world$monthly_weather)
plots <<- prepare_weather_plots(world$monthly_weather)
},
"4" = {
level_topic <<- "basic_stats"
generated_questions <<- generate_histogram_question_set(world$daily_weather$windspeed)
plots <<- prepare_histogram(world$daily_weather$windspeed)
},
"5" = {
level_topic <<- "basic_stats"
samples <- generate_samples(1, 2, world$shelter_materials)
generated_questions <<- generate_boxplot_question_set(samples)
plots <<- prepare_boxplot(samples, "Total rain leaked (mm)")
},
"6" = {
level_topic <<- "basic_stats"
generated_questions <<- generate_scatterplot_question_set(world$trauma_assessments, linear=TRUE)
plots <<- prepare_scatterplot(world$trauma_assessments)
})
current_question(0)
nquestions(length(generated_questions$qna))
level_answers <<- rep(NA, nquestions())
current_plot(1)
nplots(length(plots))
if (nplots() < 2) {
hide("plotLeftButton")
hide("plotRightButton")
} else {
show("plotLeftButton")
show("plotRightButton")
}
# use renderUI to create a dynamic number of output ui elements
output$plots_ui <- renderUI({
nump <- nplots()
if (nump == 1) {
output$plot_1 <- renderPlot({
# plot(1:10)
plots[[1]]
})
tagList(
plotOutput("plot_1")
)
} else if (nump > 1) {
lapply(1:nump, function(i) {
output_name <- paste0("plot_", i)
output[[output_name]] <- renderPlot({
# plot.new()
# replayPlot(plots[[i]])
plots[[i]]
})
if (i == 1) {
tagList(
plotOutput(
outputId = paste0("plot_", i),
))
} else {
tagList(
hidden(plotOutput(
outputId = paste0("plot_", i),
)))
}
})
}
})
} else {
show("endPage")
hide("levelPage")
}
output$levelText <- renderText({paste0("This is level ",progress$level,".")})
show("levelPage")
hide("introPage")
hide("progressPage")
})
bindEvent(observeNewLevel, input$progressNextButton, input$introNextButton,
input$gameStartButton, ignoreInit=TRUE)
observePlotLeftButton <- observe({
i <- current_plot()
if (i > 1) {
current_plot(i-1)
hide(paste0("plot_",i))
show(paste0("plot_",i-1))
}
if (i == 2) {
disable("plotLeftButton")
}
enable("plotRightButton")
})
bindEvent(observePlotLeftButton, input$plotLeftButton)
observePlotRightButton <- observe({
i <- current_plot()
if (i < nplots()) {
current_plot(i+1)
hide(paste0("plot_",i))
show(paste0("plot_",i+1))
}
if (i == (nplots() - 1)) {
disable("plotRightButton")
}
enable("plotLeftButton")
})
bindEvent(observePlotRightButton, input$plotRightButton)
}
