Shiny: observeEvent stuck on DTOutput - r

In the app below, I can switch back and forth between outputs generated by shiny::plotOutput and shiny::dataTableOutput. But when I select the option "DT", which generates a table using the DT::DTOutput function, the app gets stuck:
I can interact with the table (good)
Clicking "Load" does nothing (not good) even though it worked perfectly when non-DT output was selected before. Clicking "Load" should switch to selected output.
Is this a bug in DT? Is there a workaround?
UI:
library(shiny)
ui <- fluidPage(
uiOutput("ui_select"),
uiOutput("my_ui")
)
Server:
server <- function(input, output) {
output$ui_select = renderUI({
tagList(
selectInput("selectVal", "Select value", choices = c("gg", "dt", "DT")),
actionButton("loadVal", label = "Load")
)
})
observeEvent(input$loadVal, {
val = isolate({ input$selectVal })
output$my_output = switch(
val,
"gg" = renderPlot({ ggplot2::qplot(cyl, drat, data = mtcars) }),
"dt" = renderDataTable({ mtcars[1:3, 1:3] }),
"DT" = DT::renderDT({ mtcars[1:3, 1:3] })
)
output$my_ui = renderUI({
switch(
val,
"gg" = plotOutput("my_output"),
"dt" = dataTableOutput("my_output"),
"DT" = DT::DTOutput("my_output")
)
})
})
}
shinyApp(ui, server)

Its generally not a good idea to render much inside the observe as a memory leak can occur. have a look at the example below with a bigger diamonds dataset from the ggplot2 package.
library(shiny)
library(ggplot2)
data(diamonds)
ui <- fluidPage(
uiOutput("ui_select"),
uiOutput("my_ui")
)
server <- function(input, output) {
output$ui_select = renderUI({
tagList(
selectInput("selectVal", "Select value", choices = c("gg", "dt", "DT")),
actionButton("loadVal", label = "Load")
)
})
observeEvent(input$loadVal, {
val = isolate({ input$selectVal })
output$gg_output = renderPlot({ ggplot2::qplot(cyl, drat, data = mtcars) })
output$dt_output = renderDataTable({ diamonds })
output$DT_output = DT::renderDT({ diamonds })
output$my_ui = renderUI({
switch(
val,
"gg" = plotOutput("gg_output"),
"dt" = dataTableOutput("dt_output"),
"DT" = DT::DTOutput("DT_output")
)
})
})
}
shinyApp(ui, server)
Also I dont think its very efficient to create objects all the time, its best to render them once and simply switch and show what is required.
Proposed solution
library(shiny)
library(shinyjs)
library(ggplot2)
data(diamonds)
outputs <- c("gg_output","dt_output","DT_output")
hideoutputs <- function(output_names){
lapply(output_names, function(output_name){
hide(output_name)
})
}
ui <- fluidPage(
useShinyjs(),
uiOutput("ui_select"),
plotOutput("gg_output"),
dataTableOutput("dt_output"),
DT::DTOutput("DT_output")
)
server <- function(input, output, session) {
hideoutputs(outputs)
v <- reactiveValues(selection = "None")
output$ui_select <- renderUI({
tagList(
selectInput("selectVal", "Select value", choices = c("gg", "dt", "DT")),
actionButton("loadVal", label = "Load")
)
})
output$gg_output <- renderPlot({
qplot(cyl, drat, data = mtcars)
})
output$dt_output <- renderDataTable({
diamonds
})
output$DT_output <- DT::renderDT({
diamonds
})
observeEvent(input$loadVal, {
if(v$selection == input$selectVal){
return()
}
hideoutputs(outputs)
switch(
input$selectVal,
"gg" = show("gg_output"),
"dt" = show("dt_output"),
"DT" = show("DT_output")
)
v$selection <- input$selectVal
})
}
shinyApp(ui, server)

You're essentially defining multiple elements with the same ID. That's invalid HTML, and is bound to result in undefined behaviour. Sometimes defining multiple inputs/outpust with identical IDs seems to work, but it should never be done.
Giving each output its own ID solves this.
server <- function(input, output) {
output$ui_select = renderUI({
tagList(
selectInput("selectVal", "Select value", choices = c("gg", "dt", "DT")),
actionButton("loadVal", label = "Load")
)
})
observeEvent(input$loadVal, {
val = isolate({ input$selectVal })
output$gg_output = renderPlot({ ggplot2::qplot(cyl, drat, data = mtcars) })
output$dt_output = renderDataTable({ mtcars[1:3, 1:3] })
output$DT_output = DT::renderDT({ mtcars[1:3, 1:3] })
output$my_ui = renderUI({
switch(
val,
"gg" = plotOutput("gg_output"),
"dt" = dataTableOutput("dt_output"),
"DT" = DT::DTOutput("DT_output")
)
})
})
}
shinyApp(ui, server)

Related

update table in rshiny (using dttable) and save the new information into a variable

