I have a selectizeInput with multiple = TRUE in a shiny application and I would like to prevent the user from selecting NULL (i.e., from leaving it blank). My goal is to ensure that at least one item is selected (no matter which one).
I found this question on the opposite problem (i.e., limiting maximum number of selections) and I checked selectize documentation. Unfortunately, there seem to be no minItems option. Is there a way to achieve my desired functionality?
Minimum example:
library(shiny)
shinyApp(
ui = fluidPage(
selectizeInput(
inputId = "testSelect",
label = "Test",
choices = LETTERS[1:4],
selected = LETTERS[1],
multiple = TRUE,
# Problem: how to specify 'minItems' here
options = list(maxItems = 2)
),
verbatimTextOutput("selected")
),
server = function(input, output) {
output$selected <- renderPrint({
input$testSelect
})
}
)
Seems to be an open issue: #https://github.com/selectize/selectize.js/issues/1228.
Concerning your R/Shiny implementation you could use a workaround with renderUI().
You would build the input on the server side and control the selected choices.
Before you build the input on the server side you can check the current value and if it does not fulfill your requirement you can overwrite it:
selected <- input$testSelect
if(is.null(selected)) selected <- choices[1]
Reproducible example:
library(shiny)
choices <- LETTERS[1:4]
shinyApp(
ui = fluidPage(
uiOutput("select"),
verbatimTextOutput("selected")
),
server = function(input, output) {
output$selected <- renderPrint({
input$testSelect
})
output$select <- renderUI({
selected <- input$testSelect
if(is.null(selected)) selected <- choices[1]
selectizeInput(
inputId = "testSelect",
label = "Test",
choices = choices,
selected = selected,
multiple = TRUE,
options = list(maxItems = 2)
)
})
}
)
Related
I am building a shiny app that, among other things, tries to identify a person's Census subdivision (in Canada) from an input postal code. Occasionally, postal codes overlap multiple subdivisions, so when that happens, I want users to be able to choose which subdivision they want to see. I was hoping to do it with a radio button input inside of a modal dialog. In the app below, the appropriate radio buttons appear, but I am unable to select a value. Each time I try to press one of the radio buttons, it appears to re-load the modal dialog without recording the choice. I am wondering if there is a) a way to make this work that has escaped me or b) a better way to accomplish this same goal? There are only two postal codes in the data frame that loads - A0A1P0 which exhibits the problem and N5X1G4, which has only a single census subdivision and thus doesn't trigger the modal.
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
splitLayout(
textInput("pcode", NULL, value="", placeholder = "e.g., A1A1A1"),
actionButton("findpc", "Find Me!"))
),
mainPanel(
withSpinner(verbatimTextOutput("mygeog"))
)
)
)
server <- function(input, output, session) {
library(dplyr)
load(file("https://quantoid.net/files/so/pccf_reprex.rda"))
output$mygeog <- renderPrint({
validate(need(input$findpc, ""))
mypc <- gsub(" ", "", input$pcode)
tmp_pc <- pccf_reprex
tmp_pc <- as.data.frame(subset(tmp_pc, PC == mypc))
if(nrow(tmp_pc) > 1){
geog_chc <- c(tmp_pc$CSDuid)
names(geog_chc) <- c(tmp_pc$CSDname)
showModal(dedupModal(chc=geog_chc))
tmp_pc <- tmp_pc[which(geog_chc == input$chooseGeog), ]
}
paste0("Geographic Indicator CSD: ",
tmp_pc$CSDname[1])
})
dedupModal <- function(failed = FALSE, chc) {
modalDialog(
span('Your Post Code did not identify a unique CSD. Please pick the appropriate one from the list below.'),
radioButtons("chooseGeog", "Choose Region", choices = chc, selected=character(0)),
footer = tagList(
actionButton("ok", "OK")
)
)
}
observeEvent(input$ok, {
# Check that data object exists and is data frame.
removeModal()
})
}
shinyApp(ui, server)
I was able to find a suitable solution by putting an event observer around the "Find Me!" button and rendering the print output inside the event observer. Here's the solution:
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
tags$script("
Shiny.addCustomMessageHandler('chooseGeog', function(value) {
Shiny.setInputValue('chooseGeog', value);
});
"),
sidebarLayout(
sidebarPanel(
splitLayout(
textInput("pcode", NULL, value="", placeholder = "e.g., A1A1A1"),
actionButton("findpc", "Find Me!"))
),
mainPanel(
verbatimTextOutput("mygeog")
)
)
)
server <- function(input, output, session) {
library(dplyr)
load(file("https://quantoid.net/files/so/pccf_reprex.rda"))
output$trig <- renderUI({
actionButton("trigger", "trigger")
})
observeEvent(input$findpc, {
mypc <- gsub(" ", "", input$pcode)
tmp_pc <- pccf_reprex
tmp_pc <- as.data.frame(subset(tmp_pc, PC == mypc))
if(nrow(tmp_pc) > 1){
geog_chc <- c(tmp_pc$CSDuid)
names(geog_chc) <- c(tmp_pc$CSDname)
showModal(dedupModal(chc=geog_chc))
}else{
session$sendCustomMessage("chooseGeog", tmp_pc$CSDuid[1])
}
output$mygeog <- renderPrint({
req(input$chooseGeog)
tmp_pc <- tmp_pc %>% filter(geog_chc == input$chooseGeog)
paste0("Geographic Indicator CSD: ",
tmp_pc$CSDname[1])
})
})
dedupModal <- function(failed = FALSE, chc) {
modalDialog(
span('Your Post Code did not identify a unique CSD. Please pick the appropriate one from the list below.'),
radioButtons("chooseGeog", "Choose Region", choices = chc, selected=character(0)),
footer = tagList(
actionButton("ok", "OK")
)
)
}
observeEvent(input$ok, {
# Check that data object exists and is data frame.
removeModal()
})
}
shinyApp(ui, server)
I am trying to select only filtered rows using select all button that comes with select extension in shiny's DT package but it selects all the rows.
Here's the sample shiny app
Below is the reproducible code for the app:
library(DT)
data(mpg)
# Define UI for application
ui <- fluidPage(
# Application title
titlePanel("Select only filtered rows using selectall button"),
br(),
br(),
DT::dataTableOutput("table")
)
# Define server logic
server <- function(input, output) {
output$table <- DT::renderDataTable({
datatable(mpg, escape=F,
rownames=F,
filter = 'top',
# colnames = c("Data Type","Variable","Description", "Filename"),
class = "compact hover row-border",
extensions = c('Scroller','Select', 'Buttons'),
options = list(
select = list(style = "multi", items = "row"),
columnDefs = list(list(className = 'dt-center', targets = "_all")),
language = list(
info = 'Showing _START_ to _END_ of _TOTAL_ variables'),
deferRender = TRUE,
scrollY = 500,
scroller = TRUE,
dom = "Blfrtip",
buttons = c('selectAll', 'selectNone')
),
selection="none"
) }, server = F
)
}
# Run the application
shinyApp(ui = ui, server = server)
I think I may have to add some custom javascript to fix this but I am not good with it.
Can anyone help or give any suggestions.
Thanks
Somehow I managed to figure out the solution for my question. Posting it here, so it might help others. I got help from couple of places. Datatable document and stackoverflow
Using these helps, I extended my selectall button functionality and also extended it for deselectall button (deselect any filtered rows).
Here's the updated shiny app
Below is the updated code:
library(shiny)
library(DT)
data(mpg)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Select only filtered rows using selectall button"),
br(),
br(),
DT::dataTableOutput("table")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$table <- DT::renderDataTable({
datatable(mpg, escape=F,
rownames=F,
filter = 'top',
# colnames = c("Data Type","Variable","Description", "Filename"),
class = "compact hover row-border",
extensions = c('Scroller','Select', 'Buttons'),
options = list(
select = list(style = "multi", items = "row"),
columnDefs = list(list(className = 'dt-center', targets = "_all")),
language = list(
info = 'Showing _START_ to _END_ of _TOTAL_ variables'),
deferRender = TRUE,
scrollY = 500,
scroller = TRUE,
dom = "Blfrtip",
buttons = list(list(extend='selectAll',className='selectAll',
text="select all rows",
action=DT::JS("function () {
var table = $('.dataTable').DataTable();
table.rows({ search: 'applied'}).deselect();
table.rows({ search: 'applied'}).select();
}")
), list(extend='selectNone',
text="DeselectAll",
action=DT::JS("function () {
var table = $('.dataTable').DataTable();
table.rows({ search: 'applied'}).select();
table.rows({ search: 'applied'}).deselect();
}")
))
),
selection="none"
) }, server = F
)
}
# Run the application
shinyApp(ui = ui, server = server)
Hope this help others.
Can shinyjs do something like if(is_disabled("#my_element_id")) do_something()?
I'd like to be able to see if a specific HTML element is disabled (by shinyjs or other means) before doing something else with it.
There's no such function. The answer depends on what you want exactly. Here is something which could help:
library(shiny)
library(shinyjs)
jsCode <- 'shinyjs.isDisabled = function(params) {
var el = $("#radiobtns");
Shiny.setInputValue("disabled", el.prop("disabled"));
}'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = "isDisabled"),
actionButton("button", "Disable radio buttons"),
radioButtons("radiobtns", "Radio buttons", c("Yes", "No"))
)
server <- function(input, output) {
observeEvent(input$button, {
toggleState("radiobtns")
js$isDisabled()
})
observeEvent(input$disabled, {
if(input$disabled){
cat("disabled\n")
}else{
cat("enabled\n")
}
})
}
shinyApp(ui = ui, server = server)
I don't know much of JavaScript, and I'm having a problem to override the default message in the Shiny R App, when I'm outputting table.
When table is empty, it's giving message "No data available in table" in the first row. I wanted to put some app-specific instructions instead.
I found that there's something like:
options = list(searching = FALSE,paging = FALSE) but don't know what option it would be to switch that text.
Also, I found JS code to reset the message (https://datatables.net/reference/option/language.zeroRecords),
but I wasn't able to attach this correctly to renderDataTable in Shiny.
I just don't know the correct syntax of incorporating JS into shiny, I tried
options = list(searching = FALSE,paging = FALSE, callback=DT:JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}
'
but it didn't work. I would appreciate some guidance on this.
Here's the whole code. Right now my attempts to replace the mesage are ignored:
library(ggplot2)
library(DT)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new Row in the UI for selectInputs
fluidRow(
column(12,
selectInput("man",
"Manufacturer:",
c("All",
unique(as.character(mpg$manufacturer))))
)
),
# Create a new row for the table.
fluidRow(
DT::dataTableOutput("table")
)
)
server <-function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
},options = list(searching = FALSE,paging = FALSE,callback=DT::JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}}
') )
))
}
shinyApp(ui = ui, server = server)
Do not use the callback, you can directly set the language -> zeroRecords attribute using the options parameter:
server <- function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
}, options =
list(searching = FALSE,paging = FALSE,
language = list(
zeroRecords = "No records to display - custom text")
)))
}
This works for me.
I am using shinyTree package and its checkbox option.
library(shiny)
library(shinyTree)
server <- shinyServer(function(input, output, session) {
# Defining lists inside list and rendering it in the shinyTree
output$tree <- renderTree({
list(
root1 = "123",
root2 = list(
SubListA = list(leaf1 = "", leaf2 = "", leaf3=""),
SubListB = structure(list(leafA = "", leafB = ""),stselected=TRUE)
)
)
})
})
ui <- shinyUI(
pageWithSidebar(
# Application title
headerPanel("shinyTree with checkbox controls"),
sidebarPanel(
mainPanel(
# Show a simple table with checkbox.
shinyTree("tree", checkbox = TRUE)
))
)
shinyApp(ui, server)
While running the above code, while selecting the sublistB the child of it also gets selected.
SublistB was selected but the child leafA and leafB also are selected
How can I only select subListB, and not selecting its leaves. Just like what happens when we use simple select property of shinyTree.
library(shiny)
library(shinyTree)
server <- shinyServer(function(input, output, session) {
output$tree <- renderTree({
list(
root1 = "",
root2 = list(
SubListA = list(leaf1 = "", leaf2 = "", leaf3=""),
SubListB = list(leafA = "", leafB = "")
)
)
})
})
ui<-shinyUI(
pageWithSidebar(
# Application title
headerPanel("Simple shinyTree!"),
sidebarPanel(
mainPanel(
# Show a simple table.
shinyTree("tree")
)
))
shinyApp(ui, server)
Simple shinyTree selection of only parent node SubListB and not the child nodes leafA and leafB