My R Shiny app has text and a datatable. When I click a datatable row, the data changes and the table is updated using a datatable proxy so that the table page doesn't change. Also the text updates to show how many rows were clicked.
The problem is that when the text updates, it also updates the table which resets to page 1, ruining the point of using the datatable proxy.
Here is a working example. Run it with and without the last code line commented (the code line starting with v$selected_count <- ...)
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
uiOutput("app_ui")
)
, server = function(input, output){
v <- reactiveValues(
selected_count = 0
, data = iris
)
output$app_ui <- renderUI({
tagList(
h5(v$selected_count) # Want this to update without affecting the datatable
, DTOutput('tbl')
)
})
output$tbl = renderDT({
datatable(iris)
})
observeEvent(
input$tbl_rows_selected
, {
i <- input$tbl_rows_selected
v$data[i, "Species"] <- ""
dataTableProxy("tbl") %>% replaceData(v$data, resetPaging = FALSE, clearSelection = FALSE)
v$selected_count <- v$selected_count + 1 # Comment this line to see the difference to the datatable
}
)
}
)
Related
I have a Shiny app (please see end for a minimum working example) with a "parent" reactable table and a drilldown table that pops up when a user clicks on a row of the parent table. The information on which row is selected in the parent is obtained via reactable::getReactableState(). However, when the user switches to a different "parent" table, the function returns the row selection for the outdated table, not the updated one.
This occurs event though the output for the new parent table has completed it's calculations and is fully updated by the time the drilldown table starts it's calculations. After the whole systems finished and the app is idle, something (and I'm not sure what) triggers the input to reactable::getReactableState() to be invalidated, and the reactives fire again, but this time using the updated (or "correct" from my perspective) tables, and returns the expected result, which is that now row is selected.
Referring to the reactive graph below, what I want to do is have input$tables-table_parent__reactable__selected set not NULL every time input$tables-data_set changes.
I have tried to do this via the session$sendCustomMessage() and Shiny.addCustomMessageHandler approach found here: Change the input value in shiny from server, but I find that, although I can change input$tables-table_parent__reactable__selected value it doesn't seem to send send the info to the browser until after all the outputs are done caculating when input$tables-data_set is changed.
A minimum working example:
UI module:
drilldownUI <- function(id) {
ns <- NS(id)
tagList(
tags$script("
Shiny.addCustomMessageHandler('tables-table_parent__reactable__selected', function(value) {
Shiny.setInputValue('tables-table_parent__reactable__selected', value);
});
"),
shiny::selectizeInput(
inputId = ns("data_set"),
label = "Data set",
choices = c("iris", "cars"),
selected = "iris"
),
reactable::reactableOutput(outputId = ns("table_parent"),
width = "100%"),
reactable::reactableOutput(
outputId = NS(id, "drilldown_table"),
width = "100%"
)
)
}
Server module:
drilldownServer <- function(id, dat) {
moduleServer(id, function(input, output, session) {
dataset <- reactive({
data_list <-
list(iris = as.data.table(iris), cars = as.data.table(MASS::Cars93))
data_list[[input$data_set]]
})
data_grouped <- reactive({
dataset()[, .N, by = c(grouping_var())]
})
grouping_var <- reactive({
if (input$data_set == "iris") {
return("Species")
}
"Origin"
})
output$table_parent <- reactable::renderReactable({
req(input$data_set)
reactable::reactable(
data_grouped(),
selection = "single",
onClick = "select"
)
})
selected <- reactive({
out <- reactable::getReactableState("table_parent", "selected")
if(is.null(out)||out=="NULL") return(NULL)
out
})
output$drilldown_table <- reactable::renderReactable({
req(selected())
# This should only fire after a new parent table is generated and the row selection is
# reset to NULL, but it fires once the new table is generated and BEFORE the row selection
# is reset to NULL
selected_group <- data_grouped()[selected(), ][[grouping_var()]]
drilldown_data <- dataset()[get(grouping_var()) == selected_group]
reactable::reactable(drilldown_data)
})
observeEvent(input$data_set, {
session$sendCustomMessage("tables-table_parent__reactable__selected", 'NULL')
})
})
App:
library(shiny)
library(reactable)
library(data.table)
# Define UI for application that draws a histogram
ui <- fluidPage(
drilldownUI("tables")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
drilldownServer("tables")
}
# Run the application
shinyApp(ui = ui, server = server)
I found the solution thanks in part to this SO answer https://stackoverflow.com/a/39440482/9474704.
The key was to consider the row selection a state, rather than just reacting to input changes. Then, by using reactiveValues() instead of reactive(), I could update the state in multiple places using observeEvent().
An important additonal piece of information was that observe functions are eager, and you can set a priority, so when the user changes the input$data_set, I could reset the row selection to 0 before the drilldown reactable::renderReactable() section was evaluated.
The updates to the server module below for an example of the working solution:
drilldownServer <- function(id, dat) {
moduleServer(id, function(input, output, session) {
dataset <- reactive({
data_list <-
list(iris = as.data.table(iris), cars = as.data.table(MASS::Cars93))
data_list[[input$data_set]]
})
data_grouped <- reactive({
dataset()[, .N, by = c(grouping_var())]
})
grouping_var <- reactive({
if (input$data_set == "iris") {
return("Species")
}
"Origin"
})
# Create output for parent table
output$table_parent <- reactable::renderReactable({
req(input$data_set)
reactable::reactable(data_grouped(),
selection = "single",
onClick = "select")
})
# Create state variable
selected <- reactiveValues(n = 0)
currentSelected <- reactive({
reactable::getReactableState("table_parent", "selected")
})
observeEvent(currentSelected(), priority = 0, {
selected$n <- currentSelected()
})
# When data set input changes, set the selected number of rows to 0e
observeEvent(input$data_set,
label = "reset_selection",
priority = 9999, {
selected$n <- 0
})
# Create output for drilldown table
output$drilldown_table <- reactable::renderReactable({
req(selected$n > 0)
selected_group <-
data_grouped()[selected$n, ][[grouping_var()]]
drilldown_data <-
dataset()[get(grouping_var()) == selected_group]
reactable::reactable(drilldown_data)
})
})
}
UPDATE
I've gotten to what I think is the root problem. The following R Shiny App produces a UI with 2 text input boxes, as well as event observers that print messages to the console as the text changes in their respective text input boxes. The issue is that only one of these event observers works correctly, and I can't figure out why.
ui.R (shortened)
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(
renderUI({
fluidPage(
column(12, dataTableOutput("Main_table")),
box(textInput("TEST_BOX", label=NULL, value="TEST"))
)
})
)
server.R (shortened)
shinyServer(function(input, output) {
test <- reactiveValues()
test$data <- data.table(ID = 1, Group = 1)
output$Main_table <- renderDataTable({
datatable(data.frame(test$data,
New_Group=as.character(textInput("BOX_ID", label = NULL, value = "TEST2",
width = '100px'))), escape=F
)})
observeEvent(input$TEST_BOX, {
print("Test Box Success")
})
observeEvent(input$BOX_ID, {
print("Box ID Success")
})
})
Original Post:
I'm attempting to create a simple app in R Shiny to allow the user to interactively update the values in a column of a small table, then be able to hit a "Save Changes" button and update the table to include their selections.
I've gotten really close with the code below (I think), but for some reason the inputs cbox_1 to cbox_10 always come back as NULL.
ui.R
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(fluidPage(
dashboardBody(uiOutput("MainBody")
)
))
server.R
# Load libraries
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
# Define server logic
shinyServer(function(input, output) {
# Create sample data
vals <- reactiveValues()
vals$Data <- data.table(ID = 1:10, Group = 1:1)
# Create main UI with Save Changes button and additional text input box for testing.
output$MainBody <- renderUI({
fluidPage(
box(width=12,
h3(strong("Group Testing"),align="center"),
hr(),
box(textInput("test", label=NULL, value="TESTING")),
column(6, offset = 5, actionButton("save_changes","Save changes")),
column(12, dataTableOutput("Main_table"))
)
)
})
# Function to be used to create multiple text input boxes.
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = vals$Data$Group[i], width = '100px', ...))
}
inputs
}
# Renders table to include column with text input boxes. Uses function above.
output$Main_table <- renderDataTable({
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(dom = 't', pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
}
)
# Tests if the test input box works.
observeEvent(input$test, {
print("Success1")
})
# Tests if the first input box in the table works.
observeEvent(input$cbox_1, {
print("Success2")
})
# Tests if the Save Changes button works.
observeEvent(input$save_changes, {
print("Success3")
# Assigns the values in the input boxes (New_Group) to the existing Group column.
for (i in 1:nrow(vals$Data)) {
vals$Data$Group[i] <- eval(paste0("input$cbox_", i))
}
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
})
})
The first two observeEvents at the end of the code are solely for testing purposes. "Success2" is never printed even when the contents of the first box are changed. "Success1" is printed when the test box is changed, but I'm not sure why one works and the other doesn't. I've tried inserting a browser() statement in various places of the code to check the value of cbox_1, but it always comes back NULL. I'd also be open to alternate solutions to this problem if I'm approaching it completely wrong. Thanks.
After further research, an approach utilizing the rhandsontable package seemed like the best solution. I modeled my code after this example:
Data input via shinyTable in R shiny application
I also utilized several of the options described here:
https://jrowen.github.io/rhandsontable/#introduction
I am trying to make a basic program in R shiny framework so that I can display an interactive data table. The basic function I need to perform but can't is getting the row and column index of any selected/clicked cell. I have done research online and followed the tutorials exactly, but what is shown in the tutorials does not appear to be working. Since I think getting clicks is harder, I have settled with getting the row and column index of whatever cell is selected. Here is what I currently have for the ui.R and server.R files:
library(shiny)
library(shinyTable)
library(DT)
server <- function(input, output, session) {
lastTransToMat = data.table(cbind(c(.5,.5),c(.8,.2)))
output$transtable = DT::renderDataTable(lastTransToMat,options = list(target = 'column+row'))
output$response <-DT::renderDataTable({
rows= as.numeric(input$transtable_rows_selected)
cols = as.numeric(input$transtable_columns_selected)
print(rows)
print(cols)
response = data.table(cbind(c(paste0("rows: ",rows),c(paste0("cols: " ,cols)))))
print(response)
return(response)
})
}
shinyUI(fluidPage(
titlePanel("transition table"),
mainPanel(
DT::dataTableOutput('transtable'),
DT::dataTableOutput('response')
)
))
When I runApp() on this, I am only able to get the index of the row, but not the index of the column. See output below:
numeric(0)
V1
1: rows: 1
2: cols:
There is a similar data.table output in the shiny app itself.
Does anyone know why this is happening?
How can I get both the row and column index of a selection? And what about clicks?
Best,
Paul
EDIT:
As per user5029763's suggestion, I replaced my server.R function with the following:
#ui.R
library(shiny)
library(shinyTable)
library(DT)
shinyUI(fluidPage(
titlePanel("transition table"),
mainPanel(
DT::dataTableOutput('transtable'),
DT::dataTableOutput('response'),
htmlOutput('response2')
)
))
#server.R
server <- function(input, output, session) {
lastTransToMat = data.table(cbind(c(.5,.5),c(.8,.2)))
output$transtable = DT::renderDataTable(lastTransToMat,server = F,options = list(target = 'cell'))
output$response <-DT::renderDataTable({
cell= as.numeric(input$transtable_cell_clicked)
print(cell)
response = data.table(cbind(c(paste0("cell: "),c(paste0(cell)))))
print(response)
return(response)
})
output$response2 <- renderUI({
cells <- input$transtable_cell_clicked
if(length(cells) == 0) return( div('No cell is selected') )
cells <- data.frame(cells)[-3]
response <- paste0(c('Row', 'Column'), ': ', cells, collapse = ' / ')
div(response)
})
}
Output before any click:
Output after click/selection:
Is this the same as the output you get when you runApp() on this?
EDIT: Also just FYI, I tried this on another computer with the most updated version of R and got the same output, so I don't think it has to do with my version/computer.
If what you want is to get the index of clicked cells you could go with:
output$transtable = DT::renderDataTable(
lastTransToMat,
server = F,
selection = list(target = 'cell')
)
Then, input$transtable_cell_clicked will be a list with row/column index and the value within the cell. Just remember that the column index starts at 0.
EDIT: one way to print out
#server.R
output$response2 <- renderUI({
cells <- input$transtable_cell_clicked
if(length(cells) == 0) return( div('No cell is selected') )
cells <- data.frame(cells)[-3]
response <- paste0(c('Row', 'Column'), ': ', cells, collapse = ' / ')
div(response)
})
#ui.R
htmlOutput('response2')
I reproduced an example shiny app written by Yihui Xie (https://yihui.shinyapps.io/DT-rows/). The app uses DT::renderDataTable() which allows a row selection.
Everything works perfectly fine. I was however wondering if it's possible to reset the row selection (i.e. undo the click selection) ? I already tried it with an action button to reset s = input$x3_rows_selected (see script below).
With my current script,s = input$x3_rows_selected does indeed get emptied, I can however not refill it. Also the selected rows are still clicked (shaded)
Does anyone has an idea? Is there an option within DT::renderDataTable() to reset the selection? Or does anyone has an idea for a workaround?
Thank you!
Example form https://yihui.shinyapps.io/DT-rows/) with my modification (action button):
server.R
library(shiny)
library(DT)
shinyServer(function(input, output, session) {
# you must include row names for server-side tables
# to be able to get the row
# indices of the selected rows
mtcars2 = mtcars[, 1:8]
output$x3 = DT::renderDataTable(mtcars2, rownames = TRUE, server = TRUE)
# print the selected indices
selection <- reactive({
if (input$resetSelection)
vector() else input$x3_rows_selected
})
output$x4 = renderPrint({
if (length(selection())) {
cat("These rows were selected:\n\n")
output <- selection()
cat(output, sep = "\n")
}
})
})
ui.R
library(shiny)
shinyUI(
fluidPage(
title = 'Select Table Rows',
h1('A Server-side Table'),
fluidRow(
column(9, DT::dataTableOutput('x3')),
column(3, verbatimTextOutput('x4'),
actionButton('resetSelection',
label = "Click to reset row selection"
) # end of action button
) #end of column
)))
In the current development version of DT (>= 0.1.16), you can use the method selectRows() to clear selections. Please see the section "Manipulate An Existing DataTables Instance" in the documentation.
Here is a possible solution, maybe not the best but it works. It is based on re-create the datatable each time the action button is clicked, so the selected rows are removed.
library(shiny)
library(DT)
runApp(list(
server = function(input, output, session) {
mtcars2 = mtcars[, 1:8]
output$x3 = DT::renderDataTable({
# to create a new datatable each time the reset button is clicked
input$resetSelection
mtcars2
}, rownames = TRUE, server = TRUE
)
# print the selected indices
selection <- reactive ({
input$x3_rows_selected
})
output$x4 = renderPrint({
if (length(selection())) {
cat('These rows were selected:\n\n')
output <- selection()
cat(output, sep = '\n')
}
})
},
ui = shinyUI(fluidPage(
title = 'Select Table Rows',
h1('A Server-side Table'),
fluidRow(
column(9, DT::dataTableOutput('x3')),
column(3, verbatimTextOutput('x4'),
actionButton( 'resetSelection',label = "Click to reset row selection")
) #end of column
)
))
))
I have a shinyTable in a shiny app. It is editable, but because of a submitButton elsewhere in the app the edits are not saved until the button is pressed. If more than one change is made and the button is pressed only the last change is saved.
My question is how can I get it to save all the changes that have been made ?
Perhaps there is a way that I can get at the contents of the whole table in the UI so I can workaround ?
Or would I be better off using shinysky or something else ?
Below is a reproducible example based on an example from the package. You'll see that if you make 2 changes to the upper table and then press the button only the 2nd change gets copied to the lower table.
library(shiny)
library(shinyTable)
server <- function(input, output, session) {
rv <- reactiveValues(cachedTbl = NULL)
output$tbl <- renderHtable({
if (is.null(input$tbl)){
#fill table with 0
tbl <- matrix(0, nrow=3, ncol=3)
rv$cachedTbl <<- tbl
print(tbl)
return(tbl)
} else{
rv$cachedTbl <<- input$tbl
print(input$tbl)
return(input$tbl)
}
})
output$tblNonEdit <- renderTable({
rv$cachedTbl
})
}
ui <- shinyUI(pageWithSidebar(
headerPanel("Simple Shiny Table!"),
sidebarPanel(
helpText(HTML("A simple editable matrix with an update button.
Shows that only most recent change is saved.
<p>Created using shinyTable."))
),
# Show the simple table
mainPanel(
#editable table
htable("tbl"),
#update button
submitButton("apply table edits"),
#to show saved edits
tableOutput("tblNonEdit")
)
))
shinyApp(ui = ui, server = server)
Thanks for your time.
Andy
Following advice from Joe Cheng at RStudio on a related question, it appears that submitButton is not advised and can cause pain.
Switching to actionButton and isolate was relatively straightforward in this simple example and in my application.
Solution below.
library(shiny)
library(shinyTable)
server <- function(input, output, session) {
rv <- reactiveValues(cachedTbl = NULL)
output$tbl <- renderHtable({
if (is.null(input$tbl)){
#fill table with 0
tbl <- matrix(0, nrow=3, ncol=3)
rv$cachedTbl <<- tbl
return(tbl)
} else{
rv$cachedTbl <<- input$tbl
return(input$tbl)
}
})
output$tblNonEdit <- renderTable({
#add dependence on button
input$actionButtonID
#isolate the cached table so it only responds when the button is pressed
isolate({
rv$cachedTbl
})
})
}
ui <- shinyUI(pageWithSidebar(
headerPanel("shinyTable with actionButton to apply changes"),
sidebarPanel(
helpText(HTML("A simple editable matrix with a functioning update button.
Using actionButton not submitButton.
Make changes to the upper table, press the button and they will appear in the lower.
<p>Created using shinyTable."))
),
# Show the simple table
mainPanel(
#editable table
htable("tbl"),
#update button
actionButton("actionButtonID","apply table edits"),
#to show saved edits
tableOutput("tblNonEdit")
)
))
shinyApp(ui = ui, server = server)