如何在闪亮的应用程序中使 ggvis 工具提示交互?
How to make ggvis tooltip interactive in shiny app?
在下面的示例中,我有一个交互式闪亮的 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")
}
)
ui代码
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 />")
})
这是一个更简单的 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")
})
我的问题是如何使工具提示功能具有交互性。弹出标签仍然显示原始数据集的信息,即使用户切换到第二个数据集。我尝试将其放入反应函数和其他几种方式,但它们都不起作用。在下面的示例中,我只是在工具提示功能中使用 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")
}
)
ui代码
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 />")
})
这是一个更简单的 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")
})