如何在闪亮的应用程序中使 ggvis 工具提示交互？

Question

在下面的示例中，我有一个交互式闪亮 ggvis choropleth，每个州的收入弹出标签。用户可以从下拉列表中切换数据。

我的问题是如何使工具提示功能具有交互性。即使用户切换到第二个数据集，弹出的标签仍然显示原始数据集的信息。我尝试将其放入反应函数和其他几种方式中，但它们都不起作用。在下面的示例中，我只是在 tooltip 函数中使用 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")

    )
  )
))

更新：

这是我尝试过的。我还在 add_tooltip 中使用 values() 而不是 values。但它不起作用。

###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 和分组类似的组级工具提示。选择不同的数据集时，图形和工具提示信息都会更改。

ui

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

})