R Shiny update textInput fields' in DT on changing variable selection - r

I am building an app where the user loads an .RData data set (the file can be downloaded from here) and selects variable from a list (DT), moves it to another list (also DT) and then the available factor levels are displayed in a third DT underneath. This third DT also has a column of dynamically generated textInput fields which match the number of available factor levels for the variable where the user can add new values for the existing factor levels. The entered values are stored in a reactiveValues object. For now the object is just printed in the R console. The app looks like this:
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
ui <- fluidPage(
shinyFilesButton(id = "recodeChooseSrcFile", label = "Choose data file", title = "Navigate and select a file", multiple = FALSE),
fluidRow(
column(width = 6,
DTOutput(outputId = "recodeAllAvailableVars"),
),
column(width = 1, align = "center",
br(), br(), br(), br(), br(), br(), br(), br(), br(), br(),
uiOutput(outputId = "recodeArrowSelVarsRight"),
br(), br(),
uiOutput(outputId = "recodeArrowSelVarsLeft"),
),
column(width = 5,
DTOutput(outputId = "recodeVarsSelection"),
),
br(), br()
),
br(), br(),
DTOutput(outputId = "recodeScheme")
)
server <- function(input, output, session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL, var.levels = NULL)
# Select file and extract the variables.
shinyFileChoose(input, "recodeChooseSrcFile", roots = available.volumes, filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile, {
if(length(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null), lapply(X = file.var.recode$loaded, FUN = function(i) {
if(is.null(attr(x = i, which = "levels"))) {
NULL
} else {
attr(x = i, which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),
order_col = 1:ncol(file.var.recode$loaded))
}
}, ignoreInit = TRUE)
observe({
var.props.initial.available.vars <- data.table(Variables = as.character(), order_col = as.numeric())
var.props.initial.selected.vars <- data.table(Variables = as.character(), order_col = as.numeric())
recodeAllVars <- reactiveValues(recodeAvailVars = var.props.initial.available.vars, recodeSelectedVars = var.props.initial.selected.vars)
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight", label = NULL, icon("angle-right"), width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft", label = NULL, icon("angle-left"), width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight, {
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars), recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected, , drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected, , drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars), recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
})
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj), FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp", i), label = NULL, value = NULL, width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
input[[paste0(id, i)]]
}))
}
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,
V2 = initial.recode.new.values$values,
V3 = rep(x = "->", times = length(initial.recode.new.values$values)),
V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp", len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))))
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},
rownames = FALSE,
colnames = c("Available variable values", "Old", "->", "New"),
class = "cell-border stripe;compact cell-border;",
selection="none",
escape = FALSE,
options = list(
pageLength = 1500,
dom = 'BRrt',
rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
})
}
shinyApp(ui, server)
It all works fine when the variable is selected, the newly entered values are immediately updated and shown in the console on every key stroke. However, if the user decides to remove the variable from the DT of selected ones, the new.recoding.values$values reactive value becomes immediately NULL (as intended), but when another variable is added to the DT of selected variables, the old values for the previous variable are immediately brought back and never get updated. In addition, if the new variable has more levels than the first entered, then the last is possible to update, but not the previous ones (try entering ASBG03, then replace it with ASBG04 to see what I mean).
I don't really understand why is this happening. What I tried so far is to explicitly set the new.recoding.values$values to NULL in:
1.The observer where it is generated, before the shinyValue function is ran.
2.In the observeEvent where the right arrow button is pressed, i.e.:
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars),
recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
new.recoding.values$values <- NULL
})
UPDATE:
3.Following Tonio Liebrand's advice, I tried to update the text inputs as follow (added just after rendering the last DT):
observe({
if(nrow(entered.new.values$values) == 0) {
lapply(seq_len(length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))), function(i) {
updateTextInput(session,
input[[paste0("numinp", i)]],
value = NULL,
label = NULL)
})
}
})
None of these helped. Every time I remove the variable selected at first, the new.recoding.values$values is printed as NULL in the console, but then adding another variable new.recoding.values$values suddenly recovers the first values entered first, like it still "remembers" the first input.
I don't really understand this behavior can someone help to overcome this, i.e. really update on variable change?

