Related
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)
I would like to disable menu items and selectInput, while my Shiny app is loading. I have managed to disable buttons and textInput with some javacript (cf. Disable elements when Shiny is busy), but I can't get it to work with selectInput and menus. I'm not interested in alternatives solutions.
library(shiny)
js <- "$(document).on('shiny:busy', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', false);
});"
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
tags$head(tags$script(js)),
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
actionButton("buttonID","This adds 10 seconds of Sys.sleep"),
textInput("textID","Write text here..."),
selectInput("selectID","This should be disables while loading",choices=c("A","B","C"))
)
)
)
server <- function(input, output) {
observeEvent(input$buttonID,{
Sys.sleep(10)
})
}
shinyApp(ui, server)
Theres easier way of disabling widgets using shinyjs package. theres a reactiveValuesToList function which will collect all the reactivesinputs you have within the session and you can simply use that:
library(shiny)
library(shinyjs)
ui <- fluidPage(
titlePanel("Hello Shiny!"),
useShinyjs(),
sidebarLayout(
sidebarPanel(
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
actionButton("buttonID","This adds 5 seconds of Sys.sleep"),
textInput("textID","Write text here..."),
selectInput("selectID","This should be disables while loading",choices=c("A","B","C"))
)
)
)
server <- function(input, output) {
observeEvent(input$buttonID,{
myinputs <- names(reactiveValuesToList(input))
print(myinputs)
for(i in 1:length(myinputs)){
disable(myinputs[i])
}
Sys.sleep(5)
for(i in 1:length(myinputs)){
enable(myinputs[i])
}
})
}
shinyApp(ui, server)
ANSWER A)
The simple answer to your question is to set selectize = FALSE in your selectInput.
In the shiny docs, it's stated that the selectInput function uses the selectize.js JavaScript library by default (see below).
"By default, selectInput() and selectizeInput() use the
JavaScript library selectize.js
(https://github.com/brianreavis/selectize.js) to instead of the basic
select input element. To use the standard HTML select input element,
use selectInput() with selectize=FALSE."
By setting selectize = FALSE you are instead using the standard HTML select input element. This, in turn, is now picked up by your jquery var $inputs = $('button,input,select,ul');. I'm not sure why the element is not picked up when using the selectize.js library.
See the below example. Note that the selectInput options look different when using the html standard (not as nice aesthetically imo).
# ANSWER A)
library(shiny)
js <- "$(document).on('shiny:busy', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', false);
});"
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
tags$head(tags$script(js)),
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
actionButton("buttonID", "This adds 3 seconds of Sys.sleep"),
textInput("textID", "Write text here..."),
selectInput("selectID", "This should be disables while loading", choices=c("A","B","C"), selectize = FALSE)
)
)
)
server <- function(input, output) {
observeEvent(input$buttonID,{
Sys.sleep(3)
})
}
shinyApp(ui, server)
ANSWER B)
Below is how I got the selectize.js selectInput to disable when shiny is busy, as per your question, using the conditionalPanel. It's a bit of a hacky solution, but works well.
Note that I am creating two selectInputs which are similar. One is initialised as disabled using the shinyjs package. This is the one that is displayed when shiny is busy. Using jquery snippet $('html').hasClass('shiny-busy') we make use of the shiny-busy class applied when shiny is busy performing logic on the server side. When this class is removed (i.e. when shiny is idle) the conditionalPanel swaps in the other selectInput UI element that is not disabled.
# EXAMPLE B)
library(shiny)
library(shinyjs)
js <- "$(document).on('shiny:busy', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', true);
});
$(document).on('shiny:idle', function() {
var $inputs = $('button,input,select,ul');
console.log($inputs);
$inputs.prop('disabled', false);
});"
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
tags$head(tags$script(js)),
navlistPanel(
tabPanel("Component 1"),
tabPanel("Component 2")
)
),
mainPanel(
useShinyjs(),
actionButton("buttonID", "This adds 3 seconds of Sys.sleep"),
textInput("textID", "Write text here..."),
#selectInput("selectID", "This should be disables while loading", choices=c("A","B","C"), selectize = FALSE)
div(
conditionalPanel(
condition="$('html').hasClass('shiny-busy')",
shinyjs::disabled(
selectInput(
inputId = 'selectID_disabled', # note the addition of "_disabled" as IDs need to be unique
label = "This should be disables while loading",
choices = "Loading...",
selected = NULL,
selectize = TRUE,
width = 250,
size = NULL
)
)
),
conditionalPanel(
condition="$('html').hasClass('')",
selectInput(
inputId = 'selectID',
label = "This should be disables while loading",
choices = c("A","B","C"),
selected = NULL,
selectize = TRUE,
width = 250,
size = NULL
)
),
style = "margin-top:20px;"
),
)
)
)
shinyServer(function(input, output, session) {
observeEvent(input$buttonID,{
Sys.sleep(3)
})
})
shinyApp(ui, server)
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)
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)
})
}
)
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'
});});"
)
)
}