added block() and unblock()

NAMESPACE

@@ -4,10 +4,12 @@ export(add_busy_bar)
 export(add_busy_gif)
 export(add_busy_spinner)
 export(add_loading_state)
+export(block)
 export(busy_start_up)
 export(config_notify)
 export(config_report)
 export(hide_spinner)
+export(html_dependency_block)
 export(html_dependency_busy)
 export(html_dependency_epic)
 export(html_dependency_freezeframe)
@@ -46,6 +48,7 @@ export(show_spinner)
 export(spin_epic)
 export(spin_kit)
 export(stop_gif)
+export(unblock)
 export(update_busy_bar)
 export(update_modal_progress)
 export(update_modal_spinner)

NEWS.md

@@ -1,3 +1,8 @@
+# shinybusy 0.3.2
+
+* New functions `block()` and `unblock()` to block/unblock elements (like outputs) during a lonng calculation.
+
+
 # shinybusy 0.3.1
 
 * Use correct HTML dependencies.

R/block.R

@@ -0,0 +1,62 @@
+
+#' Block / unblock an UI element
+#'
+#' @param id Id of the element to block, for exemple an `outputId`.
+#' @param text Text displayed below the blocking indicator.
+#' @param type Type of blocking indicator.
+#' @param ... Other configuration option, see [online documentation](https://notiflix.github.io/documentation#DocsBlock).
+#' @param selector Custom CSS selector, if used `id` is ignored.
+#' @param session Default Shiny session.
+#'
+#' @return No value.
+#' @export
+#'
+#' @name block
+#'
+#' @example examples/block.R
+block <- function(id,
+                  text = "Loading",
+                  type = c("standard", "hourglass", "circle", "arrows", "dots", "pulse"),
+                  ...,
+                  selector = NULL,
+                  session = shiny::getDefaultReactiveDomain()) {
+  type <- match.arg(type)
+  insertUI(
+    selector = "html",
+    ui = tagList(html_dependency_block()),
+    immediate = TRUE,
+    where = "afterBegin",
+    session = session
+  )
+  if (is.null(selector))
+    selector <- paste0("#", session$ns(id))
+  session$sendCustomMessage(
+    type =  "shinybusy-block-output",
+    message = list(
+      selector = selector,
+      type = type,
+      text = text,
+      config = list(...)
+    )
+  )
+}
+
+#' @param timeout Unblock after a delay.
+#' @export
+#'
+#' @rdname block
+unblock <- function(id,
+                    selector = NULL,
+                    timeout = 0,
+                    session = shiny::getDefaultReactiveDomain()) {
+  if (is.null(selector))
+    selector <- paste0("#", session$ns(id))
+  session$sendCustomMessage(
+    type =  "shinybusy-unblock-output",
+    message = list(
+      selector = selector,
+      timeout = timeout
+    )
+  )
+}
+

R/dependencies.R

@@ -150,3 +150,16 @@ html_dependency_report <- function() {
     script = "report.js"
   )
 }
+
+#' @export
+#' @rdname html-dependencies
+html_dependency_block <- function() {
+  htmlDependency(
+    name = "shinybusy-block",
+    version = packageVersion("shinybusy"),
+    src = list(file = "packer"),
+    package = "shinybusy",
+    script = "block.js",
+    head = "<style>.nx-block-temporary-position {opacity: 1!important;}</style>"
+  )
+}

examples/block.R

@@ -0,0 +1,62 @@
+library(shinybusy)
+library(shiny)
+
+ui <- fluidPage(
+
+  tags$h3("Block Output"),
+
+
+  fluidRow(
+    column(
+      width = 6,
+      plotOutput(outputId = "plot1"),
+      actionButton("block_manually", "Block / unblock")
+    ),
+    column(
+      width = 6,
+      plotOutput(outputId = "plot2"),
+      actionButton("block_reac", "Block when calculating in reactive()")
+    )
+  )
+
+)
+
+server <- function(input, output, session) {
+
+  output$plot1 <- renderPlot({
+    barplot(table(floor(runif(100) * 6)))
+  })
+
+  observeEvent(input$block_manually, {
+    if (input$block_manually %% 2 == 1) {
+      block(id = "plot1", type = "pulse", svgColor = "#5ea4d8")
+    } else {
+      unblock(id = "plot1")
+    }
+  })
+
+  data_r <- reactive({
+    input$block_reac
+    block(
+      id = "plot2",
+      type = "circle",
+      text = "Calculating, please wait...",
+      messageColor = "#FFF",
+      svgColor = "#FFF",
+      backgroundColor = "#5ea4d8"
+    )
+    Sys.sleep(3)
+    data <- data.frame(x = rnorm(50), y = rnorm(50))
+    unblock(id = "plot2", timeout = 300)
+    return(data)
+  })
+
+  output$plot2 <- renderPlot({
+    plot(data_r())
+  })
+
+}
+
+if (interactive())
+  shinyApp(ui, server)
+

srcjs/config/entry_points.json

@@ -3,5 +3,6 @@
   "loading": "./srcjs/exts/loading.js",
   "busy": "./srcjs/exts/busy.js",
   "notify": "./srcjs/exts/notify.js",
-  "report": "./srcjs/exts/report.js"
+  "report": "./srcjs/exts/report.js",
+  "block": "./srcjs/exts/block.js"
 }

srcjs/exts/block.js

@@ -0,0 +1,13 @@
+import "shiny";
+import { Block } from 'notiflix/build/notiflix-block-aio';
+
+Shiny.addCustomMessageHandler("shinybusy-block-output", function(data) {
+  if (data.hasOwnProperty("text")) {
+    Block[data.type](data.selector, data.text, data.config);
+  } else {
+    Block[data.type](data.selector,data.config);
+  }
+});
+Shiny.addCustomMessageHandler("shinybusy-unblock-output", function(data) {
+  Block.remove(data.selector, data.timeout);
+});