ggvis and shiny - hover property fails on added data with key - r

I'm trying to learn how to use ggvis and shiny together, by adapting the code from the movie explorer exmaple.
I have come across a problem where when a user's interaction adds new data to the graph, the hover effects don't work for the new data if there is a key. I'd like to be able to keep the key, because I'll also want to have a tooltip.
A quick example is below. To reproduce bug:
1) Run shiny app.
2) Use the select box to add the "b" points.
3) Now the "a" points will increase in size upon hover, as expected, but the "b" points will not.
To get proper behavior, I could just comment out the line in server.r, but I don't want to do that (because of the tooltip I want to add). Is there something I can do with reactive to get the hover behavior on all points?
Thank you!
server.r
library(ggvis)
# Set up data on app start
all_data <- data.frame(x=1:4, y=1:4, z=c("a", "b", "b", "a"), ID=1:4)
shinyServer(function(input, output, session) {
# Filter the data
this_data <- reactive({
all_data[all_data$z %in% input$z, ]
})
# A reactive expression with the ggvis plot
vis <- reactive({
this_data %>%
ggvis(~x, ~y) %>%
layer_points(fill = ~z,
key := ~ID, # Comment out this line for proper behavior
size := 50, size.hover := 500,
fillOpacity := 0.9, fillOpacity.hover := 0.5)
})
vis %>% bind_shiny("plot1")
})
ui.r
library(ggvis)
shinyUI(fluidPage(
titlePanel("Example"),
fluidRow(
column(3,
wellPanel(
selectInput("z", "Select Z", c("a", "b"),
selected = "a", multiple=TRUE)
)
),
column(9,
ggvisOutput("plot1")
)
)
))

This had me pretty confused. I could replicate it in a bunch of strange ways - e.g. adding groups / adding points. The order in which you added groups and removed them also did strange things.
In one of my own shiny/ggvis plots that I made after the movie example, I had a similar issue with key/ID and I found that adding the ID after all data filtering worked better. I tried that here by adding the ID variable after the filtering but it still didn't work. However, adding it in a new reactive did.
here is my ggvis/shiny where I had to do something similar - https://jalapic.shinyapps.io/cricket
and the raw code - https://github.com/jalapic/shinyapps/blob/master/cricket/server.R
I think this works - at least for me. Effectively, note I remove the ID from the data setup. I then add it in a new reactive after our filtering is done in the first reactive.
# Set up data on app start
all_data <- data.frame(x=c(1,3:5), y=1:4, z=c("a", "b", "b", "a"))
shinyServer(function(input, output, session) {
# Filter the data
this_data <- reactive({
all_data[all_data$z %in% input$z, ]
})
this_data1 <- reactive({
as.data.frame(this_data() ) %>% mutate(ID = row_number(x))
})
# A reactive expression with the ggvis plot
vis <- reactive({
this_data1 %>%
ggvis(~x, ~y) %>%
layer_points(fill = ~z,
key := ~ID, # Comment out this line for proper behavior
size := 50, size.hover := 500,
fillOpacity := 0.9, fillOpacity.hover := 0.5)
})
vis %>% bind_shiny("plot1")
})
I should add that I have added the ID variable using the %>% mutate(row_number()) command from dplyr but I'm sure you could do it in another way if this doesn't suit you.

Related

How to create dynamic leaflet plot by using selectinput variable selection on reactive data in r shiny?

I am running a leaflet plot in shiny that is already partially dynamic with selection to create reactive data but having troubles in dynamic variable selection on reactive data in renderLeaflet({}) section.
looking to dynamically change: district_map_data()$Daily_confirmed with district_map_data()$input$id_districts_var_selection.
Working code below when variable is fixed to (Daily_confirmed):
district_map_data <- reactive({
req(input$id_state_for_district)
district_map_data <- state_level_map %>%
data preprocessing code ...
}) %>%
bindCache(input$id_state_for_district)
# ------------------------------------------------------------------ #
output$id_state_map <- renderLeaflet({
req(input$id_districts_var_selection)
pal_district <- colorBin(palette = "plasma", bins = 4,
# Need dynamic code here
domain = district_map_data()$Daily_confirmed) # {input$id_districts_var_selection}
label_district = paste("Latest Daily Cases:",
# Need dynamic code here
as.character(district_map_data()$Daily_confirmed)) %>%
lapply(htmltools::HTML)
district_map_data() %>% leaflet() %>%
addPolygons(
label = label_district,
# Need dynamic code here
fillColor = ~ pal_district(Daily_confirmed)) %>%
addLegend(position = "bottomleft",
pal = pal_district,
# Need dynamic code here
values = ~ district_map_data()$Daily_confirmed,
opacity = 0.7)
})
One possible way I know is to pivot longer the variables into 1 & filter it within the reactive data itself with the selectInput selection but will only try that if I do not find any solution here.
Any help is much appreciated !!!

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)

