R/shiny.R

In DT: A Wrapper of the JavaScript Library 'DataTables'

#' Helper functions for using DT in Shiny
#'
#' These two functions are like most \code{fooOutput()} and \code{renderFoo()}
#' functions in the \pkg{shiny} package. The former is used to create a
#' container for table, and the latter is used in the server logic to render the
#' table.
#' @param outputId output variable to read the table from
#' @param width the width of the table container
#' @param height the height of the table container
#' @param fill passed to \code{htmlwidgets::\link{shinyWidgetOutput}()}, see
#'   there for explanation (requires \pkg{htmlwidgets} > v1.5.4).
#' @references \url{https://rstudio.github.io/DT/shiny.html}
#' @export
#' @examples # !formatR
#' if (interactive()) {
#'   library(shiny)
#'   library(DT)
#'   shinyApp(
#'     ui = fluidPage(fluidRow(column(12, DTOutput('tbl')))),
#'     server = function(input, output) {
#'       output$tbl = renderDT(
#'         iris, options = list(lengthChange = FALSE)
#'       )
#'     }
#'   )
#' }
dataTableOutput = function(outputId, width = '100%', height = 'auto', fill = TRUE) {
  args = list(outputId, 'datatables', width, height, package = 'DT')
  if ("fill" %in% names(formals(htmlwidgets::shinyWidgetOutput)))
    args$fill = fill

  htmltools::attachDependencies(
    do.call(htmlwidgets::shinyWidgetOutput, args),
    crosstalk::crosstalkLibs(),
    append = TRUE
  )
}

#' @export
#' @rdname dataTableOutput
DTOutput = dataTableOutput

