How to reset selected rows in Shiny - r

I have a small rshiny app, in which i can select row in datatable and get values from first columns.
but how to quickly get rid of the selected rows and values without clicking on the row again?
also if you know what can be improved in this code, then write, I just started coding in R
# Define UI
ui <- fluidPage(
dataTableOutput('main_information'),
fluidRow(
column(8,verbatimTextOutput('selected_rows', placeholder = TRUE)),
fluidRow(
column(4,actionButton("reset", "RESET"))
)
)
)
# Define server function
server <- function(input, output,session) {
getScoreTable<-reactive({
db <- dbConnect(SQLite(), "path")
data <- dbGetQuery(
conn = db,
statement =
'...'
)
})
output$main_information <- renderDataTable(
getScoreTable(),
options = list(
pageLength = 5,
lengthMenu = list(c(5,10, 25, 50, 100),
c('5', '10', '25','50', '100'))
)
)
s<-reactiveValues(data= NULL)
output$selected_rows = renderPrint({
s = input$main_information_rows_selected
if (length(s)) {
cat('These values were selected:\n\n')
cat(getScoreTable()[s,1], sep = '\n')
}else{
cat('No value has been selected')
}
})
}
# Create Shiny object
shinyApp(ui = ui, server = server)

You can use a custom action button:
library(DT)
js <- "
function ( e, dt, node, config ) {
dt.rows().deselect();
}
"
datatable(
iris,
extensions = c("Buttons", "Select"),
selection = "none",
options = list(
"dom" = "Bfrtip",
"select" = TRUE,
"buttons" = list(
list(
"extend" = "collection",
"text" = "DESELECT",
"action" = JS(js)
)
)
)
)
This example works fine. If you have an issue in Shiny, please provide a minimal reproducible code, not using SQL.

Related

Save edited and reactive Shiny table in R

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)

Make an active reset sort or replace datatable button in datatable in shiny

I am trying to place a button inside the datatable where if the user wants to reset the sorted column they can hit the button and table gets reset or changed to it's original order. At the moment, when I press the button, it is not triggering any event on click. The event should replace the data in the server part.
I am currently following these posts:
shiny DT datatable - reset filters
https://github.com/rstudio/DT/issues/76
Reset a DT table to the original sort order
However, in the last two posts above, even though they get the job done, the button is not part of the datatable.
Here is my reprex:
library(DT)
library(shiny)
library(shinyjs)
# function placed in the global.R
clearSorting <- function(proxy) {
shinyjs::runjs(paste0("$('#' + document.getElementById('", proxy$id,"').getElementsByTagName('table')[0].id).dataTable().fnSort([]);"))
}
# ui.R
ui <- fluidPage(
DT::DTOutput(outputId = "table"),
shinyjs::useShinyjs()
)
# servcer.R
server <- function(input, output) {
output$table <- renderDT({
DT::datatable(data = iris,
filter = 'top',
extensions = c('Buttons'),
options = list(scrollY = 600,
scrollX = TRUE,
autoWidth = TRUE,
dom = '<"float-left"l><"float-right"f>rt<"row"<"col-sm-4"B><"col-sm-4"i><"col-sm-4"p>>',
buttons = list(
list(
extend = '',
text = 'Reset Table',
action = JS("function() {document.getElementById('reset_sort').click();}")
)
),
scrollCollapse= TRUE,
lengthChange = TRUE,
widthChange= TRUE))
})
observeEvent(input$reset_sort, {
data <- iris
clearSorting(proxy = DT::dataTableProxy(outputId = "table"))
DT::replaceData(proxy = DT::dataTableProxy(outputId = "table"),
data = data,
rownames = FALSE)
})
}
shinyApp(ui = ui, server = server)
Here is a way:
library(DT)
js <- c(
"function(e, dt, node, config){",
" dt.iterator('table', function(s){",
" s.aaSorting.length = 0;",
" s.aiDisplay.sort(function(a,b){",
" return a-b;",
" });",
" s.aiDisplayMaster.sort(function(a,b){",
" return a-b;",
" });",
" }).draw();",
"}"
)
datatable(
iris,
extensions = "Buttons",
options = list(
dom = "Bfrtip",
buttons = list(
list(
extend = "collection",
text = "Reset columns order",
action = JS(js)
)
)
)
)
To use it in Shiny, you may need to set server = FALSE in renderDT:
output$table <- renderDT({
......
}, server = FALSE)

Implementing Feedback in R / Shiny with DT DataTables rows per select input choice not working / crashing