ggvis hover ability in for loop in shiny app

I am trying to create a variable number of plots in a shiny app, each with hover ability from ggvis using add_tooltip() to display actual data points. To create a variable number of plots I am using a for loop. See below for a toy example that can be run on its own.
For some reason in my code the hover over ability only works correctly for the final plot that is created. Does anyone know how I might be able to fix this or maybe have a suggestion for a better approach?
Thanks!
library(shiny)
library(ggvis)
# Define ui for variable amounts of plots
ui <- fluidPage(
fluidRow(
uiOutput("mydisplay")
)
)
server <- function(input, output) {
# toy data example
x = data.frame(
id = 1:30,
myname = c(rep("First 10",10),rep("Second 10",10),rep("Third 10",10)),
stringsAsFactors = F
)
# ggvis add_tooltip() function
all_values <- function(x) {
if(is.null(x)) return(NULL)
row <- mydf[mydf$id == x$id, c("id","myname") ]
paste0(names(row), ": ", format(row), collapse = "<br />")
}
# For loop to create variable number of plots
for (k in 1:length(unique(x$myname))){
mydf = subset(x,x$myname==unique(x$myname)[k])
mydf %>% ggvis(~id, ~id) %>%
layer_points(size := 30, key := ~id) %>%
add_tooltip(all_values,"hover") %>%
bind_shiny(paste0("p_",k), paste0("p_ui_",k))
}
# For displaying in the UI
output$mydisplay = renderUI({
lapply(1:length(unique(x$myname)), function(j) {
fluidRow(
column(7, ggvisOutput(paste0("p_",j)))
)
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
Answered my own question thanks to this question here. The ggvis code needs to be wrapped in a reactive({}) function. Hope this helps someone.

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?

Using ggvis to show longitudinal data, where a slider controls the year

I'm trying to use a slider to control year in a longitudinal spatial data set, essentially a set of scatter plots. I can't figure out how to assign the slider to this variable - can you do this in ggvis?
A simplified data set:
data <- data.frame(year=rep(2000:2002, each=23),
x=rnorm(23*3,10), y=rnorm(23*3,10),
count=c(rnorm(23,2), rnorm(23,4), rnorm(23,6)))
What I've tried:
### This is what is looks like in ggplot2, I'm aiming to be able to toggle
### between these panels
ggplot(data, aes(x, y, size=count)) + geom_point() + facet_grid(~year)
### Here is where I'm at with ggvis
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points()
# I'm not sure how to assign a variable (year) to a slider, I've been trying
# within the layer_points() function
### I also tried using the props() function, but I don't fully understand
### how to use it.
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points() %>%
props(prop("fill", input_slider(min(data$year), max(data$year)))) #error message
Any help is appreciated!
I'm not sure if you want to use the slider to filter the data points (i.e. only show those points from the year selected on the slider), or to show the years in different colors according to the slider's value.
Case 1 (only display the points from a specific year)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity=input_slider(min(data$year), max(data$year), step=1,
map=function(x) ifelse(data$year == x, 1, 0)))
Case 2 (highlight the selected years)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(fill=input_slider(min(data$year), max(data$year), step=1,
map=function(x) factor(x == data$year)))
EDIT2: How to simply wrap a left_right() function.
In the first edit I presented a solution that is not properly considered as wrapping.
I was interested in creating a wrapper of the reactive object returned by left_right(), avoiding modifying create_keyboard_event all together.
After reading the source code of ggvis more thoroughly and more on S4 objects in R,
I realized that yes, you can simply wrap a reactive object, as long as you preserve the broker class and its broker attribute appropriately.
This allows us to write more elegant code, like:
year_lr <- left_right(1997, 2002, value=2000, step=1)
year_wrapper <- reactive({
as.numeric(year_lr() == data$year)
})
class(year_wrapper) <- c("broker", class(year_wrapper))
attr(year_wrapper, "broker") <- attr(year_lr, "broker")
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity:=year_wrapper)
EDIT: How to create your own (modified) left_right() function
user3389288 asked me a good question, that since you don't have a map argument for left_right() function, how can you actually bind keyboard event to generate custom parameters. For example, in the context of this question, how can we tailor left_right() as a year filter?
If you dig into the source code of ggvis, you can see that left_right() is simply a thin wrapper function calling create_keyboard_event.
Hence we can create our own version of left_right(), or even h_j_k_l() say if you are fanatic about Vi.
But, here is a big but, if you dig one layer further to look at the implementation of create_keyboard_event, you will find that it is not quite suitable for our task.
This is because in order to show some of the dots, while hide others, we have to let left_right return a vector (that equals to the number of rows in data).
However, both left_right and create_keyboard_event are created with the assumption that the returned value (which is also the current state of the value modified by Left/Right key presses) is a scalar.
In order to separate the return value (vector) from the cached current state (scalar, i.e. the year), we have to create a slightly modified version of left_right() and create_keyboard_event.
Below is the source code that would work.
data <- data.frame(year=rep(1997:2002, each=12),
x=rnorm(24*3,10), y=rnorm(24*3,10),
count=c(rnorm(24,2), rnorm(24,4), rnorm(24,6)))
create_keyboard_event2 <- function(map, default.x = NULL, default.res = NULL) {
# A different version of ggvis::create_keyboard_event function:
# the major different is that the map function returns a list,
# list$x is the current value and list$res the result (returned to a ggvis prop).
# this seperation allows us to return a vector of different
# values instead of a single scalar variable.
if (!is.function(map)) stop("map must be a function")
vals <- shiny::reactiveValues()
vals$x <- default.x
vals$res <- default.res
# A reactive to wrap the reactive value
res <- reactive({
vals$res
})
# This function is run at render time.
connect <- function(session, plot_id) {
key_press_id <- paste0(plot_id, "_key_press")
shiny::observe({
key_press <- session$input[[key_press_id]]
if (!is.null(key_press)) {
# Get the current value of the reactive, without taking a dependency
current_value <- shiny::isolate(vals$x)
updated <- map(key_press, current_value)
vals$x <- updated$x
vals$res <- updated$res
}
})
}
ggvis:::connector_label(connect) <- "key_press"
spec <- list(type = "keyboard")
ggvis:::create_broker(res, connect = connect, spec = spec)
}
# a modified version of left_right. this closure encapsulates the
# data "year", allowing us to perform comparison of the current state of
# left_right (numeric year number) to the year vector.
left_right_year <- function(min, max, value = (min + max) / 2,
step = (max - min) / 40, year) {
# Given the key_press object and current value, return the next value
map <- function(key_press, current_value) {
key <- key_press$value
print(current_value)
if (key == "left") {
new_value <- pmax(min, current_value - step)
} else if (key == "right") {
new_value <- pmin(max, current_value + step)
} else {
new_value = current_value
}
list(x=new_value, res=as.numeric(year == new_value))
}
create_keyboard_event2(map, value, as.numeric(value==year))
}
# now with an additional argument, the data$year
alpha_by_year <- left_right_year(1997, 2002, value=2000, step=1, data$year)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity:=alpha_by_year) # if you let left_right_year return
# a factor vector, you can use fill:=... as well
You can compare left_right_year and create_keyboard_event2 with their vanilla version counterparts.
For example, the original create_keyboard_event is:
create_keyboard_event <- function(map, default = NULL) {
if (!is.function(map)) stop("map must be a function")
vals <- shiny::reactiveValues()
vals$x <- default
# A reactive to wrap the reactive value
res <- reactive({
vals$x
})
# This function is run at render time.
connect <- function(session, plot_id) {
key_press_id <- paste0(plot_id, "_key_press")
shiny::observe({
key_press <- session$input[[key_press_id]]
if (!is.null(key_press)) {
# Get the current value of the reactive, without taking a dependency
current_value <- shiny::isolate(vals$x)
vals$x <- map(key_press, current_value)
}
})
}
connector_label(connect) <- "key_press"
spec <- list(type = "keyboard")
create_broker(res, connect = connect, spec = spec)
}
You can see that our modified version will not only cache the current state vals$x, but also the return vector vals$res.
The variable vals is a reactive value. The concept is borrowed from Shiny. You can check out this document about a high-level overview of reactive values and reactivity in general.
A question yet to be answered
Since vals$x is itself a reactive value. Intuitively, if
x <- left_right(1, 100, value=20, step=10)
then
y <- reactive(x() * 2)
should allow us to implement a quick map function.
However it doesn't work as expected. I am yet to figure out why exactly. If you know the answer, please kindly let me know!
UPDATED: c.f. EDIT2
The answers above are great. Definitively worth study. This is what I came up with for the original question for a quick fix.
Global.R:
library(shiny)
library(ggvis)
data<-data.frame(year=rep(2000:2002, each=23), x=rnorm(23*3,10), y=rnorm(23*3,10),
count=c(rnorm(23,2),rnorm(23,4),rnorm(23,6)))
ui.R:
shinyUI(bootstrapPage(
h3("Ploting Diferent Years Using a Slider",align="center"),
br(),
fluidRow(column(4,ggvisOutput("yearPlot"),offset=3)),
fluidRow(column(3,sliderInput("YearSelect", "Year: ",min=2000,max=2002,step=1,value=2000),offset=5))
))
Server.R:
shinyServer(function(input, output,session) {
plotdata <- reactive({
chosendat <- data[data$year==input$YearSelect, ]
names(chosendat) <- c("year","xvar","yvar","count")
return(chosendat)
})
vis1% ggvis(~xvar, ~yvar, size=~count) %>% layer_points()
})
vis1 %>% bind_shiny("yearPlot")
})

Resources