I have a table where the user can change the data, and the updated data will be used for future calculations.
Here is an example of a table, and I want it so that when the table is modified, the necessary information on the main panel will be updated accordingly.
Here is my code:
library(ggplot2)
library(DT)
library(shiny)
ui <- fluidPage(
sidebarLayout(sidebarPanel(
DTOutput("mytable"),
actionButton("update", "Update")
),
mainPanel(
plotOutput("plot"),
verbatimTextOutput("text")
)
)
)
server <- function(input, output, session) {
tab <- reactiveValues(df = {data.frame(
num = 1:5,
x = LETTERS[1:5],
y = c(14,5,8,9,13)
)})
output$mytable <- renderDT({
DT::datatable(tab$df, editable = T, selection = "none")
})
observeEvent(input$update,{
output$plot <- renderPlot({
tab$df %>% ggplot(aes(x,y)) + geom_point()
})
output$text <- renderPrint({
tab$df$x
})
})
}
shinyApp(ui, server)
Try this approach with your server method.
First, add an observeEvent to detect edits/changes to your datatable. When there are, the changes are stored in your tab which is reactive.
Second, if you want an actionbutton to redo the plot and text, then would also make a second reactiveValues rv and observeEvent to store and update them when the button is pressed.
server <- function(input, output, session) {
tab <- reactiveValues(df = {data.frame(
num = 1:5,
x = LETTERS[1:5],
y = c(14,5,8,9,13)
)})
rv <- reactiveValues(
plot = NULL,
text = NULL
)
output$mytable <- renderDT({
DT::datatable(tab$df, editable = T, selection = "none")
})
observeEvent(input$mytable_cell_edit, {
row <- input$mytable_cell_edit$row
clmn <- input$mytable_cell_edit$col
tab$df[row, clmn] <- input$mytable_cell_edit$value
})
observeEvent(input$update,{
rv$text <- tab$df$x
rv$plot <- tab$df %>%
ggplot(aes(x,y)) +
geom_point()
})
output$plot <- renderPlot({
rv$plot
})
output$text <- renderPrint({
rv$text
})
}

Can we check shiny applications using testthat and usethis

is there a way to check the below applications. This is a sample application to display selected rows. But in general is there a way to acheive this. For example the below code is perfect. Suppose I may some errors in this and I need to check all in once. Can we do that? I have also pasted the error code down
Correct
library(shiny)
library(DT)
ui <- basicPage(
mainPanel(DT::dataTableOutput('mytable')),
textOutput("selected")
)
server <- function(input, output,session) {
mydata <- reactive({mtcars})
output$mytable = DT::renderDataTable(
datatable(mydata())
)
selectedRow <- eventReactive(input$mytable_rows_selected,{
row.names(mtcars)[c(input$mytable_rows_selected)]
})
output$selected <- renderText({
selectedRow()
})
}
runApp(list(ui = ui, server = server))
Wrong/Error code
library(shiny)
library(DT)
ui <- basicPage(
mainPanel(DT::dataTableOutput('mytable')),
textOutput("selected")
)
server <- function(input, output,session) {
mydata <- reactive({mtcars})
output$mytable = DT::renderDataTable(
datatable(mydata())
)
selectedRow <- eventReactive(input$mytable_rows_selected,{
row.names(mtcars)[c(input$[mytable_rows_selected])]
})
output$selected <- renderText({
selectedRow
})
}
runApp(list(ui = ui, server = server))
I use the package shinytest to test my shiny apps. shinytest uses phantomJS to manipulate the app (i.e. simulate button presses etc.)
An entry in testthat/test-shinyapp.R looks something like:
test_that("Shiny template works", {
app <- shinytest::ShinyDriver$new("Path_To_ShinyApp/"))
# plot changes
# first click makes plot
testthat::expect_false(length(grepl("^(data:image/png;base64)",
app$getAllValues()$output$plot1$src)) > 0)
app$setInputs(apply = "click")
testthat::expect_true(length(grepl("^(data:image/png;base64)",
app$getAllValues()$output$plot1$src)) > 0)
testthat::expect_true(grepl("^(data:image/png;base64)",
app$getAllValues()$output$plot1$src))
# are subsequent changes applied?
testthat::expect_identical(app$getAllValues()$input$xVar, "mpg")
testthat::expect_true(
grepl(" mpg cyl", app$getAllValues()$output$summary1))
app$setInputs(xVar = "drat")
app$setInputs(apply = "click")
testthat::expect_true(
grepl(" drat cyl", app$getAllValues()$output$summary1))
# # test for reactive
# shinytest::expectUpdate(app, xVar = "wt", output = "plot1" )
# shinytest::expectUpdate(app, yVar = "drat", output = "plot1" )
# shinytest::expectUpdate(app, xVar = "cyl", output = "summary1" )
# shinytest::expectUpdate(app, yVar = "mpg", output = "summary1" )
# cleanup
app$stop()
unlink(paste0(ws2us(testDir),"_ShinyApp"), recursive = TRUE)
})

Make a Shiny module reactive when creating the module via a function

