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

Question

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!

Answer 1

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

Answer 2

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")
})