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)
In the below minimal code examples (first one without Shiny, second one with Shiny), I'm trying to figure out how to change the alignment of the contents of the row header column in this table rendered using R package rhandsontable. The row header column contents are currently centered, I'm trying to see how you can change the aligment to left and right. I tried adding %>% hot_col(0, halign='htLeft') but this only works for non-header columns (it doesn't accept the value I tried of 0 for accessing the row header column).
Any suggestions for how to do this? I assume this takes some CSS or js.
Code version without Shiny:
library(rhandsontable)
DF = data.frame(
integer = 1:5,
numeric = rnorm(5),
factor_allow = factor(letters[1:5],
levels = letters[5:1],
ordered = TRUE
),
stringsAsFactors = FALSE)
rownames(DF) <- c("One","Two","Three","Four","Five")
rhandsontable(DF,rowHeaderWidth = 96) %>%
hot_col("factor_allow", allowInvalid = TRUE)
Code version with Shiny:
library(rhandsontable)
library(shiny)
DF = data.frame(
integer = 1:5,
numeric = rnorm(5),
factor_allow = factor(letters[1:5],
levels = letters[5:1],
ordered = TRUE),
stringsAsFactors = FALSE
)
rownames(DF) <- c("One","Two","Three","Four","Five")
ui <- fluidPage(br(), rHandsontableOutput('my_table'))
server <- function(input, output, session) {
output$my_table <- renderRHandsontable({
rhandsontable(DF) %>%
hot_col("factor_allow", allowInvalid = TRUE)
})
}
shinyApp(ui,server)
I_O solution for code without Shiny (see Answers for solution for code with Shiny):
library(rhandsontable)
library(htmltools)
DF = data.frame(
integer = 1:5,
numeric = rnorm(5),
factor_allow = factor(letters[1:5],
levels = letters[5:1],
ordered = TRUE
),
stringsAsFactors = FALSE)
rownames(DF) <- c("One","Two","Three","Four","Five")
rhandsontable(DF,rowHeaderWidth = 96) %>%
hot_col("factor_allow", allowInvalid = TRUE)
browsable(
tagList(list(
tags$head(
tags$style("th{text-align:right !important; ## [1]
color:red !important}" ## [2]
)
),
my_table ## don't forget to specify widget
))
)
As you suggested, modifying the CSS is one approach. That should be possible via a renderer function, but you could also include custom CSS.
In your case, you'd probably best target the th element (the dedicated class .colHeader is applied to a <span> within which text aligning doesn't make much sense).
If you're serving the table as part of a Shiny app, here's how. Example:
ui <- fluidPage(
tags$head(
tags$style(HTML("
th{text-align:right !important;
width: 96px; ## you can specify the width here, too
"))
),
## ...
rHandsontableOutput('my_table')
## ...
)
In a larger project, you might prefer to maintain CSS styling in a separate file (see section File-based CSS of above ressource).
Otherwise, you could try this:
library(htmltools)
## ...
my_table <- rhandsontable(DF,rowHeaderWidth = 96) %>%
hot_col("factor_allow", allowInvalid = TRUE)
## ...
browsable(
tagList(list(
tags$head(
tags$style("th{text-align:right !important; ## [1]
color:red !important}" ## [2]
)
),
my_table ## don't forget to specify widget
))
)
[1] note the !important to override other definitions
[2] just to verify function at first glance, remove later ...
In the MWE code below, user inputs into the first matrix (firstInput is the name of the custom function that invokes the first matrix) are fed into a second matrix (secondInput) that the user can optionally input into, and the results of secondInput are fed into the output plot. (This link between the 2 matrices may sound absurd, but in the more complete code this is extracted from, inputs into the second matrix go through extra/intrapolations; in the spirit of MWE I removed that functionality).
In running this you can see that the user can click action button "Show" to see that 2nd matrix, since those inputs are optional.
My issue is reactivity. Currently as drafted, if the user makes a change to the value in the first matrix without showing the second matrix, then those changes are not reactively reflected in the plot. I would like data to flow through the reactivity chain even when the 2nd matrix is hidden. Is there a workaround, a simple other way, to "skin this cat"?
MWE code:
rm(list = ls())
library(shiny)
library(shinyMatrix)
library(shinyjs)
firstInput <- function(inputId){
matrixInput(inputId,
value = matrix(c(5), 1, 1, dimnames = list(c("1st input"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
secondInput <- function(inputId,x){
matrixInput(inputId,
value = matrix(c(x), 1, 1, dimnames = list(c("2nd input"),NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
ui <- fluidPage(
titlePanel("Model"),
sidebarLayout(
sidebarPanel(
uiOutput("panel"),
hidden(uiOutput("secondInput")) # <<< remove "hidden" and reactivity is restored
),
mainPanel(plotOutput("plot1"))
)
)
server <- function(input, output) {
input1 <- reactive(input$input1)
input2 <- reactive(input$input2)
output$panel <- renderUI({
tagList(
useShinyjs(),
firstInput("input1"),
actionButton('show','Show 2nd inputs'),
actionButton('hide','Hide 2nd inputs'))
})
output$secondInput <- renderUI({
req(input1())
secondInput("input2",input$input1[1,1])
})
output$plot1 <-renderPlot({
req(input2())
plot(rep(input2(),times=5))
})
observeEvent(input$show,{shinyjs::show("secondInput")})
observeEvent(input$hide,{shinyjs::hide("secondInput")})
}
shinyApp(ui, server)
You can do:
output$secondInput <- renderUI({
req(input1())
secondInput("input2",input$input1[1,1])
})
outputOptions(output, "secondInput", suspendWhenHidden = FALSE)
EDIT
Another possibility is to use the CSS property visibility: hidden to hide the second input, instead of shinyjs::hidden (which sets the CSS property display: none). With this property, the second input is not visible but it takes up some space, it is not "strictly hidden".
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$style(HTML(".Hidden {visibility: hidden;}"))
),
titlePanel("Model"),
sidebarLayout(
sidebarPanel(
uiOutput("panel"),
div(
id = "secondInputContainer",
class = "Hidden",
uiOutput("secondInput")
)
),
mainPanel(plotOutput("plot1"))
)
)
server <- function(input, output) {
# input1 <- reactive(input$input1) useless
# input2 <- reactive(input$input2) useless
output$panel <- renderUI({
tagList(
firstInput("input1"),
actionButton('show', 'Show 2nd inputs'),
actionButton('hide', 'Hide 2nd inputs'))
})
output$secondInput <- renderUI({
req(input$input1)
secondInput("input2", input$input1[1,1])
})
output$plot1 <-renderPlot({
req(input$input2)
plot(rep(input$input2, times=5))
})
observeEvent(input$show, {
removeCssClass("secondInputContainer", "Hidden")
})
observeEvent(input$hide, {
addCssClass("secondInputContainer", "Hidden")
})
}
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()); } ')
)
)
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)