使用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 。

在更详细地阅读了ggvis的源代码以及更多关于R中的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问我一个很好的问题，因为你没有left_right()函数的map参数，你如何实际绑定键盘事件来生成自定义参数。 例如，在这个问题的上下文中，我们如何将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与其vanilla版本对应物进行比较。

例如，原始的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

Answer 2

上面的答案很棒。 绝对值得研究。 这就是我想出的原始问题，以便快速解决问题。

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

    })