manage_sessions <- function(state,
opt,
session = shiny::getDefaultReactiveDomain()) {
manage_url_params(state, session, opt)
if (opt$enable_resume_session) {
manage_p_id(state, session, opt)
# list(shiny::observe(save_session(state, opt = opt)),
# clean_session_dir(session = session, opt = opt))
#
# clean_session_dir was originally used to iterate over all the files in
# the session directory and delete old ones. However it seemed to
# produce rare errors with the following traceback:
#
# Warning: Error in gzfile: all connections are in use
# 48: gzfile
# 47: readRDS
# 46: read_timestamp
# 45: ::
#
# This may be due to the fact that the process ends up iterating
# over very many files at the same time.
# On reflection, this process seems unnecessary, we don't need to
# delete this old data, so this functionality has now been disabled.
shiny::observe(save_session(state, opt = opt))
}
}
manage_url_params <- function(state, session, opt) {
shiny::isolate({
url_params(state) <- get_url_params_from_browser(session)
language <- get_url_params(state)$language
if (is.null(language) || !language %in% opt$languages) {
language <- opt$languages[1]
set_url_param("language", language, session, state)
}
language(state) <- language
})
}
manage_p_id <- function(state, session, opt) {
shiny::isolate({
p_id_url <- get_url_params(state)$p_id
if (!is.null(p_id_url)) {
if (is_p_id_valid(p_id_url)){
try_resume_session(p_id = p_id_url, state, session, opt,
ask_to_confirm_resume = TRUE,
reset_if_resume_fails = !opt$allow_any_p_id_url)
} else {
error(state) <- describe_valid_p_id()
allow_session_saving(state) <- FALSE
}
} else {
if (opt$force_p_id_from_url) {
error(state) <- "p_id parameter must be provided through the URL."
allow_session_saving(state) <- FALSE
} else if (opt$auto_p_id) {
p_id <- generate_new_p_id(opt)
p_id(state) <- p_id
set_url_param("p_id", p_id, session, state)
}
}
})
}
get_url_params_from_browser <- function(session) {
shiny::parseQueryString(session$clientData$url_search)
}
# get_p_id_from_url <- function(session) {
# shiny::parseQueryString(session$clientData$url_search)$p_id
# }
#' Set a URL parameter
#'
#' Sets a URL parameter.
#' @param key URL parameter key.
#' @param value URL parameter value.
#' @param session The participant's \code{session} object.
#' @param state The participant's \code{state} object.
#' @export
set_url_param <- function(key, value, session, state) {
stopifnot(is.scalar(value), is.scalar.character(key))
# if (key == "p_id") stop("p_id is a protected URL parameter")
# params <- shiny::parseQueryString(session$clientData$url_search)
params <- get_url_params(state)
params[[key]] <- as.character(value)
set_url_params(params, session, state)
}
set_url_params <- function(params, session, state) {
if (!allow_url_rewrite(state)) return(NULL)
stopifnot(is.list(params))
keys <- vapply(names(params), function(x) utils::URLencode(x, reserved = TRUE,
repeated = TRUE),
character(1))
values <- vapply(params,
function(x) utils::URLencode(x, reserved = TRUE,
repeated = TRUE),
character(1))
str <- paste0("?", paste(paste(keys, values, sep = "="),
collapse = "&"))
shiny::updateQueryString(str, mode = "replace", session = session)
url_params(state) <- params
}
# push_p_id_to_url <- function(p_id, session) {
# session$sendCustomMessage("push_p_id_to_url", p_id)
# }
try_resume_session <- function(p_id, state, session, opt,
ask_to_confirm_resume,
reset_if_resume_fails) {
stopifnot(is.scalar.character(p_id),
is.scalar.logical(ask_to_confirm_resume),
is.scalar.logical(reset_if_resume_fails))
p_id(state) <- p_id
set_url_param(key = "p_id", value = p_id, session, state)
data <- safe_load_session(p_id, opt)
success <- !is.null(data)
if (success) {
if (ask_to_confirm_resume) {
shinyjs::runjs("confirm_resume_session();")
} else {
shiny::showNotification("Resuming previous session.")
}
state$update_data(passive = data$passive, reactive = data$reactive)
set_url_params(get_url_params(state), session, state)
increment_num_restarts(state)
if (!is_test_closed(opt)) closed(state) <- FALSE
} else {
if (reset_if_resume_fails) {
shinyjs::alert(paste0("Failed to load this user's testing session.\n",
"Beginning a new session."))
shinyjs::runjs("reset_p_id_and_refresh_browser();")
allow_session_saving(state) <- FALSE
} else {
shiny::showNotification("Starting new session.")
}
}
success
}
generate_new_p_id <- function(opt) {
p_id <- NA
R.utils::mkdirs(opt$session_dir)
while (is.na(p_id)) {
candidate <- generate_id(32)
is_unique <- dir.create(file.path(opt$session_dir, candidate),
showWarnings = FALSE)
if (is_unique) {
p_id <- candidate
save_timestamp(opt, p_id)
}
}
p_id
}
save_session <- function(state, opt) {
stopifnot(is(state, "state"), is.scalar.character(opt$session_dir))
p_id <- p_id(state)
if (!is.null(p_id) && allow_session_saving(state)) {
path.p_id <- file.path(opt$session_dir, p_id)
path.data <- file.path(path.p_id, "data.RDS")
R.utils::mkdirs(path.p_id)
state$save_data(path.data)
save_timestamp(opt, p_id)
}
}
load_session <- function(p_id, opt) {
path <- file.path(opt$session_dir, p_id, "data.RDS")
x <- readRDS(path)
if (identical(x$format, STATE_RDS_FORMAT)) {
x
} else {
warning("failed to load session with out-of-date format")
NULL
}
}
safe_load_session <- function(p_id, opt) {
res <- NULL
tryCatch(res <- load_session(p_id, opt),
warning = function(w) NULL,
error = function(e) NULL)
res
}
save_timestamp <- function(opt, p_id) {
stopifnot(is.scalar.character(p_id), is.scalar.character(opt$session_dir))
saveRDS(Sys.time(), file.path(opt$session_dir, p_id, "timestamp.RDS"))
}
# Returns NA if no timestamp found
read_timestamp <- function(opt, p_id) {
stopifnot(is.scalar.character(p_id), is.scalar.character(opt$session_dir))
path <- file.path(opt$session_dir, p_id, "timestamp.RDS")
if (file.exists(path)) readRDS(path) else NA
}
# Deletes all session caches that are older than a certain amount.
clean_session_dir <- function(session, opt) {
stopifnot(is.scalar.numeric(opt$session_timeout_min),
is.scalar.numeric(opt$clean_sessions_interval_min),
is.scalar.character(opt$session_dir))
millis <- opt$clean_sessions_interval_min * 60 * 1000
shiny::observe({
shiny::invalidateLater(millis, session)
dirs <- list.dirs(opt$session_dir, recursive = FALSE)
for (dir in dirs) {
p_id <- basename(dir)
time <- read_timestamp(opt, p_id)
if (!is.na(time) && time < Sys.time() - opt$session_timeout_min * 60) {
unlink(dir, recursive = TRUE)
}}})}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.