#' @export
#' @rdname dataTableOutput
#' @param expr an expression to create a table widget (normally via
#'   \code{\link{datatable}()}), or a data object to be passed to
#'   \code{datatable()} to create a table widget
#' @param server whether to use server-side processing. If \code{TRUE}, then the
#'   data is kept on the server and the browser requests a page at a time; if
#'   \code{FALSE}, then the entire data frame is sent to the browser at once.
#'   Highly recommended for medium to large data frames, which can cause
#'   browsers to slow down or crash. Note that if you want to use
#'   \code{renderDataTable} with \code{shiny::bindCache()}, this must be
#'   \code{FALSE}.
#' @param env The parent environment for the reactive expression. By default,
#'   this is the calling environment, the same as when defining an ordinary
#'   non-reactive expression. If \code{expr} is a quosure and \code{quoted} is
#'   \code{TRUE}, then \code{env} is ignored.
#' @param quoted If it is \code{TRUE}, then the \code{\link{quote}()}ed value of
#'   \code{expr} will be used when \code{expr} is evaluated. If \code{expr} is a
#'   quosure and you would like to use its expression as a value for
#'   \code{expr}, then you must set \code{quoted} to \code{TRUE}.
#' @param funcFilter (for expert use only) passed to the \code{filter} argument
#'   of \code{\link{dataTableAjax}()}
#' @param future whether the server-side filter function should be executed as a
#'   future or as a standard synchronous function. If true, the future will be
#'   evaluated according to the session's \link[future]{plan}.
#' @param outputArgs A list of arguments to be passed through to the implicit
#'   call to \code{\link{dataTableOutput}()} when
#'   \code{\link{renderDataTable}()} is used in an interactive R Markdown
#'   document.
#' @param ... ignored when \code{expr} returns a table widget, and passed as
#'   additional arguments to \code{\link{datatable}()} when \code{expr} returns
#'   a data object
renderDataTable = function(
    expr, server = TRUE, env = parent.frame(), quoted = FALSE,
    funcFilter = dataTablesFilter, future = FALSE,
    outputArgs = list(), ...
  ) {
  if (!quoted) expr = substitute(expr)

  # TODO: this can be simplified after this htmlwidgets PR is merged
  # https://github.com/ramnathv/htmlwidgets/pull/122
  outputInfoEnv = new.env(parent = emptyenv())
  outputInfoEnv[["outputName"]] = NULL
  # jcheng 2018-12-17:
  # It's important to save the session, not just the outputName. It turns
  # out that if the datatable is defined in a module, the outputName is
  # the fully qualified name, and session is the top-level session (that
  # is, the outputName and session that is passed to the render function).
  # That's a fine combination, or alternatively it'd be fine if the name
  # was unqualified and the session was module-specific. But during my
  # commit to add async support, I broke this pairing, and used the (fully
  # qualified) outputName from the render function, and the session from
  # getDefaultReactiveDomain() (which is module specific), and this combo
  # is no good--you end up with the module prefix included twice in the
  # ajax URL. See issue #626 for the repro.
  outputInfoEnv[["session"]] = NULL

  exprFunc = shiny::exprToFunction(expr, env, quoted = TRUE)
  argFunc = shiny::exprToFunction(list(..., server = server), parent.frame(), quoted = FALSE)
  widgetFunc = function() {
    opts = options(DT.datatable.shiny = TRUE); on.exit(options(opts), add = TRUE)
    instance = exprFunc()
    if (promises::is.promising(instance)) {
      promises::then(instance, processWidget)
    } else {
      processWidget(instance)
    }
  }
  processWidget = function(instance) {
    args = argFunc()
    server = args$server; args$server = NULL # the last element is `server`
    # which is only used in `renderDT()` not `datatable()`, the reason
    # of having it in `argFunc()` is we want `server` to be reactive
    if (!all(c('datatables', 'htmlwidget') %in% class(instance))) {
      instance = do.call(datatable, c(list(instance), args))
    } else if (length(args) != 0) {
      warning("renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable")
    }

    # in the server mode, we should not store the full data in JSON
    if (server && !is.null(instance[['x']])) {
      if (!is.null(instance$x$crosstalkOptions$group)) {
        stop("Crosstalk only works with DT client mode: DT::renderDataTable({...}, server=FALSE)")
      }

      origData = instance[['x']][['data']]
      instance$x$data = NULL

      # register the data object in a shiny session
      options = instance[['x']][['options']]

      # autoHideNavigation won't work in the server mode
      if (isTRUE(instance[['x']][['autoHideNavigation']]))
        warning("`autoHideNavigation` only works with DT client mode and it will be ignored",
                immediate. = TRUE, call. = FALSE)

      # Normalize "ajax" argument; if we leave it a string then we have several
      # code paths that need to account for both string and list representations
      if (is.character(options[['ajax']])) {
        options$ajax = list(url = options$ajax)
      }

      if (is.null(options[['ajax']][['url']])) {
        url = sessionDataURL(outputInfoEnv[["session"]], origData, outputInfoEnv[["outputName"]], funcFilter, future)
        options$ajax$url = url
      }
      instance$x$options = fixServerOptions(options)

      # We need to warn the use of "Select" extension in the server-side processing
      # mode since right now there's no good way of supporting the server mode.
      # More specifically, the Select ext can't remember the cross-page selections
      # because the javascript implementation doesn't take the server mode into account.
      # Until that gets changed, we are not able to integrate the Select ext with DT's
      # own implementations.
      if ('Select' %in% as.character(instance$x$extensions)) warning(
        "The Select extension is not able to work with the server-side ",
        "processing mode properly. It's recommended to use the Select extension ",
        "only in the client-side processing mode (by setting `server = FALSE` ",
        "in `DT::renderDT()`) or use DT's own selection implementations (",
        "see the `selection` argument in ?DT::datatable).",
        immediate. = TRUE, call. = FALSE
      )
    }

    instance
  }

  renderFunc = htmlwidgets::shinyRenderWidget(
    widgetFunc(), dataTableOutput, environment(), FALSE
  )

  # The cacheHint arg is not present in Shiny < 1.6.0. Once that version is
  # very widely used, we can remove this if() statement.
  func = if ("cacheHint" %in% names(formals(shiny::markRenderFunction))) {
    # Can't cache with server-side processing
    cacheHint = if (server) FALSE else list(label = "renderDataTable", userExpr = expr)

    shiny::markRenderFunction(
      uiFunc = dataTableOutput,
      renderFunc = function(shinysession, name, ...) {
        domain = tempVarsPromiseDomain(outputInfoEnv, outputName = name, session = shinysession)
        removeTimestampFromSnapshot(name, shinysession)
        promises::with_promise_domain(domain, renderFunc())
      },
      outputArgs = outputArgs,
      cacheHint = cacheHint
    )
  } else {
    shiny::markRenderFunction(
      uiFunc = dataTableOutput,
      renderFunc = function(shinysession, name, ...) {
        domain = tempVarsPromiseDomain(outputInfoEnv, outputName = name, session = shinysession)
        removeTimestampFromSnapshot(name)
        promises::with_promise_domain(domain, renderFunc())
      },
      outputArgs = outputArgs
    )
  }

  func = shiny::snapshotPreprocessOutput(func, function(value) {
    # Looks for a string like this in the JSON:
    # "url":"session/2a2b834d90637a7559f3ebaba460ad10/dataobj/table?w=&nonce=aea032f33aedfd0e",
    # and removes it, so that the value isn't saved in test snapshots.
    gsub('"ajax"\\s*:\\s*\\{\\s*"url"\\s*:\\s*"[^"]*"\\s*,?', '"ajax":{', value)
  })

  shiny::registerInputHandler('DT.cellInfo', function(val, ...) {
    opts = options(stringsAsFactors = FALSE); on.exit(options(opts), add = TRUE)
    val = lapply(val, as.data.frame)
    do.call(rbind, val)
  }, TRUE)

  func
}

