_shiny_datatable_reference_201512311525

Purpose: Reference app for datatable stuff
Frozen: yes

global.R

# Packages ----------------------------------------------------------------

library(shiny)
library(shinydashboard)
library(shinyBS)

# Variables ---------------------------------------------------------------

DFLT_action_enable_scrolling <- FALSE
DFLT_scrolling_y_limit <- 800
DFLT_action_selectiontype <- "single"

# Functions ---------------------------------------------------------------

createRecord <- function(input, db) {
  db$data <- rbind(
    db$data,
    data.frame(
      task = input$task,
      time = input$time,
      time_unit = "hour",
      stringsAsFactors = FALSE
    )
  )
}
updateRecord <- function(input, db, selection) {
  db$data[selection,] <- data.frame(
    task = input$task,
    time = input$time,
    time_unit = "hour",
    stringsAsFactors = FALSE
  )
}
deleteRecord <- function(db, selection) {
  db$data <- db$data[-selection,]
}

niceNames <- function(x) {
  s <- strsplit(x, " |_|\\.", perl = TRUE)[[1]]
  paste(toupper(substring(s, 1,1)), substring(s, 2),
    sep = "", collapse = " ")
}

server.R

# Server ------------------------------------------------------------------

shinyServer(function(input, output, session) {
  ## Initialize DB //
  db <- reactiveValues(data = data.frame(
    task = character(),
    time = numeric(),
    time_unit = character()
  )[-1,])

  ## UI control //
  ui_control <- reactiveValues(
    case = c("hide", "create", "update")[1],
    selection = NULL,
    refresh = TRUE
  )
  observeEvent(input$action_trigger, {
    if (input$action_trigger) {
      ui_control$case <- "create"
    } else {
      ui_control$case <- "hide"
    }
  })

  ## Render UI //
  output$ui_input <- renderUI({
    case <- ui_control$case
    if (case == "hide")
      return()

    ## Case dependent input //
    if (case == "create") {
      task <- ifelse(is.null(tmp <- isolate(input$task)), "", tmp)
      time <- ifelse(is.null(tmp <- isolate(input$time)), "", tmp)

      buttons <- div(
        style = "display:inline-block",
        actionButton("action_create", "Create"),
        actionButton("action_cancel", "Cancel")
      )
      updateTextInput(session, "first")
    } else if (case == "update") {
      task <- db$data[ui_control$selection, "task"]
      time <- db$data[ui_control$selection, "time"]
      buttons <- div(
        style = "display:inline-block",
        actionButton("action_update", "Update"),
        actionButton("action_cancel", "Cancel"),
        p(),
        actionButton(
          "action_delete",
          "Delete",
          icon = icon("exclamation-triangle")
        )
      )
    } else {
      stop(sprintf("Invalid case: %s", case))
    }

    tagList(
      textInput("task", "Task", task),
      numericInput("time", "Time", time),
      buttons
    )
  })

  ## CRUD operations //
  observeEvent(input$action_create, {
    createRecord(input, db = db)
    shinyBS::updateButton(session, "action_trigger", value = FALSE)
    ui_control$case <- "hide"
  })
  observeEvent(input$action_update, {
    updateRecord(input, db = db, selection = ui_control$selection)
    ui_control$refresh <- NULL
    ui_control$refresh <- TRUE
    # ui_control$case <- "hide"
  })
  observeEvent(input$action_delete, {
    deleteRecord(db = db, selection = ui_control$selection)
    tmp <- ui_control$selection[1] - 1
    if (tmp == 0) tmp <- NULL
    ui_control$selection <- tmp
    ui_control$refresh <- NULL
    ui_control$refresh <- TRUE
    # ui_control$case <- "hide"
  })
  observeEvent(input$action_cancel, {
    ui_control$case <- "hide"
    shinyBS::updateButton(session, "action_trigger", value = FALSE)
  })

  ## Selection //
  observe({
    idx <- input$dt_rows_selected
    ui_control$selection <- idx
  })
  observe({
    idx <- ui_control$selection
    if (!is.null(idx)) {
      ui_control$case <- "update"
    } else {
      ui_control$case <- "hide"
    }
  })

  ## Transformation handlers //
  observeEvent(input$action_time_days, {
    if (nrow(db$data)) {
      db$data$time <- db$data$time / 8
      db$data$time_unit <- "day"
      ui_control$refresh <- NULL
      ui_control$refresh <- TRUE
    }
  })
  observeEvent(input$action_time_hours, {
    if (nrow(db$data)) {
      db$data$time <- db$data$time * 8
      db$data$time_unit <- "hour"
      ui_control$refresh <- NULL
      ui_control$refresh <- TRUE
    }
  })

  ## Render table: preparations //
  observeEvent(input$action_enable_scrolling, {
    ui_control$refresh <- NULL
    ui_control$refresh <- TRUE
  })
  observeEvent(input$scrolling_y_limit, {
    ui_control$refresh <- NULL
    ui_control$refresh <- TRUE
  })
  observeEvent(input$action_selectiontype, {
    ui_control$refresh <- NULL
    ui_control$refresh <- TRUE
  })
  dt_options = reactive({
    scroll <- input$action_enable_scrolling
    list(
      dom = "ltipr",
      autoWidth = TRUE,
      scrollX = TRUE,
      scrollY = if (scroll) {
        sprintf("%spx", input$scrolling_y_limit * 1)
      },
      scrollCollapse = if (scroll) {
        TRUE
      },
      lengthMenu = list(
        c(3, 5, -1),
        c(3, 5, "All")
      ),
      iDisplayLength = 3
    )
  })

  ## Render table: DT //
  output$dt <- DT::renderDataTable({
    if (!ui_control$refresh) {
      return()
    }
    ## Note:
    ## Not really necessary for this example use case as `db$data` already
    ## introduces a reactive dependency.
    ## However, that might not always be the case for data I/O when an
    ## actual database is involved. In this case, this part will most likely
    ## have to be informed about required re-rendering by an explicit reactive
    ## value that other parts update upon I/O operations

    tmp <- db$data
    names(tmp) <- sapply(names(tmp), niceNames)
    tmp
  }, selection = input$action_selectiontype, options = dt_options())

  ## DT proxy //
  proxy <- DT::dataTableProxy("dt")

  ## Render table: DT 2 //
  output$dt_2 <- DT::renderDataTable({
    if (!ui_control$refresh) {
      return()
    }
    # data.frame(a=1)
    tmp <- db$data
    names(tmp) <- sapply(names(tmp), niceNames)
    tmp
  }, selection = input$action_selectiontype, options = dt_options())

  ## DT 2 proxy //
  proxy_2 <- DT::dataTableProxy("dt_2")

  ## Keep/restory previous selection //
  observe({
    ui_control$refresh
    if (!input$action_keep_selection) {
      return()
    }
    DT::selectRows(proxy, as.numeric(ui_control$selection))
    DT::selectRows(proxy_2, as.numeric(ui_control$selection))
  })

  ## Resets //
  observe({
    if (ui_control$case == "create") {
      updateTextInput(session, "task", value = sprintf("Test %s", Sys.time()))
      updateTextInput(session, "time", value = 1)
    }
  })
})

