R/proxy.R

In CannaData/CannaSelectize: Enhancements to 'Selectize' in 'Shiny'

# Copyright (C) 2017 CannaData Solutions
# 
# This file is part of CannaSignup.
# 
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

#' Manipulate an existing selectizeInput
#' 
#' @param outputId the id of the \code{shiny::selectizeInput} to be manipulated
#' @inheritParams DT::dataTableProxy
#' @import shiny
#' @export
#' @note Code borrowed from \code{DT::dataTableProxy}
selectizeProxy <- function(outputId, session = shiny::getDefaultReactiveDomain(), deferUntilFlush = TRUE) {
  if (is.null(session))
    stop('datatableProxy() must be called from the server function of a Shiny app')
  
  structure(
    list(id = session$ns(outputId), session = session, deferUntilFlush = deferUntilFlush),
    class = 'selectizeProxy'
  )
}

#' Update choices in selectizeInput without rerendering
#' @param proxy a proxy object returned by \code{selectizeProxy}
#' @param options a (optionally named) vector of options for the selectize, or a list with values for labels, values, and groups
#' @note Similar to \code{shiny::updateSelectizeInput} except asynchronious
#' @export
update_options <- function(proxy, options) {
  if (is.list(options)) {
    labels <- options$label
    values <- options$value
    groups <- options$group
    } else if (is.null(names(options))) {
    labels <- options
    values <- options
    groups <- NULL
  } else {
    labels <- names(options)
    values <- options
    groups <- NULL
  }

  invokeRemote(proxy, "update_options", dropNulls(list(values = as.vector(values),
                                             labels = labels,
                                             groups = groups)))
}

dropNulls <- getFromNamespace('dropNulls', 'shiny')

#' @export
#' @rdname update_options
update_value <- function(proxy, value) {
  invokeRemote(proxy, "update_value", list(value = as.vector(value)))
}

#' @export
#' @rdname update_options
#' @param value Value of option to be edited
#' @param data Updated data
update_option <- function(proxy, value, data) {
  invokeRemote(proxy, "update_option", list(value = value, data = data))
}

# Borrowed from DT
invokeRemote <- function(proxy, method, args = list()) {
  if (!inherits(proxy, 'selectizeProxy'))
    stop('Invalid proxy argument; selectize proxy object was expected')
  
  msg = list(id = proxy$id, call = list(method = method, args = args))
  
  sess = proxy$session
  if (proxy$deferUntilFlush) {
    sess$onFlushed(function() {
      sess$sendCustomMessage('CannaSelectize', msg)
    }, once = TRUE)
  } else {
    sess$sendCustomMessage('CannaSelectize', msg)
  }
  proxy
}