mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-08 21:55:02 -05:00
49a346334b
Fixes #2192. Two problems here: 1. It's not documented but apparently we supported data frames for choices in updateSelectInput/updateSelectizeInput (it doesn't appear to work correctly for selectInput/selectizeInput though). This was used in 023-optgroup-server as well as by the user who reported #2172. 2. The example in 023-optgroup-server was also counting on the default value of optgroupLabelField, which (starting post-Shiny v1.1) was being set to a new default of "group". That now won't happen unless optgroupField is also blank. I'm less confident about the ramifications of this change. The selectize docs with the relevant bits are here: https://github.com/selectize/selectize.js/blob/master/docs/usage.md#data_searching
822 lines
24 KiB
R
822 lines
24 KiB
R
#' Change the value of a text input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @param value The value to set for the input object.
|
|
#' @param placeholder The placeholder to set for the input object.
|
|
#'
|
|
#' @seealso \code{\link{textInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("controller", "Controller", 0, 20, 10),
|
|
#' textInput("inText", "Input text"),
|
|
#' textInput("inText2", "Input text 2")
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' # We'll use the input$controller variable multiple times, so save it as x
|
|
#' # for convenience.
|
|
#' x <- input$controller
|
|
#'
|
|
#' # This will change the value of input$inText, based on x
|
|
#' updateTextInput(session, "inText", value = paste("New text", x))
|
|
#'
|
|
#' # Can also set the label, this time for input$inText2
|
|
#' updateTextInput(session, "inText2",
|
|
#' label = paste("New label", x),
|
|
#' value = paste("New text", x))
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
|
|
message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
#' Change the value of a textarea input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @inheritParams updateTextInput
|
|
#'
|
|
#' @seealso \code{\link{textAreaInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("controller", "Controller", 0, 20, 10),
|
|
#' textAreaInput("inText", "Input textarea"),
|
|
#' textAreaInput("inText2", "Input textarea 2")
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' # We'll use the input$controller variable multiple times, so save it as x
|
|
#' # for convenience.
|
|
#' x <- input$controller
|
|
#'
|
|
#' # This will change the value of input$inText, based on x
|
|
#' updateTextAreaInput(session, "inText", value = paste("New text", x))
|
|
#'
|
|
#' # Can also set the label, this time for input$inText2
|
|
#' updateTextAreaInput(session, "inText2",
|
|
#' label = paste("New label", x),
|
|
#' value = paste("New text", x))
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateTextAreaInput <- updateTextInput
|
|
|
|
|
|
#' Change the value of a checkbox input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @param value The value to set for the input object.
|
|
#'
|
|
#' @seealso \code{\link{checkboxInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("controller", "Controller", 0, 1, 0, step = 1),
|
|
#' checkboxInput("inCheckbox", "Input checkbox")
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' # TRUE if input$controller is odd, FALSE if even.
|
|
#' x_even <- input$controller %% 2 == 1
|
|
#'
|
|
#' updateCheckboxInput(session, "inCheckbox", value = x_even)
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
|
|
message <- dropNulls(list(label=label, value=value))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
|
|
#' Change the label or icon of an action button on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @param icon The icon to set for the input object. To remove the
|
|
#' current icon, use \code{icon=character(0)}.
|
|
#'
|
|
#' @seealso \code{\link{actionButton}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' actionButton("update", "Update other buttons"),
|
|
#' br(),
|
|
#' actionButton("goButton", "Go"),
|
|
#' br(),
|
|
#' actionButton("goButton2", "Go 2", icon = icon("area-chart")),
|
|
#' br(),
|
|
#' actionButton("goButton3", "Go 3")
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' req(input$update)
|
|
#'
|
|
#' # Updates goButton's label and icon
|
|
#' updateActionButton(session, "goButton",
|
|
#' label = "New label",
|
|
#' icon = icon("calendar"))
|
|
#'
|
|
#' # Leaves goButton2's label unchaged and
|
|
#' # removes its icon
|
|
#' updateActionButton(session, "goButton2",
|
|
#' icon = character(0))
|
|
#'
|
|
#' # Leaves goButton3's icon, if it exists,
|
|
#' # unchaged and changes its label
|
|
#' updateActionButton(session, "goButton3",
|
|
#' label = "New label 3")
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
|
|
if (!is.null(icon)) icon <- as.character(validateIcon(icon))
|
|
message <- dropNulls(list(label=label, icon=icon))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
|
|
#' Change the value of a date input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @param value The desired date value. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
|
|
#' @param min The minimum allowed date. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format.
|
|
#' @param max The maximum allowed date. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format.
|
|
#'
|
|
#' @seealso \code{\link{dateInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("n", "Day of month", 1, 30, 10),
|
|
#' dateInput("inDate", "Input date")
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' date <- as.Date(paste0("2013-04-", input$n))
|
|
#' updateDateInput(session, "inDate",
|
|
#' label = paste("Date label", input$n),
|
|
#' value = date,
|
|
#' min = date - 3,
|
|
#' max = date + 3
|
|
#' )
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateDateInput <- function(session, inputId, label = NULL, value = NULL,
|
|
min = NULL, max = NULL) {
|
|
|
|
# Make sure values are NULL or Date objects. This is so we can ensure that
|
|
# they will be formatted correctly. For example, the string "2016-08-9" is not
|
|
# correctly formatted, but the conversion to Date and back to string will fix
|
|
# it.
|
|
formatDate <- function(x) {
|
|
if (is.null(x))
|
|
return(NULL)
|
|
format(as.Date(x), "%Y-%m-%d")
|
|
}
|
|
value <- formatDate(value)
|
|
min <- formatDate(min)
|
|
max <- formatDate(max)
|
|
|
|
message <- dropNulls(list(label=label, value=value, min=min, max=max))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
|
|
#' Change the start and end values of a date range input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @param start The start date. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format. Supplying \code{NA} clears the start date.
|
|
#' @param end The end date. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
|
|
#' @param min The minimum allowed date. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format.
|
|
#' @param max The maximum allowed date. Either a Date object, or a string in
|
|
#' \code{yyyy-mm-dd} format.
|
|
#'
|
|
#' @seealso \code{\link{dateRangeInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("n", "Day of month", 1, 30, 10),
|
|
#' dateRangeInput("inDateRange", "Input date range")
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' date <- as.Date(paste0("2013-04-", input$n))
|
|
#'
|
|
#' updateDateRangeInput(session, "inDateRange",
|
|
#' label = paste("Date range label", input$n),
|
|
#' start = date - 1,
|
|
#' end = date + 1,
|
|
#' min = date - 5,
|
|
#' max = date + 5
|
|
#' )
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateDateRangeInput <- function(session, inputId, label = NULL,
|
|
start = NULL, end = NULL, min = NULL,
|
|
max = NULL) {
|
|
# Make sure start and end are strings, not date objects. This is for
|
|
# consistency across different locales.
|
|
if (inherits(start, "Date")) start <- format(start, '%Y-%m-%d')
|
|
if (inherits(end, "Date")) end <- format(end, '%Y-%m-%d')
|
|
if (inherits(min, "Date")) min <- format(min, '%Y-%m-%d')
|
|
if (inherits(max, "Date")) max <- format(max, '%Y-%m-%d')
|
|
|
|
message <- dropNulls(list(
|
|
label = label,
|
|
value = dropNulls(list(start = start, end = end)),
|
|
min = min,
|
|
max = max
|
|
))
|
|
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
#' Change the selected tab on the client
|
|
#'
|
|
#' @param session The \code{session} object passed to function given to
|
|
#' \code{shinyServer}.
|
|
#' @param inputId The id of the \code{tabsetPanel}, \code{navlistPanel},
|
|
#' or \code{navbarPage} object.
|
|
#' @param selected The name of the tab to make active.
|
|
#'
|
|
#' @seealso \code{\link{tabsetPanel}}, \code{\link{navlistPanel}},
|
|
#' \code{\link{navbarPage}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(sidebarLayout(
|
|
#' sidebarPanel(
|
|
#' sliderInput("controller", "Controller", 1, 3, 1)
|
|
#' ),
|
|
#' mainPanel(
|
|
#' tabsetPanel(id = "inTabset",
|
|
#' tabPanel(title = "Panel 1", value = "panel1", "Panel 1 content"),
|
|
#' tabPanel(title = "Panel 2", value = "panel2", "Panel 2 content"),
|
|
#' tabPanel(title = "Panel 3", value = "panel3", "Panel 3 content")
|
|
#' )
|
|
#' )
|
|
#' ))
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observeEvent(input$controller, {
|
|
#' updateTabsetPanel(session, "inTabset",
|
|
#' selected = paste0("panel", input$controller)
|
|
#' )
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateTabsetPanel <- function(session, inputId, selected = NULL) {
|
|
message <- dropNulls(list(value = selected))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
#' @rdname updateTabsetPanel
|
|
#' @export
|
|
updateNavbarPage <- updateTabsetPanel
|
|
|
|
#' @rdname updateTabsetPanel
|
|
#' @export
|
|
updateNavlistPanel <- updateTabsetPanel
|
|
|
|
#' Change the value of a number input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @param value The value to set for the input object.
|
|
#' @param min Minimum value.
|
|
#' @param max Maximum value.
|
|
#' @param step Step size.
|
|
#'
|
|
#' @seealso \code{\link{numericInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' sliderInput("controller", "Controller", 0, 20, 10),
|
|
#' numericInput("inNumber", "Input number", 0),
|
|
#' numericInput("inNumber2", "Input number 2", 0)
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#'
|
|
#' observeEvent(input$controller, {
|
|
#' # We'll use the input$controller variable multiple times, so save it as x
|
|
#' # for convenience.
|
|
#' x <- input$controller
|
|
#'
|
|
#' updateNumericInput(session, "inNumber", value = x)
|
|
#'
|
|
#' updateNumericInput(session, "inNumber2",
|
|
#' label = paste("Number label ", x),
|
|
#' value = x, min = x-10, max = x+10, step = 5)
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
|
|
min = NULL, max = NULL, step = NULL) {
|
|
|
|
message <- dropNulls(list(
|
|
label = label, value = formatNoSci(value),
|
|
min = formatNoSci(min), max = formatNoSci(max), step = formatNoSci(step)
|
|
))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
#' Update Slider Input Widget
|
|
#'
|
|
#' Change the value of a slider input on the client.
|
|
#'
|
|
#' @template update-input
|
|
#' @param value The value to set for the input object.
|
|
#' @param min Minimum value.
|
|
#' @param max Maximum value.
|
|
#' @param step Step size.
|
|
#' @param timeFormat Date and POSIXt formatting.
|
|
#' @param timezone The timezone offset for POSIXt objects.
|
|
#'
|
|
#' @seealso \code{\link{sliderInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run this example in interactive R sessions
|
|
#' if (interactive()) {
|
|
#' shinyApp(
|
|
#' ui = fluidPage(
|
|
#' sidebarLayout(
|
|
#' sidebarPanel(
|
|
#' p("The first slider controls the second"),
|
|
#' sliderInput("control", "Controller:", min=0, max=20, value=10,
|
|
#' step=1),
|
|
#' sliderInput("receive", "Receiver:", min=0, max=20, value=10,
|
|
#' step=1)
|
|
#' ),
|
|
#' mainPanel()
|
|
#' )
|
|
#' ),
|
|
#' server = function(input, output, session) {
|
|
#' observe({
|
|
#' val <- input$control
|
|
#' # Control the value, min, max, and step.
|
|
#' # Step size is 2 when input value is even; 1 when value is odd.
|
|
#' updateSliderInput(session, "receive", value = val,
|
|
#' min = floor(val/2), max = val+4, step = (val+1)%%2 + 1)
|
|
#' })
|
|
#' }
|
|
#' )
|
|
#' }
|
|
#' @export
|
|
updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
|
|
min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
|
|
{
|
|
dataType <- getSliderType(min, max, value)
|
|
|
|
if (is.null(timeFormat)) {
|
|
timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
|
|
}
|
|
|
|
if (dataType == "date" || dataType == "datetime") {
|
|
to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
|
|
if (!is.null(min)) min <- to_ms(min)
|
|
if (!is.null(max)) max <- to_ms(max)
|
|
if (!is.null(value)) value <- to_ms(value)
|
|
}
|
|
|
|
message <- dropNulls(list(
|
|
label = label,
|
|
value = formatNoSci(value),
|
|
min = formatNoSci(min),
|
|
max = formatNoSci(max),
|
|
step = formatNoSci(step),
|
|
`data-type` = dataType,
|
|
`time-format` = timeFormat,
|
|
timezone = timezone
|
|
))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
|
|
updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
|
|
selected = NULL, inline = FALSE, type = NULL,
|
|
choiceNames = NULL, choiceValues = NULL) {
|
|
if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
|
|
|
|
args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
|
|
|
|
if (!is.null(selected)) selected <- as.character(selected)
|
|
|
|
options <- if (!is.null(args$choiceValues)) {
|
|
format(tagList(
|
|
generateOptions(session$ns(inputId), selected, inline, type,
|
|
args$choiceNames, args$choiceValues)
|
|
))
|
|
}
|
|
|
|
message <- dropNulls(list(label = label, options = options, value = selected))
|
|
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
#' Change the value of a checkbox group input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @inheritParams checkboxGroupInput
|
|
#'
|
|
#' @seealso \code{\link{checkboxGroupInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' p("The first checkbox group controls the second"),
|
|
#' checkboxGroupInput("inCheckboxGroup", "Input checkbox",
|
|
#' c("Item A", "Item B", "Item C")),
|
|
#' checkboxGroupInput("inCheckboxGroup2", "Input checkbox 2",
|
|
#' c("Item A", "Item B", "Item C"))
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' x <- input$inCheckboxGroup
|
|
#'
|
|
#' # Can use character(0) to remove all choices
|
|
#' if (is.null(x))
|
|
#' x <- character(0)
|
|
#'
|
|
#' # Can also set the label and select items
|
|
#' updateCheckboxGroupInput(session, "inCheckboxGroup2",
|
|
#' label = paste("Checkboxgroup label", length(x)),
|
|
#' choices = x,
|
|
#' selected = x
|
|
#' )
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateCheckboxGroupInput <- function(session, inputId, label = NULL,
|
|
choices = NULL, selected = NULL, inline = FALSE,
|
|
choiceNames = NULL, choiceValues = NULL) {
|
|
updateInputOptions(session, inputId, label, choices, selected,
|
|
inline, "checkbox", choiceNames, choiceValues)
|
|
}
|
|
|
|
|
|
#' Change the value of a radio input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @inheritParams radioButtons
|
|
#'
|
|
#' @seealso \code{\link{radioButtons}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' p("The first radio button group controls the second"),
|
|
#' radioButtons("inRadioButtons", "Input radio buttons",
|
|
#' c("Item A", "Item B", "Item C")),
|
|
#' radioButtons("inRadioButtons2", "Input radio buttons 2",
|
|
#' c("Item A", "Item B", "Item C"))
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' x <- input$inRadioButtons
|
|
#'
|
|
#' # Can also set the label and select items
|
|
#' updateRadioButtons(session, "inRadioButtons2",
|
|
#' label = paste("radioButtons label", x),
|
|
#' choices = x,
|
|
#' selected = x
|
|
#' )
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
|
|
selected = NULL, inline = FALSE,
|
|
choiceNames = NULL, choiceValues = NULL) {
|
|
# you must select at least one radio button
|
|
if (is.null(selected)) {
|
|
if (!is.null(choices)) selected <- choices[[1]]
|
|
else if (!is.null(choiceValues)) selected <- choiceValues[[1]]
|
|
}
|
|
updateInputOptions(session, inputId, label, choices, selected,
|
|
inline, 'radio', choiceNames, choiceValues)
|
|
}
|
|
|
|
|
|
#' Change the value of a select input on the client
|
|
#'
|
|
#' @template update-input
|
|
#' @inheritParams selectInput
|
|
#'
|
|
#' @seealso \code{\link{selectInput}} \code{\link{varSelectInput}}
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' p("The checkbox group controls the select input"),
|
|
#' checkboxGroupInput("inCheckboxGroup", "Input checkbox",
|
|
#' c("Item A", "Item B", "Item C")),
|
|
#' selectInput("inSelect", "Select input",
|
|
#' c("Item A", "Item B", "Item C"))
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output, session) {
|
|
#' observe({
|
|
#' x <- input$inCheckboxGroup
|
|
#'
|
|
#' # Can use character(0) to remove all choices
|
|
#' if (is.null(x))
|
|
#' x <- character(0)
|
|
#'
|
|
#' # Can also set the label and select items
|
|
#' updateSelectInput(session, "inSelect",
|
|
#' label = paste("Select input label", length(x)),
|
|
#' choices = x,
|
|
#' selected = tail(x, 1)
|
|
#' )
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
|
|
selected = NULL) {
|
|
choices <- if (!is.null(choices)) choicesWithNames(choices)
|
|
if (!is.null(selected)) selected <- as.character(selected)
|
|
options <- if (!is.null(choices)) selectOptions(choices, selected)
|
|
message <- dropNulls(list(label = label, options = options, value = selected))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
|
|
#' @rdname updateSelectInput
|
|
#' @inheritParams selectizeInput
|
|
#' @param server whether to store \code{choices} on the server side, and load
|
|
#' the select options dynamically on searching, instead of writing all
|
|
#' \code{choices} into the page at once (i.e., only use the client-side
|
|
#' version of \pkg{selectize.js})
|
|
#' @export
|
|
updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
|
|
selected = NULL, options = list(),
|
|
server = FALSE) {
|
|
if (length(options)) {
|
|
res <- checkAsIs(options)
|
|
cfg <- tags$script(
|
|
type = 'application/json',
|
|
`data-for` = session$ns(inputId),
|
|
`data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
|
|
HTML(toJSON(res$options))
|
|
)
|
|
session$sendInputMessage(inputId, list(config = as.character(cfg)))
|
|
}
|
|
if (!server) {
|
|
return(updateSelectInput(session, inputId, label, choices, selected))
|
|
}
|
|
|
|
noOptGroup <- TRUE
|
|
if (is.list(choices)) {
|
|
# check if list is nested
|
|
for (i in seq_along(choices)) {
|
|
if (is.list(choices[[i]]) || length(choices[[i]]) > 1) {
|
|
noOptGroup <- FALSE
|
|
break()
|
|
}
|
|
}
|
|
}
|
|
# convert choices to a data frame so it returns [{label: , value: , group: },...]
|
|
choices <- if (is.data.frame(choices)) {
|
|
# jcheng 2018/09/25: I don't think we ever said data frames were OK to pass
|
|
# to updateSelectInput, but one of the example apps does this and at least
|
|
# one user noticed when we broke it.
|
|
# https://github.com/rstudio/shiny/issues/2172
|
|
# https://github.com/rstudio/shiny/issues/2192
|
|
as.data.frame(choices, stringsAsFactors = FALSE)
|
|
} else if (is.atomic(choices) || noOptGroup) {
|
|
# fast path for vectors and flat lists
|
|
if (is.list(choices)) {
|
|
choices <- unlist(choices)
|
|
}
|
|
if (is.null(names(choices))) {
|
|
lab <- as.character(choices)
|
|
} else {
|
|
lab <- names(choices)
|
|
# replace empty names like: choices = c(a = 1, 2)
|
|
# in this case: names(choices) = c("a", "")
|
|
# with replacement below choices will be: lab = c("a", "2")
|
|
empty_names_indices <- lab == ""
|
|
lab[empty_names_indices] <- as.character(choices[empty_names_indices])
|
|
}
|
|
data.frame(label = lab, value = choices, stringsAsFactors = FALSE)
|
|
} else {
|
|
# slow path for nested lists/optgroups
|
|
list_names <- names(choices)
|
|
if (is.null(list_names)) {
|
|
list_names <- rep("", length(choices))
|
|
}
|
|
|
|
choice_list <- mapply(choices, list_names, FUN = function (choice, name) {
|
|
group <- ""
|
|
lab <- name
|
|
if (lab == "") lab <- as.character(choice)
|
|
|
|
if (is.list(choice) || length(choice) > 1) {
|
|
group <- rep(name, length(choice))
|
|
choice <- unlist(choice)
|
|
|
|
if (is.null(names(choice))) {
|
|
lab <- as.character(choice)
|
|
} else {
|
|
lab <- names(choice)
|
|
# replace empty names like: choices = c(a = 1, 2)
|
|
# in this case: names(choices) = c("a", "")
|
|
# with replacement below choices will be: lab = c("a", "2")
|
|
empty_names_indices <- lab == ""
|
|
lab[empty_names_indices] <- as.character(choice[empty_names_indices])
|
|
}
|
|
}
|
|
|
|
list(
|
|
label = lab,
|
|
value = as.character(choice),
|
|
group = group
|
|
)
|
|
}, SIMPLIFY = FALSE)
|
|
|
|
|
|
extract_vector <- function(x, name) {
|
|
vecs <- lapply(x, `[[`, name)
|
|
do.call(c, vecs)
|
|
}
|
|
|
|
data.frame(
|
|
label = extract_vector(choice_list, "label"),
|
|
value = extract_vector(choice_list, "value"),
|
|
group = extract_vector(choice_list, "group"),
|
|
stringsAsFactors = FALSE, row.names = NULL
|
|
)
|
|
}
|
|
|
|
value <- unname(selected)
|
|
attr(choices, 'selected_value') <- value
|
|
|
|
message <- dropNulls(list(
|
|
label = label,
|
|
value = value,
|
|
url = session$registerDataObj(inputId, choices, selectizeJSON)
|
|
))
|
|
session$sendInputMessage(inputId, message)
|
|
}
|
|
#' @rdname updateSelectInput
|
|
#' @inheritParams varSelectInput
|
|
#' @export
|
|
updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
|
|
if (is.null(data)) {
|
|
choices <- NULL
|
|
} else {
|
|
choices <- colnames(data)
|
|
}
|
|
updateSelectInput(
|
|
session = session,
|
|
inputId = inputId,
|
|
label = label,
|
|
choices = choices,
|
|
selected = selected
|
|
)
|
|
}
|
|
#' @rdname updateSelectInput
|
|
#' @export
|
|
updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
|
|
if (is.null(data)) {
|
|
choices <- NULL
|
|
} else {
|
|
choices <- colnames(data)
|
|
}
|
|
updateSelectizeInput(
|
|
session = session,
|
|
inputId = inputId,
|
|
label = label,
|
|
choices = choices,
|
|
selected = selected,
|
|
options = options,
|
|
server = server
|
|
)
|
|
}
|
|
|
|
|
|
|
|
selectizeJSON <- function(data, req) {
|
|
query <- parseQueryString(req$QUERY_STRING)
|
|
|
|
# extract the query variables, conjunction (and/or), search string, maximum options
|
|
var <- c(safeFromJSON(query$field))
|
|
|
|
# all keywords in lower-case, for case-insensitive matching
|
|
key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
|
|
|
|
if (identical(key, '')) key <- character(0)
|
|
mop <- as.numeric(query$maxop)
|
|
vfd <- query$value # the value field name
|
|
sel <- attr(data, 'selected_value', exact = TRUE)
|
|
|
|
# start searching for keywords in all specified columns
|
|
idx <- logical(nrow(data))
|
|
if (length(key)) {
|
|
for (v in var) {
|
|
matches <- do.call(
|
|
cbind,
|
|
lapply(key, function(k) {
|
|
grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
|
|
})
|
|
)
|
|
# merge column matches using OR, and match multiple keywords in one column
|
|
# using the conjunction setting (AND or OR)
|
|
matches <- rowSums(matches)
|
|
if (query$conju == 'and')
|
|
idx <- idx | (matches == length(key))
|
|
else
|
|
idx <- idx | matches
|
|
}
|
|
}
|
|
# only return the first n rows (n = maximum options in configuration)
|
|
idx <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)
|
|
# make sure the selected value is in the data
|
|
if (length(sel)) {
|
|
i <- stats::na.omit(match(sel, data[, vfd]))
|
|
if (length(i)) idx <- sort(utils::head(unique(c(i, idx)), mop))
|
|
}
|
|
data <- data[idx, ]
|
|
|
|
res <- toJSON(columnToRowData(data))
|
|
httpResponse(200, 'application/json', enc2utf8(res))
|
|
}
|