We Keep Coding

How to hide a conditional panel using js in R Shiny when any action or other button is clicked other than specified inputs?

I am trying to hide the conditional panel illustrated below when there is any user input other than the user clicking on the action button "Delete" or making a selection in the selectInput() function rendered in the conditional panel, as shown in the below image. Other user inputs will be added (action buttons, radio buttons, selectInputs, etc.) so it isn't feasible to list each action that causes the conditional panel to hide. That conditional panel should always render upon the click of "Delete". Any suggestions for how to do this? Code is shown at the bottom.
Code:
library(rhandsontable)
library(shiny)
mydata <- data.frame('Col 1' = c(1,24,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D')
ui <- fluidPage(br(),
rHandsontableOutput("mytable"),br(),
fluidRow(
column(1,actionButton("addCol", "Add",width = '70px')),
column(1,actionButton("delCol","Delete",width = '70px')),
column(3,conditionalPanel(condition = "input.delCol",uiOutput("delCol"))) # js here
)
)
server <- function(input, output) {
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$addCol, {
if(input$addCol > 0){
newcol <- data.frame(mydata[,1])
names(newcol) <- paste("Col",ncol(mydata)+1)
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata,rowHeaderWidth = 100, useTypes = TRUE)
}, ignoreNULL = FALSE)
observeEvent(input$delCol,
{output$delCol<-renderUI(selectInput("delCol",label=NULL,choices=colnames(mydata),selected="Col 1"))}
)
}
shinyApp(ui,server)

Per Mike´s comment I started with shinyjs and this simple example from the shinyjs reference manual, with minor modification for 2 buttons:
library(shiny)
library(shinyjs)
ui = fluidPage(
useShinyjs(), # Set up shinyjs
actionButton("btn", "Click to show"),
actionButton("btn1","Click to hide"),
hidden(p(id = "element", "I was invisible"))
)
server = function(input, output) {
observeEvent(input$btn, {show("element")})
observeEvent(input$btn1,{hide("element")})
}
shinyApp(ui,server)
Then I expanded it to my code in the OP per the below. Note that this will still require an observeEvent() for each user action that triggers selectInput() to hide instead of a global hide every time there's any user input other than a click of "Delete" action button. I'm not sure this is possible but will continue researching. Multiple observeEvents() won't be too bad of an option in any case.
Resolving code:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Col 1' = c(1,24,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D')
ui <- fluidPage(
useShinyjs(), # set up shinyjs
br(),
rHandsontableOutput("mytable"),br(),
fluidRow(
column(1,actionButton("addCol", "Add",width = '70px')),
column(1,actionButton("delCol","Delete",width = '70px')),
column(3, hidden(uiOutput("delCol2")))) # hide selectInput()
)
server <- function(input,output,session){
output$mytable = renderRHandsontable(dat())
dat <- eventReactive(input$addCol, {
if(input$addCol > 0){
newcol <- data.frame(mydata[,1])
names(newcol) <- paste("Col",ncol(mydata)+1)
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata,rowHeaderWidth = 100, useTypes = TRUE)
}, ignoreNULL = FALSE)
observeEvent(input$delCol, show("delCol2")) # clicking Delete button reveals selectInput()
observeEvent(input$addCol, hide("delCol2")) # clicking Add hides selectInput()
output$delCol2 <-renderUI({
selectInput(
"delCol3",
label=NULL,
choices=colnames(mydata),
selected="Col 1"
)
})
}
shinyApp(ui,server)

Embedded inputs in R Shiny Datatable - javascript issue

