#' Change the value of a text input on the client
#'
#' @template update-input
#' @param value The value to set for the input object.
#'
#' @seealso \code{\link{textInput}}
#'
#' @examples
#' \dontrun{
#' shinyServer(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))
#'   })
#' })
#' }
#' @export
updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
  message <- dropNulls(list(label=label, value=value))
  session$sendInputMessage(inputId, message)
}


#' 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
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # TRUE if input$controller is even, FALSE otherwise.
#'     x_even <- input$controller %% 2 == 0
#'
#'     updateCheckboxInput(session, "inCheckbox", value = x_even)
#'   })
#' })
#' }
#' @export
updateCheckboxInput <- updateTextInput


#' Change the value of a slider input on the client
#'
#' @template update-input
#' @param value The value to set for the input object.
#'
#' @seealso \code{\link{sliderInput}}
#'
#' @examples
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # We'll use the input$controller variable multiple times, so save it as x
#'     # for convenience.
#'     x <- input$controller
#'
#'     # Similar to number and text. only label and value can be set for slider
#'     updateSliderInput(session, "inSlider",
#'       label = paste("Slider label", x),
#'       value = x)
#'
#'     # For sliders that pick out a range, pass in a vector of 2 values.
#'     updateSliderInput(session, "inSlider2", value = c(x-1, x+1))
#'
#'     # An NA means to not change that value (the low or high one)
#'     updateSliderInput(session, "inSlider3", value = c(NA, x+2))
#'   })
#' })
#' }
#' @export
updateSliderInput <- updateTextInput