#' @export
#' @rdname dataTableOutput
renderDT = renderDataTable

getAll = function(x, env) {
  as.list(mget(x, env, ifnotfound = rep(list(NULL), times = length(x))))
}

setAll = function(lst, env) {
  mapply(names(lst), lst, FUN = function(name, val) {
    assign(name, val, env)
  })
  invisible()
}

removeTimestampFromSnapshot = function(name, session) {
  shiny::snapshotPreprocessInput(paste0(name, "_state"), function(value) {
    value$time <- NULL
    value
  }, session)
}

# This promise domain is needed to set/unset temporary variables in
# a specific environment anytime a promise handler is invoked in the
# domain. This is used to pass the Shiny output name from where we
# know it (in the function(shinysession, name, ...) {...}) to where
# we don't know it, but need it (processWidget).
tempVarsPromiseDomain = function(env, ...) {
  force(env)
  vars = list(...)

  promises::new_promise_domain(
    wrapOnFulfilled = function(onFulfilled) {
      # force(onFulfilled)
      function(...) {
        old = getAll(names(vars), env)
        setAll(vars, env)
        on.exit({
          setAll(old, env)
        }, add = TRUE)

        onFulfilled(...)
      }
    },
    wrapOnRejected = function(onRejected) {
      # force(onRejected)
      function(...) {
        old = getAll(names(vars), env)
        setAll(vars, env)
        on.exit({
          setAll(old, env)
        }, add = TRUE)

        onRejected(...)
      }
    },
    wrapSync = function(expr) {
      old = getAll(names(vars), env)
      setAll(vars, env)
      on.exit({
        setAll(old, env)
      }, add = TRUE)

      force(expr)
    }
  )
}

#' Manipulate an existing DataTables instance in a Shiny app
#'
#' The function \code{dataTableProxy()} creates a proxy object that can be used
#' to manipulate an existing DataTables instance in a Shiny app, e.g. select
#' rows/columns, or add rows.
#' @param outputId the id of the table to be manipulated (the same id as the one
#'   you used in \code{\link{dataTableOutput}()})
#' @param session the Shiny session object (from the server function of the
#'   Shiny app)
#' @param deferUntilFlush whether an action should be carried out right away, or
#'   should be held until after the next time all of the outputs are updated
#' @note \code{addRow()} only works for client-side tables. If you want to use
#'   it in a Shiny app, make sure to use \code{renderDataTable(..., server =
#'   FALSE)}. Also note that the column filters (if used) of the table will not
#'   be automatically updated when a new row is added, e.g., the range of the
#'   slider of a column will stay the same even if you have added a value
#'   outside the range of the original data column.
#' @references \url{https://rstudio.github.io/DT/shiny.html}
#' @rdname proxy
#' @export
dataTableProxy = 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), rawId = outputId, session = session,
    deferUntilFlush = deferUntilFlush
  ), class = 'dataTableProxy')
}

#' @param proxy a proxy object returned by \code{dataTableProxy()}
#' @param selected an integer vector of row/column indices, or a matrix of two
#'   columns (row and column indices, respectively) for cell indices; you may
#'   use \code{NULL} to clear existing selections
#' @param ignore.selectable when \code{FALSE} (the default), the "non-selectable"
#'   range specified by \code{selection = list(selectable= )} is respected, i.e.,
#'   you can't select "non-selectable" range. Otherwise, it is ignored.
#'
#' @rdname proxy
#' @export
selectRows = function(proxy, selected, ignore.selectable = FALSE) {
  invokeRemote(
    proxy, 'selectRows',
    list(I_null(as.integer(selected)), ignore.selectable)
  )
}

#' @rdname proxy
#' @export
selectColumns = function(proxy, selected, ignore.selectable = FALSE) {
  invokeRemote(
    proxy, 'selectColumns',
    list(I_null(as.integer(selected)), ignore.selectable)
  )
}

I_null = function(x) if (is.null(x)) list() else x

