如何从闪亮的应用程序中的绘图中删除文本(数据标签)?

时间:2018-04-01 23:53:50

标签: r ggplot2 shiny

您好我已经创建了一个闪亮的应用程序,它可以在所选变量之间创建散点图。然后,当我单击数据点时,点的名称将打印在图中。问题是,当我用其他变量更新绘图时,打印不会被删除。一般来说,我想了解如何从我的情节中删除数据标签。

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())
 })






}

1 个答案:

答案 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_clickplotly_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)

enter image description here