r - 如何在 Shiny 中单击添加/保留任意数量的绘图层

Question

按照 this question 中给出的答案，我可以通过每次点击在绘图上渲染一个多边形:



但是，我似乎找不到一种简单的方法来允许 polygon()坚持。我现在的方式是，每次都重新绘制初始图和注释。

解耦注释和绘图以便可以创建多个注释的 (a) 正确方法是什么？

我觉得我可以用“画圈”按钮添加一个新的polygon() ，但我不确定如何在 R 中创建一个新的“对象”。

代码:

服务器

library(shiny)
library(maps)
library(mapdata)
library(rworldmap)
library(gridExtra)

circleFun <- function(center = c(0,0),radius = 1, npoints = 100){
    tt <- seq(0,2*pi,length.out = npoints)
    xx <- center[1] + radius * cos(tt)
    yy <- center[2] + radius * sin(tt)
    return(data.frame(x = xx, y = yy))
}

shinyServer(function(input, output) {
  # Reactive dependencies
  buttonClicked <- reactive(input$paintupdate)

  isolate({
  theworld <- function() {
    myplot <- map("world2", wrap=TRUE, plot=TRUE,
        resolution=2)
  }})

  user.circle <- function() {
    if (buttonClicked() > 0) {
      cur.circ <- circleFun(c(input$plotclick$x,input$plotclick$y),
                            radius=input$radius*100, npoints = 30)
      polygon(x=cur.circ$x,y=cur.circ$y,
              col = rainbow(1000,s=0.5,alpha=0.5)[input$circlecolor])
    }
  }

  output$myworld <- renderPlot({
    theworld()
    user.circle()
  })

  output$clickcoord <- renderPrint({
    # get user clicks, report coords
    if ("plotclick" %in% names(input)) {
      print(input$plotclick)
    }
    print(buttonClicked())
  })



})

用户界面

library(shiny)

# Define UI for application
shinyUI(pageWithSidebar(

  # Application title
  headerPanel("App"),

  sidebarPanel(
    sliderInput("radius", 
                "Location radius", 
                min = 0,
                max = 1, 
                value = 0.1,
                round=FALSE,
                step=0.001),
    sliderInput("circlecolor",
                "Circle color (hue)",
                min=0,
                max=1000,
                step=1,
                value=sample(1:1000,1)),
    actionButton("paintupdate", "Paint Circle"),
    textOutput("clickcoord")
  ),

  mainPanel(
    tabsetPanel(
      tabPanel("Map",
               plotOutput("myworld", height="650px",width="750px",
                          clickId="plotclick")
      )
    )
  )
))

Answer 1

您可以稍微更改示例并添加 reactiveValue使这项工作

library(shiny)
library(maps)
library(mapdata)
library(rworldmap)
library(gridExtra)

circleFun <- function(center = c(0,0),radius = 1, npoints = 100){
  tt <- seq(0,2*pi,length.out = npoints)
  xx <- center[1] + radius * cos(tt)
  yy <- center[2] + radius * sin(tt)
  return(data.frame(x = xx, y = yy))
}

library(shiny)

# Define UI for application
runApp(
  list(ui = pageWithSidebar(

    # Application title
    headerPanel("App"),

    sidebarPanel(
      sliderInput("radius", 
                  "Location radius", 
                  min = 0,
                  max = 1, 
                  value = 0.1,
                  round=FALSE,
                  step=0.001),
      sliderInput("circlecolor",
                  "Circle color (hue)",
                  min=0,
                  max=1000,
                  step=1,
                  value=sample(1:1000,1)),
      actionButton("paintupdate", "Paint Circle"),
      textOutput("clickcoord")
    ),

    mainPanel(
      tabsetPanel(
        tabPanel("Map",
                 plotOutput("myworld", height="650px",width="750px",
                            clickId="plotclick")
        )
      )
    )
  ),
  server = function(input, output, session) {
    # Reactive dependencies
    myReact <- reactiveValues()
    buttonClicked <- reactive(input$paintupdate)

    isolate({
      theworld <- function() {
        myplot <- map("world2", wrap=TRUE, plot=TRUE,
                      resolution=2)
      }})


    user.circle <- function(a,b,c,d) {
      cur.circ <- circleFun(c(a,b),
                            radius=c, npoints = 30)
      polygon(x=cur.circ$x,y=cur.circ$y,
              col = rainbow(1000,s=0.5,alpha=0.5)[d])     
    }


    observe({
      if (buttonClicked() > 0) {
        # take a dependence on button clicked
        myReact$poly <- c(isolate(myReact$poly), list(list(a=isolate(input$plotclick$x), b= isolate(input$plotclick$y)
                                             ,c=isolate(input$radius*100), d = isolate(input$circlecolor))))
      }
    }, priority = 100)

    output$myworld <- renderPlot({
      theworld()
        for(i in seq_along(myReact$poly)){
          do.call(user.circle, myReact$poly[[i]])
        }
    })

    output$clickcoord <- renderPrint({
      # get user clicks, report coords
      if ("plotclick" %in% names(input)) {
        print(input$plotclick)
      }
      print(buttonClicked())
    })



  }), display.mode= "showcase"
)