#' @rdname proxy
#' @export
selectCells = function(proxy, selected, ignore.selectable = FALSE) {
  invokeRemote(
    proxy, 'selectCells',
    list(selected, ignore.selectable)
  )
}

#' @param data a single row of data to be added to the table; it can be a matrix
#'   or data frame of one row, or a vector or list of row data (in the latter
#'   case, please be cautious about the row name: if your table contains row
#'   names, here \code{data} must also contain the row name as the first
#'   element)
#' @rdname proxy
#' @export
addRow = function(proxy, data, resetPaging = TRUE) {
  if ((is.matrix(data) || is.data.frame(data)) && nrow(data) != 1)
    stop("'data' must be of only one row")
  rn <- rownames(data); if (!is.null(rn)) rn <- I(rn)
  # must apply unname() after as.list() because a data.table object
  # can't be really unnamed. The names() attributes will be
  # preserved but with empty strings (see #760).
  invokeRemote(proxy, 'addRow', list(unname(as.list(data)), rn, resetPaging))
}

#' @rdname proxy
#' @export
clearSearch = function(proxy) {
  updateSearch(proxy, list(global = '', columns = ''))
}

#' @param page a number indicating the page to select
#' @rdname proxy
#' @export
selectPage = function(proxy, page) {
  invokeRemote(proxy, 'selectPage', list(page))
}

#' @param caption a new table caption (see the \code{caption} argument of
#'   \code{\link{datatable}()})
#' @rdname proxy
#' @export
updateCaption = function(proxy, caption) {
  invokeRemote(proxy, 'updateCaption', list(captionString(caption)))
}

#' @param keywords a list of two components: \code{global} is the global search
#'   keyword of a single character string (ignored if \code{NULL});
#'   \code{columns} is a character vector of the search keywords for all columns
#'   (when the table has one column for the row names, this vector of keywords
#'   should contain one keyword for the row names as well)
#' @rdname proxy
#' @export
updateSearch = function(proxy, keywords = list(global = NULL, columns = NULL)) {
  global = keywords$global
  if (is.null(global)) {
    keywords['global'] = list(NULL)
  } else {
    if (!is.character(global) || length(global) != 1)
      stop('keywords$global must be a character string')
  }
  columns = keywords$columns
  if (is.null(columns)) {
    keywords['columns'] = list(NULL)
  } else {
    if (is.character(columns)) {
      if (length(columns) == 0) stop(
        'The length of keywords$columns must be greater than zero if it is a character vector'
      )
    } else if (is.list(columns)) {
      if (any(sapply(columns, length) > 1)) stop(
        'keywords$columns should be a list of NULL or character strings'
      )
    } else stop('keywords$columns must be either a character vector or a list')
  }
  invokeRemote(proxy, 'updateSearch', list(keywords))
}

#' @param show a vector of column positions to show (the indexing starts at
#' 0, but if row.names are visible, they are the first column).
#' @rdname proxy
#' @export
showCols = function(proxy, show, reset = FALSE) {
  invokeRemote(proxy, 'showCols', list(show, reset))
}

#' @param hide a vector of column positions to hide
#' @param reset if \code{TRUE}, will only show/hide the columns indicated.
#' @rdname proxy
#' @export
hideCols = function(proxy, hide, reset = FALSE) {
  invokeRemote(proxy, 'hideCols', list(hide, reset))
}

#' @param order A numeric vector of column positions, starting from 0, and including
#' the row.names as a column, if they are include. Must contain a value
#' for all columns, regardless of whether they are visible or not. Also for
#' column reordering to work, the datatable must have extension 'ColReorder'
#' set as well as option 'colReordoer' set to TRUE).
#' @param origOrder Whether column reordering should be relative to the original
#' order (the default is to compare to current order)
#' @rdname proxy
#' @export
colReorder = function(proxy, order, origOrder = FALSE) {
  invokeRemote(proxy, 'colReorder', list(order, origOrder))
}


#' @param resetPaging whether to reset the paging position
#' @param clearSelection which existing selections to clear: it can be any
#'   combinations of \code{row}, \code{column}, and \code{cell}, or \code{all}
#'   for all three, or \code{none} to keep current selections (by default, all
#'   selections are cleared after the data is reloaded)
#' @note \code{reloadData()} only works for tables in the server-side processing
#'   mode, e.g. tables rendered with \code{renderDataTable(server = TRUE)}. The
#'   data to be reloaded (i.e. the one you pass to \code{dataTableAjax()}) must
#'   have exactly the same number of columns as the previous data object in the
#'   table.
#' @rdname proxy
#' @export
reloadData = function(
  proxy, resetPaging = TRUE, clearSelection = c('all', 'none', 'row', 'column', 'cell')
) {
  if ('all' %in% clearSelection) clearSelection = c('row', 'column', 'cell')
  invokeRemote(proxy, 'reloadData', list(resetPaging, clearSelection))
}

