使用ggvis显示纵向数据,滑块控制年份

Question

我正在尝试使用滑块来控制纵向空间数据集中的年份,基本上是一组散点图.我无法弄清楚如何将滑块分配给这个变量 - 你能用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)))

我尝试过的:

### 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

任何帮助表示赞赏!

Answer 1

我不确定您是否要将滑块用于filter数据点(即仅显示滑块上所选年份的那些点),或者根据滑块的值显示不同颜色的年份.

案例1(仅显示特定年份的点数)

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

案例2(突出显示所选年份)

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:如何简单地包装一个left_right()函数.

在第一次编辑中,我提出了一个没有被恰当地视为包装的解决方案.我有兴趣创建一个返回的反应对象的包装器left_right(),避免create_keyboard_event一起修改.

在R中读取了ggvis更彻底和更多关于S4对象的源代码之后,我意识到是的,你可以简单地包装一个被动对象,只要你适当地保存broker类和它的broker属性.

这允许我们编写更优雅的代码,例如:

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)

编辑:如何创建自己的(修改过的)left_right()功能

user3389288问我一个很好的问题,因为你没有函数map参数left_right(),你怎么能实际绑定键盘事件来生成自定义参数.例如,在这个问题的背景下,我们如何定制left_right()为年度过滤器？

如果你深入研究源代码ggvis,你可以看到这left_right()只是一个瘦的包装函数调用create_keyboard_event.

因此,我们可以创建自己的版本left_right(),甚至可以h_j_k_l()说如果你对Vi很狂热.但是,这里有一个很大但是,如果你进一步挖掘一层来看看它的实现create_keyboard_event,你会发现它不太适合我们的任务.

这是因为为了显示一些点,而隐藏其他点,我们必须让它left_right返回一个vector(等于行数data).但是,这两个left_right和create_keyboard_event与假定返回值(其也是的当前状态产生value由左/右改性键按压)是标量.

为了将返回值(向量)与缓存的当前状态(标量,即年份)分开,我们必须创建一个稍微修改过的版本left_right()和create_keyboard_event.

以下是可行的源代码.

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

你可以比较left_right_year和create_keyboard_event2与他们的香草版本的同行.

例如,原文create_keyboard_event是:

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

您可以看到我们的修改版本不仅会缓存当前状态vals$x,还会缓存返回向量vals$res.

变量vals是一个无功值.这个概念来自Shiny.您可以查看本文档,了解一般反应值和反应性的高级概述.

一个尚未回答的问题

因为vals$x它本身就是一个反应值.直觉,如果

x <- left_right(1, 100, value=20, step=10)

然后

y <- reactive(x() * 2)

应该允许我们实现快速map功能.

但是它没有按预期工作.我还没弄清楚为什么.如果您知道答案,请告诉我!

更新:cf EDIT2