r - 基于用户输入 Shiny 的 ggplot 突出显示区域

Question

我在 ggplot 中创建了一个篮球半场，我将其嵌入到 Shiny 的侧边栏面板中，我想根据用户输入突出显示球场的“区域”。我在想我可以使用 renderUI 和 geom_rect() 之类的东西来获得我想要的东西，但我尝试过的任何东西似乎都不起作用。有人可以帮忙吗？

我附上了一个图片链接，希望它有助于补充我上面的解释以及当前代码。

谢谢!

Court Zones Example

teams <- c("Hawks","Celtics","Nets","Hornets","Bulls","Cavaliers",
       "Mavericks","Nuggets","Pistons","Warriors","Rockets","Pacers",
       "Clippers","Lakers","Grizzlies","Heat","Bucks","Timberwolves",
       "Pelicans","Knicks","Thunder","Magic","76ers","Suns","Trail 
        Blazers", "Kings","Spurs","Raptors","Jazz","Wizards")

server <- function(input, output) {

output$half_court <- renderPlot({

ggplot() + geom_polygon(data = court[court$side==1,], aes(x = x, y = y, 
group = group), col = "gray") +
coord_equal() +
xlim(-2,50) +
ylim(-2,50) +
scale_x_continuous(breaks = c(0, 25, 50)) +
scale_y_continuous(breaks = c(0, 12.5, 25, 37.5, 50)) +
xlab("") + ylab("") +
theme(axis.text.x = element_blank(),
      axis.text.y = element_blank(), axis.ticks.x = element_blank(),
      axis.ticks.y = element_blank(), axis.title = element_blank()) +
theme(panel.background = element_rect(fill = 'white')) +
geom_rect(aes_string(xmin = 0, xmax = 10, ymin = 37.6, ymax = 47), fill 
= "yellow", alpha = 0.20) +
geom_rect(aes_string(xmin = 40, xmax = 50, ymin = 0, ymax = 9.4), fill 
= "green", alpha = 0.20)
}, bg = "transparent")
}

ui <- fluidPage(
titlePanel(title=div(img(src="primary.png", height = 50, width = 
50),strong("Database"))),
  sidebarLayout(
    sidebarPanel(
  selectInput("season", "Season",c("","2016","2015","2014")),
  selectInput("team", "Team 1",c("",teams)),
  selectInput("team", "Team 2",c("",teams)),
  selectInput("pass", "Pass Location",c("",1:25)),
  selectInput("poss", "Possession Location",c("",1:25)),
  plotOutput(outputId = "half_court")
  ),
mainPanel()
)
)

shinyApp(ui = ui, server = server)

Answer 1

使用基本图，您可以获得透明图(renderPlot({...}, bg="transparent"))，添加透明矩形(rect(..., col = rgb(0, 50, 255, 50, maxColorValue = 256))) 并通过 CSS (HTML("#plot{background:url(https://...)}))).

有关示例应用，请参见下文:

bckpic <- "https://thedatagame.files.wordpress.com/2016/03/nba_court.jpg"

pos <- function(x, y){
  xx <- x1 <- (x - 1)*5 + c(0, 5)
  yy <- 25 - ((y - 1)*5 + c(0, 5))
  return(c(xx[1], yy[2], xx[2], yy[1]))
}

ui <- fluidPage(
  tags$style(type='text/css', HTML("#plot{background:url(https://thedatagame.files.wordpress.com/2016/03/nba_court.jpg);
                                    background-size: 200px 200px;
                                    background-repeat: no-repeat;}")),
  selectInput("pass", "Pass Location", 1:25),
  selectInput("possess", "Possession Location", 1:25, 25),
  uiOutput("style"),
  plotOutput("plot")
)


server <- function(input, output){
  output$plot <- renderPlot({
    par(mar = c(0,0,0,0))
    plot(0, 0, ylim = c(0,25), xlim = c(0, 25), type='p', yaxt = "n", 
         xaxt = "n", xlab = "", ylab = "")
    nr <- as.numeric(input$pass)
    posi <- pos(ifelse(nr%%5 > 0, nr%%5, 5),ceiling(nr/5))
    rect(posi[1], posi[2], posi[3], posi[4], col = rgb(0, 50, 255, 50, maxColorValue = 256))

    nr <- as.numeric(input$possess)
    posi <- pos(ifelse(nr%%5 > 0, nr%%5, 5),ceiling(nr/5))
    rect(posi[1], posi[2], posi[3], posi[4], col = rgb(255, 50, 0, 50, maxColorValue = 256))

  }, bg="transparent", width = 200, height = 200)
}

runApp(shinyApp(ui, server), launch.browser = TRUE)