shiny/serverside.R

In mgencare/RBigPivot: Manages large datasets to be used in a web application data table.

dataTableAjax = function(session, data, rownames) {

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

  # abuse tempfile() to obtain a random id unique to this R session
  id = 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)

  session$registerDataObj(id, data, dataTablesJSON)

}

 registerDataObj = function(name, data, filterFunc) {
      # abusing downloads at the moment
      self$downloads$set(name, list(data = data, filter = filterFunc))
      return(sprintf('session/%s/dataobj/%s?w=%s',
                     URLencode(self$token, TRUE),
                     URLencode(name, TRUE),
                     workerId()))
    }

# convert a data frame to JSON as required by DataTables request
dataTablesJSON = function(data, req) {
  n = nrow(data)
  # DataTables requests were sent via POST
  URLdecode = shinyFun('URLdecode')
  params = URLdecode(rawToChar(req$rook.input$read()))
  q = shiny::parseQueryString(params, nested = TRUE)
  ci = q$search[['caseInsensitive']] == 'true'

  # global searching
  i = seq_len(n)
  if (q$search[['value']] != '') {
    i0 = apply(data, 2, function(x) {
      grep2(q$search[['value']], as.character(x),
            fixed = q$search[['regex']] == 'false', ignore.case = ci)
    })
    i = intersect(i, unique(unlist(i0)))
  }

  # search by columns
  if (length(i)) for (j in names(q$columns)) {
    col = q$columns[[j]]
    # if the j-th column is not searchable or the search string is "", skip it
    if (col[['searchable']] != 'true') next
    if ((k <- col[['search']][['value']]) == '') next
    j = as.integer(j)
    dj = data[, j + 1]
    ij = if (is.numeric(dj) || is.Date(dj)) {
      r = commaToRange(k)
      if (length(r) != 2)
        stop('The range of a numeric / date / time column must be of length 2')
      if (is.Date(dj)) {
        # r is milliseconds
        r = as.POSIXct(r / 1000, origin = '1970-01-01')
        if (inherits(dj, 'Date')) r = as.Date(r)
      }
      which(dj >= r[1] & dj <= r[2])
    } else if (is.factor(dj)) {
      which(dj %in% jsonlite::fromJSON(k))
    } else {
      grep2(k, as.character(dj), fixed = col[['search']][['regex']] == 'false',
            ignore.case = ci)
    }
    i = intersect(ij, i)
    if (length(i) == 0) break
  }
  if (length(i) != n) data = data[i, , drop = FALSE]

  # 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[, as.integer(k) + 1]
    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]
  }
  # paging
  if (q$length != '-1') {
    i = seq(as.integer(q$start) + 1L, length.out = as.integer(q$length))
    i = i[i <= nrow(data)]
    fdata = data[i, , drop = FALSE]  # filtered data
  } else fdata = data

  fdata = unname(as.matrix(fdata))
  if (is.character(fdata) && q$escape != 'false') {
    if (q$escape == 'true') fdata = htmlEscape(fdata) else {
      k = as.integer(strsplit(q$escape, ',')[[1]])
      # use seq_len() in case escape = negative indices, e.g. c(-1, -5)
      for (j in seq_len(ncol(fdata))[k]) fdata[, j] = htmlEscape(fdata[, j])
    }
  }

  toJSON = shinyFun('toJSON')
  res = toJSON(list(
    draw = as.integer(q$draw),
    recordsTotal = n,
    recordsFiltered = nrow(data),
    data = fdata
  ))
  httpResponse = shinyFun('httpResponse')
  # TODO: enc2utf8() may not be necessary if we use jsonlite
  httpResponse(200, 'application/json', enc2utf8(res))
}