Shiny app with crosstalk and different interactive plots and tables - r

I want to build a shiny application that allows the user to interact with different plots and tables that are linked. To be precise, plot1 shows the raw data as a scatter plot, plot2 shows the data in an aggregated barplot, and finally table1 shows the data aggregated by another variable.
For example using ggplot2::mpg, I want hwy vs cty in plot1; plot2 shows the average hwy by manufacturer; and table1 shows the average hwy by drv.
The important bit is that when the user selects drv == "r" in the table, plot1 and plot2 should be reactive to that. Similarly, if a range is selected in plot1, then plot2 and table1 should show the values for the filtered data only, similarly, if a group is excluded by clicking on the legend in plot2, eg drv != "r", then that should be applied to the other data as well.
Using basic shiny I would create a reactive dataset which is filtered by the selection of each plot/table, but this feels a little bit too complicated for the task at hand.
This seems to be the perfect example for crosstalk but I am not able to get it to work.
For a simple example, I was using echarts4r for the interactivity.
MWE
An MWE looks like this:
library(dplyr) # for aggregating the data
library(ggplot2) # for the mpg dataset
library(shiny) # ...
library(crosstalk) # ...
library(reactable) # interactive tables
library(echarts4r) # interactive charts
# 1. Create the shared datasets =====
sd_raw <- SharedData$new(mpg, group = "mpg")
sd_by_man <- as_tibble(mpg) |>
group_by(manufacturer, drv) |>
summarise(n = n(), mean_hwy = mean(hwy)) |>
SharedData$new(group = "mpg")
sd_by_drv <- as_tibble(mpg) |>
group_by(drv) |>
summarise(n = n(), mean_hwy = mean(hwy)) |>
SharedData$new(group = "mpg")
# 2. Define shiny UI ====
ui <- fluidPage(
fluidRow(
column(4, echarts4rOutput("plot1")),
column(4, echarts4rOutput("plot2")),
column(4, reactableOutput("table1"))
)
)
# 3. Define shiny Server ====
server <- function(input, output, session) {
output$plot1 <- renderEcharts4r({
# apparently echarts4r and group_by do not play well with sd_raw, but need
# the $data() element
sd_raw$data() |>
group_by(drv) |>
e_charts(hwy) |>
e_scatter(cty, ) |>
e_tooltip() |>
e_brush()
})
output$plot2 <- renderEcharts4r({
sd_by_man$data() |>
group_by(drv) |>
e_charts(manufacturer, stack = "drv") |>
e_bar(mean_hwy) |>
e_tooltip() |>
e_brush()
})
output$table1 <- renderReactable({
reactable(
sd_by_drv$data(),
selection = "multiple",
onClick = "select",
rowStyle = list(cursor = "pointer"),
minRows = 10
)
})
}
shinyApp(ui, server)
Which results in an app like this
Note that the app looks correct, but for example
selecting a drv in the table does not change the plots, or
de-selecting a drv does not change the other outputs, or
brushing an area on the first plot also does not change the other outputs.
Any idea how to get this interactivity to work? Can this be done using crosstalk or do I need to resort back to using basic shiny reactivity (which of course would make the app a lot more complicated...)

Related

R Shiny: Unable to update heat map Top Annotation using CheckboxGroupInput()

I'm creating a heatmap using InteractiveComplexHeatMaps in R Shiny and I'm having trouble sub-setting my data in a way that the user can choose how to group/annotate the heatmap by CheckboxGroupInput (allowing multiple). In my data, there are multiple variables that I'd like to display for each column of the heatmap.
I'd like to know what exactly is the return type of CheckboxGroupInput as the console is telling me that the Annotation function will not accept a list. Below is the reproducible example structured in the same way as my actual app.
ui <- fluidPage(
checkboxGroupInput("hm_annotate", "Select variables to annotate by:",
choices = ""),
InteractiveComplexHeatmapOutput()
)
server <- function(input, output, session) {
data <- reactive({
aframe <- mtcars
bframe <- scale(t(aframe))
cframe <- aframe %>% select(vs, am, gear, carb)
dframe <- cframe[, c("vs",input$hm_annotate), drop = FALSE]
ha <- HeatmapAnnotation(df = dframe)
ht1 <- Heatmap(bframe, top_annotation = ha)
list(
cframe = cframe,
ht = ht1
)
})
observe({
req(data()$cframe)
updateCheckboxGroupInput(session, "hm_annotate", choices = colnames(data()$cframe))
})
observe({
makeInteractiveComplexHeatmap(input, output, session, data()$ht)
})
}
shinyApp(ui, server)
There are two issues with the current code. 1) After clicking on the checkbox, it updates the heatmap for a second then revert back. 2) Due to the current sub-setting, there are two 'vs' options.