ui.R

source("global.R")

# UI ---------------------------------------------------------------------

DFLT_action_enable_scrolling <- FALSE
DFLT_scrolling_y_limit <- 600

shinyUI(fluidPage(
  div(
    style = "display:inline-block",
    p(),
    # actionButton("action_trigger", "Create"),
    shinyBS::bsButton("action_trigger", "Create", type = "toggle"),
    ## --> toogle button
    ## Conceptionally, a checkbox input with button-like style
    ## Would be great if this was part of shiny's core
    actionButton("action_time_days", "Time in days"),
    actionButton("action_time_hours", "Time in hours")
  ),
  tabsetPanel(
    tabPanel(
      title = "Scrolling options",
        checkboxInput("action_enable_scrolling", "Enable Y-scrolling",
          value = DFLT_action_enable_scrolling),
        numericInput("scrolling_y_limit", "Height limit for Y-scrolling (in px)",
          value = DFLT_scrolling_y_limit)
    ),
    tabPanel(
      title = "Selection options",
      p(),
      radioButtons("action_selectiontype", "Selection type",
        choices = c("single", "multiple"),
        selected = DFLT_action_selectiontype,
        inline = TRUE),
      checkboxInput("action_keep_selection", "Keep selection after re-rendering", value = FALSE),
      p(
        "If enabled, selections made will be kept",
        br(),
        "Otherwise they're forgotten after an database-relevant operation has been performed."
      )
    )
  ),
  hr(),
  uiOutput("ui_input"),
  hr(),
  h3("Database (shiny)"),
  DT::dataTableOutput("dt"),
  hr(),
  h3("Database (shinydashboard)"),
  box(DT::dataTableOutput("dt_2"), width = 8, status = "danger")
))