#' UI Module
#'
#' Add keydown listener.
#'
#' @param id from 'shinybreakpointServer'. Can be chosen by user.
#'
#' @return HTML script tag with JavaScript code - returns
#' key pressed.
#' @import shiny
#' @noRd
shinybreakpointUI <- function(id) {
ns <- NS(id)
key_pressed <- ns("key_pressed")
js_key <- glue::glue_safe('
document.addEventListener("keydown", function(e) {{
Shiny.setInputValue("{key_pressed}", e.key, {{priority: "event"}});
}});
')
singleton(tags$head(tags$script(HTML(js_key))))
}
#' Use Module to Set Breakpoint
#'
#' Module of Shiny app needed to enable functionality to
#' setting breakpoint. Must be used in the `server` part of
#' Shiny app or in the function which is then used in the
#' `server` part of app.
#'
#' @param keyEvent key to run modal dialog with the functionality
#' to set breakpoint. `"F4"` by default.
#' @param id namespace used for all inputs and outputs in this module.
#' `"shinybreakpoint"` by default. Change if in the app some
#' other module is used which already has `"shinybreakpoint"`
#' namespace.
#' @param varName setting breakpoint is not equal to inserting only
#' `browser()`, but also additional code, one of which is assignment
#' operation. This parameter determines the variable name to assign
#' value. `"....envirr"` by default. Change if this name is already
#' in use somewhere in the app.
#'
#' @return
#' Used for side effect - adds modal dialog to the Shiny app
#' with the options to set breakpoint. Modal dialog is shown
#' when the key specified in `keyEvent` is pressed.
#'
#' @section App structure:
#'
#' One of the core concepts which founds this module is the
#' necessity to re-run the objects present in the `server`
#' part of app. This is possible only when these objects
#' do not live directly in the `server`, but in the function
#' which is then used in `server`. This naturally harmonizes
#' with the modules, but it needs the separate function for
#' objects which would be used directly in the `server`.
#'
#' `shinybreakpointServer` module was developed having Bootstrap 5
#' in mind, that's why it is recommended to use [bslib::bs_theme()]
#' to set up Bootstrap 5. Otherwise the UI experience will be
#' worse.
#'
#' Possibility to filter reactive context depending on specific
#' `input` or `output` needs [shiny::reactlog()] enabled,
#' which is done by [shinybreakpoint::set_filtering_by_id()]. This line
#' of code needs to be removed before app will be sent to production
#' (which is of course true also for
#' `shinybreakpoint::shinybreakpointServer()` line).
#'
#' See example section below for the idea of how to include all of this
#' requirements in the app. This can also be done by
#' [shinybreakpoint::snippet()] for new apps.
#'
#' @section Filtering by Id:
#'
#' **Filtering by Id is very experimental and may fail in not yet fully understandable way.**
#'
#' As long as [shiny::reactlog()] is enabled (by function
#' [shinybreakpoint::set_filtering_by_id()], because this function
#' is responsible also to manage some needed files in temporary directory, i.e.
#' it won't be enough to just use `options(shiny.reactlog = TRUE)` or similar),
#' it is possible to filter displayed source code based on `input`
#' or `output` Id, i.e. only the relevant source code
#' (`reactive`s, `observe`s and `render*` functions)
#' will be shown. Two modes are available:
#'
#' * Last changed input - last changed input is tracked automatically, i.e.
#' nothing special needs to be done.
#' * Chosen Id - by holding `Ctrl` on PC or `Cmd` on Mac and hovering mouse
#' over `input` or `output`, Id for this element will be saved (which will
#' be indicated by displaying cursor of type 'progress' for a moment).
#'
#' To successfully see all relevant source code for Id, it is necessary
#' to ensure that code inside `reactive`s, `observe`s and `render*` functions
#' is in curly (`{}`) brackets and that `observe`s as well as [shiny::bindEvent()]
#' (if used) have label, i.e. *string* is passed *directly* to the `label`
#' parameter. Label needs to be unique across all labels *and* Ids. Additionally,
#' if [shiny::bindEvent()] is used on `render*` function, label must be *the same as*
#' the `output` Id. Because in this last case Id is masked by [shiny::bindEvent()],
#' there is no afraid that label and Id won't be unique.
#'
#' **`Q` option (exit) can't be use in debug mode to properly use filtering by `Id`**. Please
#' use `c` or `f` to close the debug mode - this will return to the app and
#' then app can be stopped in usual way if needed.
#'
#' @export
#' @import shiny
#' @importFrom magrittr %>%
#' @examples
#' # To run example, copy-paste to file, save
#' # the file and run the app. Then press "F4"
#' # to open the modal dialog.
#'
#' \dontrun{
#'
#' library(shiny)
#'
#' shinybreakpoint::set_filtering_by_id() # TODO: remove
#'
#' appServer <- function(input, output, session) {
#' observe({
#' input$num
#' }, label = "observe_print_num_input")
#' }
#'
#' shinyApp(
#' ui = fluidPage(
#' theme = bslib::bs_theme(5),
#' numericInput("num", "Num", 0)
#' ),
#' server = function(input, output, session) {
#' shinybreakpoint::shinybreakpointServer() # TODO: remove
#' appServer(input, output, session)
#' }
#' )
#' }
shinybreakpointServer <- function(keyEvent = "F4",
id = "shinybreakpoint",
varName = "....envirr") {
check_requirements_shinybreakpointServer(keyEvent, id, varName)
insertUI("head", "beforeEnd", shinybreakpointUI(id), immediate = TRUE)
insertUI("head", "beforeEnd", get_element_id(id), immediate = TRUE)
insertUI("head", "beforeEnd", singleton(shinyjs::useShinyjs()), immediate = TRUE)
insertUI("head", "beforeEnd", insert_css(), immediate = TRUE)
caller_envir <- rlang::caller_env()
filenames_src_code_envirs <- prepare_src_code(caller_envir)
if (file.exists(file.path(tempdir(), "_shinybreakpoint_____reactlog.rds"))) {
reactlog_data <- readRDS(file.path(tempdir(), "_shinybreakpoint_____reactlog.rds"))
} else {
reactlog_data <- tryCatch(reactlog(), error = function() NULL)
if (!is.null(reactlog_data) && !all(unlist(lapply(reactlog_data, function(x) x$label) == "Theme Counter"))) {
saveRDS(reactlog_data, file.path(tempdir(), "_shinybreakpoint_____reactlog.rds"))
}
}
try(reactlogReset(), silent = TRUE)
if (length(reactlog_data) > 0 && nrow(filenames_src_code_envirs$filenames_parse_data) > 0) {
labelled_reactive_objects <- filenames_src_code_envirs$labelled_reactive_objects
binded_filenames_parse_data <- prepare_filenames_parse_data(filenames_src_code_envirs$filenames_parse_data)
dependency_df_ids_data_all_ids <- prepare_dependency_df_and_ids_data(reactlog_data, labelled_reactive_objects)
getDefaultReactiveDomain()$sendCustomMessage("shinybreakpoint_reactlog_ids", dependency_df_ids_data_all_ids$ids_data$label)
}
moduleServer(
id,
function(input, output, session) {
get_files <- reactive({
stats::setNames(filenames_src_code_envirs$filenames_parse_data$parse_data,
filenames_src_code_envirs$filenames_parse_data$filename_full_path)
}, label = "shinybreakpoint-get_files")
get_dependencies_last_input <- reactive({
validate_id(input$last_input, reactlog_data, dependency_df_ids_data_all_ids$ids_data)
get_dependencies_set_names(input$last_input,
find_dependencies,
binded_filenames_parse_data = binded_filenames_parse_data,
reactlog_dependency_df = dependency_df_ids_data_all_ids$reactlog_dependency_df,
ids_data = dependency_df_ids_data_all_ids$ids_data)
}, label = "shinybreakpoint-get_dependencies_last_input")
get_dependencies_chosen_id <- reactive({
validate_id(input$chosen_id, reactlog_data, dependency_df_ids_data_all_ids$ids_data)
get_dependencies_set_names(input$chosen_id,
find_dependencies,
binded_filenames_parse_data = binded_filenames_parse_data,
reactlog_dependency_df = dependency_df_ids_data_all_ids$reactlog_dependency_df,
ids_data = dependency_df_ids_data_all_ids$ids_data)
}, label = "shinybreakpoint-get_dependencies_chosen_id")
get_app_mode_src_code <- reactive({
switch(input$app_mode,
files = list(mode = "files",
src_code = get_files()),
last_input = list(mode = "last_input",
src_code = get_dependencies_last_input()),
chosen_id = list(mode = "chosen_id",
src_code = get_dependencies_chosen_id()))
}) %>%
bindEvent(input$app_mode, label = "shinybreakpoint-get_app_mode_src_code")
observe({
req(input$key_pressed == keyEvent)
showModal(modal_dialog(session, filenames_src_code_envirs$filenames_parse_data, input$chosen_id))
disabled_choices <- NULL
if (!isTruthy(input$last_input)) {
disabled_choices <- append(disabled_choices, "last_input")
}
if (!isTruthy(input$chosen_id)) {
disabled_choices <- append(disabled_choices, "chosen_id")
}
shinyWidgets::updateRadioGroupButtons(session, "app_mode", disabledChoices = disabled_choices)
}) %>%
bindEvent(input$key_pressed, label = "shinybreakpoint-update_app_mode_choices")
observe({
if (length(get_app_mode_src_code()$src_code) < 9) {
update_elements(shinyWidgets::updateRadioGroupButtons, session, "element",
app_mode_src_code = get_app_mode_src_code())
} else {
update_elements(updateSelectInput, session, "element",
app_mode_src_code = get_app_mode_src_code())
}
}) %>%
bindEvent(get_app_mode_src_code(), label = "shinybreakpoint-update_elements")
observe({
req(input$key_pressed == keyEvent)
req(get_app_mode_src_code()$mode == "files")
req(nrow(filenames_src_code_envirs$filenames_parse_data) > 0 && !is.null(filenames_src_code_envirs$filenames_parse_data))
if ((length(filenames_src_code_envirs$filenames_parse_data$filename_full_path) < 9)) {
update_filenames_with_rstudio_editor(shinyWidgets::updateRadioGroupButtons, session, "element", filenames_src_code_envirs$filenames_parse_data$filename_full_path)
} else {
update_filenames_with_rstudio_editor(updateSelectizeInput, session, "element", filenames_src_code_envirs$filenames_parse_data$filename_full_path)
}
}) %>%
bindEvent(input$key_pressed, get_app_mode_src_code(), label = "shinybreakpoint-update_files_based_on_rstudio_opened_file")
src_code_for_element <- reactive({
get_app_mode_src_code()$src_code[[input$element]]
}, label = "shinybreakpoint-src_code_for_element")
output$src_code <- reactable::renderReactable({
req(src_code_for_element())
reactable::reactable(src_code_for_element()[c("line", "src_code")],
columns = list(line = reactable::colDef(align = "center",
vAlign = "center",
width = 60,
name = "",
style = list(color = "#8b8589")),
src_code = reactable::colDef(name = "",
style = list(whiteSpace = "pre-wrap", color = "#2f4f4f"),
cell = reactable::JS(colorize_code())
)),
columnGroups = list(reactable::colGroup(name = basename(input$element),
columns = c("line", "src_code"))),
rowClass = function(index) if (is.na(src_code_for_element()[index, "src_code"])) "shinybreakpoint-na-row",
selection = "single",
onClick = "select",
sortable = FALSE,
pagination = FALSE,
compact = TRUE,
borderless = TRUE,
highlight = TRUE,
height = "86vh",
theme = reactable::reactableTheme(
backgroundColor = "#f2eeeb", highlightColor = "#DFD6D2",
rowSelectedStyle = list(backgroundColor = "#DFD6D2", boxShadow = "inset 0 3px 5px rgba(0,0,0,.125), 0 3px 5px rgba(0,0,0,.125);")
))
})
selected_row <- reactive({
shinyjs::removeCssClass(class = "shinybreakpoint-activate-btn-ready",
selector = ".shinybreakpoint-modal .shinybreakpoint-activate-btn")
reactable::getReactableState("src_code", "selected")
}, label = "shinybreakpoint-selected_row")
selected_file <- reactive({
req(selected_row())
if (get_app_mode_src_code()$mode == "files") {
input$element
} else {
src_code_for_element()$filename_full_path[selected_row()]
}
}, label = "shinybreakpoint-selected_file")
which_file <- reactive({
req(selected_file())
which(filenames_src_code_envirs$filenames_parse_data$filename_full_path == selected_file())
}, label = "shinybreakpoint-which_file")
selected_line <- reactive({
req(selected_row())
src_code_for_element()$line[selected_row()]
}, label = "shinybreakpoint-selected_line")
selected_envir <- reactive({
req(which_file())
filenames_src_code_envirs$envirs[[which_file()]]
}, label = "shinybreakpoint-selected_envir")
object <- reactive({
req(selected_line(), selected_envir())
find_object(selected_file(), selected_line(), selected_envir())
}, label = "shinybreakpoint-object")
breakpoint_can_be_set <- reactive({
req(object())
does_breakpoint_can_be_set(object())
}, label = "shinybreakpoint-breakpoint_can_be_set")
observe({
req(object())
if (isTruthy(breakpoint_can_be_set())) {
shinyjs::addCssClass(class = "shinybreakpoint-set",
selector = ".shinybreakpoint-modal .rt-tr-selected")
shinyjs::addCssClass(class = "shinybreakpoint-activate-btn-ready",
selector = ".shinybreakpoint-modal .shinybreakpoint-activate-btn")
} else {
shinyjs::addCssClass(class = "shinybreakpoint-not-set",
selector = ".shinybreakpoint-modal .rt-tr-selected")
}
}, label = "shinybreakpoint-show_green_light")
observe({
req(breakpoint_can_be_set())
exact_line <- determine_line(selected_file(), selected_line(), object()$envir, object()$at)
put_browser(object(), varName)
set_attrs(selected_file(), exact_line, object()$name, object()$envir, object()$at, caller_envir)
getDefaultReactiveDomain()$reload() # trigger the changes in the body of fun
}) %>%
bindEvent(input$activate, label = "shinybreakpoint-put_browser")
}
)
}
#' Check If Input Is Present And If Labels In ids_data Are Not Duplicated
#'
#' @param input_id input$last_input or input$chosen_id - input with id to search dependencies
#' @param reactlog_data returned by [reactlog]
#' @param ids_data prepared from [reactlog] - here we need labels column from ids_data to check
#' if there are some duplicates
#'
#' @return
#' Error (from req()) or string from validate() which is the same as error.
#' NULL if no error.
#' @noRd
validate_id <- function(input_id, reactlog_data, ids_data) {
req(isTruthy(input_id) & length(reactlog_data) > 0)
validate(check_duplicated_ids(ids_data))
}
#' Get Dependencies For Id(s) And Put It To The Named List
#'
#' @param input_id input$last_input or input$chosen_id: input with id to find dependencies for
#' @param fun_to_find_dependencies fun used in lapply, it is `find_dependencies` to find dependencies for id
#' @param binded_filenames_parse_data all src_code, but binded to one file (one data.frame)
#' @param reactlog_dependency_df relations between reactIds from [reactlog]
#' @param ids_data src_ref, labels etc. from [reactlog] to find specific reactId in filenames_parse_data (in source code)
#'
#' @return
#' named list - names according to the ids. Inside each element of list - source code (data.frame) with dependencies
#' for the id (name).
#' @noRd
get_dependencies_set_names <- function(input_id, fun_to_find_dependencies, binded_filenames_parse_data, reactlog_dependency_df, ids_data) {
stats::setNames(lapply(input_id, fun_to_find_dependencies,
binded_filenames_parse_data = binded_filenames_parse_data,
reactlog_dependency_df = reactlog_dependency_df,
ids_data = ids_data),
input_id)
}
#' Create Modal Dialog
#'
#' @param session used in 'create_UI'.
#' @param filenames_src_code used in 'create_UI'.
#' @param chosen_id vector of Ids stored input$chosen_id
#'
#' @return
#' Modal dialog.
#' @details
#' In Bootstrap 3 class 'modal-xl' is not supported and the default
#' ('medium') size of modal is displayed instead. The added script
#' fixes this - size 'large' will be displayed in Bootstrap 3.
#'
#' This additional script should be removed when Shiny will get
#' as a default Bootstrap 4 or higher version.
#' @import shiny
#' @noRd
modal_dialog <- function(session, filenames_src_code, chosen_id) {
tags$div(class = "shinybreakpoint-modal",
modalDialog(
footer = NULL,
size = "xl",
easyClose = TRUE,
create_UI(session, filenames_src_code, chosen_id),
tags$script(HTML('
if (jQuery.fn.tooltip.Constructor.VERSION.startsWith("3.")) {{
if (document.getElementById("shiny-modal").children[0].classList.contains("modal-xl")) {{
document.getElementById("shiny-modal").children[0].classList.remove("modal-xl");
document.getElementById("shiny-modal").children[0].classList.add("modal-lg");
}};
}};
'))
)
)
}
#' Create UI for Modal Dialog.
#'
#' @param session passed from 'moduleServer'.
#' @param filenames_src_code data.frame with full paths to files and basenames
#' as well as envir label and src code (but not used here).
#' @param chosen_id vector of Ids stored input$chosen_id
#'
#' @return
#' UI in modal dialog - only a message if no appropriate file found or
#' button, list of files / IDs and table with source code.
#' We need to know if selectizeInput should be displayed or radioGroupButtons.
#' If the number of elements (filenames or ids) will be too long, then we need
#' selectizeInput. This will be the same input HTML tag for all elements, i.e.
#' no matter if files or ids. However, the alternative would be probably to use
#' renderUI, but this is slower that static HTML input which if later updated
#' using update* functions.
#' @noRd
create_UI <- function(session, filenames_src_code, chosen_id) {
if (is.null(filenames_src_code) || nrow(filenames_src_code) == 0) {
UI <- tags$div(class = "no-file",
tags$div(class = "circle-div",
tags$div(class = "circle")),
tags$p("There is nothing to see here"))
} else {
choices <- sort(stats::setNames(filenames_src_code$filename_full_path,
filenames_src_code$filename))
if (length(choices) < 9 && length(chosen_id) < 9) {
elements <- shinyWidgets::radioGroupButtons(session$ns("element"), label = "",
choices = choices,
direction = "vertical") %>%
tagAppendAttributes(class = "shinybreakpoint-radioGroupButtons")
} else {
elements <- selectizeInput(session$ns("element"), label = "",
choices = choices,
width = "100%") %>%
tagAppendAttributes(class = "shinybreakpoint-selectInput")
}
UI <- tagList(
fluidRow(
column(3, class = "col-xl-2",
fluidRow(
column(4,
tags$div(class = "shinybreakpoint-div-activate",
actionButton(session$ns("activate"), label = "", icon = icon("circle", class = "fa-solid"), class = "shinybreakpoint-activate-btn"))
),
column(1,
tags$div(class = "shinybreakpoint-div-last_input_chosen_id",
shinyWidgets::radioGroupButtons(session$ns("app_mode"),
choices = c(`<i class="fa-solid fa-file-lines"></i>` = "files", `<i class="fa-solid fa-backward"></i>` = "last_input", `<i class="fa-solid fa-hand-pointer"></i>` = "chosen_id"),
selected = "files",
size = "sm")
)
)
),
fluidRow(
column(12,
tags$br(),
tags$div(class = "shinybreakpoint-div-elements",
elements)
)
),
fluidRow(
column(12,
tags$div(id = "br-shinybreakpoint-name"),
tags$div(id = "shinybreakpoint-name-div",
tags$p("shinybreakpoint", id = "shinybreakpoint-name"))
)
)
),
column(9, class = "col-xl-10",
reactable::reactableOutput(session$ns("src_code"))
)
)
)
}
UI
}
#' Use update* Function to Update HTML Input With Names from Named List Returned by `get_app_mode_src_code`
#'
#' @param update_fun name of the update* function
#' @param session session object from server module
#' @param id_html id to which element we want to update
#' @param app_mode_src_code source code (list element 'src_code') returned by reactive `get_app_mode_src_code`
#'
#' @return
#' Used for side effect - update HTML input
#' @import shiny
#' @noRd
update_elements <- function(update_fun, session, id_html, app_mode_src_code) {
choices <- sort(stats::setNames(names(app_mode_src_code$src_code),
basename(names(app_mode_src_code$src_code))))
update_fun(session, id_html,
choices = choices,
selected = choices[[1]])
}
#' Use update* Function to Update HTML Input Using Value From RStudio Editor
#'
#' @param update_fun name of the update* function
#' @param session session object from server module
#' @param id_html id to which element we want to update
#' @param filename_full_path all column (as vector) filename_full_path from filenames_parse_data
#'
#' @return
#' Used for side effect - update HTML input
#' @import shiny
#' @noRd
update_filenames_with_rstudio_editor <- function(update_fun, session, id_html, filename_full_path) {
update_fun(session, id_html,
selected = get_src_editor_file(filename_full_path))
}
#' Get Full Path to File Opened in Source Editor in RStudio
#'
#' @param filename_full_path all filename (full paths)
#' returned by 'prepare_src_code()'.
#'
#' @return
#' Filename (full path) opened in RStudio (in Source Editor). If
#' RStudio is not in use (or no file opened) or if opened file is not in the column
#' in object returned by 'prepare_src_code()', then returns the
#' first element of the passed vector.
#' @noRd
get_src_editor_file <- function(filename_full_path) {
selected <- tryCatch(rstudioapi::getSourceEditorContext()$path,
error = function(e) filename_full_path[[1]])
if (is.null(selected) || !selected %in% filename_full_path) {
selected <- filename_full_path[[1]]
}
selected
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.