Shiny: passing reactive value to function and re-evalute function if reactive value changes

I built a shiny dashboard, which takes an input file (as reactive) and creates some plots based on that file. As I did not want to rewrite all the code for barplots, histograms etc again and again, I created different functions for plotting bars, histograms etc.
As an input these functions take processed data. Usually that means that I take my raw data (stored in an reactive variable), manipulate some values and create some kind of cross tabulated dataframe, which is passed to the plotting function.
Everything works fine, except that the plots are not updated, if I change my input data. The reason for that seems to be that I first process my reactive data and then pass it to my function. Apparently one has to use the reactive variable in direct context with/inside the plot function to make the plot reactive too.
Before I start re-writing my dashboard (an option that I really don't like), I wanted to ask if somebody knew an easy workaround to pass processed reactive variables to functions and still re-evaluate these functions, if the reactive value changes?
As my code works, there is no need for a minimal example, but to make it easier to understand my problem, here is some kind of pseudo code
# read selected xlsx file
dat <- shiny::reactive({
readxl::read_xlsx(path=input$selected_file$datapath)
})
# function to plot data
plot_bar <- function(dat,
.x,
.y){
# plot data
plot(data=dat,x=.x,y=.y)
}
# call plot_bar
plot_bar(dat=dat() %>%
dplyr::count(age),
.x=age,
.y=n)
As Ronak Shah mentioned I might have been a bit too lazy not sharing a reproducible example. Sorry for that. I was hoping that plain text would do the trick as it's hard to keep it minimal with dashboards :D
Anyways, here is some reproducible code. I hope this helps to clearify the problem.
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("blupp"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput(inputId="sel_tibble",
label="select tibble",
choices=c("test1","test2"))
),
# Show a plot of the generated distribution
mainPanel(
column(width=4,
plotOutput(outputId="barplot1")),
column(width=4,
plotOutput(outputId="barplot2")),
column(width=4,
plotOutput(outputId="barplot3"))
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# some data
dat_list <- list(test1=dplyr::tibble(X=1:10,
Y=10:1,
GRP1=sample(LETTERS[1:2],
size=10,
replace=T),
GRP2=sample(LETTERS[5:6],
size=10,
replace=T)),
test2=dplyr::tibble(X=101:1000,
Y=1000:101,
GRP1=sample(LETTERS[1:2],
size=900,
replace=T),
GRP2=sample(LETTERS[5:6],
size=900,
replace=T)))
# Reactive: change between datasets (should affect plots)
dat <- reactive({
input$sel_tibble
res <- dat_list[[input$sel_tibble]]
return(res)
})
# Functions
# passing processed reactive (plot won't change)
plot_bar1 <- function(dat,
.x,
.y,
id){
# NSE
.x <- rlang::enquo(.x)
.y <- rlang::enquo(.y)
# Plot Date
output[[id]] <- renderPlot({
dat %>%
ggplot2::ggplot(ggplot2::aes(x=!!.x,y=!!.y)) +
ggplot2::geom_col()
})
}
# passing reactive and processing inside function (plot changes)
plot_bar2 <- function(dat,
.x,
id){
# NSE
.x <- rlang::enquo(.x)
# Plot Date
output[[id]] <- renderPlot({
dat() %>%
dplyr::count(!!.x) %>%
ggplot2::ggplot(ggplot2::aes(x=!!.x,y=n)) +
ggplot2::geom_col()
})
}
# Output
plot_bar1(dat=dat() %>%
dplyr::count(GRP1),
.x=GRP1,
.y=n,
id="barplot1")
plot_bar1(dat=dat() %>%
dplyr::count(GRP2),
.x=GRP2,
.y=n,
id="barplot2")
plot_bar2(dat=dat,
.x=GRP1,
id="barplot3")
}
# Run the application
shinyApp(ui = ui, server = server)
I'm not sure your way of program in shiny is wrong, but for me is odd having functions creating output values directly, and specially having functions defined in the server block. Also try to use different names for the data structures you're working with and the reactive functions you create.
I modified your code with my own practices and it works as you expected.
My advise, keep the outputs defined by name nor dynamically named, your functions best declared outside server function, and if you need to add objects dynamically use removeUI and insertUI on your server code.
Working code
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("blupp"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput(inputId="sel_tibble",
label="select tibble",
choices=c("test1","test2"))
),
# Show a plot of the generated distribution
mainPanel(
column(width=4,
plotOutput(outputId="barplot1")),
column(width=4,
plotOutput(outputId="barplot2")),
column(width=4,
plotOutput(outputId="barplot3"))
)
)
)
dat_list <- list(test1=dplyr::tibble(X=1:10,
Y=10:1,
GRP1=sample(LETTERS[1:2],
size=10,
replace=T),
GRP2=sample(LETTERS[5:6],
size=10,
replace=T)),
test2=dplyr::tibble(X=101:1000,
Y=1000:101,
GRP1=sample(LETTERS[1:2],
size=900,
replace=T),
GRP2=sample(LETTERS[5:6],
size=900,
replace=T)))
# Define server logic required to draw a histogram
plot_bar1 <- function(dat,
.x,
.y,
id){
# NSE
.x <- rlang::enquo(.x)
.y <- rlang::enquo(.y)
# Plot Date
return(
dat %>%
ggplot2::ggplot(ggplot2::aes(x=!!.x,y=!!.y)) +
ggplot2::geom_col()
)
}
plot_bar2 <- function(dat,
.x,
id){
# NSE
.x <- rlang::enquo(.x)
# Plot Date
return(
dat %>%
dplyr::count(!!.x) %>%
ggplot2::ggplot(ggplot2::aes(x=!!.x,y=n)) +
ggplot2::geom_col()
)
}
server <- function(input, output) {
# some data
# Reactive: change between datasets (should affect plots)
dat <- reactive({
#input$sel_tibble
res <- dat_list[[input$sel_tibble]]
print("data updated")
return(res)
})
# Functions
# passing processed reactive (plot won't change)
output$barplot1 <- renderPlot({
plot_bar1(dat=dat() %>%
dplyr::count(GRP1),
.x=GRP1,
.y=n,
id="barplot1") })
output$barplot2 <- renderPlot({
plot_bar1(dat=dat() %>%
dplyr::count(GRP2),
.x=GRP2,
.y=n,
id="barplot2")
})
output$barplot3 <- renderPlot({
plot_bar2(dat=dat(),
.x=GRP1,
id="barplot3")
})
# passing reactive and processing inside function (plot changes)
}
# Output
}
# Run the application
shinyApp(ui = ui, server = server)

