#' Check Requirements to Run 'shinybreakpointServer'
#'
#' @param keyEvent passed from 'shinybreakpointServer'.
#' @param id passed from 'shinybreakpointServer'.
#' @param varName passed from 'shinybreakpointServer'.
#'
#' @import shiny
#' @noRd
check_requirements_shinybreakpointServer <- function(keyEvent, id, varName) {
if (!length(keyEvent) == 1 || !is.character(keyEvent) || is.na(keyEvent) || keyEvent == "") {
stop("'keyEvent' must be of type character of length 1 and can't be NA or empty character.",
call. = FALSE)
}
if (!length(id) == 1 || !is.character(id) || is.na(id) || id == "") {
stop("'id' must be of type character of length 1 and can't be NA or empty character.",
call. = FALSE)
}
if (!length(varName) == 1 || !is.character(varName) || is.na(varName) || varName == "") {
stop("'varName' must be of type character of length 1 and can't be NA or empty character.",
call. = FALSE)
}
if (is.null(getDefaultReactiveDomain())) {
stop("No session object was found. This could mean that 'shinybreakpointServer()' was not used in the 'server' part of Shiny app as it should.",
call. = FALSE)
}
}
#' Check if Expression is a Named Function
#'
#' @param expr expression returned by 'parse()'.
#'
#' @return logical length 1.
#' @details
#' 'shiny::*' expr after coercing to character returns character length 3: double colon, package name
#' and function name. Because we need only function name, it is neccesary to use 'rev' - it is safe
#' if used for character length 1.
#' @noRd
is_named_fun <- function(expr) {
expr_3 <- try(expr[[3]], silent = TRUE)
if (!inherits(expr_3, "try-error")) {
has_assignment(expr) && is.call(expr_3) && rev(as.character(expr_3[[1]]))[[1]] == "function"
} else {
FALSE
}
}
#' Check if Expression Has Assignment
#'
#' @param expr expression returned by 'parse()'.
#'
#' @return logical length 1.
#' @noRd
has_assignment <- function(expr) {
is.call(expr) && as.character(expr[[1]]) %in% c("<-", "<<-", "=", "assign")
}
#' Check if Expression is Reactive Context
#'
#' @param expr expression returned by 'body()'.
#'
#' @return logical length 1.
#' @details
#' 'shiny::*' expr after coercing to character returns character length 3: double colon, package name
#' and function name. Because we need only function name, it is neccesary to use 'rev' - it is safe
#' if used for character length 1.
#' @noRd
is_reactive_context <- function(expr) {
is.call(expr) && grepl(get_reactive_context_regex(),
rev(as.character(expr[[1]]))[[1]], perl = TRUE)
}
#' Get Regular Expression to Indicate Reactive Context
#'
#' @return character length 1.
#' @noRd
get_reactive_context_regex <- function() {
"^reactive$|^eventReactive$|^observe$|^observeEvent$|^render"
}
#' Get Regular Expression to Indicate Functions Which Can Have Label Parameter
#'
#' @return character length 1.
#' @details
#' Needed to find dependencies based on input or output Id.
#' In reactlog there is no source reference for observers,
#' objects inside `bindEvent` or labelled reactives not binded to name, so
#' we need to find them based on parse data and labels.
#' @noRd
get_labelled_objects_regex <- function() {
"^observe$|^observeEvent$|^reactive$|^eventReactive$|^bindEvent$"
}
#' Return Second Object If First One is %empty%
#'
#' %empty% means: NULL or empty string ("")
#'
#' @param lhs left hand object
#' @param rhs right hand object
#'
#' @return
#' One of the argument depending on type / value of lhs
#' @noRd
`%empty%` <- function(lhs, rhs) {
if (is.null(lhs) || lhs == "") rhs else lhs
}
#' Check If Any Ids Are Duplicated In Data Retrieved From [reactlog]
#'
#' Used in shiny::validate() as a custom error message.
#'
#' @param ids_data collection of ids and other data from [reactlog], returned by `prepare_dependency_df_and_ids_data`
#'
#' @return
#' NULL if no duplicated ids or string if at least
#' one id (label!) is duplicated as well as list with duplicated ids (labels!).
#' @details
#' We need to be sure that Ids (i.e. labels from [reactlog]) are unique, because later we would have
#' problems with retrieving dependencies for chosen Id. Problem is that although in Shiny Ids should
#' be unique, we have rather labels than ids, i.e. labels from observers as well as names of reactives
#' are also in the same vector as Ids. That's why it is quite probably that Ids (labels) may be duplicated
#' if App wasn't developed keeping in mind that Ids and reactives and observers needs to have unique names.
#' @noRd
check_duplicated_ids <- function(ids_data) {
if (any(duplicated(ids_data$label))) {
paste0("These Ids or labels are duplicated: ",
paste0(unique(ids_data$label[duplicated(ids_data$label)]), collapse = ", "),
". Use only unique Ids and labels.")
} else {
NULL
}
}
#' Insert CSS dependency.
#'
#' @return
#' htmltools::htmlDependency object with CSS.
#' @noRd
insert_css <- function() {
htmltools::htmlDependency("shinybreakpoint-css",
version = utils::packageVersion("shinybreakpoint"),
package = "shinybreakpoint",
src = "www",
stylesheet = "css/shinybreakpoint.css")
}
#' Add 'span' Tag with Given Classes to the Parts of String
#'
#' It allows to colorize the parts of string according to the classes.
#'
#' @param code character length 1.
#'
#' @return
#' Used for side effect - string will be inserted again into the HTML element, but
#' with the `dangerouslySetInnerHTML` mode (available in React),
#' so the HTML code won't be escaped and thus colors will be visible.
#' @import shiny
#' @noRd
colorize_code <- function() {
readLines(file.path(system.file("www", package = "shinybreakpoint"),
"js",
"colorize_code.js"))
}
#' Suppress Note If Package Namespace Is Not Used
#'
#' @return
#' This function should not be used.
#' @details
#' Although `shinybreakpoint` works without
#' packages `reactlog` and `bslib`, these
#' packages should be installed when `shinybreakpoint`
#' is installed, because snippet adds functions from
#' these packages to the appended code.
#' @noRd
add_package_to_import_without_notes <- function() {
invisible(formals(reactlog::reactlog_disable))
invisible(formals(bslib::bootstrap))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.