Как сделать подсказку ggvis интерактивной в блестящем приложении?

Question

В приведенном ниже примере у меня есть интерактивный блестящий хорвлет ggvis с всплывающей меткой для дохода в каждом штате. Пользователи могут переключать данные из выпадающего списка.

Мой вопрос заключается в том, как сделать функцию всплывающей подсказки интерактивной. Всплывающая метка по-прежнему отображает информацию об исходном наборе данных, даже если пользователь переключается на второй набор данных. Я пытался поставить его в реактивную функцию и несколькими другими способами, но все они не работают. В приведенном ниже примере я просто использую df1 в функции всплывающей подсказки, чтобы вы могли запустить и взглянуть на это приложение.

Спасибо за вашу помощь!

Вот пример данных

mapdata1<-data.frame(
  state=c("alabama","alaska","arizona","arkansas","california","colorado","connecticut","delaware","florida","georgia","hawaii","idaho","illinois","indiana","iowa","kansas","kentucky","louisiana","maine","maryland","massachusetts","michigan", "minnesota","mississippi","missouri","montana","nebraska","nevada","new hampshire","new jersey","new mexico","new york","north carolina","north dakota","ohio","oklahoma", "oregon","pennsylvania","rhode island","south carolina","south dakota","tennessee","texas","utah","vermont","virginia","washington","west virginia","wisconsin","wyoming"),
  income=runif(50,min=100,max=9000))

mapdata2<-data.frame(
  state=c("alabama","alaska","arizona","arkansas","california","colorado","connecticut","delaware","florida","georgia","hawaii","idaho","illinois","indiana","iowa","kansas","kentucky","louisiana","maine","maryland","massachusetts","michigan", "minnesota","mississippi","missouri","montana","nebraska","nevada","new hampshire","new jersey","new mexico","new york","north carolina","north dakota","ohio","oklahoma", "oregon","pennsylvania","rhode island","south carolina","south dakota","tennessee","texas","utah","vermont","virginia","washington","west virginia","wisconsin","wyoming"),
  income=runif(50,min=50,max=14000))

Код сервера

library(rgdal)   
library(ggplot2) 
library(ggvis)

tf    <- tempfile()
td    <- tempdir()
download.file(url,tf, mode="wb")  
unzip(tf, exdir=td)                

usa <- readOGR(dsn=td, layer="cb_2014_us_state_20m")
shp <- usa[(!usa$STUSPS %in% c("AK","HI")),] 

df<- fortify(shp)                    
df<- merge(df,cbind(id=rownames(shp@data),shp@data),by="id")   
df$state <- tolower(df$NAME)                                                  
df1<- merge(df,mapdata1,by="state")  
df1<- df1[order(df1$order),]

df2<- merge(df,mapdata2,by="state")  
df2<- df2[order(df2$order),]

shinyServer(
  function(input,output){

    dataInput<-reactive({
      switch(input$segment,
             "K 1"=df1,
             "K 2"=df2)
    })
###tooltip function    
    values = function(x){
      if(is.null(x)) return(NULL)
      row = head(df1[df1$group == unique(x$group), ], 1)
      paste0("State: ", row$state,"<br />",
             "Income: ", row$income, "<br />")
    }
###choropleth
    vis<-reactive({
      data<-dataInput()
      data %>%
      group_by(group) %>%
      ggvis(~long, ~lat)  %>%
      hide_axis("x") %>% 
      hide_axis("y")%>%
      add_tooltip(values,"hover")%>%
      layer_paths(fill= ~income)
    })
    vis %>% bind_shiny("visplot")
  }
)

код пользовательского интерфейса

library(shiny)
library(ggvis)

shinyUI(fluidPage(
  fluidRow(
    column(3,
           wellPanel(
             selectInput("segment",
                         "Choose segment:",
                         choices = c("K 1",
                                     "K 2")
             )
           )
    ),
    column(9,
           ggvisOutput("visplot")

    )
  )
))

ОБНОВЛЕНО:

Это то, что я пытался. Я также использую values ​​() в add_tooltip вместо значений. Но это не работает.

###tooltip function    
    values<-reactive({
      data<-dataInput()
      if(is.null(x)) return(NULL)
      row = head(data[data$group == unique(x$group), ], 1)
      paste0("State: ", row$state,"<br />",
             "Income: ", row$income, "<br />")
    })

Answer 1

Вот проще mtcars пример с всплывающей подсказкой на уровне группы, как у вас с layer_paths и группировка. Информация о графике и всплывающей подсказке изменяются при выборе другого набора данных.

щ

library(ggvis)
library(shiny)

shinyUI(fluidPage(
  titlePanel("Plotting slopes"),

  sidebarLayout(
    sidebarPanel(
        selectInput("segment", label = "Choose segment", choices = c("K 1", "K 2"))),

    mainPanel(ggvisOutput("plot"))
  )
))

сервер:

library(shiny)
library(ggvis)

mtcars$cyl = factor(mtcars$cyl)
df1 = subset(mtcars, am == 0)
df2 = subset(mtcars, am == 1)

shinyServer(function(input, output) {
    dataInput = reactive({
        switch(input$segment,
                     "K 1" = df1,
                     "K 2" = df2)
    })


    values = function(x){
        if(is.null(x)) return(NULL)
        dat = dataInput()
        row = dat[dat$cyl %in% unique(x$cyl), ]
        paste0("Ave Weight: ", mean(row$wt),"<br />",
                     "Ave Carb: ", mean(row$carb), "<br />")
    }


    vis1 = reactive({
        dat = dataInput()
        dat %>%
            group_by(cyl) %>%
            ggvis(~mpg, ~wt)  %>%
            layer_paths(stroke = ~cyl, strokeOpacity := 0.3, 
                                    strokeWidth := 5) %>%
            add_tooltip(values, "hover")
    })
    vis1 %>% bind_shiny("plot")

})