r shiny reactive gtsummary table

After I fixed the rendering problem of {gtsummary} with your help: How to use {gtsummary} package in r shiny app !thanks to stefan again,
I try to construct reactivity in my app.
After construction of the summary table with {gtsummary} I would like to pass the y variable from a select input field to change the summary table.
I get this error: no applicable method for 'as_factor' applied to an object of class "c('double', 'numeric')"
That exceeds my limits. Can someone please help?
My Code:
library(shiny)
library(gtsummary)
library(gt)
# make dataset with a few variables to summarize
iris2 <- iris %>% select(Sepal.Length, Sepal.Width, Species)
# summarize the data with our package
table1 <- tbl_summary(iris2) %>% as_gt()
table1
shinyApp(
ui = fluidPage(
fluidRow(
column(12,
# Select variable for y-axis
selectInput(inputId = "y",
label = "Y-axis:",
choices = names(iris2),
selected = "Sepal.Length"),
gt_output('table')
)
)
),
server = function(input, output) {
varY <- reactive({input$y})
output$table <- render_gt({
table1 <- tbl_summary(iris2[, varY()]) %>% as_gt()
})
})
The issue is that tbl_summary expects a dataframe as its first argument, while your are passing a numeric vector iris2[, varY()]. If I got you right you want to select column varY() which could be achieved by:
table1 <- tbl_summary(select(iris2, all_of(varY()))) %>% as_gt()

Combine date slider, radio button, and map in Shiny