I have an R/Shiny app containing a datatable from the DT package.
Following this thread render dropdown for single column in DT shiny, I've been able to embed action buttons into a column in my datatable, which trigger a set of corresponding observers.
However, when the datatable is paginated, my action buttons will only function correctly for those buttons on the first page. Buttons on subsequent pages don't work. This remains the case even if I reorder the data using column sorting, as any buttons which were on page 2+ as of the initial render will not work even if they are reordered onto page 1.
I expect the problem is in how the callback argument is using javascript (which is unfortunately over my head) to render the action buttons correctly. Can anyone advise how to get the action buttons working on subsequent pages?
Here is my minimal reprex, using mtcars data:
library(shiny)
library(DT)
ui <- fluidPage(
titlePanel("reprex1")
,fluidRow(
dataTableOutput("dt1")
)
)
server <- function(input, output) {
output$dt1 <- renderDataTable({
mtlocal <- mtcars
for(n in 1:nrow(mtlocal)){
mtlocal$actionbutton[[n]] <- as.character(
actionButton(
paste0("buttonpress",n), label = paste0("buttonpress",n)
)
)
}
datatable(
mtlocal
,escape = FALSE
,selection = "none"
,callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
}, server = FALSE)
lapply(
1:nrow(mtcars),function(x){
observeEvent(
input[[paste0("buttonpress",x)]],{
showModal(
modalDialog(
h2(paste0("You clicked on button ",x,"!"))
)
)
}
)
}
)
}
# Run the application
shinyApp(ui = ui, server = server)

The callback is executed only once, and then Shiny.bind/unbind is lost when the table is redrawn. You have to use the options preDrawCallback and drawCallback:
datatable(
mtlocal
, escape = FALSE
, selection = "none"
, options = list(
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)

Is it possible to make an onfocus-function for the DataTable search bar in R shiny

I am creating a shiny app that uses a DataTable. I want to create keyboard shortcuts for different elements in this app, which I can. However these shortcuts should only be triggered if the user has the search-bar blurred out. Expressed in another way: The shortcuts should not activate if the build in search-bar is focused.
I tried with the code below which works for a standard input-field. For some reason the DataTable search is not counted as a input-field as it does not react to the js-code. Does anyone know of a way to make a focus/blur check (onfocus or onblur events) for the DataTable searchbar?
library(shiny)
library(DT)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
tags$script('$(document).on("keypress", function (e) {Shiny.onInputChange("keytyped", [e.which,e.timeStamp]);});'),
tags$script('$(document).ready(function() {
$("input").on("focus", function(){
Shiny.onInputChange("foc", 1);
});
$("input").on("blur", function(){
Shiny.onInputChange("foc", 0);
});
});'),
DT::dataTableOutput("datdata"),
textInput("test", "Test:")
)
server <- function(input, output, session) {
output$datdata <- DT::renderDataTable(mtcars
## THIS CALLBACK ONLY DOES SOMETHING WHEN SEARCHING! I NEED IT TO DO SOMETHING ON FOCUS!
# , callback = JS(
# 'table.on("search.dt", function(){
# Shiny.onInputChange("foc", 1);
# })'
# )
)
observe({
req(input$keytyped)
req(is.null(input$foc) | !input$foc)
## (Big letter codes) R = 82, S = 83, T = 84
check <- round(input$keytyped[1]) %in% c(82,83,84)
if(check){
print("ACTIVATE!")
}
})
# Print DataTable search and if input-fields are focussed.
observe(print(input$datdata_search))
observe(print(input$foc))
}
shinyApp(ui, server)
I know above code is not bullet proof (Typing "R" then clicking anywhere else but the test-field 'activates' the shortcut), but I just wanted to provide a small example.
TLDR; Is it possible to make the app print 1 or 0 depending on whether the search bar from DataTable is focused or not.
EDIT: SmokeyShakers did what I asked for. But an addition I needed was that it should ONLY be on the search-bar the value should change. Removing
tags$script('$(document).ready(function() {
$("#test").on("focus", function(){
Shiny.onInputChange("foc", 1);
});
$("#test").on("blur", function(){
Shiny.onInputChange("foc", 0);
});
});')
and then replacing "input" with "#datdata input" in the solution code solved my problem!

