Используйте handle_click в ggvis для создания интерактивного фильтра в Shiny

Question

У меня есть базовое приложение Shiny, которое использует графику ggvis(). Приложение приведено ниже.

В документации для ggvis() есть функция handle_click(vis, on_click = NULL), которая может быть передана. Кроме того, on_click является функцией обратного вызова с данными, местоположением и сеансом аргументов.

Что бы я хотел сделать, это разрешить пользователю щелкнуть по одному из столбцов на графике (одна полоса в месяц) и установить input$monthSelect в течение месяца, в который он нажал. Если бы я добавлял всплывающую подсказку, я мог бы создать функцию, которая будет воспринимать данные из слоя, который будет витаться, и я мог бы ссылаться на data$x_, чтобы получить месяц.

Пример этой функции:

update_selection = function(data){ 
    if(is.null(data)) return(NULL) 
    updateSelectInput(session 
        ,"monthSelect" 
        ,selected=data$x_) 
    } 

и добавить его к ggvis через ggvis() %>% handle_click(update_selection(data)), но я получаю сообщение об ошибке Error in func() : could not find function "fun".

Как я могу создать реактивный график?

library(ggvis) 
library(dplyr) 
library(tidyr) 
library(ReporteRs) 
data = cocaine 
data = within(data, 
    { 
    month[month==1] = "January" 
    month[month==2] = "February" 
    month[month==3] = "March" 
    month[month==4] = "April" 
    month[month==5] = "May" 
    month[month==6] = "June" 
    month[month==7] = "July" 
    month[month==8] = "August" 
    month[month==9] = "September" 
    month[month==10] = "October" 
    month[month==11] = "November" 
    month[month==12] = "December" 
    } 
) 

server = function(input, output, session){ 

    selectedState = reactive(input$stateSelect) 

    plotData = reactive({ 
    data %>% 
     group_by(state,month) %>% 
     summarise(avgPotency = mean(potency)) %>% 
     ungroup() %>% 
     spread(month,avgPotency) %>% 
     mutate(January = ifelse(is.na(January),0,January) 
      ,February = ifelse(is.na(February),0,February) 
      ,March = ifelse(is.na(March),0,March) 
      ,April = ifelse(is.na(April),0,April) 
      ,May = ifelse(is.na(May),0,May) 
      ,June = ifelse(is.na(June),0,June) 
      ,July = ifelse(is.na(July),0,July) 
      ,August = ifelse(is.na(August),0,August) 
      ,September = ifelse(is.na(September),0,September) 
      ,October = ifelse(is.na(October),0,October) 
      ,November = ifelse(is.na(November),0,November) 
      ,December = ifelse(is.na(December),0,December) 
    ) %>% 
     filter(state==selectedState()) %>% 
     gather("month","AvgPotency",-state) 
    }) 

    stateVis = reactive({ 
    plotData() %>% 
     ggvis(x=~month,y=~AvgPotency) 
    }) 
    stateVis %>% bind_shiny("cocaineCounts") 

    selectedMonth = reactive(input$monthSelect) 
    tableData = reactive({ 
    data %>% 
     filter(state==selectedState() & month==selectedMonth()) 
    }) 
    output$cocaineTable = renderUI({ 
    MyFTable = FlexTable(tableData(), 
         header.cell.props = cellProperties(padding = 2), 
         body.cell.props = cellProperties(padding = 2)) 
    return(HTML(as.html(MyFTable))) 
    }) 

} 

ui = shinyUI(
    fluidPage(
    column(6, 
      selectInput("stateSelect",label="Select a State:",choices = unique(data$state),selected=1) 
      ,selectInput("monthSelect",label="Select a Month:",choices = c('January','February','March','April','May','June','July','August','September','October','November','December'),selected=1) 
      ,ggvisOutput("cocaineCounts") 
    ) 
    ,column(6, 
      uiOutput(outputId = "cocaineTable") 
    ) 
    ) 
) 

shinyApp(ui = ui, server = server) 

Answer 1

Функция должна быть обновлена, чтобы принять три аргумента:

update_selection = function(data,location,session){ 
    if(is.null(data)) return(NULL) 
    updateSelectInput(session 
        ,"monthSelect" 
        ,selected=data$x_) 
    } 

и handle_click() должен быть передан как ggvis() %>% handle_click(update_selection)

Так полный, работает приложение:

library(ggvis) 
library(dplyr) 
library(tidyr) 
library(ReporteRs) 
data = cocaine 
data = within(data, 
    { 
    month[month==1] = "January" 
    month[month==2] = "February" 
    month[month==3] = "March" 
    month[month==4] = "April" 
    month[month==5] = "May" 
    month[month==6] = "June" 
    month[month==7] = "July" 
    month[month==8] = "August" 
    month[month==9] = "September" 
    month[month==10] = "October" 
    month[month==11] = "November" 
    month[month==12] = "December" 
    } 
) 

update_selection = function(data,location,session){ 
    if(is.null(data)) return(NULL) 
    updateSelectInput(session 
        ,"monthSelect" 
        ,selected=data$x_) 
    } 

server = function(input, output, session){ 

    selectedState = reactive(input$stateSelect) 

    plotData = reactive({ 
    data %>% 
     group_by(state,month) %>% 
     summarise(avgPotency = mean(potency)) %>% 
     ungroup() %>% 
     spread(month,avgPotency) %>% 
     mutate(January = ifelse(is.na(January),0,January) 
      ,February = ifelse(is.na(February),0,February) 
      ,March = ifelse(is.na(March),0,March) 
      ,April = ifelse(is.na(April),0,April) 
      ,May = ifelse(is.na(May),0,May) 
      ,June = ifelse(is.na(June),0,June) 
      ,July = ifelse(is.na(July),0,July) 
      ,August = ifelse(is.na(August),0,August) 
      ,September = ifelse(is.na(September),0,September) 
      ,October = ifelse(is.na(October),0,October) 
      ,November = ifelse(is.na(November),0,November) 
      ,December = ifelse(is.na(December),0,December) 
    ) %>% 
     filter(state==selectedState()) %>% 
     gather("month","AvgPotency",-state) 
    }) 

    stateVis = reactive({ 
    plotData() %>% 
     ggvis(x=~month,y=~AvgPotency) %>% 
     handle_click(update_selection) 
    }) 
    stateVis %>% bind_shiny("cocaineCounts") 

    selectedMonth = reactive(input$monthSelect) 
    tableData = reactive({ 
    data %>% 
     filter(state==selectedState() & month==selectedMonth()) 
    }) 
    output$cocaineTable = renderUI({ 
    MyFTable = FlexTable(tableData(), 
         header.cell.props = cellProperties(padding = 2), 
         body.cell.props = cellProperties(padding = 2)) 
    return(HTML(as.html(MyFTable))) 
    }) 

} 

ui = shinyUI(
    fluidPage(
    column(6, 
      selectInput("stateSelect",label="Select a State:",choices = unique(data$state),selected=1) 
      ,selectInput("monthSelect",label="Select a Month:",choices = c('January','February','March','April','May','June','July','August','September','October','November','December'),selected=1) 
      ,ggvisOutput("cocaineCounts") 
    ) 
    ,column(6, 
      uiOutput(outputId = "cocaineTable") 
    ) 
    ) 
) 

shinyApp(ui = ui, server = server)