I am trying to build a feedback system. Here is a simplified example what I am trying to build. I have a DT:datatable that is rendered with a feedback column, based on a selected input choice.
The feedback is submitted through the observeEvent on a submit button. All the UI and server components are mostly as I want.
library(shiny)
library(shinydashboard)
ui <- ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
fluidPage(
fluidRow(
uiOutput('rec_ui')
))
)
)
server <- function(input, output, session) {
mtcarsData <- reactive({
req(input$cyl)
mtcars %>%
filter(cyl == input$cyl) %>%
select(am, wt, hp, mpg)
})
output$rec_ui <- renderUI({
mtcarsData()
mainPanel(
actionButton(
'feedbackButton', 'Submit Feedback', class = 'btn-primary'
),
dataTableOutput(('rec')),
width = 12
)
})
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
observeEvent(input$feedbackButton, {
mtcars <- mtcarsData()
feedbackInput <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcars), function(row_id)
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcars$mpg[row_id],
recommendation_feedback = feedbackInput[row_id],
feedback_timestamp = as.character(Sys.time())
)
)
)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- DT::renderDataTable({
df <- mtcarsData()
feedbackCol <- lapply(1:nrow(df), function(recnum)
as.character(
radioButtons(
paste0('rec', recnum), '',
choices = c('neutral' = 'Neutral', 'good' = 'Good', 'bad' = 'Bad'),
inline = TRUE
)
)
)
feedbackCol <- tibble(Feedback = feedbackCol)
df <- bind_cols(
df,
feedbackCol
)
df %>%
DT::datatable(
extensions = 'FixedColumns',
rownames = FALSE,
escape = FALSE,
class="compact cell-border",
options = list(
pageLength = 10,
lengthChange = FALSE,
scrollX = TRUE,
searching = FALSE,
dom = 't',
ordering = TRUE,
fixedColumns = list(leftColumns = 2),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); } '
),
autoWidth = TRUE,
columnDefs = list(
list(width = '250px', targets = -1)
)
)
)
})
}
shinyApp(ui = ui, server = server)
However, upon submission, one of two things happens:
App crashes with the following error in write.table. But, the root causes is that this line of code is returning a list of NULL values instead of my feedback inputs.
Warning: Error in write.table: unimplemented type 'list' in 'EncodeElement'
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
When the app does not crash, and Feedback gets submitted, but the new inputs don't take effect. Only the first ever submission is repeated written to the CSV.
Any idea where I am going wrong with this app?
Additional Info: It is my hunch that the crash happens when I get from a selection from 'fewer rows' DT to more rows, and not the other way. For example, if I select 8 CYL first, which has more cars, and then 4, the app does not crash on submit. But the reverse, it does. BTW - in either case, my feedback does not get updated.
To avoid the app from crashing write the line
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
just before write.table()
Please note that lapply returns a list, hence your first issue.
Next, recycling input IDs in radio buttons is also an issue. By defining unique IDs, you can make it work. Lastly, to ensure that the radio buttons work all the time, it is best to define new IDs. If the IDs are fixed for a given cyl value, it will only work the first time. Subsequent selection of that cyl will display the initial selection, which can be updated via updateradioButtons, but that will not be reactive. Try this and modify display table to your needs.
library(DT)
library(data.table)
library(shiny)
#library(shinyjs)
library(shinydashboard)
options(device.ask.default = FALSE)
ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
#useShinyjs(),
fluidPage(
fluidRow(
actionButton('feedbackButton', 'Submit Feedback', class = 'btn-primary'),
DTOutput('rec'),
verbatimTextOutput("sel")
))
)
)
server <- function(input, output, session) {
cntr <- reactiveVal(0)
rv <- reactiveValues()
mtcarsData <- reactive({
mtcar <- mtcars %>% filter(cyl == input$cyl) %>%
select(cyl, am, wt, hp, mpg)
})
observe({
req(input$cyl,mtcarsData())
mtcar <- mtcarsData()
id <- cntr()
m = data.table(
rowid = sapply(1:nrow(mtcar), function(i){paste0('rec',input$cyl,i,id)}),
Neutral = 'Neutral',
Good = 'Good',
Bad = 'Bad',
mtcar
) %>%
mutate(Neutral = sprintf('<input type="radio" name="%s" value="%s" checked="checked"/>', rowid, Neutral),
Good = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Good),
Bad = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Bad)
)
rv$df <- m
print(id)
})
observeEvent(input$cyl, {
cntr(cntr()+1)
#print(cntr())
},ignoreInit = TRUE)
feedbackInputData <- reactive({
dfa <- req(rv$df)
list_values <- list()
for (i in unique(dfa$rowid)) {
list_values[[i]] <- input[[i]]
}
list_values
})
observeEvent(input$feedbackButton, {
req(input$cyl)
mtcar <- rv$df ## this could be mtcarsData(), if picking columns not in rv$df but only in mtcarsData()
dt <- rv$df
dt$Feedback <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcar), function(row_id){
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcar$mpg[row_id],
recommendation_feedback = dt$Feedback[row_id],
feedback_timestamp = as.character(Sys.time())
)
})
)
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- renderDT(
datatable(
rv$df,
selection = "none",
escape = FALSE,
options = list(
columnDefs = list(list(visible = FALSE, targets = c(0,4))), ## not displaying rowid and cyl
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-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"
),
rownames = F
),
server = FALSE
)
### verify if the radio button values are being returned
output$sel = renderPrint({
req(feedbackInputData())
feedbackInputData()
})
}
shinyApp(ui = ui, server = server)