I'm trying to generalise Shiny modules so different functions can be passed through, but the expected behaviour of reactivity is not working - could someone point me in the right direction? I have a reprex below that illustrates my problem.
I expect that the dynamic selection of view_id to change values in the renderShiny() function. It works on app load but changing selections do not flow through.
Is it something to do with the environment the module function is created within?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
The problem was the renderShiny function needs to wrap another function that creates the actual output, so its actually two separate capabilities confused by me as one: renderShiny should take the output of another function that actually creates the thing to render. The below then works:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
I think you want something like this.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Data Source:
https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv

R, Shiny Setting DataTable ID

I have created a large number of data tables using mapply, however, I need to access the data tables in a following step. R assigns random IDs to these tables if the user does not specify the IDs. Here is an example of what I would like to do:
library(shiny)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2), elementId = "DT_Test")
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)
If I look at the html, the elementID did not change to what I wanted, in fact, R gives the warning:
Warning in origRenderFunc() :
Ignoring explicitly provided widget ID "DT_Test"; Shiny doesn't use them
Even after the call, still not sure what you are trying to do.
But if you have a list of datatables and you want to access them, it works rather well like this:
library(shiny)
library(purrr)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
h2("elementId values"),
verbatimTextOutput("elementId_values"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
table <- DT::datatable(head(mtcars, 2), elementId = "DT_Test")
table2 <- DT::datatable(tail(mtcars, 1), elementId = "DT_Test2")
list_of_data_tables <- list(table, table2)
element_ids <- purrr::map(list_of_data_tables, "elementId")
output$elementId_values <- renderPrint({
element_ids
})
output$dt <- DT::renderDataTable({
list_of_data_tables[[which(element_ids == "DT_Test2")]]
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)

How to store the data from reactive SQL query for further filtering (DT) and displaying in ggplot

How i can store the data which i received from database as an object, that further (If needed) is going to be filtered with datatable (DT) and displayed using ggplot?
Here is code:
library(shiny)
library(ROracle)
library(DT)
ui <- shinyUI(navbarPage("Test",
tabPanel("Test",
sidebarLayout(
sidebarPanel(
textInput("drv", "Database Driver", value="Oracle"),
textInput("user", "User ID"),
passwordInput("passwd", "Password"),
actionButton("connectDB", "Connect to DB")) ,
mainPanel(
textOutput("test"),
wellPanel(
uiOutput("tabnames_ui"),
uiOutput("columnnames_ui"),
actionButton("button1", "Select")),
plotOutput("plot"),
dataTableOutput("tabelle")
))
)
))
server <- shinyServer(function(input, output, session) {
con=reactiveValues(cc=NULL)
observeEvent(input$connectDB,{
if(input$drv != "Oracle"){
con$cc="Only 'Oracle' implemented currently"
}else{
drv <- dbDriver("Oracle")
con$cc<- dbConnect(drv,"xxx/x",username=input$user,password=input$passwd)
}
})
observe({
if(!is.null(con$cc)& is(con$cc,"OraConnection")){ # check if connected
output$test <- renderText({
"connection success"
})
tableList <-reactive({
dbListTables(con$cc,schema="K")
})
columnList <-reactive({
dbListFields(con$cc, name=input$tabnames, schema = "K")
})
output$tabnames_ui=renderUI({selectInput("tabnames",label = "Tabelle:", choices = tableList(), selected="xy")})
output$columnnames_ui=renderUI({
selectInput("columnname", label = "Spalten:", choices = columnList(), multiple=TRUE, selected=
if(input$tabnames== "xy"){
c("DATI_CREATE","BLOCKNR","ORDNR")}
else{NULL})
})
d <- eventReactive(input$button1, { input$tabnames })
sqlOutput <- reactive({
sqlInput <- paste("select",paste(input$columnname, collapse = ","), "from K.",d(), "where dati_create between to_date('02.01.2016','dd.mm.yyyy') and to_date('07.01.2016','dd.mm.yyyy')")
rs <- dbGetQuery(con$cc, sqlInput)
})
output$tabelle <- DT::renderDataTable({
input$button1
datatable(isolate(sqlOutput()), rownames=FALSE, filter="top", options=list(pageLength=10))})
output$plot <- renderPlot({
filtered_data <- input$tabelle_rows_all
data_filt <- sqlOutput()[filtered_data,] # this row is responsible for empty plot. How i can store the sqlOutput() object so i can further manipulate it?
ggplot(data_filt, aes(x=ORDNR,y=BLOCKNR)) + geom_line()
})
}else if (!is.null(con$cc) ){
output$test <- renderText({
con$cc
})
}
})
session$onSessionEnded(function() {
observe({
if(!is.null(con$cc)& is(con$cc,"OraConnection")){# check if connected
print(paste0("disconnect ",dbDisconnect(con$cc)))}
})
})
})
shinyApp(ui=ui, server=server)
Thanks for any help!
[SOLVED]
Problem was with rownames=FALSE
so for the datatable, it should look like this:
output$tabelle <- DT::renderDataTable({
input$button1
datatable(isolate(sqlOutput()), rownames=TRUE, filter="top", options=list(pageLength=10))})
Cheers

Resources