htmlwidgets::onRender can solve this issue. Try this for your datatable:
output$datdata <- DT::renderDataTable(
htmlwidgets::onRender(
DT::datatable(mtcars), jsCode = HTML('function() {
$("input").on("focus", function(){
Shiny.onInputChange("foc", 1);
});
$("input").on("blur", function(){
Shiny.onInputChange("foc", 0);
});
}')))

r introjs bsModal

I am trying to highlight elements of my bsModal with the r wrapper for intro.js, however cannot get it to work. I have also tried to include custom js scripts, but my js is terrible.
I have also set up multiple different tests hoping it would snag onto something, however it seem like intro.js cannot find the modal's div or any any of the of the elements inside it. I am using rintrojs
Here are some example of people getting it to work in javascript:
https://github.com/usablica/intro.js/issues/302
How do I fire a modal for the next step in my introjs?
But I personally don't know Javascript well enough to integrate a custom solution myself. I've already tried :(
Here's a link to an example I've hosted with the issue:
https://arun-sharma.shinyapps.io/introjs/
Does anyone know how I can get the following dummy example to work?
library(rintrojs)
library(shiny)
library(shinydashboard)
intro_df <- data.frame(element = c('#plot_box', '#bttn2', '#box', '#modal'),
intro = c('test plot_box', 'test bttn2', 'test box', 'test modal'))
ui <- shinyUI(fluidPage(
introjsUI(),
mainPanel(
bsModal('modal', '', '', uiOutput('plot_box'), size = 'large'),
actionButton("bttn", "Start intro")
)))
server <- shinyServer(function(input, output, session) {
output$plot <- renderPlot({
plot(rnorm(50))
})
output$plot_box <- renderUI({
box(id = 'box',
actionButton('bttn2', 'dummy'),
plotOutput('plot'), width = '100%'
)
})
observeEvent(input$bttn,{
toggleModal(session, 'modal', toggle = 'toggle')
introjs(session, options = list(steps = intro_df))
})
})
shinyApp(ui = ui, server = server)

Ultimately, I think this request could make for some useful features in the rintrojs library. In any case, your problems are two-fold:
introjs should not fire until the modal is available in the HTML. The easiest way to do this is to use a button within the modal to fire the tutorial. If you want it to be automatic, you will need some JavaScript that waits until the Modal is ready before firing.
introjs wants to grey out the background and highlight the current item in the tutorial. This means it needs to "interleave" with the modal children. Because the modal is its own stacking context, introjs needs to be fired from within the modal to look at modal children. If you want to look at the entire modal, then it is sufficient to fire introjs from the parent. This functionality does not seem to be in the rintrojs package yet, but is in the JavaScript library.
In order to accomplish #1, I added a JavaScript function to fire introjs on Modal load (after a configurable delay for HTML elements to load). This requires the shinyjs package. Notice the introJs(modal_id), this ensures that the tutorial fires within the modal. In pure JavaScript, it would be introJs('#modal'):
run_introjs_on_modal_up <- function(
modal_id
, input_data
, wait
) {
runjs(
paste0(
"$('"
, modal_id
, "').on('shown.bs.modal', function(e) {
setTimeout(function(){
introJs('", modal_id, "').addSteps("
, jsonlite::toJSON(input_data, auto_unbox=TRUE)
, ").start()
}, ", wait, ")
})"
)
)
}
I also added a simple helper for closing the introjs tutorial when navigating away from the modal.
introjs_exit <- function(){
runjs("introJs().exit()")
}
There was also a single line of CSS necessary to fix the modal-backdrop from getting over-eager and taking over the DOM:
.modal-backdrop { z-index: -10;}
And a (large / not minimal) working example with multiple modals.
library(rintrojs)
library(shiny)
library(shinydashboard)
library(shinyBS)
library(shinyjs)
intro_df <- data.frame(element = c('#plot_box', '#bttn2', '#box', '#modal'),
intro = c('test plot_box', 'test bttn2', 'test box', 'test modal'))
intro_df2 <- data.frame(element = c('#plot_box2'),
intro = c('test plot_box'))
run_introjs_on_modal_up <- function(
modal_id
, input_data
, wait
) {
runjs(
paste0(
"$('"
, modal_id
, "').on('shown.bs.modal', function(e) {
setTimeout(function(){
introJs('", modal_id, "').addSteps("
, jsonlite::toJSON(input_data, auto_unbox=TRUE)
, ").start()
}, ", wait, ")
})"
)
)
}
introjs_exit <- function(){
runjs("introJs().exit()")
}
ui <- shinyUI(fluidPage(
useShinyjs(),
tags$head(tags$style(".modal-backdrop { z-index: -10;}")),
introjsUI(),
mainPanel(
bsModal('modal', '', '', uiOutput('plot_box'), size = 'large'),
bsModal('modalblah', '', '', uiOutput('plot_box2'), size = 'large'),
actionButton("bttn", "Start intro")
)))
server <- shinyServer(function(input, output, session) {
output$plot <- renderPlot({
plot(rnorm(50))
})
output$plot2 <- renderPlot({
plot(rnorm(50))
})
output$plot_box <- renderUI({
box(id = 'box',
actionButton('bttn2', 'dummy'),
plotOutput('plot'), width = '100%'
)
})
output$plot_box2 <- renderUI({
box(id = 'box2',
plotOutput('plot2'), width = '100%'
)
})
run_introjs_on_modal_up("#modal",intro_df, 1000)
run_introjs_on_modal_up("#modalblah",intro_df2, 1000)
observeEvent(input$bttn,{
toggleModal(session, 'modal', toggle = 'toggle')
})
observeEvent(input$bttn2, {
toggleModal(session, 'modal', toggle = 'toggle')
introjs_exit()
toggleModal(session, 'modalblah', toggle = 'toggle')
})
})
shinyApp(ui = ui, server = server)

I was able to fix the problem by adding
.introjs-fixParent.modal {
z-index:1050 !important;
}
to my CSS.
Working example:
library(rintrojs)
library(shiny)
library(shinydashboard)
library(shinyBS)
library(shinyjs)
intro_df <- data.frame(element = c('#plot_box', '#bttn2_intro', '#box', '#plot', '#shiny-modal'),
intro = c('test plot_box', 'test bttn2', 'test box', 'plot', 'test modal'))
ui <- shinyUI(fluidPage(
dashboardPage(dashboardHeader(title = "Test"),
dashboardSidebar(sidebarMenu(menuItem("item1", tabName = "item1"))),
dashboardBody(tabItems(tabItem("item1", actionButton("bttn", "start intro"))))),
useShinyjs(),
tags$head(tags$style(".introjs-fixParent.modal {
z-index:1050 !important;
}")),
introjsUI()
))
server <- shinyServer(function(input, output, session) {
output$plot <- renderPlot({
plot(rnorm(50))
})
output$plot_box <- renderUI({
box(id = 'box',
div(id = "bttn2_intro", actionButton('bttn2', 'dummy')),
plotOutput('plot'), width = '100%'
)
})
observeEvent(input$bttn,{
showModal(modalDialog(uiOutput('plot_box')))
})
observeEvent(input$bttn2, {
introjs(session, options = list(steps = intro_df))
})
})
shinyApp(ui = ui, server = server)

update column visibility in DT::datatable while using DT::replaceData

Is there a way (other than a 'colvis' button) to dynamically update which columns are visible in a DT::datatabe while using the DT::replaceData to update the table?
(The reason I can not use the 'colvis' button (as shown here:https://rstudio.github.io/DT/extensions.html) is I need to have a few different short cut convenient buttons that hide and show multiple complex patterns at once.)
This is an example of how I would initiate my app. Is there a way in js or the server-side to hide and show columns? Thanks!
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(2, actionButton('refresh', 'Refresh Data', icon = icon('refresh'))),
column(10, DT::dataTableOutput('foo'))
)
),
server = function(input, output, session) {
df = iris
n = nrow(df)
df$ID = seq_len(n)
loopData = reactive({
input$refresh
df$ID <<- c(df$ID[n], df$ID[-n])
df
})
output$foo = DT::renderDataTable(isolate(DT::datatable(loopData(),
options = list(
columnDefs = list(list(visible=FALSE,targets=c(0,1,2))))
)))
proxy = dataTableProxy('foo')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
}
)