您好我已经创建了一个闪亮的应用程序,它可以在所选变量之间创建散点图。然后,当我单击数据点时,点的名称将打印在图中。问题是,当我用其他变量更新绘图时,打印不会被删除。一般来说,我想了解如何从我的情节中删除数据标签。
library(shiny)
library(ggplot2)
library(plotly)
library(dplyr)
library(htmlwidgets)
js <- HTML(
"Shiny.addCustomMessageHandler('resetValue', function(variableName){
Shiny.onInputChange(variableName, null);
}
);"
)
fluidPage(
tags$head(tags$script(js)),
# App title ----
titlePanel(div("CROSS CORRELATION",style = "color:blue")),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(width = 3
),
# Main panel for displaying outputs ----
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Table",
shiny::dataTableOutput("contents")),
tabPanel("Correlation Plot",
tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 0px;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
"),conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage")
),
fluidRow(
column(3, uiOutput("lx1")),
column(3,uiOutput("lx2"))),
hr(),
fluidRow(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
),
column(3,uiOutput("td")),
column(3,uiOutput("an"))
),
fluidRow(
plotlyOutput("sc"))
)
)
)))
#server.r
function(input, output,session) {
output$lx1<-renderUI({
selectInput("lx1", label = h4("Select 1st Expression Profile"),
choices = colnames(mtcars)
)
})
output$lx2<-renderUI({
selectInput("lx2", label = h4("Select 2nd Expression Profile"),
choices = colnames(mtcars)
)
})
output$td<-renderUI({
radioButtons("td", label = h4("Trendline"),
choices = list("Add Trendline" = "lm", "Remove Trendline" = ""),
selected = "")
})
output$an<-renderUI({
radioButtons("an", label = h4("Correlation Coefficient"),
choices = list("Add Cor.Coef" = cor(subset(mtcars, select=c(input$lx1)),subset(mtcars, select=c(input$lx2))), "Remove Cor.Coef" = ""),
selected = "")
})
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observeEvent({event_data("plotly_click", source = "select")}, {
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# check if from correct curve
if(!is.null(click_data) && click_data[["curveNumber"]] == 2) {
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
}
})
output$sc<-renderPlotly({
mtcars$model <- row.names(mtcars)
if(input$td=="lm"){
p1 <- ggplot(mtcars, aes_string(x = input$lx1, y = input$lx2,key = "model",group = 1))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
scale_x_continuous(breaks = seq(0, 35, 5)) +
scale_y_continuous(breaks = seq(0, 35, 5)) +
# Change how the text looks for each element
theme(title = element_text(family = "Calibri",
size = 10,
face = "bold"),
axis.title = element_text(family = "Calibri Light",
size = 16,
face = "bold",
color = "darkgrey"),
axis.text = element_text(family = "Calibri",
size = 11))+
theme_bw()+
annotate("text", x = 5, y = 5, label = as.character(input$an))+
geom_smooth(aes(group = 1))+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_y = -1,5)
}
else{
mtcars$model <- row.names(mtcars)
p1 <- ggplot(mtcars, aes_string(x = input$lx1, y = input$lx2,key = "model",group = 1))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
scale_x_continuous(breaks = seq(0, 35, 5)) +
scale_y_continuous(breaks = seq(0, 35, 5)) +
# Change how the text looks for each element
theme(title = element_text(family = "Calibri",
size = 10,
face = "bold"),
axis.title = element_text(family = "Calibri Light",
size = 16,
face = "bold",
color = "darkgrey"),
axis.text = element_text(family = "Calibri",
size = 11))+
theme_bw()+
annotate("text", x = 5, y = 5, label = as.character(input$an))+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_y = -1,5)
}
ggplotly(p1,source = "select", tooltip = c("key")) %>%
layout(hoverlabel = list(bgcolor = "white",
font = list(family = "Calibri",
size = 9,
color = "black")))
})
# 5a. reset plotly click event and vals$click_all upon changing plot inputs
observeEvent(c(
input$lx1,
input$lx2
), {
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
})
}
答案 0 :(得分:1)
<强> 1。重置plotly
事件输入
首先,将其添加到ui:
js <- HTML(
"Shiny.addCustomMessageHandler('resetValue', function(variableName){
Shiny.onInputChange(variableName, null);
}
);"
)
ui <- fluidPage(
tags$head(tags$script(js)),
...
)
然后,使用服务器中的消息处理程序:
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
注意,plotly event
数据遵循以下格式:'.clientValue-event-source'
,其中event
是事件类型(例如plotly_click
,plotly_hover
等)和在点击事件数据来自的图中指定了source
。
此方法改编自this回答。这个article也是一个有用的参考。
<强> 2。重置反应式数据框
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
第3。使用observeEvent触发&#34;重置&#34;当情节变量改变时
observeEvent(c(
input$column_x,
input$column_y
), {
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
})
注意:您需要将session
参数添加到服务器功能中,如下所示:
server <- function(input, output, session) {
...
}
最小例子
library(shiny)
library(plotly)
library(htmlwidgets)
js <- HTML(
"Shiny.addCustomMessageHandler('resetValue', function(variableName){
Shiny.onInputChange(variableName, null);
}
);"
)
ui <- fluidPage(
# 5b. js to reset the plotly click event
tags$head(tags$script(js)),
fluidRow(column(width = 3,
selectInput("column_x", "X Variable", colnames(mtcars)),
selectInput("column_y", "Y Variable", colnames(mtcars))),
column(width = 9,
plotlyOutput("plot")
)
)
)
server <- function(input, output, session) {
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observeEvent({event_data("plotly_click", source = "select")}, {
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# check if from correct curve
if(!is.null(click_data) && click_data[["curveNumber"]] == 0) {
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
}
})
output$plot <- renderPlotly({
mtcars$model <- row.names(mtcars)
g <- ggplot(mtcars, aes_string(x = input$column_x,
y = input$column_y,
key = "model",
group = 1)) +
geom_point() +
geom_smooth(aes(group = 1)) +
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_x = 1.5)
ggplotly(g, source = "select", tooltip = c("key"))
})
# 5a. reset plotly click event and vals$click_all upon changing plot inputs
observeEvent(c(
input$column_x,
input$column_y
), {
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
})
}
shinyApp(ui, server)