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)

Attach javascript listener when using `renderUI` in Shiny app

I am ultimately trying to capture the time it takes a user to click on a series of histograms after they are displayed. However, in the example app below, a javascript error appears at the loading of the app:
Uncaught TypeError: Cannot set properties of null (setting 'onclick')
at HTMLDocument. ((index):31:30)
at e (jquery.min.js:2:30038)
at t (jquery.min.js:2:30340)
Presumably this is because document.getElementById("img") doesn't find img at the loading of the app, but I don't know how to resolve that.
I can get this to work when the histogram is displayed outside of the renderUI, but I need to change the histogram dynamically from the server, so I need this to work with a rendered UI.
shinyApp(
ui = fluidPage(
tags$script('
// ------ javascript code ------
$(document).ready(function(){
// function to set Shiny input value to current time:
const clockEvent = function(inputName){Shiny.setInputValue(inputName, new Date().getTime())}
// trigger when the value of output id "img" changes:
$(document).on("shiny:value",
function(event){
if (event.target.id === "img") {clockEvent("displayed_at")}
}
)
// trigger when the image, after being sent or refreshed, is clicked:
document.getElementById("img")
.onclick = function(){clockEvent("reacted_at")}
})
// ------------------------------
'),
sidebarLayout(
sidebarPanel(
actionButton(inputId="render_dynamic", label= "Create Dynamic UI")
),
mainPanel(
uiOutput("dynamic")
)
)
),
server = function(input, output) {
output$img <- renderImage({
outfile <- tempfile(fileext='.png')
png(outfile, width=400, height=400)
hist(rnorm(100))
dev.off()
list(src = outfile,
contentType = "image/jpeg")
},
deleteFile = FALSE)
output$reaction_time <- renderPrint(paste('reaction time (ms)', input$reacted_at - input$displayed_at))
output$dynamic <- renderUI({
req(input$render_dynamic > 0)
div(id = 'image_container',
imageOutput("img", click = "photo_click"),
textOutput("reaction_time"))
})
}
)

Here is an approach avoiding renderUI and using bindEvent:
library(shiny)
ui = fluidPage(
tags$script('
// ------ javascript code ------
$(document).ready(function(){
// function to set Shiny input value to current time:
const clockEvent = function(inputName){Shiny.setInputValue(inputName, new Date().getTime())}
// trigger when the value of output id "img" changes:
$(document).on("shiny:value",
function(event){
if (event.target.id === "img") {clockEvent("displayed_at")}
}
)
// trigger when the image, after being sent or refreshed, is clicked:
document.getElementById("img")
.onclick = function(){clockEvent("reacted_at")}
})
// ------------------------------
'),
sidebarLayout(
sidebarPanel(
actionButton(inputId="render_dynamic", label= "Create Dynamic UI")
),
mainPanel(
imageOutput("img"),
textOutput("reaction_time")
)
)
)
server = function(input, output, session) {
output$img <- renderImage({
outfile <- tempfile(fileext='.png')
png(outfile, width=400, height=400)
hist(rnorm(100))
dev.off()
list(src = outfile,
contentType = "image/jpeg")
}, deleteFile = FALSE) |> bindEvent(input$render_dynamic)
output$reaction_time <- renderPrint({
paste('reaction time (ms)', input$reacted_at - input$displayed_at)
}) |> bindEvent(input$reacted_at)
}
shinyApp(ui, server)
I don't know if there is a good reason for you to output the plot as an image and show it via renderImage instead of using renderPlot directly - but here is the renderPlot version:
library(shiny)
ui = fluidPage(
tags$script('
// ------ javascript code ------
$(document).ready(function(){
// function to set Shiny input value to current time:
const clockEvent = function(inputName){Shiny.setInputValue(inputName, new Date().getTime())}
// trigger when the value of output id "img" changes:
$(document).on("shiny:value",
function(event){
if (event.target.id === "img") {clockEvent("displayed_at")}
}
)
// trigger when the image, after being sent or refreshed, is clicked:
document.getElementById("img")
.onclick = function(){clockEvent("reacted_at")}
})
// ------------------------------
'),
sidebarLayout(
sidebarPanel(
actionButton(inputId="render_dynamic", label= "Create Dynamic UI")
),
mainPanel(
plotOutput("img"),
textOutput("reaction_time")
)
)
)
server = function(input, output, session) {
output$img <- renderPlot({
hist(rnorm(100))
}) |> bindEvent(input$render_dynamic)
output$reaction_time <- renderPrint({
paste('reaction time (ms)', input$reacted_at - input$displayed_at)
}) |> bindEvent(input$reacted_at)
}
shinyApp(ui, server)
PS: If you are still interested in how to solve the renderUI problem please check the following post on GitHub.

Seems like, from the client's perspective, the document is fully loaded before you renderUI another element. So the JQuery $(document).ready(...) gives its OK to proceed with trying to attach an event to an element which is not there (yet).
Options to avoid renderUI have already been given. If you don't want the "placeholder" blank space, you can set the image height to zero upon rendering:
ui <- fluidPage(
## ...
imageOutput("img", click = "photo_click",
height = 0
)
## ...

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()); } ')
)
)

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)
})
}
)

R: Popovers don't trigger in shiny reactive UI

I'm currently developing a shiny gadget and have ran into the small issue that Bootstrap popovers don't trigger when generated by renderUI(). Can anyone shed light on why this might be?
I'm not very familiar with js so there could be an obvious answer to this question that I'm missing.
The example below reproduces the issue. In short: a gadget is created that renders a sidebar and a plot; within the side bar are two link tags that should trigger a popover, the first being generated within the UI object, and the second generated by the combination of uiOutput() and renderUI(). For me at least, the reactive popover doesn't trigger.
MWE:
library(shiny)
library(miniUI)
# Functions for popovers --------------------------------------------------
popoverInit <- function() {
tags$head(
tags$script(
"$(document).ready(function(){$('[data-toggle=\"popover\"]').popover();});"
)
)
}
popover <- function(content, pos, ...) {
tagList(
singleton(popoverInit()),
tags$a(href = "#pop", `data-toggle` = "popover", `data-placement` = paste("auto", pos),
`data-original-title` = "", title = "", `data-trigger` = "hover",
`data-html` = "true", `data-content` = content, ...)
)
}
# Gadget function ---------------------------------------------------------
reactive_popovers <- function(data, xvar, yvar) {
ui <- miniPage(
gadgetTitleBar("Reactive popovers"),
fillRow( # Sidebar and plot.
flex = c(1, 10),
tagList(
tags$hr(),
## This popover works fine:
popover("No problems", pos = "right", "Working popover"),
tags$hr(),
## This one doesn't.
uiOutput("reactive_popover")
),
## A pointless plot.
miniContentPanel(
plotOutput("plot", height = "100%")
)
)
)
server <- function(input, output, session) {
## Render popover.
output$reactive_popover <- renderUI({
popover("Popover content", "right", "Dead popover")
})
## Render plot.
output$plot <- renderPlot({
plot(mpg ~ hp, data = mtcars)
})
}
runGadget(ui, server, viewer = browserViewer())
}
reactive_popovers()

I think this is happening because the popover from renderUI is created after the js binding so it does not get initialised.
Following the answer from this post, you could do:
popoverInit <- function() {
tags$head(
tags$script(
"$(document).ready(function(){
$('body').popover({
selector: '[data-toggle=\"popover\"]',
trigger: 'hover'
});});"
)
)
}