I want to create a map that displays traffic KPIs by date and location. The user is able to select a day of traffic with a slider, and a traffic KPI with radio buttons. The data is not showing up on the map.
I have created a reactive object that filters the data based on radio button and slider. The code to render the LeafLet map works outside the app, showing the circles for the data.
The data frame is structured as follows:
date,lat,long,pageviews,unique_visitors
01.01.2019,6.7304,-3.49,206,238
04.01.2019,7.1604,3.35,223,275
07.01.2019,52.25,-4.25,272,407
10.01.2019,46.9757,-123.8095,44,448
13.01.2019,45.4646,-98.468,98,269
16.01.2019,35.1351,-79.432,443,337
19.01.2019,39.5146,-76.173,385,21
22.01.2019,57.1704,-2.08,273,371
25.01.2019,18.2301,42.5001,115,195
28.01.2019,5.32,-4.04,7,27
31.01.2019,32.4543,-99.7384,217,136
03.02.2019,38.923,-97.2251,337,15
06.02.2019,2.7017,33.6761,201,390
09.02.2019,36.7089,-81.9713,177,201
12.02.2019,30.1204,74.29,65,82
15.02.2019,5.4667,-3.2,261,229
18.02.2019,7.1904,1.99,364,38
21.02.2019,3.9837,13.1833,131,74
24.02.2019,-22.7167,-65.7,357,198
27.02.2019,39.4228,-74.4944,297,399
02.03.2019,24.4667,54.3666,382,147
05.03.2019,34.4504,40.9186,8,373
08.03.2019,9.0833,7.5333,83,182
11.03.2019,-9.6954,-65.3597,243,444
14.03.2019,16.85,-99.916,420,29
-> It's stored under "joined" outside of the app (I'm joining two tables) and I call it at the beginning of the pipeline in the reactive object
When I select the date and metric, the output is structured as follows:
lat,long,selected_metric
lat is latitude and long is longitude
I guess the issue is how I'm calling the dataframe in renderLeaflet, as it is a reactive object I'm not sure if the ~ command works to call the columns.
# Required packages
library(shiny)
library(leaflet)
library(dplyr)
# Define UI for application that shows a map
ui <- fluidPage(
# App title
titlePanel("Metrics by location"),
# Input: select date range
sliderInput("traffic_date",
"Date:",
min = as.Date("2019-01-01","%Y-%m-%d"),
max = as.Date("2019-07-31","%Y-%m-%d"),
value=as.Date("2019-07-31"),
timeFormat="%Y-%m-%d"),
# Input: select metric
radioButtons("metric",
"Metric",
c("Pageviews" = "pageviews",
"Unique Visitors" = "unique_visitors"),
selected = "pageviews"),
# Main panel for Output
mainPanel(
# Output: map
leafletOutput("mymap")
)
)
# Define server commands to draw map with data
server <- function(input, output) {
# Reactive expression to generate dataframe for selected date and metric
d <- reactive({
day <- input$traffic_date
show_metric <- input$metric
d <- joined %>%
filter(date == day) %>%
select(lat,long,show_metric) %>%
rename(selected_metric = show_metric)
})
# Note: the last pipeline element renames the metric column back to a neutral name
#create the map
output$mymap <- renderLeaflet({
leaflet(d()) %>%
addTiles() %>%
setView(8.36,46.84,7) %>%
addCircles(lat = ~ lat,
lng = ~ long,
weight = 1,
radius = ~ selected_metric)
})
}
# Run app
shinyApp(ui, server)
Currently the code returns an empty map, and I'm not sure which step I'm missing to display the circles.
Thank you for the help!
I think your issue is the use of radius. See below taken from the help documentation:
radius
a numeric vector of radii for the circles; it can also be a one-sided formula, in which case the radius values are derived from the data (units in meters for circles, and pixels for circle markers)
I realised the markers were there they were just really small. Try multiplying the selected_metric by 10000 or changing to use addCircleMarkers.
Update
Using your data set which I converted to date and numeric where applicable and removing setView() so that the map automatically zooms to points out of that range. One of the issues I had was I initially couldn't see points as they were in Africa for example. Also many dates within the range above don't have data to display circles.
# Required packages
library(shiny)
library(leaflet)
library(dplyr)
# Define UI for application that shows a map
ui <- fluidPage(
# App title
titlePanel("Metrics by location"),
# Input: select date range
sliderInput("traffic_date",
"Date:",
min = as.Date("2019-01-01","%Y-%m-%d"),
max = as.Date("2019-07-31","%Y-%m-%d"),
value=as.Date("2019-01-01"),
timeFormat="%Y-%m-%d"),
# Input: select metric
radioButtons("metric",
"Metric",
c("Pageviews" = "pageviews",
"Unique Visitors" = "unique_visitors"),
selected = "pageviews"),
# Main panel for Output
mainPanel(
# Output: map
leafletOutput("mymap")
)
)
# Define server commands to draw map with data
server <- function(input, output) {
# Reactive expression to generate dataframe for selected date and metric
d <- reactive({
day <- input$traffic_date
show_metric <- input$metric
d <- joined %>%
filter(date == day) %>%
select(lat,long,show_metric) %>%
rename(selected_metric = show_metric)
})
# Note: the last pipeline element renames the metric column back to a neutral name
#create the map
output$mymap <- renderLeaflet({
leaflet(d()) %>%
addTiles() %>%
# setView(8.36,46.84,7) %>%
addCircles(lat = ~ lat,
lng = ~ long,
weight = 1,
radius = ~ selected_metric)
})
}
# Run app
shinyApp(ui, server)