#' Replace data in an existing table
#'
#' Replace the data object of a table output and avoid regenerating the full
#' table, in which case the state of the current table will be preserved
#' (sorting, filtering, and pagination) and applied to the table with new data.
#' @param proxy a proxy object created by \code{dataTableProxy()}
#' @param data the new data object to be loaded in the table
#' @param ... other arguments to be passed to \code{\link{dataTableAjax}()}
#' @param resetPaging,clearSelection passed to \code{\link{reloadData}()}
#' @note When you replace the data in an existing table, please make sure the
#'   new data has the same number of columns as the current data. When you have
#'   enabled column filters, you should also make sure the attributes of every
#'   column remain the same, e.g. factor columns should have the same or fewer
#'   levels, and numeric columns should have the same or smaller range,
#'   otherwise the filters may never be able to reach certain rows in the data,
#'   unless you explicitly update the filters with \code{updateFilters()}.
#'
#'   If the \code{ColReorder} extension is used, the new \code{data} must have
#'   column names that match the original data column names exactly.
#' @export
replaceData = function(proxy, data, ..., resetPaging = TRUE, clearSelection = 'all') {
  dataTableAjax(proxy$session, data, ..., outputId = proxy$rawId)
  reloadData(proxy, resetPaging, clearSelection)
}

#' @rdname replaceData
#' @export
updateFilters = function(proxy, data) {
  # make sure JS gets an array, not an object
  filters = unname(columnFilters(data))
  invokeRemote(proxy, 'updateFilters', list(filters))
}

invokeRemote = function(proxy, method, args = list()) {
  if (!inherits(proxy, 'dataTableProxy'))
    stop('Invalid proxy argument; table 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('datatable-calls', msg)
    }, once = TRUE)
  } else {
    sess$sendCustomMessage('datatable-calls', msg)
  }
  proxy
}

shinyFun = function(name) getFromNamespace(name, 'shiny')

# Works around the fact that session$getCurrentOutputInfo() in Shiny through
# version 1.4 signals an error if there is no active output (the private field
# ShinySession$currentOutputName is NULL). Consider removing in the future
# sometime after https://github.com/rstudio/shiny/pull/2707 is released.
getCurrentOutputName = function(session) {
  tryCatch(session$getCurrentOutputInfo()[["name"]], error = function(e) NULL)
}

#' Register a data object in a shiny session for DataTables
#'
#' This function stores a data object in a shiny session and returns a URL that
#' returns JSON data based on DataTables Ajax requests. The URL can be used as
#' the \code{url} option inside the \code{ajax} option of the table. It is
#' basically an implementation of server-side processing of DataTables in R.
#' Filtering, sorting, and pagination are processed through R instead of
#' JavaScript (client-side processing).
#'
#' Normally you should not need to call this function directly. It is called
#' internally when a table widget is rendered in a Shiny app to configure the
#' table option \code{ajax} automatically. If you are familiar with
#' \pkg{DataTables}' server-side processing, and want to use a custom filter
#' function, you may call this function to get an Ajax URL.
#' @inheritParams renderDataTable
#' @param session the \code{session} object in the shiny server function
#'   (\code{function(input, output, session)})
#' @param data a data object (will be coerced to a data frame internally)
#' @param rownames see \code{\link{datatable}()}; it must be consistent with
#'   what you use in \code{datatable()}, e.g. if the widget is generated by
#'   \code{datatable(rownames = FALSE)}, you must also use
#'   \code{dataTableAjax(rownames = FALSE)} here
#' @param filter (for expert use only) a function with two arguments \code{data}
#'   and \code{params} (Ajax parameters, a list of the form \code{list(search =
#'   list(value = 'FOO', regex = 'false'), length = 10, ...)}) that return the
#'   filtered table result according to the DataTables Ajax request
#' @param outputId the output ID of the table (the same ID passed to
#'   \code{dataTableOutput()}; if missing, an attempt to infer it from
#'   \code{session} is made. If it can't be inferred, a random id is
#'   generated.)
#' @references \url{https://rstudio.github.io/DT/server.html}
#' @return A character string (an Ajax URL that can be queried by DataTables).
#' @example inst/examples/ajax-shiny.R
#' @export
dataTableAjax = function(
  session, data, rownames, filter = dataTablesFilter, outputId, future = FALSE
) {

  oop = options(stringsAsFactors = FALSE); on.exit(options(oop), add = TRUE)

  if (missing(outputId)) outputId = getCurrentOutputName(session)
  # abuse tempfile() to obtain a random id unique to this R session
  if (is.null(outputId)) outputId = basename(tempfile(''))

  # deal with row names: rownames = TRUE or missing, use rownames(data)
  rn = if (missing(rownames) || isTRUE(rownames)) base::rownames(data) else {
    if (is.character(rownames)) rownames  # use custom row names
  }
  data = as.data.frame(data)  # think dplyr
  if (length(rn)) data = cbind(' ' = rn, data)

  sessionDataURL(session, data, outputId, filter, future)
}

