I'm rendering a dataTable in a shiny application. 3 inputs will be entered by the user and on clicking the button, a dataTable will be rendered with 4 columns where column 1 will be uneditable, column 2 have a drop-down, column 3 has a date, and column 4 has a feature to delete a row if needed.
I have rendered a dataTable where column 2 has a drop-down. I am not clear on how to edit dates in the dataTable and also to delete a row.
The code which I used to implement is as follows:
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
column(2, selectizeInput("type", "Type", choices = c("Item A","Item B","Item C","Item D"))),
column(2, selectizeInput("freq", "Frequency", choices = c("Daily","Monthly","Weekly","Twice Weekly"))),
column(2, dateInput("typeDate", "Date", value = NA)),
column(3, actionButton("addRow", "Add")),
column(3, actionButton("overallDates","Overall Summary"))
),
fluidRow(
column(12,
DT::dataTableOutput("tableData"))
)
)
server <- function(input, output, session){
combinedData <- data.frame()
observeEvent(input$addRow,{
if(!is.null(input$type) & !is.null(input$freq) & !is.null(input$typeDate)){
typeData <- input$type
typefreq <- input$freq
dateType <- input$typeDate
individualData <- data.frame("Type" = typeData, "Frequency" = typefreq, "Date" = dateType, stringsAsFactors = FALSE)
combinedData <<- rbind(combinedData, individualData)
for (i in 1:nrow(combinedData)) {
choiceValue <- combinedData$Frequency[i]
dateValue <- combinedData$Date[i]
combinedData$Frequency[i] <- as.character(selectInput(paste0("sel",i),"", choices = c("Daily","Monthly","Weekly","Twice Weekly"),selected = choiceValue, width = "100px"))
#combinedData$Date[i] <- dateInput(paste0("datesel",i),"", value = NULL)
}
output$tableData <- renderDataTable(
combinedData, selection = 'none', editable = TRUE, escape = FALSE,
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());")
)
observeEvent(input$deliverableData_cell_edit,{
combinedData[input$deliverableData_cell_edit$row, input$deliverableData_cell_edit$col] <<- input$deliverableData_cell_edit$value
})
print(combinedData)
}
})
}
shinyApp(ui = ui, server = server)
Can anyone provide a solution of how to add dateInput in one column and delete a row if needed by having a delete feature at the last column of the dataTable?
Related
I recently asked a similar question (Shiny DT datatable input reactivity after table is reloaded). My issue was getting a selectInput in a DT datatable to work correctly after the table is reloaded. The solution worked, which was to use javascript to unbind before reloading the table. However, that example used a static dataframe. When the input data in the datatable are reactive, it doesn't work. In the example below, when the user clicks "Update data" the first time to load data, the selectInput works correctly and input$id1 responds to the user selection. However, when the user clicks "Update data" again to update the reactive data, the input$id no longer responds to the user selection. I've seen two potential approaches to address the issue. One is using dataTableProxy() and replaceData(), and the other is renaming the selectInput ids each time the reactive data are updated. I was wondering if I can avoid those two approaches and get this example working with minimal changes.
require(shiny)
require(DT)
shinyApp(
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());
}
})")
)),
actionButton(inputId = "update", label = "Update data"),
uiOutput("resettable_table")
),
server = function(input, output, session) {
rv <- reactiveValues(
times = 1,
mydata = NULL
)
observeEvent(input$update, {
session$sendCustomMessage("unbindDT", "mytable")
rv$times <- rv$times + 1
rv$mydata <- data.frame(
Col1 = as.character(selectInput(
inputId = "id1",
label = NULL,
choices = paste0(letters, input$update),
selected = paste0(letters, input$update)[1],
))
)
})
output$mytable <- DT::renderDataTable({
req(rv$mydata)
DT::datatable(
data = rv$mydata,
escape = F,
selection = "none",
options = list(
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
)
)
}, server = F)
output$resettable_table <- renderUI({
req(rv$times)
div(
id = paste0("mydiv", rv$times),
DT::dataTableOutput("mytable")
)
})
observe({
if(is.null(input$id1)) {
print("input$id1 is NULL")
} else {
print(paste(c("input$id1:", input$id1)))
}
})
}
)
Update
Thanks to #StephaneLaurent for pointing out that the reactive counter keeping track of the number of times the data were reloaded was causing the issue. It wasn't actually necessary to put the DT datatable inside a div with an id that updated each time. Here is working code:
require(shiny)
require(DT)
shinyApp(
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());
}
})")
)),
actionButton(inputId = "update", label = "Update data"),
DT::dataTableOutput("mytable")
),
server = function(input, output, session) {
rv <- reactiveValues(mydata = NULL)
observeEvent(input$update, {
session$sendCustomMessage("unbindDT", "mytable")
rv$mydata <- data.frame(
Col1 = as.character(selectInput(
inputId = "id1",
label = NULL,
choices = paste0(letters, input$update),
selected = paste0(letters, input$update)[1],
))
)
})
output$mytable <- DT::renderDataTable({
req(rv$mydata)
DT::datatable(
data = rv$mydata,
escape = F,
selection = "none",
options = list(
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
)
)
}, server = F)
observe({
if(is.null(input$id1)) {
print("input$id1 is NULL")
} else {
print(paste(c("input$id1:", input$id1)))
}
})
}
)
The problem is caused by the presence of rv$times in the renderUI. The simplest way to make this app work is to get rid of this renderUI.
However, for fun, and in order to understand what happens, I did the app below which works with the renderUI and which shows what happens. The key point was to remove the id1 element when the table is consecutively rendered two times, before the second rendering. To do so, I use a JavaScript counter i.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
tags$head(tags$script(
HTML("var i = 1;")
)),
actionButton(inputId = "update", label = "Update data"),
uiOutput("resettable_table")
),
server = function(input, output, session) {
rv <- reactiveValues(
times = 1,
mydata = NULL
)
observeEvent(input$update, {
rv$times <- rv$times + 1
rv$mydata <- data.frame(
Col1 = as.character(selectInput(
inputId = "id1",
label = NULL,
choices = paste0(letters, input$update),
selected = paste0(letters, input$update)[1],
))
)
})
output$mytable <- DT::renderDataTable({
req(rv$mydata)
DT::datatable(
data = rv$mydata,
escape = F,
selection = "none",
options = list(
initComplete = JS('function(settings) { alert("initComplete - incrementing i"); i++; alert("i = " + i)}'),
preDrawCallback = JS('function() { alert("preDrawCallback triggered - unbinding"); Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { alert("drawCallback triggered - i = " + i); if(i===2) {alert("removing id1 and resetting i to 0"); $("#id1").remove(); i=0;} Shiny.bindAll(this.api().table().node());}')
)
)
}, server = F)
output$resettable_table <- renderUI({
div(
id = paste0("mydiv", rv$times),
tags$p(paste0("mydiv", rv$times)),
DT::dataTableOutput("mytable")
)
})
observe({
if(is.null(input$id1)) {
print("input$id1 is NULL")
} else {
print(paste(c("input$id1:", input$id1)))
}
})
}
)
I'm currently building a Shiny dashboard in R and I'm currently building a mechanism that would allow some user to comment some datatable inside it, and I got this mechanism done and sorted (as you can see on the code below). My problem is when I add the comments and refresh the page, the comments go away (as they should). Is there any way to save the datatable and keep the changes saved for any user to see, even after I refresh the dashboard page?
Thanks if you read this far :)
Please find a reproducible example below:
library(shiny)
library(DT)
dt <- data.table(
ID = c('Order 1','Order 2', 'Order 3', 'Order 4'),
Name = c('John','Peter','Anna','Richard')
)
ui <- fluidPage(
fluidRow(
column(2, pickerInput(inputId = 'selectID',
label = 'Select order ID to comment on:',
choices = c('Order 1','Order 2', 'Order 3', 'Order 4'),
selected='',
multiple=FALSE)),
column(2, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL))
,
column(1, actionButton(inputId = "button",
label = "Add Comment",
size = "extra-small",
style = "margin-top:25px"
)
)
),
fluidRow(
column(12,
dataTableOutput('data')
)
)
)
server <- function(input, output, session){
dt_comments <- reactiveVal({
data.table(
ID = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
dt_current <- reactive({
dt <- dt
## merge with current comments
if(nrow(dt_comments()) > 0)
dt <- merge(dt, dt_comments(), by = "ID", all.x = TRUE)
return(dt)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
dt_comments_new <- rbind(dt_comments(),
data.table(ID = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
dt_comments_new <- dt_comments_new[!duplicated(dt_comments_new$ID, fromLast = TRUE), , drop = FALSE]
dt_comments(dt_comments_new)
})
output$data <- DT::renderDataTable({
req(dt_current())
dt2 <- dt_current()
## show comments if non-empty
showComments <- is.null(dt2$Comment) || !all(is.na(dt2$Comment))
DT::datatable(dt2,
editable = TRUE,
options = list(
columnDefs = list(
list(targets = ncol(dt2), visible = showComments)
)
)
)
})
}
shinyApp(ui = ui, server = server)
This question is an extension of the question I posted: this question
I created a dataframe with 3 columns: num, id and val. I want my shiny app to do the following:
a dataframe dat is filtered by num column
select an value from id column from dat (selectInput).
add text comment in a text box (textInput)
click on an action button
A new column called comment is created in the data table, text comments are added to the comment column in the row where id equals the value selected.
The code is below. I cannot figure out why it's not working.
Thank a lot in advance!
library(shiny)
library(DT)
dat = data.frame(num=rep(1:2, each=5), id=rep(LETTERS[1:5],2), val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df = reactive ({ dat %>% filter(num %in% input$selectNum) })
df_current <- reactiveVal(df())
observeEvent(input$button, {
req(df_current())
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
shinyApp(ui=ui, server=server)
Instead of using a reactive/eventReactive statement for df, it might be more natural to keep track of previously inputted comments in the Comment column using a reactiveVal object for df. See also the responses to this question: R Shiny: reactiveValues vs reactive. If you prefer to use a reactive/eventReactive statement for df it is probably better to work with a separate object to store previous input comments (instead of incorporating it into the reactive statement for df).
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10)),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current <- reactiveVal(dat)
observeEvent(input$button, {
req(df_current(), input$selectID %in% dat$id)
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
shinyApp(ui=ui, server=server)
Edit: below an edited server function that using df_current <- reactive({...}) instead of df_current <- reactiveVal({...}) and defining a separate reactiveVal object to keep track of the comments.
server <- function(input, output, session) {
## initialize separate reactive object for comments
df_comments <- reactiveVal({
data.frame(
id = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
## reactive object df
df_current <- reactive({
## reactivity that df depends on
## currently df = dat does not change
df <- dat
## merge with current comments
if(nrow(df_comments()) > 0)
df <- merge(df, df_comments(), by = "id", all.x = TRUE)
return(df)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
df_comments_new <- rbind(df_comments(),
data.frame(id = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
df_comments_new <- df_comments_new[!duplicated(df_comments_new$id, fromLast = TRUE), , drop = FALSE]
df_comments(df_comments_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
There you have got a working example.
I think the thing is that you are trying to update a value through an observeEvent which is not good according to the documentation. ?observeEvent
Use observeEvent whenever you want to perform an action in response to an event. (Note that "recalculate a value" does not generally count as performing an action–see eventReactive for that.)
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current = reactive({
df = dat %>% filter(num %in% input$selectNum)
if(input$button != 0) {
input$button
df[df$id %in% input$selectID, "Comment"] <- isolate(input$comment)
}
return(df)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
}
shinyApp(ui=ui, server=server)
So you can either go with your reactive value or using eventReactive as stated in the doc.
The app below contains a selectInput of dataset IDs and a button View details which displays a modalDialog when clicked. The modal dialog has a datatable that contains some information about the datasets in the selectInput dropdown.
Here is a screenshot of the app on startup:
Since the user can select a dataset either by selecting an option from the dropdown menu or by selecting a row in the datatable, I created a reactive value rv$selectedRow which stores the value of the selected dataset. When the modal is triggered, rv$selectedRow takes the value of input$data. When the Select button in the modal footer is clicked, rv$selectedRow takes the value of input$dfs_rows_selected and the selectInput is updated to reflect this new value. This is done by the two observeEvents in the code below.
When the user selects a row, closes the modal and opens it again, I would like the page and row of the selected dataset (input$data) to be pre-selected. I tried to achieve this using selection = list(mode = 'single', selected = rv$selectedRow) in the renderDT call. As you can see in the screenshot, row 1 should be pre-selected but it isn't. I feel like I'm missing a req() somewhere in the renderDT but I'm not sure. The value of rv$selectedRow checks out when I print it to the console, so I don't know why the selected argument of renderDT isn't working. I am also not sure how to store the page of the selected row. Any insight would be much much appreciated as I'm a little lost.
The app is as follows:
library(shiny)
library(DT)
datasets = data.frame(cbind(id = seq_len(4), name = c('iris', 'mtcars', 'satellite', 'credit')))
# UI ----------------------------------------------------------------------
ui = fluidPage(
selectInput('data', 'Select dataset:', choices = datasets$id),
actionButton('view', 'View details')
)
# SERVER ------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
rv = reactiveValues(selectedRow = NULL, selectedPage = NULL)
# Opening the modal
observeEvent(input$view, {
rv$selectedRow = req(input$data)
print(paste("selectedRow on 'View':", rv$selectedRow))
showModal(modalDialog(
title = 'Available datasets',
tags$b('Click on a row to select a dataset.'),
br(),
br(),
DT::dataTableOutput('dfs'),
easyClose = F,
footer = tagList(
modalButton('Cancel'),
bsButton('select', 'Select')
)
)
)
})
# Rendering the DT - pre-selection of row not working
output$dfs <- renderDT({
print(paste("selectedRow on 'renderDT':", rv$selectedRow))
datasets
},
options = list(
# displayStart = selectedPage,
pageLength = 2
),
filter = 'top',
selection = list(mode = 'single', selected = rv$selectedRow),
rownames = F
)
# Saving the selected row and updating the selectInput
observeEvent(input$select, {
rv$selectedRow = req(input$dfs_rows_selected)
print(paste("selectedRow on 'Select':", rv$selectedRow))
updateSelectInput(session = session, inputId = 'data', selected = datasets[rv$selectedRow, 1])
removeModal(session)
})
})
shinyApp(ui, server)
Updated code:
As per this solution and the one posted by Wilmar below, using datatable() in the renderDT seemed to fix the problem -
library(shiny)
library(DT)
datasets = data.frame(cbind(id = seq_len(4), name = c('iris', 'mtcars', 'satellite', 'credit')))
# UI ----------------------------------------------------------------------
ui = fluidPage(
selectInput('data', 'Select dataset:', choices = datasets$id),
actionButton('view', 'View details')
)
# SERVER ------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
rv = reactiveValues(selectedRow = NULL, selectedPage = NULL)
# Opening the modal
observeEvent(input$view, {
print(paste("selectedRow on 'View':", rv$selectedRow))
showModal(modalDialog(
title = 'Available datasets',
tags$b('Click on a row to select a dataset.'),
br(),
br(),
DT::dataTableOutput('dfs'),
easyClose = F,
footer = tagList(
modalButton('Cancel'),
bsButton('select', 'Select')
)
)
)
})
# Rendering the DT - pre-selection of row not working
output$dfs <- renderDataTable({
r = rv$selectedRow
print(paste("selectedRow on 'renderDT':", r))
datatable(
datasets,
options = list(
displayStart = as.numeric(r)-1,
pageLength = 2
),
filter = 'top',
selection = list(mode = 'single', selected = r),
rownames = F
)
}, server = F)
# Saving the selected row and updating the selectInput
observeEvent(input$select, {
rv$selectedRow = req(input$dfs_rows_selected)
print(paste("selectedRow on 'Select':", rv$selectedRow))
updateSelectInput(session = session, inputId = 'data', selected = datasets[rv$selectedRow, 1])
removeModal(session)
})
observe({
rv$selectedRow = input$data
})
})
shinyApp(ui, server)
I guess this is what you're looking for. Your first problem was that you had to convert rv$selectedRow to numeric. Secondly it you were re-rendering your datatable everytime you pressed the "view" button. And thirdly you didn't do anything with your selectInput ("data").
I transformed rv$selectedRow to a numeric, moved your showModal to the ui and created an observer for your selectInput. In addition, I wrapped your datafarme in the datatable function, which I think is a bit more convenient.
Working example:
library(shiny)
library(DT)
library(shinyBS)
datasets = data.frame(cbind(id = seq_len(4), name = c('iris', 'mtcars', 'satellite', 'credit')))
# UI ----------------------------------------------------------------------
ui = fluidPage(
selectInput('data', 'Select dataset:', choices = datasets$id),
actionButton('view', 'View details'),
tags$head(tags$style("#df_popup .modal-footer{ display:none}
#df_popup .modal-header .close{display:none}")),
bsModal("df_popup", title='Available datasets', trigger='view',
tags$b('Click on a row to select a dataset.'),
br(),
br(),
DT::dataTableOutput('dfs'),
column(12, align='right',
modalButton('Cancel'),
bsButton('select', 'Select')
)
)
)
# SERVER ------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
rv = reactiveValues(selectedRow = NULL, selectedPage = NULL)
# Rendering the DT - pre-selection of row not working
output$dfs <- renderDT({
print(paste("selectedRow on 'renderDT':", rv$selectedRow))
datatable(datasets, options = list(
# displayStart = selectedPage,
pageLength = 2
),
filter = 'top',
selection = list(mode = 'single', selected=c(as.numeric(rv$selectedRow))),
rownames = F)
},
)
# Saving the selected row and updating the selectInput
observeEvent(input$select, {
rv$selectedRow = req(input$dfs_rows_selected)
print(paste("selectedRow on 'Select':", rv$selectedRow))
updateSelectInput(session = session, inputId = 'data', selected = datasets[rv$selectedRow, 1])
toggleModal(session, 'df_popup')
})
observeEvent(input$data, {
rv$selectedRow = input$data
print(paste("selectedRow on 'data':", rv$selectedRow))
})
})
shinyApp(ui, server)
I'm building a R Shiny app with a dynamic datatable, using the DT package. Users are able to select two columns within a data.frame that contains more columns.
When users select a column, the datatable is updated and all filters/sorting are reset to default within the datatable object. How can I let the application remember filters and sorting when the given column is not replaced by the user?
Minimal working example below:
library(shiny)
library(DT)
library(data.table)
server <- function(input, output) {
df <- data.frame(
name = rep('a',20),
dimA = 1:20,
dimB = 21:40,
dimC = 41:60
)
observe({
columns <- c('name', input$dim1ID, input$dim2ID)
dfDt <- df[names(df) %in% columns]
output$dtDataTable = DT::renderDataTable(
server = FALSE,
expr = datatable(
dfDt,
filter = 'top',
rownames = FALSE,
selection = 'none',
options = list(sDom = '<"top">rt<"bottom">ip')
)
)
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
## Dimension 1
selectInput(
inputId = "dim1ID",
label = "Dimensie 1",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimA'
),
## Dimension 2
selectInput(
inputId = "dim2ID",
label = "Dimensie 2",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimB'
)
),
mainPanel(DT::dataTableOutput('dtDataTable'))
)
)
shinyApp(ui = ui, server = server)
This can be done using the DataTables Information, in particular the "state" information (input$tableId_state) which contains the order information of the current table, and input$tableId_search_columns which contains the filtering information by columns. If the columns are fixed (ie in the example above "Dimensie 1" and "Dimensie 2" would always be at the same place), it is much simpler to "remember" which one was ordered (unlike the original example where they are alphabetically reordered when the table is created). For instance based on the above example, the following will work if you sort the "A" column and change the right column from "B" to "C" and back:
library(shiny)
library(DT)
library(data.table)
server <- function(input, output) {
df <- data.frame(
name = rep('a',20),
dimA = 1:20,
dimB = 21:40,
dimC = 41:60
)
values <- reactiveValues(
prevDim1 = "",
prevDim2 = "",
options = list(sDom = '<"top">rt<"bottom">ip',
stateSave = TRUE,
order = list())
)
observeEvent(input$dtDataTable_state$order, {
values$options$order <- input$dtDataTable_state$order
})
observeEvent({
input$dim1ID
input$dim2ID
},{
columns <- c('name', input$dim1ID, input$dim2ID)
dfDt <- df[names(df) %in% columns]
if(length(values$options$order) != 0 && ((values$prevDim1 != input$dim1ID && values$options$order[[1]][[1]] == 1) | (values$prevDim2 != input$dim2ID && values$options$order[[1]][[1]] == 2)) ){
values$options$order = list()
}
values$prevDim1 <- input$dim1ID
values$prevDim2 <- input$dim2ID
output$dtDataTable = DT::renderDataTable(
server = FALSE,
expr = datatable(
dfDt,
filter = 'top',
rownames = FALSE,
selection = 'none',
options = values$options
)
)
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
## Dimension 1
selectInput(
inputId = "dim1ID",
label = "Dimensie 1",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimA'
),
## Dimension 2
selectInput(
inputId = "dim2ID",
label = "Dimensie 2",
choices = c('dimA', 'dimB', 'dimC'),
selected = 'dimB'
)
),
mainPanel(DT::dataTableOutput('dtDataTable'))
)
)
shinyApp(ui = ui, server = server)