R Shiny: Accessing input reactive from dynamic selectInput in multilayer reactive setup

PROBLEM SYNOPSIS: I have a shiny app I am building where I am trying to support database calls that drive dynamic lists of choices for selectInputs and where that dynamic input drives what a ggvis plot shows. The dynamic selectInput is not correctly selected and filtering the ggvis plot
QUESTION: How can I support dynamic drop down lists while still ensuring my ggvis plot filters based on the chosen item?
PROBLEM DETAIL:
Within my Server.R file I have a reactive that grabs a slice of data from the database. The get_chunk function is a call to NEO4J that I know works:
shinyServer( function(input, output, session) {
CURRENT_CHUNK <- reactive({
#call NEO4J
chunk <- get_chunk(some_list = input$chunk)
return(chunk)
})
I also have a reactive that simply filters down the data based on the ui choices on the front end. The input$A value is the chosen value from a dynamically built dropdown list. The filter_reactive is below. NOTE: I've separated these two so I don't have to call the database all the time; only when I choose a different CHUNK. The filter reactive looks like the following:
NO_DB_REACTIVE <- reactive({
#react to current_chunk and pull back a chunk.
filter_down <- CURRENT_CHUNK()
#check for nulls
if (!is.null(chunk)) {
if (input$A != "All") {filter_down <- filter_down %>% filter(A == input$A)}
return(filter_down)
}
return(filter_down)
})
The input$A value is generated dynamically as follows within the server.R file:
# reactively /dynamically generated the choices for the channel owners
output$owner_choices <- renderUI({ selectInput("A", "FOR Owner"
, as.list(c("All",unique(CURRENT_CHUNK()[,'owner'] )))
, "All") })
I also have a reactive that generates my GGVIS plot that looks like the following:
#All of the visualizations
MY_VIS <- reactive({
# Lables for axes
yvar_name <- names(display_choices)[display_choices == input$yvar]
xvar_name <- names(cat_choices)[cat_choices == input$xvar]
#retrieving
yvar <- prop("y", as.symbol(input$yvar))
xvar <- prop("x", as.symbol(input$xvar))
CURRENT_CHUNK %>%
ggvis(x = xvar, y = yvar) %>%
layer_bars() %>%
add_axis("x", title = xvar_name, properties = axis_props(labels = list(angle = 45, align = "left", fontSize = 10))) %>%
add_axis("y", title = yvar_name) %>%
set_options(width = 900, height = 300)
})
I tried to slim this down as much as possible. There is some dynamic choosing of axes there but you get the point. Notice I currently call CURRENT CHUNK within the MY_VIS reactive. And the end of the file has these:
output$table <- renderDataTable({ NO_DB_REACTIVE() })
MY_VIS %>% bind_shiny("my_vis")
When I filter items this way I get no errors. My table filters on input$A changes and the vis does not; I want the vis to change based on what input$A is as well.
I originally tried having MY_VIS depend on NO_DB_REACTIVE. This fails as input$A is never generated. I guess because CURRENT_CHUNK never runs as it doesn't have to. Notice the output$owner_choices is generated by reacting to CURRENT_CHUNK() not NO_DB_REACTIVE().
KEY QUESTION: How can I set this up so my input$A value is available when I want to filter my ggvis plot?

Resources