sessionDataURL = function(session, data, id, filter, future) {

  toJSON = shinyFun('toJSON')
  httpResponse = shinyFun('httpResponse')

  filterFun = function(data, req) {
    # DataTables requests were sent via POST
    params = rawToChar(req$rook.input$read())
    # I don't think the browser would send out nonASCII strings, but keep it as it is
    Encoding(params) = 'UTF-8'
    # shiny::parseQueryString() calls httpuv::decodeURIComponent() internally and will handle encoding correctly
    params = shiny::parseQueryString(params, nested = TRUE)

    res = tryCatch(filter(data, params), error = function(e) {
      list(error = as.character(e))
    })

    jsonArgs = c(list(x = res, dataframe = 'rows'),
                 getOption('DT.TOJSON_ARGS', getOption('htmlwidgets.TOJSON_ARGS')))
    httpResponse(200, 'application/json', enc2utf8(do.call(toJSON, jsonArgs)))

  }

  filterFunExecute = function(data, req) {
    if (future) {
      promises::future_promise(seed = TRUE, { filterFun(data, req) })
    } else filterFun(data, req)
  }

  session$registerDataObj(id, data, filterFunExecute)
}

# filter a data frame according to the DataTables request parameters
dataTablesFilter = function(data, params) {
  n = nrow(data)
  q = params
  # users may be updating the table too frequently
  if (length(q$columns) != ncol(data)) return(list(
    draw = as.integer(q$draw),
    recordsTotal = n,
    recordsFiltered = 0,
    data = list(),
    DT_rows_all = seq_len(n),
    DT_rows_current = list()
  ))

  # map DataTables's column index in the query (`i` here) to the actual column
  # index in data via its name because the two indices won't match when columns
  # are reordered via the colReorder extension
  imap = unlist(lapply(q$columns, function(col) {
    # if data doesn't have column names (e.g., #1108), assume it's not reordered
    # (which may not be true)
    if (is.null(names(data))) return(0L)
    k = col[['name']]
    if (!is.character(k) || k == '') return(0L)
    i = match(k, names(data))
    if (is.na(i)) stop("The column name '", k, "' is not found in data.")
    i
  }))
  if (all(imap == 0)) imap[] = seq_len(ncol(data))

  # which columns are searchable?
  searchable = logical(ncol(data))
  for (j in names(q$columns)) {
    if (q$columns[[j]][['searchable']] == 'true') searchable[imap[j]] = TRUE
  }

  # global searching options (column search shares caseInsensitive)
  # for some reason, q$search might be NULL, leading to error `if (logical(0))`
  global_opts = list(
    smart = !identical(q$search[['smart']], 'false'),
    regex = q$search[['regex']] != 'false',
    caseInsensitive = q$search[['caseInsensitive']] == 'true'
  )

  # start searching with all rows
  i = seq_len(n)

  # apply SearchBuilder query if present
  if (!is.null(s <- q$searchBuilder)) {
    r = sbEvaluateSearch(s, data)
    if (!is.null(r)) i = which(r)
  }

  # search by columns
  if (length(i)) for (j in names(q$columns)) {
    col = q$columns[[j]]
    j = imap[j]
    # if the j-th column is not searchable or the search string is "", skip it
    if (!searchable[j]) next
    if ((k <- col[['search']][['value']]) == '') next
    k = httpuv::decodeURIComponent(k)
    column_opts = list(
      regex = col[['search']][['regex']] != 'false',
      caseInsensitive = global_opts$caseInsensitive
    )
    dj = data[i, j]
    i = i[doColumnSearch(dj, k, options = column_opts)]
    if (length(i) == 0) break
  }

  # global searching
  if (length(i) && any((k <- q$search[['value']]) != '')) {
    dg = data[i, searchable, drop = FALSE]
    k = httpuv::decodeURIComponent(k)
    i = i[doGlobalSearch(dg, k, options = global_opts)]
  }

  if (length(i) != n) data = data[i, , drop = FALSE]
  iAll = i  # row indices of filtered data

  # sorting
  oList = list()
  for (ord in q$order) {
    k = ord[['column']]  # which column to sort
    d = ord[['dir']]     # direction asc/desc
    if (q$columns[[k]][['orderable']] != 'true') next
    col = data[, imap[k]]
    oList[[length(oList) + 1]] = (if (d == 'asc') identity else `-`)(
      if (is.numeric(col)) col else xtfrm(col)
    )
  }
  if (length(oList)) {
    i = do.call(order, oList)
    data = data[i, , drop = FALSE]
    iAll = iAll[i]
  }
  # paging
  if (q$length != '-1') {
    len = as.integer(q$length)
    # I don't know why this can happen, but see https://github.com/rstudio/DT/issues/164
    if (is.na(len)) {
      warning("The DataTables parameter 'length' is '", q$length, "' (invalid).")
      len = 0
    }
    i = seq(as.integer(q$start) + 1L, length.out = len)
    i = i[i <= nrow(data)]
    fdata = data[i, , drop = FALSE]  # filtered data
    iCurrent = iAll[i]
  } else {
    fdata = data
    iCurrent = iAll
  }

  if (q$escape != 'false') {
    k = seq_len(ncol(fdata))
    if (q$escape != 'true') {
      # q$escape might be negative indices, e.g. c(-1, -5)
      k = k[as.integer(strsplit(q$escape, ',')[[1]])]
    }
    for (j in k) if (maybe_character(fdata[, j])) fdata[, j] = htmlEscape(fdata[, j])
  }

  # TODO: if iAll is just 1:n, is it necessary to pass this vector to JSON, then
  # to R? When n is large, it may not be very efficient
  list(
    draw = as.integer(q$draw),
    recordsTotal = n,
    recordsFiltered = nrow(data),
    data = cleanDataFrame(fdata),
    DT_rows_all = iAll,
    DT_rows_current = iCurrent
  )
}

