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()}
Related
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.
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)))
}
})
}
)
We have a situation where in we would want to take inputs from user in a datatable by creating dynamic drop-downs and would want to save the data locally. We have tried multiple combinations however these are not getting working in our scenario for e.g.: reset, refresh (can't use it as we have a login page). Below is the reproducible e.g.:
The problem with the code is that it takes old value not the updated one.
library(shiny)
library(DT)
ui <- fluidPage(
title = 'Selectinput column in a table',
h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
numericInput('num', "enter a number", value = 5, min = 1, max = 10, step = 1),
DT::dataTableOutput('foo'),
verbatimTextOutput('sel'),
actionButton(
"saveBtn",
"Submit Request",
style = "color: #fff; background-color: #282364;
border-color: #2e6da4",
class = "btn btn-primary"
)
)
server <- function(input, output, session) {
data <- reactive({
df <- head(iris, input$num)
for (i in 1:nrow(df)) {
df$species_selector[i] <- as.character(selectInput(paste0("sel", i),
"",
choices = unique(iris$Species),
width = "100px"))
}
df
})
output$foo = DT::renderDataTable(
data(), escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]]))
})
observeEvent(input$saveBtn, {
Test_Data <- sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]])
Test_Data <- as.data.frame(Test_Data)
print(Test_Data)})
}
shinyApp(ui, server)
One solution could be creating dynamic ID's, however this can create complexity in our model as we have multiple drop-downs :
https://community.rstudio.com/t/update-dt-table-dropdowns-with-reactive-data-in-shiny/96100/2
You can execute JavaScript to periodically update selected values of dropdown menus:
e.g. JavaScript e.g. invoked by function shinyjs::runjs
document.getElementById("sel1").value = "versicolor"
In the code below, I am saving user selected rows into CSV file. It is working perfectly fine. Problem arises if I add filter='top', selection = 'multiple' in datatable() function then it stops returning row value (row position). The user-defined function rowSelect() returns row value.
See the complete code below -
library(shiny)
library(RODBC)
library(DT)
library(shinyalert)
mydata = mtcars
mydata$id = 1:nrow(mydata)
d = data.frame(stringsAsFactors = F)
runApp(
list(ui = pageWithSidebar(
headerPanel('Examples of Table'),
sidebarPanel(
textInput("collection_txt",label="RowIndex")
,br(),useShinyalert(),
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:" )
})
df_subset <- reactive({
d = data.frame(n = rowSelect(), stringsAsFactors = F)
return(d)
})
observeEvent(input$run, {write.csv(mydata[as.numeric(df_subset()$n),], file = "Writeback.csv" , row.names=F)
shinyalert(title = "Task Completed!", type = "success")})
output$mytable = DT::renderDataTable({
DT::datatable(cbind(Flag=paste0('<input type="checkbox" id="srows_', mydata$id, '" value="', mydata$id, '">',""),
mydata), extensions = 'Buttons', options = list(orderClasses = TRUE,
pageLength = 5, lengthChange = FALSE, dom = 'Bfrtip',
buttons = c('copy', 'csv', 'excel'),
drawCallback= JS(
'function(settings) {
Shiny.unbindAll(this.api().table().node());
Shiny.bindAll(this.api().table().node());}')
),escape=F)
}
)
}), launch.browser = T
)
Any help would be highly appreciated!
My shiny app reads in an external csv file, updates it using user inputs in the app and updates the external csv file with these. This works locally however with my app on the shiny server it does not update, any idea why this is? Thanks.
I've added some simplistic code below but not really sure if it makes sense, the function num is meant to take the inputs, search for them in data frame and update and then output updated data frame and another data frame called "numbers" with timestamp.
The stuff with the modals at the bottom is that the num() function only happens when button is pressed, this creates modals with shows user what they have inputted and if they press 'proceed' the csv is updated if not they can go back and change details.
ui <- fluidPage(
useShinyjs(),
selectInput("1", "Pick a number", "1-2","2-3"),
selectInput("2", "Pick another number", "4-5", "5-6"),
actionButton("go", "Go")
)
server <- function(input, output, session){
df <- read.csv(df.csv, header = TRUE, sep = ",")
num <- function(df, num1, num2){
date.stamp <- format(Sys.time(), "%Y-%m-%d-%H-%M-%S")
save.file <- paste0("numbers", date.stamp, ".csv")
write.csv(df, file = save.file, row.names = FALSE)
write.csv(df, file = "df.csv", row.names = FALSE)
return(df)
}
observe({
shinyjs::toggleState("go", condition = isTruthy(input$1)
&& isTruthy(input$2))
})
react <- reactiveValues()
observeEvent(input$go, {
react$colm1 <- input$1
react$colm2 <- input$2
react$df1 <- data.frame("Numbers" = c("Num1", "Num2"),
"Values" = c(react$colm1, react$colm2))
react$review <- datatable(rownames = FALSE,
selection = "none",
options = list(dom = "t",
pageLength = nrow(rv$df.check),
autoWidth = FALSE,
columnDefs = list(list(width =
"20%",
targets = c(1)),
list(className = "dt-center",
targets = c(1)))),
react$df.check)
showModal(
modalDialog(
footer = tagList(modalButton("Change numbers"),
actionButton("click", label = "Proceed")
),
strong(em("Inputs Entered")),
p("Please double check numbers"),
DT::renderDataTable({
react$review
})
))
observeEvent(input$click, {
num(df, input$1, input$2)
shinyjs::reset("1");shinyjs::reset("s2")
removeModal()
})
})}
shinyApp(ui = ui, server = server) #calls shiny app