Because the textFields are created within the datatable, you need to unbind before you use the table again (updateTextInput doesn't work). Using the code from this answer, I added the JS script with the unbind function and the function is called in the observer for the left arrow. Then you get a working app:
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
shinyFilesButton(id = "recodeChooseSrcFile", label = "Choose data file", title = "Navigate and select a file", multiple = FALSE),
fluidRow(
column(width = 6,
DTOutput(outputId = "recodeAllAvailableVars"),
),
column(width = 1, align = "center",
br(), br(), br(), br(), br(), br(), br(), br(), br(), br(),
uiOutput(outputId = "recodeArrowSelVarsRight"),
br(), br(),
uiOutput(outputId = "recodeArrowSelVarsLeft"),
),
column(width = 5,
DTOutput(outputId = "recodeVarsSelection"),
),
br(), br()
),
br(), br(),
DTOutput(outputId = "recodeScheme")
)
server <- function(input, output, session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL, var.levels = NULL)
# Select file and extract the variables.
shinyFileChoose(input, "recodeChooseSrcFile", roots = available.volumes, filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile, {
if(length(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null), lapply(X = file.var.recode$loaded, FUN = function(i) {
if(is.null(attr(x = i, which = "levels"))) {
NULL
} else {
attr(x = i, which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),
order_col = 1:ncol(file.var.recode$loaded))
}
}, ignoreInit = TRUE)
observe({
var.props.initial.available.vars <- data.table(Variables = as.character(), order_col = as.numeric())
var.props.initial.selected.vars <- data.table(Variables = as.character(), order_col = as.numeric())
recodeAllVars <- reactiveValues(recodeAvailVars = var.props.initial.available.vars, recodeSelectedVars = var.props.initial.selected.vars)
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight", label = NULL, icon("angle-right"), width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft", label = NULL, icon("angle-left"), width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight, {
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars), recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected, , drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected, , drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars), recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
session$sendCustomMessage("unbindDT", "recodeScheme")
})
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj), FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp", i), label = NULL, value = NULL, width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
input[[paste0(id, i)]]
}))
}
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,
V2 = initial.recode.new.values$values,
V3 = rep(x = "->", times = length(initial.recode.new.values$values)),
V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp", len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))))
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},
rownames = FALSE,
colnames = c("Available variable values", "Old", "->", "New"),
class = "cell-border stripe;compact cell-border;",
selection="none",
escape = FALSE,
options = list(
pageLength = 1500,
dom = 'BRrt',
rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
})
}
shinyApp(ui, server)
However, I recommend you to read more about reactivity, e.g. here. You use a lot of observers, and you nest them. I don't recommend that, because this can lead to strange behaviour. Also, try to use more reactive/reactiveExpression, because observe/observeEvent can make your app slower. Before I found the correct solution, I tried to unnest your code a bit, and it still works! That shows that you had complexity in your app you actually don't need:
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
# additional functions
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj), FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp", i), label = NULL, value = NULL, width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id, len, input) {
unlist(lapply(seq_len(len), function(i) {
input[[paste0(id, i)]]
}))
}
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
shinyFilesButton(id = "recodeChooseSrcFile", label = "Choose data file", title = "Navigate and select a file", multiple = FALSE),
fluidRow(
column(width = 6,
DTOutput(outputId = "recodeAllAvailableVars"),
),
column(width = 1, align = "center",
br(), br(), br(), br(), br(), br(), br(), br(), br(), br(),
uiOutput(outputId = "recodeArrowSelVarsRight"),
br(), br(),
uiOutput(outputId = "recodeArrowSelVarsLeft"),
),
column(width = 5,
DTOutput(outputId = "recodeVarsSelection"),
),
br(), br()
),
br(), br(),
DTOutput(outputId = "recodeScheme")
)
server <- function(input, output, session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL, var.levels = NULL)
# define variables
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
# Select file and extract the variables.
shinyFileChoose(input, "recodeChooseSrcFile", roots = available.volumes, filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile, {
if(length(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes, input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null), lapply(X = file.var.recode$loaded, FUN = function(i) {
if(is.null(attr(x = i, which = "levels"))) {
NULL
} else {
attr(x = i, which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),
order_col = 1:ncol(file.var.recode$loaded))
}
}, ignoreInit = TRUE)
recodeAllVars <- reactiveValues(recodeAvailVars = data.table(Variables = as.character(), order_col = as.numeric()),
recodeSelectedVars = data.table(Variables = as.character(), order_col = as.numeric()))
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight", label = NULL, icon("angle-right"), width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft", label = NULL, icon("angle-left"), width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars, cols = "order_col")
}
},
caption = "Available variables",
rownames = FALSE,
colnames = c("Names", "sortingcol"),
options = list(
ordering = FALSE,
columnDefs = list(list(visible = FALSE, targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight, {
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars), recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected, , drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected, , drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft, {
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars), recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected, , drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[ , "Variables"]), , drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected, , drop = F])
session$sendCustomMessage("unbindDT", "recodeScheme")
})
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,
V2 = initial.recode.new.values$values,
V3 = rep(x = "->", times = length(initial.recode.new.values$values)),
V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp",
len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]]))),
input = input)
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[ , Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},
rownames = FALSE,
colnames = c("Available variable values", "Old", "->", "New"),
class = "cell-border stripe;compact cell-border;",
selection="none",
escape = FALSE,
options = list(
pageLength = 1500,
dom = 'BRrt',
rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
# end of server
}
shinyApp(ui, server)
There is still some room for improvement, e.g. you could try to use a reactive instead of observe for the following snippet:
# Observe if the file is loaded, and if yes, update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})

Related

How to update row-wise filter in Shiny datatable