#' Server-side searching
#'
#' \code{doGlobalSearch()} can be used to search a data frame given the search
#' string typed by the user into the global search box of a
#' \code{\link{datatable}}. \code{doColumnSearch()} does the same for a vector
#' given the search string typed into a column filter. These functions are used
#' internally by the default \code{filter} function passed to
#' \code{\link{dataTableAjax}()}, allowing you to replicate the search results
#' that server-side processing returns.
#'
#' @param x a vector, the type of which determines the expected
#'   \code{search_string} format
#' @param search_string a string that determines what to search for. The format
#'   depends on the type of input, matching what a user would type in the
#'   associated filter control.
#' @param options a list of options used to control how searching character
#'   values works. Supported options are \code{regex}, \code{caseInsensitive}
#'   and (for global search)
#'   \href{https://datatables.net/reference/option/search.smart}{\code{smart}}.
#' @param data a data frame
#'
#' @return An integer vector of filtered row indices
#'
#' @seealso The column filters section online for search string formats:
#'   \url{https://rstudio.github.io/DT/}
#' @seealso Accessing the search strings typed by a user in a Shiny app:
#'   \url{https://rstudio.github.io/DT/shiny.html}
#'
#' @examples
#' doGlobalSearch(iris, 'versi')
#' doGlobalSearch(iris, "v.r.i", options = list(regex = TRUE))
#'
#' doColumnSearch(iris$Species, '["versicolor"]')
#' doColumnSearch(iris$Sepal.Length, '4 ... 5')
#' @export
doColumnSearch = function(x, search_string, options = list()) {
  if (length(search_string) == 0 || search_string == '') return(seq_along(x))
  if (is.numeric(x) || is.Date(x)) {
    which(filterRange(x, search_string))
  } else if (is.factor(x)) {
    which(x %in% fromJSON(search_string))
  } else if (is.logical(x)) {
    which(x %in% as.logical(fromJSON(search_string)))
  } else {
    grep2(
      search_string, as.character(x),
      fixed = !(options$regex %||% FALSE),
      ignore.case = options$caseInsensitive %||% TRUE
    )
  }
}

