Last active
December 31, 2015 15:30
-
-
Save jankowtf/d48916fbf8e8d0456ae2 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Purpose: Reference app for datatable stuff | |
Frozen: yes |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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 = " ") | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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) | |
} | |
}) | |
}) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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") | |
)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment