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
}
})
I would like my datatable to display content which depends on the status of checkboxes contained in the table. I have found help with both, including checkboxes in a DT as well as changing data table content, but when I try and combine these solutions I don't get what I want. When checking a box, the table is redrawn twice, the first time the way I want but a moment later it switches back.
This is the code which should almost do... Is there someone out there to help before I get crazy?
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DT::dataTableOutput('x1'),
verbatimTextOutput('x2')
),
server = function(input, output, session) {
# create a character vector of shiny inputs
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# obtain the values of inputs
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) TRUE else value
}))
}
n = 6
df = data.frame(
cb = shinyInput(checkboxInput, n, 'cb_', value = TRUE, width='1px'),
month = month.abb[1:n],
YN = rep(TRUE, n),
ID = seq_len(n),
stringsAsFactors = FALSE)
loopData = reactive({
df$YN <<- shinyValue('cb_', n)
df
})
output$x1 = DT::renderDataTable(
isolate(loopData()),
escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')#,
))
proxy = dataTableProxy('x1')
observe({
replaceData(proxy, loopData())
})
output$x2 = renderPrint({
data.frame(Like = shinyValue('cb_', n))
})
}
)
Yes, your example code almost works. The only thing not right is that the value of df$cb needs to be changed, too.
For example, let's say you clicked the second row and input$cb_2 gets changed. shiny would record that input$cb_2 got changed to FALSE. Since the value of df$cb[[2]] was still checkbox(..., value = TRUE), when the table gets re-drawed, a checked checkbox would be displayed and R thought that input$cb_2 got changed again and so your data would be altered correspondly.
Checked the example code if there's anything uncleared.
The worked example code
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DT::dataTableOutput('x1'),
verbatimTextOutput('x2')
),
server = function(input, output, session) {
# create a character vector of shiny inputs
shinyInput = function(FUN, len, id, value, ...) {
if (length(value) == 1) value <- rep(value, len)
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = value[i]))
}
inputs
}
# obtain the values of inputs
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) TRUE else value
}))
}
n = 6
df = data.frame(
cb = shinyInput(checkboxInput, n, 'cb_', value = TRUE, width='1px'),
month = month.abb[1:n],
YN = rep(TRUE, n),
ID = seq_len(n),
stringsAsFactors = FALSE)
loopData = reactive({
df$cb <<- shinyInput(checkboxInput, n, 'cb_', value = shinyValue('cb_', n), width='1px')
df$YN <<- shinyValue('cb_', n)
df
})
output$x1 = DT::renderDataTable(
isolate(loopData()),
escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))
proxy = dataTableProxy('x1')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
output$x2 = renderPrint({
data.frame(Like = shinyValue('cb_', n))
})
}
)
I have DT where I added checkboxes as a first column. Their idea is to give the user the option of removing selected rows and placing them in a file. After pressing the button cold "delete", the data is sent to the file, but I do not know how to update DT, to get data without those deleted rows.
Code:
library(shiny)
library(DT)
library(dplyr)
shinyApp(
ui <- fluidPage(DT::dataTableOutput("ruless"),
fluidRow(column(4, offset = 1, actionButton("delete", "Delete", width = 200)))),
server <- function(input, output) {
values <- reactiveValues(data = NULL)
values$data <- as.data.frame(
cbind(c("a", "d", "b", "c", "e", "f"),
c(1463, 159, 54, 52, 52, 220),
c(0.7315, 0.0795, 0.027, 0.026, 0.026, 0.11)
)
)
shinyInput = function(FUN, len, id, ...) {
#validate(need(character(len)>0,message=paste("")))
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
output$ruless <- DT::renderDataTable({
datatable(
data.frame(delete=shinyInput(checkboxInput,nrow(values$data),"cbox_"), values$data),
selection="multiple",
escape = FALSE,
filter = list(position = 'top', clear = FALSE),
extensions = list("ColReorder" = NULL, "Buttons" = NULL),
options = list(
dom = 'BRrltpi',
autoWidth=TRUE,
lengthMenu = list(c(10, 50, -1), c('10', '50', 'All')),
ColReorder = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
buttons = list(
'copy',
'print',
list(
extend = 'collection',
buttons = c('csv', 'excel', 'pdf'),
text = 'Download',
selected = TRUE
)
)
)
)
})
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
observeEvent(input$delete, {
checkbox_rules <- data.frame(selected=shinyValue("cbox_",nrow(values$data)))
marked_rules <- as.data.frame(values$data[(which(checkbox_rules == TRUE)),])
if (file.exists("delete_file.csv")){
delete_file <- as.data.frame(read_csv2("delete_file.csv", col_names = TRUE))
delete_file <- as.data.frame(rbind(delete_file, marked_rules))
delete_file <- delete_file[!duplicated(delete_file), ]
write.csv2(delete_file, file = "delete_file.csv", sep=";", row.names = FALSE)
}
else{
write.csv2(marked_rules, file = "delete_file.csv", sep=";", row.names = FALSE)
}
})
}
)
I would like also to replace delete button and rename rest of buttons above DT. I am thinking about something like that:
I it possible to do? Thank in advance!
Is it possible?
You can update the data.frame in the observer like this
values$data <- values$data[!checkbox_rules,]
At the end it should look something like this
observeEvent(input$delete, {
checkbox_rules <- data.frame(selected=shinyValue("cbox_",nrow(values$data)))
marked_rules <- as.data.frame(values$data[(which(checkbox_rules == TRUE)),])
values$data <- values$data[!checkbox_rules,]
if (file.exists("delete_file.csv")){
delete_file <- as.data.frame(read_csv2("delete_file.csv", col_names = TRUE))
delete_file <- as.data.frame(rbind(delete_file, marked_rules))
delete_file <- delete_file[!duplicated(delete_file), ]
write.csv2(delete_file, file = "delete_file.csv", sep=";", row.names = FALSE)
}
else{
write.csv2(marked_rules, file = "delete_file.csv", sep=";", row.names = FALSE)
}
})
hope this helps!