#' @rdname doColumnSearch
#' @export
doGlobalSearch = function(data, search_string, options = list()) {
  n = nrow(data)
  if (length(v <- search_string) > 0) {
    if (options$smart %||% TRUE) {
      # https://datatables.net/reference/option/search.smart
      v = unlist(strsplit(gsub('^\\s+|\\s+$', '', v), '\\s+'))
    }
  }
  if (length(v) == 0) v = ''
  m = if ((nv <- length(v)) > 1) array(FALSE, c(dim(data), nv)) else logical(n)
  # TODO: this searching method may not be efficient and need optimization
  if (!identical(v, '')) {
    for (j in seq_len(ncol(data))) {
      for (k in seq_len(nv)) {
        i0 = grep2(
          v[k], as.character(data[, j, drop = TRUE]),
          fixed = !(options$regex %||% FALSE),
          ignore.case = options$caseInsensitive %||% TRUE
        )
        if (nv > 1) m[i0, j, k] = TRUE else m[i0] = TRUE
      }
    }
    which(if (nv > 1) apply(m, 1, function(z) all(colSums(z) > 0)) else m)
  } else seq_len(n)
}

# when both ignore.case and fixed are TRUE, we use grep(ignore.case = FALSE,
# fixed = TRUE) to do lower-case matching of pattern on x; assume value = FALSE
grep2 = function(pattern, x, ignore.case = FALSE, fixed = FALSE, ...) {
  if (fixed && ignore.case) {
    pattern = tolower(pattern)
    x = tolower(x)
    ignore.case = FALSE
  }
  # when the user types in the search box, the regular expression may not be
  # complete before it is sent to the server, in which case we do not search
  if (!fixed && inherits(try(grep(pattern, '', perl = TRUE), silent = TRUE), 'try-error'))
    return(seq_along(x))
  # #749 if both fixed and perl are TRUE, the latter will be ignored by R with
  # an annoyed warning
  grep(pattern, x, ignore.case = ignore.case, fixed = fixed, perl = !fixed, ...)
}

# filter a numeric/date/time vector using the search string "lower ... upper"
filterRange = function(d, string) {
  if (!grepl('[.]{3}', string) || length(r <- strsplit(string, '[.]{3}')[[1]]) > 2)
    stop('The range of a numeric / date / time column must be of length 2')
  if (length(r) == 1) r = c(r, '')  # lower,
  r = gsub('^\\s+|\\s+$', '', r)
  r1 = r[1]; r2 = r[2]
  if (is.numeric(d)) {
    r1 = as.numeric(r1); r2 = as.numeric(r2)
  } else if (inherits(d, 'Date')) {
    if (r1 != '') r1 = as.Date(r1)
    if (r2 != '') r2 = as.Date(r2)
  } else {
    if (r1 != '') r1 = as.POSIXct(r1, tz = 'GMT', '%Y-%m-%dT%H:%M:%S')
    if (r2 != '') r2 = as.POSIXct(r2, tz = 'GMT', '%Y-%m-%dT%H:%M:%S')
  }
  if (r[1] == '') return(d <= r2)
  if (r[2] == '') return(d >= r1)
  d >= r1 & d <= r2
}

# treat factors as characters
maybe_character = function(x) {
  is.character(x) || is.factor(x)
}

# make sure we have a tidy data frame (no unusual structures in it)
cleanDataFrame = function(x) {
  x = unname(x)  # remove column names
  if (!is.data.frame(x)) return(x)
  for (j in seq_len(ncol(x))) {
    xj = x[, j]
    xj = unname(xj)  # remove names
    dim(xj) = NULL  # drop dimensions
    if (is.table(xj)) xj = c(xj)  # drop the table class
    x[[j]] = xj
  }
  unname(x)
}

fixServerOptions = function(options) {
  options$serverSide = TRUE
  if (is.null(options$processing)) options$processing = TRUE

  # if you generated the Ajax URL from dataTableAjax(), I'll configure type:
  # 'POST' and a few other options automatically
  if (!inShiny()) return(options)
  if (length(grep('^session/[a-z0-9]+/dataobj/', options$ajax$url)) == 0)
    return(options)

  if (is.null(options$ajax$type)) options$ajax$type = 'POST'
  if (is.null(options$ajax$data)) options$ajax$data = JS(
    'function(d) {',
    sprintf(
      'd.search.caseInsensitive = %s;',
      tolower(!isFALSE(options[['search']]$caseInsensitive))
    ),
    sprintf(
      'd.search.smart = %s;',
      tolower(!isFALSE(options[['search']]$smart))
    ),
    sprintf('d.escape = %s;', attr(options, 'escapeIdx', exact = TRUE)),
    'var encodeAmp = function(x) { x.value = x.value.replace(/&/g, "%26"); }',
    'encodeAmp(d.search);',
    '$.each(d.columns, function(i, v) {encodeAmp(v.search);});',
    '}'
  )
  options
}