I'm trying to update row-wise filter in datatable basis on the inputs we receive from user on every row, so that only relevant values in sub-sequent inputs can be selected.
I have tried to replicate my scenario using below code, where in if User selects "setosa" as "spieces_selector" hence only "1-50" values should appear in "New_Data_selector". Similarly if a User selects "versicolor" in 2nd row hence for 2nd row "New_Data_selector" should have the values from "51-100".
Would appreciate your help on this.
library(shiny)
library(DT)
iris$New_Data <- c(1:150)
ui <- fluidPage(
title = 'Selectinput column in a table',
h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
numericInput('num', "enter a number", value = 5, min = 1, max = 10, step = 1),
DT::dataTableOutput('foo'),
verbatimTextOutput('sel'),
actionButton(
"saveBtn",
"Submit Request",
style = "color: #fff; background-color: #282364;
border-color: #2e6da4",
class = "btn btn-primary"
)
)
server <- function(input, output, session) {
data <- reactive({
df <- head(iris, input$num)
for (i in 1:nrow(df)) {
df$species_selector[i] <- as.character(selectInput(paste0("sel1", i),
"",
choices = unique(iris$Species),
width = "100px"))
df$New_Data_selector[i] <- as.character(selectInput(paste0("sel2", i),
"",
choices = unique(iris$New_Data),
width = "100px"))
}
df
})
output$foo = DT::renderDataTable(
data(), escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]]))
})
observeEvent(input$saveBtn, {
Test_Data <- sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]])
Test_Data <- as.data.frame(Test_Data)
print(Test_Data)})
}
shinyApp(ui, server)
The following works (based on my earlier answer) - but it's pretty slow. Will need to investigate further.
library(DT)
library(shiny)
library(datasets)
library(data.table)
myIris <- copy(iris)
setDT(myIris)
myIris[, Index := seq_len(.N)]
selectInputIDs_A <- paste0("sel_A", myIris$Index)
selectInputIDs_B <- paste0("sel_B", myIris$Index)
myIris[, selectInputs_A := sapply(selectInputIDs_A, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(myIris$Species), selected = "setosa"))})]
myIris[, selectInputs_B := sapply(selectInputIDs_B, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(myIris[Species == "setosa"]$Index), selected = "setosa"))})]
initTbl <- copy(myIris)
ui <- fluidPage(
DT::dataTableOutput(outputId = 'my_table')
)
server <- function(input, output, session) {
displayTbl <- reactive({
myIris[, selectInputs_A := sapply(selectInputIDs_A, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(Species), selected = input[[x]]))}),]
myIris[, selectInputs_B := sapply(seq_along(selectInputs_B), function(x){as.character(selectInput(inputId = selectInputIDs_B[x], label = "", choices = unique(myIris[Species == input[[selectInputIDs_A[x]]]]$Index), selected = input[[selectInputIDs_A[x]]]))})]
})
output$my_table = DT::renderDataTable({
DT::datatable(
initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}, server = TRUE)
my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
observeEvent({sapply(selectInputIDs_A, function(x){input[[x]]})}, {
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)

How to render datatable with radiobutton inputs per each row in R Shiny multiple times without generating new inputs each time

I have a R Shiny app with datatable in which there is an input field at each row. I was able to implement it whenever the data is static - generated one time. But in my app the user need to load the data multiple times and each time to fill in the input and submit, and then load another dataset.
In the first load the input works well, but on the change of data it is probably try to re-render the input fields, and they stop responding. I hacked it with creating a new input ids per data load, but this solution may end with thousands of inputs if the user have many dataset to go over.
I short, I would like to implement this without the values$j index: (paste0("answers_",values$j,"_", i)).
thanks,
p.s. with renderTable it works, but I need the render
I have a minimum reproducible example below:
library(shiny)
library(DT)
library(data.table)
ui <- fluidPage(
selectInput("selected_project", "Select project",choices=c("A","B"),multiple=FALSE,selected = "A")
,selectInput("maximum_questions_to_show", "Maximum questions to show",choices=c(5,10),multiple=FALSE,selected = 10)
,actionButton("submit_answers","Submit")
,verbatimTextOutput('answersText')
,DT::dataTableOutput("answerTable")
# ,tableOutput("answerTable")
)
server <- function(input, output, session){
values <- reactiveValues(j=0)
getData<-eventReactive(c(input$selected_project,input$maximum_questions_to_show), {
values$j=values$j+1
print("BBB")
if(input$selected_project=="A")
data<-data.frame("project"=rep("A",30),"id"=paste0("A_",1:30),"answers"=rep("n",30),stringsAsFactors=FALSE)
if(input$selected_project=="B")
data<-data.frame("project"=rep("B",50),"id"=paste0("B_",1:50),"answers"=rep("n",50),stringsAsFactors=FALSE)
nrows<-min(dim(data)[1],as.numeric(input$maximum_questions_to_show))
data=data[1:nrows,]
answers<-sapply(1:nrows,function(i) {
as.character(radioButtons(inputId=paste0("answers_",values$j,"_", i), label=paste0("answers_",values$j,"_", i)
, choices=c("n","y"),selected=data$answers[i],inline=TRUE))
})
# answers<-sapply(1:nrows,function(i) {
# as.character(radioButtons(inputId=paste0("answers_", i), label=paste0("answers_", i)
# , choices=c("n","y"),selected=data$answers[i],inline=TRUE))
# })
data$answers<-answers
return(list("data"=data))
}, ignoreNULL = FALSE)
output$answerTable <- DT::renderDataTable({
data<-getData()$data
data.table(
"project"=data[,"project"]
,"id"=data[,"id"]
,"answers" = data[,"answers"]
)
},editable = TRUE,escape=FALSE,selection = 'none', server = FALSE,rownames = FALSE,
,options = list(dom="Bftsp",lengthMenu = list(c(5, 15, -1), c('5', '15', 'All')),pageLength = 5,paging=TRUE
,preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }')
,drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '))
)
# output$answerTable <- renderTable({
# data<-getData()$data
# data[,c("id","answers")]
# },sanitize.text.function = function(x) x)
answers_results <- reactive({
data<-getData()$data
nrows<-dim(data)[1]
(sapply(1:nrows, function(i) input[[paste0("answers_",values$j,"_", i)]]))
# (sapply(1:nrows, function(i) input[[paste0("answers_", i)]]))
})
output$answersText = renderPrint({
unlist(lapply(answers_results() , function(x) ifelse(is.null(x),"n",x)))
})
observeEvent(input$submit_answers,{
print(unlist(lapply(answers_results() , function(x) ifelse(is.null(x),"n",x))))
})
}
shinyApp(ui, server)
You have to unbind each time there's a rendering. Here I run the unbinding in getData:
library(shiny)
library(DT)
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
selectInput(
"selected_project",
"Select project",
choices = c("A", "B"),
multiple = FALSE,
selected = "A"
),
selectInput(
"maximum_questions_to_show",
"Maximum questions to show",
choices = c(5, 10),
multiple = FALSE,
selected = 10
),
actionButton("submit_answers", "Submit"),
verbatimTextOutput("answersText"),
DTOutput("answerTable")
)
server <- function(input, output, session){
getData <- eventReactive(
c(input$selected_project, input$maximum_questions_to_show),
{
session$sendCustomMessage("unbindDT", "answerTable")
print("BBB")
if(input$selected_project == "A"){
data <- data.frame(
"project" = rep("A", 30),
"id" = paste0("A_", 1:30),
"answers" = rep("n", 30),
stringsAsFactors = FALSE
)
}else{
data <- data.frame(
"project" = rep("B", 50),
"id" = paste0("B_", 1:50),
"answers" = rep("n", 50),
stringsAsFactors = FALSE
)
}
nrows <- min(nrow(data), as.numeric(input$maximum_questions_to_show))
data <- data[1:nrows, ]
answers <- sapply(1:nrows, function(i){
as.character(
radioButtons(inputId=paste0("answers_", i),
label=paste0("answers_", i),
choices=c("n","y"),
selected=data$answers[i],
inline=TRUE)
)
})
data$answers <- answers
return(list("data" = data))
},
ignoreNULL = FALSE
)
output$answerTable <- renderDT(
{
data <- getData()$data[, c("project", "id", "answers")]
datatable(
data,
editable = TRUE,
escape = FALSE,
selection = "none",
rownames = FALSE,
options = list(
dom = "Bftsp",
lengthMenu = list(c(5, 15, -1), c("5", "15", "All")),
pageLength = 5,
paging = TRUE,
preDrawCallback =
JS("function() { Shiny.unbindAll(this.api().table().node()); }"),
drawCallback =
JS("function() { Shiny.bindAll(this.api().table().node()); } ")
)
)
},
server = FALSE
)
answers_results <- reactive({
data <- getData()$data
nrows <- nrow(data)
(sapply(1:nrows, function(i) input[[paste0("answers_", i)]]))
})
output$answersText <- renderPrint({
unlist(lapply(answers_results(), function(x) ifelse(is.null(x), "n", x)))
})
observeEvent(input$submit_answers, {
print(unlist(lapply(answers_results(), function(x) ifelse(is.null(x), "n", x))))
})
}
shinyApp(ui, server)

When using selectizeGroupUI from shinyWidgets, how to limit default selection to a specified subset of data?

The below example code for selectizeGroupUI() works great for my needs. However by default when first invoking it selects and shows the entire dataset, before the user applies any filters.
My problem is the dataset I'm using this for is very large and takes some time to load. Is there a way to limit the initial dataset view to a subset of the data frame (in this example, manufacturer = Audi), and the user clicks another to-be-added button in order to show the complete dataset?
Example code:
library(shiny)
library(shinyWidgets)
data("mpg", package = "ggplot2")
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h3("Filter data with selectize group"),
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = c("manufacturer", "model", "trans", "class"),
selected = c("manufacturer", "model", "trans", "class"),
inline = TRUE
),
selectizeGroupUI(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
)
),
status = "primary"
),
DT::dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output, session) {
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "my-filters",
data = mpg,
vars = vars_r
)
output$table <- DT::renderDataTable({
req(res_mod())
res_mod()
})
}
shinyApp(ui, server)
Since we are dealing with a module (and the inputs are not directly accessible), I modified the function selectizeGroupServer To include an updater for manufacturer input. The new function is called selectizeGroupServer_custom
observe({
updateSelectInput(inputId = 'manufacturer', choices = unique(rv$data$manufacturer), selected = 'audi')
})
new module:
selectizeGroupServer_modified <-
function(input, output, session, data, vars)
{
`%inT%` <- function(x, table) {
if (!is.null(table) && ! "" %in% table) {
x %in% table
} else {
rep_len(TRUE, length(x))
}
}
ns <- session$ns
shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"),
display = "none")
rv <- reactiveValues(data = NULL, vars = NULL)
observe({
if (is.reactive(data)) {
rv$data <- data()
}
else {#this will be the first data
rv$data <- as.data.frame(data)
}
if (is.reactive(vars)) { #this will be the data type for vars
rv$vars <- vars()
}
else {
rv$vars <- vars
}
for (var in names(rv$data)) {
if (var %in% rv$vars) {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0("container-",
var)), display = "table-cell")
}
else {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0("container-",
var)), display = "none")
}
}
})
observe({
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(session = session, inputId = x,
choices = vals, server = TRUE)
#CODE INSERTED HERE
if (x == 'manufacturer') {
updateSelectizeInput(session = session, inputId = x,
choices = vals, server = TRUE, selected = 'manufacturer')
}
})
})
observeEvent(input$reset_all, {
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(session = session, inputId = x,
choices = vals, server = TRUE)
})
})
observe({
vars <- rv$vars
lapply(X = vars, FUN = function(x) {
ovars <- vars[vars != x]
observeEvent(input[[x]], {
data <- rv$data
indicator <- lapply(X = vars, FUN = function(x) {
data[[x]] %inT% input[[x]]
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
if (all(indicator)) {
shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"),
display = "none")
}
else {
shinyWidgets:::toggleDisplayServer(session = session, id = ns("reset_all"),
display = "block")
}
for (i in ovars) {
if (is.null(input[[i]])) {
updateSelectizeInput(session = session, inputId = i,
choices = sort(unique(data[[i]])), server = TRUE)
}
}
if (is.null(input[[x]])) {
updateSelectizeInput(session = session, inputId = x,
choices = sort(unique(data[[x]])), server = TRUE)
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
})
})
observe({
updateSelectInput(inputId = 'manufacturer', choices = unique(rv$data$manufacturer), selected = 'audi')
})
return(reactive({
data <- rv$data
vars <- rv$vars
indicator <- lapply(X = vars, FUN = function(x) {
`%inT%`(data[[x]], input[[x]])
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
return(data)
}))
}
app:
library(shiny)
library(shinyWidgets)
data("mpg", package = "ggplot2")
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h3("Filter data with selectize group"),
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = c("manufacturer", "model", "trans", "class"),
selected = c("manufacturer", "model", "trans", "class"),
inline = TRUE
),
selectizeGroupUI(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
)
),
status = "primary"
),
DT::dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output, session) {
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer_modified,
id = "my-filters",
data = mpg,
vars = vars_r
)
output$table <- DT::renderDataTable({
res_mod()
})
}
shinyApp(ui, server)
EDIT:
If we want to have a button that says "show all data", we can modify selectizeGroupUI. The new name will be selectizeGroupUI_custom
Modules and App code:
library(shiny)
library(shinyWidgets)
# SERVER MODULE -----------------------------------------------------------
selectizeGroupServer_modified <-
function(input, output, session, data, vars) {
`%inT%` <- function(x, table) {
if (!is.null(table) && !"" %in% table) {
x %in% table
} else {
rep_len(TRUE, length(x))
}
}
ns <- session$ns
shinyWidgets:::toggleDisplayServer(
session = session, id = ns("reset_all"),
display = "none"
)
rv <- reactiveValues(data = NULL, vars = NULL)
observe({
if (is.reactive(data)) {
rv$data <- data()
} else { # this will be the first data
rv$data <- as.data.frame(data)
}
if (is.reactive(vars)) { # this will be the data type for vars
rv$vars <- vars()
} else {
rv$vars <- vars
}
for (var in names(rv$data)) {
if (var %in% rv$vars) {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0(
"container-",
var
)), display = "table-cell")
} else {
shinyWidgets:::toggleDisplayServer(session = session, id = ns(paste0(
"container-",
var
)), display = "none")
}
}
})
observe({
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(
session = session, inputId = x,
choices = vals, server = TRUE
)
})
})
observeEvent(input$reset_all, {
lapply(X = rv$vars, FUN = function(x) {
vals <- sort(unique(rv$data[[x]]))
updateSelectizeInput(
session = session, inputId = x,
choices = vals, server = TRUE
)
})
})
observe({
vars <- rv$vars
lapply(X = vars, FUN = function(x) {
ovars <- vars[vars != x]
observeEvent(input[[x]],
{
data <- rv$data
indicator <- lapply(X = vars, FUN = function(x) {
data[[x]] %inT% input[[x]]
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
if (all(indicator)) {
shinyWidgets:::toggleDisplayServer(
session = session, id = ns("reset_all"),
display = "none"
)
} else {
shinyWidgets:::toggleDisplayServer(
session = session, id = ns("reset_all"),
display = "block"
)
}
for (i in ovars) {
if (is.null(input[[i]])) {
updateSelectizeInput(
session = session, inputId = i,
choices = sort(unique(data[[i]])), server = TRUE
)
}
}
if (is.null(input[[x]])) {
updateSelectizeInput(
session = session, inputId = x,
choices = sort(unique(data[[x]])), server = TRUE
)
}
},
ignoreNULL = FALSE,
ignoreInit = TRUE
)
})
})
observe({
updateSelectInput(inputId = "manufacturer", choices = unique(rv$data$manufacturer), selected = "audi")
})
return(reactive({
data <- rv$data
vars <- rv$vars
indicator <- lapply(X = vars, FUN = function(x) {
`%inT%`(data[[x]], input[[x]])
})
indicator <- Reduce(f = `&`, x = indicator)
data <- data[indicator, ]
return(data)
}))
}
# UI MODULE ---------------------------------------------------------------
selectizeGroupUI_custom <-
function(id, params, label = NULL, btn_label = "Reset filters", inline = TRUE) {
ns <- NS(id)
if (inline) {
selectizeGroupTag <- tagList(
##### NEW LOCATION FOR THE BUTTON #####
actionButton(
inputId = ns("reset_all"), label = btn_label,
style = "float: left;"
##### NEW LOCATION FOR THE BUTTON #####
),
tags$b(label), tags$div(
class = "btn-group-justified selectize-group",
role = "group", `data-toggle` = "buttons", lapply(
X = seq_along(params),
FUN = function(x) {
input <- params[[x]]
tagSelect <- tags$div(
class = "btn-group",
id = ns(paste0("container-", input$inputId)),
selectizeInput(
inputId = ns(input$inputId),
label = input$title, choices = input$choices,
selected = input$selected, multiple = ifelse(is.null(input$multiple),
TRUE, input$multiple
), width = "100%",
options = list(
placeholder = input$placeholder,
plugins = list("remove_button"), onInitialize = I("function() { this.setValue(\"\"); }")
)
)
)
return(tagSelect)
}
)
)
)
} else {
selectizeGroupTag <- tagList(tags$b(label), lapply(
X = seq_along(params),
FUN = function(x) {
input <- params[[x]]
tagSelect <- selectizeInput(
inputId = ns(input$inputId),
label = input$title, choices = input$choices,
selected = input$selected, multiple = ifelse(is.null(input$multiple),
TRUE, input$multiple
), width = "100%", options = list(
placeholder = input$placeholder,
plugins = list("remove_button"), onInitialize = I("function() { this.setValue(\"\"); }")
)
)
return(tagSelect)
}
), actionLink(
inputId = ns("reset_all"), label = btn_label,
icon = icon("remove"), style = "float: right;"
))
}
tagList(
singleton(tagList(tags$link(
rel = "stylesheet", type = "text/css",
href = "shinyWidgets/modules/styles-modules.css"
), shinyWidgets:::toggleDisplayUi())),
selectizeGroupTag
)
}
# APP ---------------------------------------------------------------------
data("mpg", package = "ggplot2")
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
tags$h3("Filter data with selectize group"),
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = c("manufacturer", "model", "trans", "class"),
selected = c("manufacturer", "model", "trans", "class"),
inline = TRUE
),
selectizeGroupUI_custom(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
), btn_label = "Show all data"
),
status = "primary"
),
DT::dataTableOutput(outputId = "table")
)
)
)
########### SERVER###########
server <- function(input, output, session) {
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer_modified,
id = "my-filters",
data = mpg,
vars = vars_r
)
output$table <- DT::renderDataTable({
res_mod()
})
}
shinyApp(ui, server)