#' 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.
#' @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
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # We'll use the input$controller variable multiple times, so save it as x
#'     # for convenience.
#'     x <- input$controller
#'
#'     updateDateInput(session, "inDate",
#'       label = paste("Date label", x),
#'       value = paste("2013-04-", x, sep=""),
#'       min   = paste("2013-04-", x-1, sep=""),
#'       max   = paste("2013-04-", x+1, sep="")
#'     )
#'   })
#' })
#' }
#' @export
updateDateInput <- function(session, inputId, label = NULL, value = NULL,
    min = NULL, max = NULL) {

  # If value is a date object, convert it to a string with yyyy-mm-dd format
  # Same for min and max
  if (inherits(value, "Date"))  value <- format(value, "%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=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.
#' @param end The end date. Either a Date object, or a string in
#'   \code{yyyy-mm-dd} format.
#' @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
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # We'll use the input$controller variable multiple times, so save it as x
#'     # for convenience.
#'     x <- input$controller
#'
#'     updateDateRangeInput(session, "inDateRange",
#'       label = paste("Date range label", x),
#'       start = paste("2013-01-", x, sep=""))
#'       end = paste("2013-12-", x, sep=""))
#'   })
#' })
#' }
#' @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 = c(start, 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
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # TRUE if input$controller is even, FALSE otherwise.
#'     x_even <- input$controller %% 2 == 0
#'
#'     # Change the selected tab.
#'     # Note that the tabset container must have been created with an 'id' argument
#'     if (x_even) {
#'       updateTabsetPanel(session, "inTabset", selected = "panel2")
#'     } else {
#'       updateTabsetPanel(session, "inTabset", selected = "panel1")
#'     }
#'   })
#' })
#' }
#' @export
updateTabsetPanel <- function(session, inputId, selected = NULL) {
  message <- dropNulls(list(value = selected))
  session$sendInputMessage(inputId, message)
}


#' 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
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # 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)
#'   })
#' })
#' }
#' @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)
}


#' Change the value of a checkbox group input on the client
#'
#' @template update-input
#' @param choices A named vector or named list of options. For each item, the
#'   name will be used as the label, and the value will be used as the value.
#' @param selected A vector or list of options (values) which will be selected.
#'
#' @seealso \code{\link{checkboxGroupInput}}
#'
#' @examples
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # We'll use the input$controller variable multiple times, so save it as x
#'     # for convenience.
#'     x <- input$controller
#'
#'     # Create a list of new options, where the name of the items is something
#'     # like 'option label x 1', and the values are 'option-x-1'.
#'     cb_options <- list()
#'     cb_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
#'     cb_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
#'
#'     # Change values for input$inCheckboxGroup
#'     updateCheckboxGroupInput(session, "inCheckboxGroup", choices = cb_options)
#'
#'     # Can also set the label and select items
#'     updateCheckboxGroupInput(session, "inCheckboxGroup2",
#'       label = paste("checkboxgroup label", x),
#'       choices = cb_options,
#'       selected = sprintf("option-%d-2", x)
#'     )
#'   })
#' })
#' }
#' @export
updateCheckboxGroupInput <- function(session, inputId, label = NULL,
  choices = NULL, selected = NULL) {

  choices <- choicesWithNames(choices)
  if (!is.null(selected))
    selected <- validateSelected(selected, choices, inputId)

  options <- if (length(choices))
    columnToRowData(list(value = choices, label = names(choices)))

  message <- dropNulls(list(label = label, options = options, value = selected))

  session$sendInputMessage(inputId, message)
}


#' Change the value of a radio input on the client
#'
#' @template update-input
#' @param choices A named vector or named list of options. For each item, the
#'   name will be used as the label, and the value will be used as the value.
#' @param selected A vector or list of options (values) which will be selected.
#'
#' @seealso \code{\link{radioButtons}}
#'
#' @examples
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # We'll use the input$controller variable multiple times, so save it as x
#'     # for convenience.
#'     x <- input$controller
#'
#'     r_options <- list()
#'     r_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
#'     r_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
#'
#'     # Change values for input$inRadio
#'     updateRadioButtons(session, "inRadio", choices = r_options)
#'
#'     # Can also set the label and select an item
#'     updateRadioButtons(session, "inRadio2",
#'       label = paste("Radio label", x),
#'       choices = r_options,
#'       selected = sprintf("option-%d-2", x)
#'     )
#'   })
#' })
#' }
#' @export
updateRadioButtons <- updateCheckboxGroupInput


#' Change the value of a select input on the client
#'
#' @template update-input
#' @param choices A named vector or named list of options. For each item, the
#'   name will be used as the label, and the value will be used as the value.
#' @param selected A vector or list of options (values) which will be selected.
#'
#' @seealso \code{\link{selectInput}}
#'
#' @examples
#' \dontrun{
#' shinyServer(function(input, output, session) {
#'
#'   observe({
#'     # We'll use the input$controller variable multiple times, so save it as x
#'     # for convenience.
#'     x <- input$controller
#'
#'     # Create a list of new options, where the name of the items is something
#'     # like 'option label x 1', and the values are 'option-x-1'.
#'     s_options <- list()
#'     s_options[[sprintf("option label %d 1", x)]] <- sprintf("option-%d-1", x)
#'     s_options[[sprintf("option label %d 2", x)]] <- sprintf("option-%d-2", x)
#'
#'     # Change values for input$inSelect
#'     updateSelectInput(session, "inSelect", choices = s_options)
#'
#'     # Can also set the label and select an item (or more than one if it's a
#'     # multi-select)
#'     updateSelectInput(session, "inSelect2",
#'       label = paste("Select label", x),
#'       choices = s_options,
#'       selected = sprintf("option-%d-2", x)
#'     )
#'   })
#' })
#' }
#' @export
updateSelectInput <- updateCheckboxGroupInput

#' @rdname updateSelectInput
#' @param options a list of options (see \code{\link{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` = inputId,
      `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
      HTML(toJSON(res$options))
    )
    session$sendInputMessage(inputId, list(newOptions = as.character(cfg)))
  }
  if (!server) {
    return(updateSelectInput(session, inputId, label, choices, selected))
  }
  # in the server mode, the choices are not available before we type, so we
  # cannot really pre-select any options, but here we insert the `selected`
  # options into selectize forcibly
  value <- unname(selected)
  selected <- choicesWithNames(selected)
  message <- dropNulls(list(
    label = label,
    value = value,
    selected = if (length(selected)) {
      columnToRowData(list(label = names(selected), value = selected))
    },
    url = session$registerDataObj(inputId, choices, selectizeJSON)
  ))
  session$sendInputMessage(inputId, message)
}

selectizeJSON <- function(data, req) {
  query <- parseQueryString(req$QUERY_STRING)
  # extract the query variables, conjunction (and/or), search string, maximum options
  var <- fromJSON(query$field)
  cjn <- if (query$conju == 'and') all else any
  # all keywords in lower-case, for case-insensitive matching
  key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
  if (identical(key, '')) key <- character(0)
  mop <- query$maxop

  # convert a single vector to a data frame so it returns {label: , value: }
  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
  data <- if (is.atomic(data)) {
    data <- choicesWithNames(data)
    data.frame(label = names(data), value = data, stringsAsFactors = FALSE)
  } else as.data.frame(data, stringsAsFactors = FALSE)

  # 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)
    idx <- idx | apply(matches, 1, cjn)
  }
  # only return the first n rows (n = maximum options in configuration)
  idx <- head(which(idx), mop)
  data <- data[idx, ]

  httpResponse(200, 'application/json', toJSON(columnToRowData(data)))
}