I am using a future promise to call my data more efficiently. However, I'm finding that my filters (called through selecticizeGroupServer) do not work with the future promise.
See attached for a minimal reproducible example. The filters work as expected when I remove the "future_promise" function from the data reactive expression. However, when I use "future_promise," the filter module fails.
Could you please help me figure out what I'm doing wrong?
library(shiny)
library(future)
library(promises)
library(shinyWidgets)
plan(multisession)
ui <- fluidPage(
titlePanel("Example App"),
sidebarLayout(
sidebarPanel(),
mainPanel(
selectizeGroupUI(
id = "filters",
inline = FALSE,
params = list(
`mpg` = list(inputId = "mpg", title = "mpg", placeholder = "All"),
`cyl` = list(inputId = "cyl", title = "cyl", placeholder = "All"),
`disp` = list(inputId = "disp", title = "disp", placeholder = "All")
)
)
)
)
)
server <- function(input, output) {
data <- reactive({
future_promise({
mtcars
})
})
filter_mod <- reactive({})
observe({
filter_mod <<- callModule(
module = selectizeGroupServer,
id = "filters",
inline = FALSE,
data = data,
vars = c("mpg", "cyl", "disp")
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
We can use a initialized reactiveVal instead of reactive to avoid passing a promise to selectizeGroupServer.
Please check the following:
library(shiny)
library(future)
library(promises)
library(shinyWidgets)
plan(multisession)
ui <- fluidPage(
titlePanel("Example App"),
sidebarLayout(
sidebarPanel("The choices will appear after 5 seconds:"),
mainPanel(
selectizeGroupUI(
id = "filters",
inline = FALSE,
params = list(
`mpg` = list(inputId = "mpg", title = "mpg", placeholder = "All"),
`cyl` = list(inputId = "cyl", title = "cyl", placeholder = "All"),
`disp` = list(inputId = "disp", title = "disp", placeholder = "All")
)
)
)
)
)
server <- function(input, output, session) {
data <- reactiveVal(NULL)
future_promise({
Sys.sleep(5) # long running task
mtcars
}) %...>% data() # assign to reactiveVal "data" once the future_promise is resolved
filter_mod <- callModule(
module = selectizeGroupServer,
id = "filters",
inline = FALSE,
data = data,
vars = c("mpg", "cyl", "disp")
)
}
shinyApp(ui = ui, server = server)
Related
I would like to update the options for the select input when someone chooses to filter for the cylinders. However, whenever I update the options in the select input by filtering for cylinders, the reactive fires two times. How can I avoid that?
library(tidyverse)
library(shiny)
library(DT)
data("mtcars")
mtcars <- mtcars %>% tibble::rownames_to_column(var = "cars")
ui <- fluidPage(
shiny::selectInput(
inputId = "cars",
label = "Cars",
choices = mtcars$cars,
selected = mtcars$cars,
multiple = TRUE
),
shiny::checkboxGroupInput(
inputId = "cyl",
label = "Cyl",
choices = unique(mtcars$cyl),
selected = unique(mtcars$cyl)
),
DT::dataTableOutput(outputId = "table")
)
server <- function(session, input, output) {
temp <- shiny::reactive({
temp <- mtcars %>%
dplyr::filter(cars %in% input$cars, cyl %in% input$cyl)
print("Reactive fires twice")
return(temp)
})
shiny::observeEvent(input$cyl, {
shiny::updateSelectInput(
session,
inputId = "cars",
choices = temp()$cars,
selected = temp()$cars
)
})
output$table <- DT::renderDataTable({
temp()
})
}
This solution uses reactive values and I believe avoids the double trigger as it separates trigger events.
library(tidyverse)
library(shiny)
library(DT)
data("mtcars")
mtcars <- mtcars %>% rownames_to_column(var = "cars")
ui <- fluidPage(
selectInput(
inputId = "cars",
label = "Cars",
choices = mtcars$cars,
selected = mtcars$cars,
multiple = TRUE
),
checkboxGroupInput(
inputId = "cyl",
label = "Cyl",
choices = unique(mtcars$cyl),
selected = unique(mtcars$cyl)
),
dataTableOutput(outputId = "table")
)
server <- function(session, input, output) {
r <- reactiveValues(
temp = mtcars
)
observeEvent(input$cyl, ignoreNULL = FALSE, {
r$temp <- mtcars %>%
filter(cyl %in% input$cyl)
updateSelectInput(session,"cars",choices = r$temp$cars, selected = r$temp$cars)
print(input$cyl)
})
observeEvent(input$cars, ignoreNULL = FALSE, {
r$temp <- mtcars %>%
filter(cars %in% input$cars)
})
output$table <- DT::renderDataTable({
r$temp
})
}
shinyApp(ui,server)
Here is a solution using a reactive value instead of a reactive conductor, a priority level for the observers, and freezeReactiveValue:
library(shiny)
library(DT)
data("mtcars")
mtcars <- mtcars %>% tibble::rownames_to_column(var = "cars")
ui <- fluidPage(
selectInput(
inputId = "cars",
label = "Cars",
choices = mtcars[["cars"]],
selected = mtcars[["cars"]],
multiple = TRUE
),
checkboxGroupInput(
inputId = "cyl",
label = "Cyl",
choices = unique(mtcars[["cyl"]]),
selected = unique(mtcars[["cyl"]])
),
DTOutput(outputId = "table")
)
server <- function(session, input, output) {
Temp <- reactiveVal()
observeEvent(list(input[["cars"]], input[["cyl"]]), {
temp <- mtcars %>%
dplyr::filter(cars %in% input[["cars"]], cyl %in% input[["cyl"]])
Temp(temp)
}, priority = 2) # higher priority than the other observer
observeEvent(input[["cyl"]], {
freezeReactiveValue(input, "cars") # prevents the above observer to trigger
updateSelectInput(
session,
inputId = "cars",
choices = mtcars[["cars"]], # don't use Temp() here, otherwise you can't select the removed items
selected = Temp()[["cars"]]
)
}, priority = 1)
output[["table"]] <- renderDT({
Temp()
})
}
shinyApp(ui, server)
i have some a bunch of user inputs built using selectizeGroupUI from shinywidgets package .When i try to bookmark them i get no saved values.it seems hard to bookmark selectizeGroupUI.Does any one can help me?.
library(shiny)
library(shinyWidgets)
data("mpg", package = "ggplot2")
ui <- function(request) {
fluidPage(
fluidRow(
column(
width = 10,
offset = 1,
bookmarkButton(),
tags$h3("Filter data with selectize group"),
panel(
selectizeGroupUI(
id = "my-filters",
params = list(
manufacturer = list(inputId = "manufacturer", title = "Manufacturer:"),
model = list(inputId = "model", title = "Model:"),
trans = list(inputId = "trans", title = "Trans:"),
class = list(inputId = "class", title = "Class:")
)
), status = "primary"),
DT::dataTableOutput(outputId = "table"))))
}
server <- function(input, output, session) {
vals <- reactiveValues(sum = NULL)
res_mod <- callModule(
module = selectizeGroupServer,
id = "my-filters",
data = mpg,
vars = c("manufacturer", "model", "trans", "class"))
output$table <- DT::renderDataTable(res_mod())
# Bookmarking code --------------------------
onBookmark(function(state) {
state$values$filtered <- res_mod()
})
onRestore(function(state) {
vals$sum <- state$values$filtered
})
}
shinyApp(ui, server, enableBookmarking = "server")
I'm building a shinyApp on mtcars data. I got 2 actionButtons (Go & Clear).
The Go button is for displaying the output on mainPanel whereas the Clear button is for clearing that output.
My Clear button isn't working due to some unforeseen reason. Can somebody please have a look at my codes. I shall be extremely grateful.
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
DT::dataTableOutput('mytable') )))
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
# thedata <- eventReactive(input$reset,{
# data_table<-NULL
# })
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)
insertUI() and removeUI() is what you might be looking for.
Removing the element is easier with removeUI():
observeEvent(input$reset, {
removeUI("#mytable")
})
To avoid that you dont delete it permanently you could use insertUI():
observeEvent(input$go, {
insertUI("#placeholder", "afterEnd", ui = DT::dataTableOutput('mytable'))
})
In order to place the element correctly you can use a placeholder in the mainPanel():
mainPanel(
tags$div(id = "placeholder")
)
Then you could remove the dependency of thedata() from the input button, since you use the insertUI() now. (You should swith to insertUI(), because otherwise you cant re-insert the table once its deleted without it,...)
thedata <- reactive({
...
})
Full example would read:
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
tags$div(id = "placeholder")
)
)
)
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- reactive({
input$go
isolate({
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
return(data_table)
})
})
observeEvent(input$reset, {
removeUI("#mytable")
})
observeEvent(input$go, {
insertUI("#placeholder", "afterEnd", ui = DT::dataTableOutput('mytable'))
})
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)
)
Why not inject some javascript? This way, your code is kept virtually unchanged.
Create a js file in your shiny folder with the following code (rmDt.js in this example):
$("#reset").click(function() {
$(".display.dataTable.no-footer").DataTable().destroy();
$(".display.dataTable.no-footer").DataTable().clear().draw();
$(".display.no-footer").DataTable().destroy();
$(".display.no-footer").DataTable().clear().draw();
});
Save this file and then inject it in your shiny R script:
library(shiny)
library(DT)
library(dplyr)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear"),
includeScript(path ="rmDt.js") # inject javascript
),
mainPanel(
DT::dataTableOutput('mytable') ))
)
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server, options = list(launch.browser = T))
I'm building a shinyApp on mtcars data. I got 2 actionButtons (Go & Clear).
The Go button is for displaying the output on mainPanel whereas the Clear button is for clearing that output.
My Clear button isn't working due to some unforeseen reason. Can somebody please have a look at my codes. I shall be extremely grateful.
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
DT::dataTableOutput('mytable') )))
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
# thedata <- eventReactive(input$reset,{
# data_table<-NULL
# })
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)
I didn't analyze your script completly, but i can see that it doesn't call the second button at all (Clear). You made an eventReactive() using input$go for the first button to make the plot, but you need to call input$reset too if you want to make it work.
I tried to make a web application with R::shiny but I met a problem with a piece of code. Indeed, I would like to upload a csv file and display a correlogram.
I tried to set up the correlogram with the actionbutton() followed by the updateSelectizeInput()
However an error has been occured :
Error: Unsupported index type: NULL
Anybody have a solution ? thanks
NB - I don't want to use the fileInput widget to upload the csv file ! Only by the actionbutton !
library(shiny)
library(readr)
library(corrplot)
library(DT)
# File used for the example
data(iris)
write.csv(x = iris, file = "iris.csv")
#UI
ui <- shinyUI(
fluidPage(
navbarPage(
id = "navbar",
tabPanel(
title = "UPLOAD",
br(),
actionButton(inputId = "file", label = "ADD A FILE")
)
)
)
)
#SERVER
server <- function(input, output, session) {
path <- reactiveValues(pth = NULL)
file.choose2 <- function(...) {
pathname <- NULL;
tryCatch({
pathname <- file.choose();
}, error = function(ex) {
})
pathname;
}
observeEvent(input$file,{
path$pth <- file.choose2()
})
observeEvent(input$file, {
newvalue <- "B"
updateNavbarPage(session, "navbar", newvalue)
})
data <- reactive({
df <- readr::read_csv(file = path$pth)
return(df)
})
observeEvent(input$file, {
appendTab(
inputId = "navbar",
tabPanel(
value = "B",
title = "Corr",
sidebarLayout(
sidebarPanel(
selectizeInput(
inputId = "select04",
label = "Select features",
choices = NULL,
multiple = TRUE)
),
mainPanel(
plotOutput(
outputId = "corrplot01", height = "650px")
)
)
)
)
}, once = TRUE)
# I suppose there is a problem with this line
observeEvent(input$select04, {
col <- names(data())
col.num <- which(sapply(data(), class) == "numeric")
col <- col[col.num]
updateSelectizeInput(session = session, inputId = "select04", choices = col)
})
output$corrplot01 <- renderPlot({
df <- data()
df1 <- df[,input$select04]
corr <- cor(x = df1, use = "pairwise.complete.obs")
corrplot(corr = corr,
title = "")
})
}
shinyApp(ui, server)
I changed your ui and server a bit, but I think that might solve your problem.
I deleted the observeEvent(input$file, ...{}) from the server and added the ui part in the Ui directly.
I also added 3 req() calls in the data reactive, in the second observeEvent(input$select04, ...{}) which I changed to a normal observe and in the renderPlot call.
library(shiny)
library(readr)
library(corrplot)
library(DT)
# File used for the example
data(iris)
write.csv(x = iris, file = "iris.csv", row.names = F)
#UI
ui <- shinyUI(
fluidPage(
navbarPage(
id = "navbar",
tabPanel(
title = "UPLOAD",
br(),
actionButton(inputId = "file", label = "ADD A FILE"),
tabPanel(
value = "B",
title = "Corr",
sidebarLayout(
sidebarPanel(
selectizeInput(width = "300px",
inputId = "select04",
label = "Select features",
choices = NULL,
multiple = TRUE)
),
mainPanel(
plotOutput(
outputId = "corrplot01", height = "650px")
)
)
)
)
)
)
)
#SERVER
server <- function(input, output, session) {
path <- reactiveValues(pth = NULL)
file.choose2 <- function(...) {
pathname <- NULL;
tryCatch({
pathname <- file.choose();
}, error = function(ex) {
})
pathname;
}
observeEvent(input$file,{
path$pth <- file.choose2()
})
observeEvent(input$file, {
newvalue <- "B"
updateNavbarPage(session, "navbar", newvalue)
})
data <- reactive({
req(path$pth)
df <- readr::read_csv(file = path$pth)
return(df)
})
# I suppose there is a problem with this line
observe({
req(names(data()))
col <- names(data())
col.num <- which(sapply(data(), class) == "numeric")
col <- col[col.num]
updateSelectizeInput(session = session, inputId = "select04", choices = col)
})
output$corrplot01 <- renderPlot({
req(input$select04)
df <- data()
df1 <- df[,input$select04]
corr <- cor(x = df1, use = "pairwise.complete.obs")
corrplot(corr = corr,
title = "")
})
}
shinyApp(ui, server)