在 Shiny 中单击更改绘图

Question

当我偶然发现 Shiny 中的另一个问题时，我希望你能再次帮助我：

我希望图形在被点击的那一刻发生变化。这是一个最小的例子：

ui.R（显示可点击的图形和文本框）

shinyUI(fluidPage(
  titlePanel("Title"),
  sidebarLayout(
    sidebarPanel(
    ),
    mainPanel(
      plotOutput("graph", width = "100%", click = "plot_click"),
      verbatimTextOutput("click_info")
    )
  )
) 
) 

server.R（图形只包含“A”、“B”、“C”、“D”，点击时我会在文本框中找到最近的字母）

shinyServer(function(input, output, session) {

  # Visualization output:  
  observe({
    output$graph <- renderPlot({
      data <- data.frame(x=c(1,2,1,2), y=c(1,1,2,2), 
              values=c("A","B","C","D"), stringsAsFactors=FALSE)
      plot(data$x, data$y, pch=data$values)
    })  
  })

  # interaction click in graph  
  observe({
    click <- c(input$plot_click$x, input$plot_click$y)
    data <- data.frame(x=c(1,2,1,2), y=c(1,1,2,2),
                       values=c("A","B","C","D"), stringsAsFactors=FALSE)
    nearest_point <- which.min(apply(data[,1:2], 1, function(a) sum(((click-a)^2))))
    id <- data$values[nearest_point]
    output$click_info <- renderPrint({
      id
    })
  })
})

现在我想要在图表中标记我点击的字母，例如用另一种颜色。但到目前为止我所有的尝试都失败了。

Answer 1

试试这个：

ui <- shinyUI(fluidPage(
  titlePanel("Title"),
  sidebarLayout(
    sidebarPanel(
    ),
    mainPanel(
      plotOutput("graph", width = "100%", click = "plot_click"),
      verbatimTextOutput("click_info")
    )
  )
) 
)

server <- shinyServer(function(input, output, session) {
  data <- data.frame(x=c(1,2,1,2), y=c(1,1,2,2), 
                     values=c("A","B","C","D"), stringsAsFactors=FALSE)

  # Visualization output:  
  observe({
    output$graph <- renderPlot({
      plot(data$x, data$y, pch=data$values)
    })  
  })


  # interaction click in graph  
  observe({
    if(is.null(input$plot_click$x)) return(NULL)
    click         <- c(input$plot_click$x, input$plot_click$y)
    print(click)
    nearest_point <- which.min(apply(data[,1:2], 1, function(a) sum(((click-a)^2))))
    id <- data$values[nearest_point]

    output$click_info <- renderPrint({
      id
    })
    color <- rep("black",length(data$x))
    color[data$values==id] <- "red"

    isolate({
      output$graph <- renderPlot({
        plot(data$x, data$y, pch=data$values, col=color)
      }) 
    })

  })
})
shinyApp(ui=ui,server=server)

使用 ggplot2

根据@bunks 建议编辑：

library(ggplot2)
library(shiny)

ui <- shinyUI(fluidPage(
  titlePanel("Title"),
  sidebarLayout(
    sidebarPanel(
    ),
    mainPanel(
      plotOutput("graph", width = "100%", click = "plot_click"),
      verbatimTextOutput("click_info")
    )
  )
))

server <- shinyServer(function(input, output, session) {
  data <- data.frame(x=c(1,2,1,2), 
                         y=c(1,1,2,2), 
                         values=c("A","B","C","D"), 
                         stringsAsFactors=FALSE, 
                         color=rep("1",4))
  makeReactiveBinding('data')

  output$graph <- renderPlot({
    ggplot(data=data,aes(x=x,y=y,label=values,color=color))+geom_text()+theme_classic()+guides(colour=FALSE)
  })  

  observeEvent(input$plot_click, {
    # Get 1 datapoint within 15 pixels of click, see ?nearPoints
    np <- nearPoints(data, input$plot_click, maxpoints=1 , threshold = 15)

    output$click_info <- renderPrint({np$values})

    data$color <<- rep("1",length(data$x))
    data$color[data$values==np$values] <<- "2"
  })
})
shinyApp(ui=ui,server=server)