Capture filtered results from a datatable and store it as a new dataset in Shiny

I have a shiny application that loads a couple of datasets (diamonds & mtcars) and displays them as datatable in the mainpanel. I am trying to implement a couple of functionality
1. Store datasets: Once the user create filters in the datatable, allow them to store the filtered results as a new dataset.
2. Remove datasets: Allow the users to remove any datasets from the list of created datasets
app.R
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
my_data[[dataset]] <- get(input$dataset)
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
I think the "removedatasets" functionality works fine. I am not able to get the "store dataset" functionality to work. I am not sure how to capture the filtered datatable from the environment to store and add it to the list of datasets.
I would really appreciate any help on this. Thanks.
Here is a solution that recreates the filtering on the original data based on the filter inputs stored in my_state$datatable_search_columns. The strings are turned into the correct filter conditions which are then applied to the data set before saving. Note that I haven't tested it with a condition in the global search bar:
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
# get filter conditions
filter_conditions <- lapply(my_state$datatable_search_columns, function(column) {
# check if it is a numerical filter and extract the values
if (str_detect(column, "\\.\\.\\.")) {
vals <- strsplit(column, " ")
c(as.numeric(vals[[1]][1]), as.numeric(vals[[1]][3])) # min/max values
} else {
if (column == "") {
NA
} else {
vals <- strsplit(column, "\"")
index <- seq(from = 2, to = length(vals[[1]]), by = 2)
as.character(vals[[1]][index])
}
}
})
# do the filtering
temp <- get(input$dataset)
temp <- as.data.frame(temp)
for (i in seq_along(filter_conditions)) {
current_vals <- filter_conditions[[i]]
if (all(is.numeric(current_vals))) {
# it's a numeric column
temp <- temp[temp[, i] >= current_vals[1] & temp[, i] <= current_vals[2], ]
}
if (all(is.character(current_vals))) {
# it's a character column
temp[, i] <- as.character(temp[, i])
temp <- temp[temp[, i] %in% current_vals, ]
}
}
my_data[[dataset]] <- temp
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
Edit
Here is a version where you can select the changed dataset after storing it:
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
# get filter conditions
filter_conditions <- lapply(my_state$datatable_search_columns, function(column) {
# check if it is a numerical filter and extract the values
if (str_detect(column, "\\.\\.\\.")) {
vals <- strsplit(column, " ")
c(as.numeric(vals[[1]][1]), as.numeric(vals[[1]][3])) # min/max values
} else {
if (column == "") {
NA
} else {
vals <- strsplit(column, "\"")
index <- seq(from = 2, to = length(vals[[1]]), by = 2)
as.character(vals[[1]][index])
}
}
})
# do the filtering
temp <- get(input$dataset)
temp <- as.data.frame(temp)
for (i in seq_along(filter_conditions)) {
current_vals <- filter_conditions[[i]]
if (all(is.numeric(current_vals))) {
# it's a numeric column
temp <- temp[temp[, i] >= current_vals[1] & temp[, i] <= current_vals[2], ]
}
if (all(is.character(current_vals))) {
# it's a character column
temp[, i] <- as.character(temp[, i])
temp <- temp[temp[, i] %in% current_vals, ]
}
}
df[[dataset]] <<- temp
my_info[["datasetlist"]] <- c(my_info[["datasetlist"]], input$stored_name)
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
A few issues with your code I've noticed:
I recommend not to use get, this makes it less clear and debuggable where the data comes from; I'd work directly with the lists/reactives where your data is stored to retrieve it
there is something going on with the filters set in the table; they stay even when you switch datasets, I think you have to put some work into that
you have a lot of similar lists (like my_df and df) (and I think you don't use both), which makes your code harder to understand
try to use more observeEvent/updateXXInput as it's a bit faster than doing all the renderUI on the server side

How to add new row in R Shiny dataTable without refreshing the existing selected data variable in table

I am trying to create a data filter using R Shiny and DataTables, So far I am able to add the data and when I click on Add New Filter after selecting the variables , The selected variable values is refreshed.
Please help me so when I add new row , the selected variable remains same.
Below is the code:
server.r
library(shiny)
library(shinyBS)
library(shinyjs)
library(DT)
library(rhandsontable)
shinyServer(function(input, output, session) {
myValue <- reactiveValues()
observe({
if(is.null(myValue$Filter)){
Choices<- c("a","b","c","d")
myValue$Filter = data.frame(
Variable = shinyInput(selectInput, 1:5, 'var_', cl = "dynamicInputs", label = "", choices = Choices ,selected=Choices[1]),
Filter = shinyInput(actionButton, 1:5, 'go_button_', cl=NULL, label = "Filter", onclick = goButtonOnClick()) ,
Logic = c(NA,shinyInput(selectInput, 2:5, 'logic_', cl = "dynamicInputs",label = "", choices = c("And","Or"))),
Remove = c(NA,shinyInput(actionButton, 2:5, 'remove_button_',cl=NULL, "", icon = icon("close"), onclick = removeButtonOnClick())),
stringsAsFactors = FALSE,
row.names = 1:5
)
maxId<<-5
}
})
#Functions
shinyInput <- function(FUN, objs, id,cl= NULL, ...) {
inputs <- character(length(objs))
if(is.null(cl)){
for (i in 1:length(objs)) {
inputs[i] <- as.character(FUN(paste0(id, objs[i]), ...))
}
}
else {
for (i in 1:length(objs)) {
inputs[i] <- as.character(div(class=cl,FUN(paste0(id, objs[i]), ...)))
}
}
inputs
}
goButtonOnClick <- function() {
return('Shiny.onInputChange(\"select_button\", this.id) ;
Shiny.setInputValue(\"filter_button_change\", Math.random()) ')
}
removeButtonOnClick <- function() {
return('Shiny.onInputChange(\"select_remove_button\", this.id)')
}
extractValues<-function(idSeq,objName){
unlist(lapply(idSeq,function(id){
selected<-as.numeric(id)
return(as.character(shinyValue(objName, selected)))
}))
}
# Add new Condition Row
observeEvent(input$addnewRow,{
if(is.null(myValue$Filter) || nrow(myValue$Filter)==0)
return()
idSeq<-unlist(lapply(myValue$Filter$Filter,function(x){
buttonId<-stringr::str_extract(x,paste0("go_button_","\\d+"))
num<-as.numeric(gsub("go_button_","",buttonId))
return(num)
}))
allVars<-extractValues(idSeq,"var_")
allLogic<-extractValues(idSeq,"logic_")
Choices<- c("a","b","c","d")
Variable<-unlist(lapply(1:length(idSeq),function(i){
shinyInput(selectInput, idSeq[i], 'var_', cl = "dynamicInputs", label = "", choices = Choices ,selected=allVars[i])
}))
Logic<-unlist(lapply(1:length(idSeq),function(i){
if(is.na(allLogic[i]))
return(NA)
shinyInput(selectInput, idSeq[i], 'logic_', cl = "dynamicInputs",label = "", choices = c("And","Or"),selected=allLogic[i])
}))
myValue$Filter$Variable<-Variable
myValue$Filter$Logic<-Logic
maxId<<-maxId+1
newRow <- data.frame(
Variable = shinyInput(selectInput, maxId, 'var_', cl = "dynamicInputs", label = "", choices = Choices),
Filter = shinyInput(actionButton, maxId, 'go_button_',cl=NULL, label = "Filter", onclick = goButtonOnClick() ),
Logic = shinyInput(selectInput, maxId, 'logic_',cl = "dynamicInputs", label = "", choices = c("And","Or")),
Remove = shinyInput(actionButton, maxId, 'remove_button_',cl=NULL, "", icon = icon("close"), onclick = removeButtonOnClick() ),
stringsAsFactors = FALSE
)
rownames(newRow) <- as.character(nrow(myValue$Filter)+1)
myValue$Filter <- rbind(myValue$Filter,newRow)
})
# Remove Row
observeEvent(input$select_remove_button,{
if(is.null(myValue$Filter) || nrow(myValue$Filter)==0)
return()
idSeq<-unlist(lapply(myValue$Filter$Filter,function(x){
buttonId<-stringr::str_extract(x,paste0("go_button_","\\d+"))
num<-as.numeric(gsub("go_button_","",buttonId))
return(num)
}))
allVars<-extractValues(idSeq,"var_")
allLogic<-extractValues(idSeq,"logic_")
Choices <- c("a","b","c","d")
Variable<-unlist(lapply(1:length(idSeq),function(i){
shinyInput(selectInput, idSeq[i], 'var_', cl = "dynamicInputs", label = "", choices = Choices ,selected=allVars[i])
}))
Logic<-unlist(lapply(1:length(idSeq),function(i){
if(is.na(allLogic[i]))
return(NA)
shinyInput(selectInput, idSeq[i], 'logic_', cl = "dynamicInputs",label = "", choices = c("And","Or"),selected=allLogic[i])
}))
myValue$Filter$Variable<-Variable
myValue$Filter$Logic<-Logic
rowToRemove<- which(unlist(lapply(myValue$Filter$Remove,function(x){stringr::str_extract(x,paste0("remove_button_","\\d+"))}))==input$select_remove_button)
myValue$Filter<-myValue$Filter[-rowToRemove,]
if(nrow(myValue$Filter)>0)
rownames(myValue$Filter)<-as.character(1:nrow(myValue$Filter))
})
# Display bsModal for filter
observeEvent(input$filter_button_change, {
toggleModal(session,"CustomDataFilter",toggle="open")
})
# helper function for reading selectinput
shinyValue = function(id, objs) {
unlist(lapply(objs, function(i) {
value = input[[paste0(id, i)]]
if (is.null(value))
NA
else{
value
}
}))
}
# Show Filter Table
output$mytable = DT::renderDataTable({
if(is.null(myValue$Filter))
return()
myValue$Filter
}, selection = 'none', server = FALSE, escape = FALSE, options = list(
dom = "ti",
paging = TRUE,
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
})
ui.r
library(shiny)
library(shinyBS)
library(shinyjs)
library(DT)
library(rhandsontable)
shinyUI(fluidPage(
tags$head(tags$script(HTML("
$(document).on('change', '.dynamicInputs .selector select', function(){
Shiny.setInputValue('lastSelectId', this.id, {priority: 'event'});
});
"))),
tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})"
)
),
tags$button(
id = "reset_button",
class="btn action-button",
icon("close")
),
bsModal("CustomDataFilter","Settings","go_CustomDataFilter_Settings",size="large",
uiOutput("FilterDataSettings")
),
bsModal("CustomDataFormula","Settings","go_CustomDataFormula_Settings",size="large",
uiOutput("CustomDataFormula")
),
actionButton("addnewRow"," Add New Filter "),
DT::dataTableOutput('mytable')
)
)

Resources