#' The scribe-function for \code{LG_shiny_interface_1_TS_info}
#'
#' @description This internal function is a scribe for the
#' "old-branch"-parameters from the \code{LG_shiny}-interface.
#'
#' @param .env The environment where the \code{TS_logging}-object
#' lives.
#'
#' @param .env2 The environment containing the two lists \code{input}
#' and \code{output}.
#'
#' @details This helper-function will check if any changes in the top
#' level of the interface for the \code{LG_shiny}-function implies
#' that an update of stored values should be undertaken. In
#' addition it will perform the initial adjustments of the
#' \code{TS_info} part of the \code{input_triggers}, in order for
#' the possibility of auto-select to work as intended in the main
#' function.
#'
#' @return This scribe-function reads and writes to the internal
#' \code{TS_logging}-object that keeps track of the
#' \code{LG_shiny}-interface.
#'
#' @keywords internal
LG_shiny_interface_1_TS_info_scribe <- function(.env, .env2) {
## The first time this function is called, it might be some
## 'pre-selected values that still ought to be added to the
## selected values. This should only happen once.
if (.env$.first_time)
on.exit(.env$.first_time <- FALSE)
## Create a helper-function to perform a pesky repeated test, to
## see if the value of interest is of the problematic type.
.not_na_select <- function(.pos) {
.x <- .bm[.pos]
if (is.na(.x)) {
FALSE
} else
! stringr::str_detect(string = .x, pattern = "[Ss]elect")
}
## Check the information in the 'TS_info'-part of
## 'input_triggers', and figure out if a valid
## environment-bookmark can be constructed.
.bm <- unlist(.env$TS_logging$update$input_triggers$TS_info)
## Reminder: The test for validity is that neither 'NA'-values
## nor "Select..." occurs in any of the three first positions
## ("TS_key", "TS", and "Approx"). The "Boot_Approx" is a
## subnode of "Approx", and can thus be excluded.
.valid_bm <- all(vapply(X = seq_along(head(.bm, -1)),
FUN = .not_na_select,
FUN.VALUE = logical(1)))
if (.valid_bm) {
## Write the 'input'-values to the logging-environment
LG_shiny_interface_0_RW_log(.env, .env2, .RW = "W")
## Reset the values logged for the actionButtons.
.env$TS_logging$update$input_triggers$TCS_type[] <- 0L
.env$TS_logging$update$input_triggers$second_graphical[] <- 0L
LG_shiny_set_values(.env, .env2,
.part =c("TCS_type", "second_graphical"))
}
kill(.valid_bm)
## Identify the position where the 'input'-value differs from the
## value registered in the 'input_trigger'.
.new_values <- unlist(.env$input[names(.bm)])
## Reminder: Normally, this function will not be called unless
## there is a difference between the values in '.bm' and
## '.new_values', but in the initiation phase they will by
## construction be identical, and that must be taken into account
## when we look for the position of the relevant starting point.
if (identical(.bm, .new_values)) {
.first_time_not_NA <- !is.na(.bm)
## Terminate if nothing has been recorded.
if (!any(.first_time_not_NA)) {
return(NULL)
} else {
## Identify the position of the last non-NA-value, and use
## that as a starting point.
.pos <- max(which(.first_time_not_NA))
}
} else {
## Find the position of the difference.
for (.pos in seq_along(.bm)) {
if (! identical(x = .new_values[.pos],
y = .bm[.pos]))
break
}
}
## Update the 'TS_info'-part of '.env$TS_logging' (using the '.bm'
## as intermediate to get more compact code). Start by setting
## all the parts of '.bm' that are going to be updated to 'NA'.
## In case there are insufficient data available to perform a
## full update, this will avoid errors concerning invalid paths
## later on in the code.
.bm[.pos:length(.bm)] <- NA
.bm[.pos] <- .new_values[.pos]
## Reset the stored slider-names for the parts after position
## number '.pos' to 'NA'. (Not meaningful to do when 'pos' is
## equal to '4'.)
if (.pos < 4) {
.env$TS_logging$update$select_names[(.pos+1):4] <- NA_character_
## ## ## Hopefully the above part will soon be obsolete.
for (.p in (.pos+1):4)
.env$TS_logging$update$select_Input[[.p]]$names <- NA_character_
kill(.p)
}
## Update the relevant 'last'-value in 'TS_logging'.
if (.pos == 1) {
.env$TS_logging$last <- .new_values[.pos]
} else
.env$TS_logging[[.bm[1:(.pos-1)]]]$last <- .new_values[.pos]
kill(.new_values)
## If the replaced position refers to a "Select..."-case, then it
## only remains to update the 'input_triggers' and terminate.
if (!.not_na_select(.pos)) {
.env$TS_logging$update$input_triggers$TS_info[] <- .bm
return(NULL)
}
## Still running? If so we need to see how much of the interface
## that can be extracted from the available data. First of all:
## If '.pos' is '1', then use the 'last'-node to fill in the
## second position of the 'input_triggers'. This could be an
## 'NA'-value or a "Select..."-case, and adjustments due to that
## is necessary in the auto-selection procedure.
if (.pos == 1) {
## Update 'input_triggers' and 'select_names' for 'TS'
.env$TS_logging$update$select_names$TS <-
.env$TS_logging[[.bm[1:.pos]]]$names
.env$TS_logging$update$select_Input$TS$label <-
.env$TS_logging[[.bm[1:.pos]]]$label
.env$TS_logging$update$select_Input$TS$selected <-
.env$TS_logging[[.bm[1:.pos]]]$last
.env$TS_logging$update$select_Input$TS$choices <-
c(.env$TS_logging[[.bm[1:.pos]]]$header,
.env$TS_logging[[.bm[1:.pos]]]$names)
.bm[.pos+1] <- .env$TS_logging[[.bm[1:.pos]]]$last
if (!.not_na_select(.pos+1)) {
.env$TS_logging$update$input_triggers$TS_info[] <- .bm
return(NULL)
} else {
## A minor update of the non-reactive 'input'-list is
## needed for the next part to work properly.
.env$input$TS <- .env$TS_logging$update$select_Input$TS$selected
.pos <- .pos + 1
}
}
## The case where '.pos' is equal to '2' implies a new value for
## "TS". In this case we might need to load the relevant
## info-object (if it is the first time that TS-node is being
## visited), and extract the desired information about the
## available "Approx"- and "Boot_Approx"-nodes.
if (.pos == 2) {
.TS_node <- .bm[c("TS_key", "TS")]
## The first time this node is visited, it is necessary to
## load the info-object to get hold of the information.
if (!.env$TS_logging[[.TS_node]]$visited) {
.env$TS_logging[[.TS_node]]$visited <- TRUE
## Load the 'info'-file.
load(file = file.path(
paste(c(.env$main_dir,
.bm["TS"]),
collapse = .Platform$file.sep),
LG_default$info_file_name),
envir = .env)
## Detect the relevant names of the "Approx"-nodes.
.env$TS_logging[[.TS_node]]$names <-
names(.env$info)[str_detect(
string = names(.env$info),
pattern = LG_default$folder_defaults["approx.dir"])]
## Add information for 'label', 'header' and 'last'
.env$TS_logging[[.TS_node]]$label <- ifelse(
test = length(.env$TS_logging[[.TS_node]]$names) == 1,
yes = "Auto-selected the only available approximation",
no = sprintf("%s approximations available",
length(.env$TS_logging[[.TS_node]]$names)))
if (length(.env$TS_logging[[.TS_node]]$names) > 1) {
.env$TS_logging[[.TS_node]]$header <- "Select an approximation"
} else {
.env$TS_logging[[.TS_node]]$header <- character(0)
}
if (length(.env$TS_logging[[.TS_node]]$names) == 1) {
.env$TS_logging[[.TS_node]]$last <- .env$TS_logging[[.TS_node]]$names
} else {
.env$TS_logging[[.TS_node]]$last <- .env$TS_logging[[.TS_node]]$header
}
## Override the previous values when no data are available.
if (length(.env$TS_logging[[.TS_node]]$names) == 0) {
.env$TS_logging[[.TS_node]]$last <- "Nothing here to select"
.env$TS_logging[[.TS_node]]$label <- "No approximations detected"
.env$TS_logging[[.TS_node]]$header <- "Nothing here to select"
}
## For the approx-parts: Add a bookkeeping-environment to
## keep track of all the relevant values.
for (.part in .env$TS_logging[[.TS_node]]$names) {
.env$TS_logging[[.TS_node]] <- c(
.env$TS_logging[[.TS_node]],
LG_shiny_interface_1_helper(
.env = .env,
.approx = .part))
}
kill(.part)
}
## Update the 'select_names' for "Approx".
.env$TS_logging$update$select_names$Approx <-
.env$TS_logging[[.TS_node]]$names
.env$TS_logging$update$select_Input$Approx$label <-
.env$TS_logging[[.TS_node]]$label
.env$TS_logging$update$select_Input$Approx$selected <-
.env$TS_logging[[.TS_node]]$last
.env$TS_logging$update$select_Input$Approx$choices <-
c(.env$TS_logging[[.TS_node]]$header,
.env$TS_logging[[.TS_node]]$names)
## The first time this function is used, it might be some
## 'pre-selected values hanging around.
if (all(.env$.first_time,
!is.na(.env$pre_selected$Approx))) {
.env$TS_logging$update$select_Input$Approx$selected <- .env$pre_selected$Approx
.env$TS_logging[[.TS_node]]$last <- .env$pre_selected$Approx
.env$TS_logging$update$input_triggers$TS_info$Approx <- .env$pre_selected$Approx
}
## Add information to the next position of the
## 'input_triggers', and check if it is possible to continue,
## or if it is necessary to wait for further input from the
## interactive user-interface.
.bm[.pos+1] <- .env$TS_logging[[.TS_node]]$last
.env$TS_logging$update$input_triggers$TS_info[] <- .bm
if (.not_na_select(.pos+1)) {
.pos <- .pos + 1
} else
return(NULL)
kill(.TS_node)
}
## The case where '.pos' is equal to '3' indicates that it might
## or might not be bootstrap-values available. For simulated
## data there never will be any bootstrap-nodes, whereas it for
## real data might not have been computed yet. Nevertheless, this
## part of the code does not need to worry about that, since the
## stored default 'NA'-values will trigger the desired behaviour
## in the workers arriving later on.
if (.pos == 3) {
.TS_node <- .bm[1:.pos]
## Update the 'select_names' for "Boot_Approx".
.env$TS_logging$update$select_names$Boot_Approx <-
.env$TS_logging[[.TS_node]]$names
.env$TS_logging$update$select_Input$Boot_Approx$label <-
.env$TS_logging[[.TS_node]]$label
.env$TS_logging$update$select_Input$Boot_Approx$selected <-
.env$TS_logging[[.TS_node]]$last
.env$TS_logging$update$select_Input$Boot_Approx$choices <-
c(.env$TS_logging[[.TS_node]]$header,
.env$TS_logging[[.TS_node]]$names)
## Register if we do have an actual bootstrap-node
.env$TS_logging$update$is_bootstrap <-
.env$TS_logging[[.TS_node]]$is_bootstrap
## Update the 'input_triggers' and return.
.bm[.pos+1] <- .env$TS_logging[[.TS_node]]$last
.env$TS_logging$update$input_triggers$TS_info[] <- .bm
## Read information from 'TS_logging' into the 'input'-lists
LG_shiny_interface_0_RW_log(.env, .env2, .RW="R")
return(NULL)
}
## The case where '.pos' is equal to '4' indicates that we have
## an actual bootstrap-node. The only thing that is required now
## is to update the 'input_triggers' and return.
if (.pos == 4) {
## Update the 'input_triggers'
.env$TS_logging$update$input_triggers$TS_info[] <- .bm
## Find the correct environment and update the required parts
## of the logging-structure
..env <- LG_shiny_interface_0_RW_log(.env, .env2)
..env$last <- .bm[.pos]
.env$TS_logging$update$select_Input$Boot_Approx$selected <- .bm[.pos]
## Read information from 'TS_logging' into the 'input'-lists
LG_shiny_interface_0_RW_log(.env, .env2, .RW="R")
return(NULL)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.