save_question_submission <- function(session, label, question, answer) {
save_object(
session = session,
object_id = label,
tutorial_object("question_submission", list(
api_version = 1,
question = question,
answer = answer
))
)
}
save_reset_question_submission <- function(session, label, question) {
save_object(
session = session,
object_id = label,
tutorial_object("question_submission", list(
question = question,
reset = TRUE
))
)
}
save_exercise_submission <- function(session, label, code, output, error_message, checked, feedback) {
# for client storage we only forward error output. this is because we want
# to replay errors back into the client with no execution (in case they were
# timeout errors as a result of misbehaving code). for other outputs the client
# will just tickle the inputs to force re-execution of the outputs.
storage <- tutorial_storage(session)
if (identical(storage$type, "client")) {
if (!is.null(error_message) && !identical(error_message, ""))
output <- error_message_html(error_message)
else
output <- NULL
}
# save object
save_object(
session = session,
object_id = label,
tutorial_object("exercise_submission", list(
code = code,
output = output,
checked = checked,
feedback = feedback
))
)
}
save_section_skipped <- function(session, sectionId) {
save_object(
session = session,
object_id = ns_wrap("section_skipped", sectionId),
tutorial_object("section_skipped", list())
)
}
save_video_progress <- function(session, video_url, time, total_time) {
save_object(
session = session,
object_id = video_url,
tutorial_object("video_progress", list(
time = time,
total_time = total_time
))
)
}
client_state_object_id <- "tutorial-client-state-825E9CBB-FF7A-4C2C-A201-A075AB758F34"
save_client_state <- function(session, data) {
save_object(
session = session,
object_id = client_state_object_id,
tutorial_object("client_state", data)
)
}
get_client_state <- function(session) {
object <- get_object(session, client_state_object_id)
if (!is.null(object))
object$data
else
list()
}
get_exercise_submission <- function(session, label) {
get_object(session = session, object_id = label)
}
get_all_state_objects <- function(session, exercise_output = TRUE) {
# get all of the objects
objects <- get_objects(session)
# strip output (the client doesn't need it and it's expensive to transmit)
objects <- lapply(objects, function(object) {
if (object$type == "exercise_submission") {
if (!exercise_output) {
object$data["output"] <- list(NULL)
}
}
object
})
# return objects
objects
}
filter_state_objects <- function(state_objects, types) {
Filter(x = state_objects, function(object) {
object$type %in% types
})
}
submissions_from_state_objects <- function(state_objects) {
filtered_submissions <- filter_state_objects(state_objects, c("question_submission", "exercise_submission"))
Filter(x = filtered_submissions, function(object) {
# only return answered question, not reset questions
if (object$type == "question_submission") {
!isTRUE(object$data$reset)
} else {
TRUE
}
})
}
video_progress_from_state_objects <- function(state_objects) {
filter_state_objects(state_objects, c("video_progress"))
}
section_skipped_progress_from_state_objects <- function(state_objects) {
filter_state_objects(state_objects, c("section_skipped"))
}
progress_events_from_state_objects <- function(state_objects) {
# first submissions
submissions <- submissions_from_state_objects(state_objects)
progress_events <- lapply(submissions, function(submission) {
data <- list(
label = submission$id
)
if (submission$type == "question_submission") {
data$answer <- submission$data$answer
}
else if (submission$type == "exercise_submission") {
if (!is.null(submission$data$feedback))
correct <- submission$data$feedback$correct
else
correct <- TRUE
data$correct <- correct
}
list(event = submission$type,
data = data)
})
# now sections skipped
section_skipped_progress <- section_skipped_progress_from_state_objects(state_objects)
section_skipped_progress_events <- lapply(section_skipped_progress, function(skipped) {
list(event = "section_skipped",
data = list(
sectionId = ns_unwrap("section_skipped", skipped$id)
))
})
progress_events <- append(progress_events, section_skipped_progress_events)
# now video_progress
video_progress <- video_progress_from_state_objects(state_objects)
video_progress_events <- lapply(video_progress, function(progress) {
list(event = "video_progress",
data = list(
video_url = progress$id,
time = progress$data$time,
total_time = progress$data$total_time
))
})
progress_events <- append(progress_events, video_progress_events)
# return progress events
progress_events
}
save_object <- function(session, object_id, data) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
data$id <- object_id
tutorial_storage(session)$save_object(tutorial_id, tutorial_version, user_id, object_id, data)
}
update_object <- function(object) {
if (is.null(object)) {
return(object)
}
if (identical(object$type, "question_submission")) {
api_version <- object$data$api_version
if (!is.null(api_version)) {
# if (identical(version, 1)) {
# # do nothing
# }
} else {
# as of v0.10.0...
# upgrade from old storage format to new storage format
# rename answers -> answer
object$data$answer <- object$data$answers
object$data$answers <- NULL
}
}
object
}
get_object <- function(session, object_id) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
object <- tutorial_storage(session)$get_object(tutorial_id, tutorial_version, user_id, object_id)
update_object(object)
}
get_objects <- function(session) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
objects <- tutorial_storage(session)$get_objects(tutorial_id, tutorial_version, user_id)
lapply(objects, update_object)
}
remove_all_objects <- function(session) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
tutorial_storage(session)$remove_all_objects(tutorial_id, tutorial_version, user_id)
}
initialize_objects_from_client <- function(session, objects) {
tutorial_id <- read_request(session, "tutorial.tutorial_id")
tutorial_version <- read_request(session, "tutorial.tutorial_version")
user_id <- read_request(session, "tutorial.user_id")
client_storage(session)$initialize_objects_from_client(tutorial_id,
tutorial_version,
user_id,
objects)
}
# helper to form a tutor object (type + data)
tutorial_object <- function(type, data) {
list(
type = type,
data = data
)
}
ns_wrap <- function(ns, id) {
paste0(ns, id)
}
ns_unwrap <- function(ns, id) {
substring(id, nchar(ns) + 1)
}
# get the currently active storage handler
tutorial_storage <- function(session) {
# local storage implementation
local_storage <- filesystem_storage(
file.path(rappdirs::user_data_dir(), "R", "learnr", "tutorial", "storage")
)
# function to determine "auto" storage
auto_storage <- function() {
if (getOption("shiny.testmode", default = FALSE)) {
# With shinytest, we don't want to restore state; start with a clean slate
# each time.
return(no_storage())
}
location <- read_request(session, "tutorial.http_location")
if (is_localhost(location))
local_storage
else
client_storage(session)
}
# examine the option
storage <- getOption("tutorial.storage", default = "auto")
# resolve NULL to "none"
if (is.null(storage))
storage <- "none"
# if it's a character vector then resolve it
if (is.character(storage)) {
storage <- switch(storage,
auto = auto_storage(),
local = local_storage,
client = client_storage(session),
none = no_storage()
)
}
# verify that storage is a list
if (!is.list(storage))
stop("tutorial.storage must be a 'auto', 'local', 'client', 'none' or a ",
"list of storage functions")
# validate storage interface
if (is.null(storage$save_object))
stop("tutorial.storage must implement the save_object function")
if (is.null(storage$get_object))
stop("tutorial.storage must implement the get_object function")
if (is.null(storage$get_objects))
stop("tutorial.storage must implements the get_objects function")
# return it
storage
}
#' Filesystem-based storage for tutor state data
#'
#' Tutorial state storage handler that uses the filesystem as a backing store.
#' The directory will contain tutorial state data partitioned by `user_id`,
#' `tutorial_id`, and `tutorial_version` (in that order)
#'
#' @param dir Directory to store state data within
#' @param compress Should \code{.rds} files be compressed?
#'
#' @return Storage handler suitable for \code{options(tutorial.storage = ...)}
#'
#' @export
filesystem_storage <- function(dir, compress = TRUE) {
# helpers to transform ids into valid filesystem paths
id_to_filesystem_path <- function(id) {
id <- gsub("..", "", id, fixed = TRUE)
utils::URLencode(id, reserved = TRUE, repeated = TRUE)
}
id_from_filesystem_path <- function(path) {
utils::URLdecode(path)
}
# get the path to storage (ensuring that the directory exists)
storage_path <- function(tutorial_id, tutorial_version, user_id) {
path <- file.path(dir,
id_to_filesystem_path(user_id),
id_to_filesystem_path(tutorial_id),
id_to_filesystem_path(tutorial_version))
if (!utils::file_test("-d", path))
dir.create(path, recursive = TRUE)
path
}
# functions which implement storage via saving to RDS
list(
type = "local",
save_object = function(tutorial_id, tutorial_version, user_id, object_id, data) {
object_path <- file.path(storage_path(tutorial_id, tutorial_version, user_id),
paste0(id_to_filesystem_path(object_id), ".rds"))
saveRDS(data, file = object_path, compress = compress)
},
get_object = function(tutorial_id, tutorial_version, user_id, object_id) {
object_path <- file.path(storage_path(tutorial_id, tutorial_version, user_id),
paste0(id_to_filesystem_path(object_id), ".rds"))
if (file.exists(object_path))
readRDS(object_path)
else
NULL
},
get_objects = function(tutorial_id, tutorial_version, user_id) {
objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
objects <- list()
for (object_path in list.files(objects_path, pattern = utils::glob2rx("*.rds"))) {
object <- readRDS(file.path(objects_path, object_path))
object_id <- sub("\\.rds$", "", id_from_filesystem_path(object_path))
objects[[length(objects) + 1]] <- object
}
objects
},
remove_all_objects = function(tutorial_id, tutorial_version, user_id) {
objects_path <- storage_path(tutorial_id, tutorial_version, user_id)
unlink(objects_path, recursive = TRUE)
}
)
}
# client side storage implementation. data is saved by broadcasting it to the client
# this data is subsequently restored during initialize and stored in a per-session
# in memory table for retreival
client_storage <- function(session) {
# helper to form a unique tutorial context id (note that we don't utilize the user_id
# as there is no concept of server-side user in client_storage, user scope is 100%
# determined by connecting user agent)
tutorial_context_id <- function(tutorial_id, tutorial_version) {
paste(tutorial_id, tutorial_version, sep = "-")
}
# get a reference to the session object cache for a gvien tutorial context
object_store <- function(context_id) {
# create session objects on demand
session_objects <- read_request(session, "tutorial.session_objects")
if (is.null(session_objects)) {
session_objects <- new.env(parent = emptyenv())
write_request(session, "tutorial.session_objects", session_objects)
}
# create entry for this context on demand
if (!exists(context_id, envir = session_objects))
assign(context_id, new.env(parent = emptyenv()), envir = session_objects)
store <- get(context_id, envir = session_objects)
# return reference to the store
store
}
list(
type = "client",
save_object = function(tutorial_id, tutorial_version, user_id, object_id, data) {
# save the object to our in-memory store
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
# scrub "answers" from the state stored on the client (client storage only)
data <- scrub_correct_and_feedback(data)
assign(object_id, data, envir = store)
# broadcast to client
session$sendCustomMessage("tutorial.store_object", list(
context = context_id,
id = object_id,
data = base64_enc(serialize(data, connection = NULL))
))
},
get_object = function(tutorial_id, tutorial_version, user_id, object_id) {
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
if (exists(object_id, envir = store))
get(object_id, envir = store)
else
NULL
},
get_objects = function(tutorial_id, tutorial_version, user_id) {
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
objects <- list()
for (object in ls(store))
objects[[length(objects) + 1]] <- get(object, envir = store)
objects
},
remove_all_objects = function(tutorial_id, tutorial_version, user_id) {
# remove on server side (client side is handled on client)
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
rm(list = ls(store), envir = store)
},
# function called from initialize to prime object storage from the browser db
initialize_objects_from_client = function(tutorial_id, tutorial_version, user_id, objects) {
context_id <- tutorial_context_id(tutorial_id, tutorial_version)
store <- object_store(context_id)
for (object_id in names(objects)) {
data <- unserialize(base64_dec(objects[[object_id]]))
assign(object_id, data, envir = store)
}
}
)
}
# no-op storage implementation
no_storage <- function() {
list(
type = "none",
save_object = function(tutorial_id, tutorial_version, user_id, object_id, data) {},
get_object = function(tutorial_id, tutorial_version, user_id, object_id) { NULL },
get_objects = function(tutorial_id, tutorial_version, user_id) { list() },
remove_all_objects = function(tutorial_id, tutorial_version, user_id) {}
)
}
scrub_correct_and_feedback <- function(data) {
if (is.null(data)) {
return(data)
}
if (identical(data$type, "question_submission")) {
data$data$correct <- NULL
}
if (identical(data$type, "exercise_submission")) {
data$data$feedback <- NULL
}
data
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.