Add DT extensions using Shiny and selectinput

Trying to add in the following information to a datatable in Shiny, and getting errors when using the selectinput:
Error: incorrect number of dimensions
library(DT)
library(readr)
library(jsonlite)
library(data.table)
gumdad <- fromJSON("data/boxes.json")
# Define UI for app ----
ui <- fluidPage(
# App title ----
titlePanel("Box Scores"),
#FILTERS
selectInput("season",
"Season:",
c("All",
unique(as.character(gumdad$season)))),
# Main panel for displaying outputs ----
mainPanel(
# Output: Table----
DT::dataTableOutput('tableone')
)
)
# Define server logic ----
server <- function(input, output) {
output$tableone = renderDataTable({
data <- datatable(gumdad, extensions = 'Buttons', rownames = FALSE, escape = FALSE, selection = 'none',
colnames = c('Season', 'Date', 'Opponent', 'Result', 'UNC', 'Opp', 'OT', 'Location', 'Type','Box Score'),
options = list(buttons = c('copy', 'csv'), paging = FALSE, dom = 'Bfrtip')
)
if (input$season != "All") {
data <- data[data$season == input$season,]
}
return(data)
})
gumdad$box <- sapply(gumdad$box, function(x)
toString(tags$a(href=paste0("https://boxscorexxx.com/", x), "Box Score")))
}
shinyApp(ui = ui, server = server)
How can I used the selectInput while customizing the datatable with the correct dimensions?
In your code, data is not a dataframe, this is a datatable. It's not possible to subset it like this: data[data$season == input$season,]. Subset gumdad instead:
output$tableone = renderDT({
data <- gumdad
if (input$season != "All") {
data <- data[data$season == input$season,]
}
datatable(data, extensions = 'Buttons', rownames = FALSE, escape = FALSE, selection = 'none',
colnames = c('Season', 'Date', 'Opponent', 'Result', 'UNC', 'Opp', 'OT', 'Location', 'Type','Box Score'),
options = list(buttons = c('copy', 'csv'), paging = FALSE, dom = 'Bfrtip')
)
})
Also note that you should use renderDT instead of renderDatatable (or use DT::renderDatatable, which is the same as renderDT).

Shiny Performance Improvement

I am looking for suggestions in improving performance of my shiny app. This shiny app saves data in CSV format when user selects a particular row by clicking on check box. I don't want it to save data every time when user clicks on check box. Hence I created action button so that user clicks on button only when he is done with the checkbox selection of multiple rows.
library(shiny)
library(DT)
mydata = mtcars
mydata$id = 1:nrow(mydata)
runApp(
list(ui = pageWithSidebar(
headerPanel('Examples of Table'),
sidebarPanel(
textInput("collection_txt",label="RowIndex")
,br(),
actionButton("run", "Write Data"),
br(),
p("Writeback with every user input. CSV file gets saved on your working directory!")),
mainPanel(
DT::dataTableOutput("mytable")
))
, server = function(input, output, session) {
shinyInput <- function(FUN,id,num,...) {
inputs <- character(num)
for (i in seq_len(num)) {
inputs[i] <- as.character(FUN(paste0(id,i),label=NULL,...))
}
inputs
}
rowSelect <- reactive({
rows=names(input)[grepl(pattern = "srows_",names(input))]
paste(unlist(lapply(rows,function(i){
if(input[[i]]==T){
return(substr(i,gregexpr(pattern = "_",i)[[1]]+1,nchar(i)))
}
})))
})
observe({
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "RowIndex:" )
d = data.frame(n = rowSelect(), stringsAsFactors = F)
if (input$run == 0)
return()
isolate({write.csv(mydata[as.numeric(d$n),], file = "Writeback.csv" , row.names=F)})
})
output$mytable = DT::renderDataTable({
DT::datatable(cbind(Flag=shinyInput(checkboxInput,"srows_",nrow(mydata),value=NULL,width=1),
mydata), extensions = 'Buttons', options = list(orderClasses = TRUE,
pageLength = 5, lengthChange = FALSE, dom = 'Bfrtip',
buttons = c('copy', 'csv', 'excel'),
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}')
),escape=F)
}
)
}), launch.browser = T
)
I want action button to write data in CSV format only when user clicks on action button. Is there any way to improve the code below.
d = data.frame(n = rowSelect(), stringsAsFactors = F)
if (input$run == 0)
return()
isolate({write.csv(mydata[as.numeric(d$n),], file = "Writeback.csv" , row.names=F)})
Why are you not using observeEvent for the actionButton?
observeEvent(input$run, {
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "RowIndex:" )
d = data.frame(n = rowSelect(), stringsAsFactors = F)
write.csv(mydata[as.numeric(d$n),], file = "Writeback.csv" , row.names=F)
})
I think you're looking for the require function req(input$run) or try if(is.null(input$run)==T){return()}

Resources