在 shiny 应用程序中使用 sliderInput 为区域着色

Question

赏金将在 2 天后到期。 此问题的答案有资格获得+50声望赏金。 TarJae想让更多人关注这个问题。

我有这个改编自 web 的小示例应用程序：

library( shiny )
library( shinyWidgets )

  ui <- fluidPage(
    
    tags$br(),
    
    noUiSliderInput(
      inputId = "noui2", label = "Slider vertical:",
      min = 0, max = 1000, step = 50,
      value = c(100, 400), margin = 100,
      orientation = "vertical",
      width = "100px", height = "300px"
    ),
    verbatimTextOutput(outputId = "res2")
    
  )
  
  server <- function(input, output, session) {
    
    output$res2 <- renderPrint(input$noui2)
    
  }
  
  shinyApp(ui, server)

然后我加载图像作为背景，如：

我想知道是否有一种方法可以为图形边界中 100 到 400 之间（由滑块给出）的特定区域高度着色，例如：

Answer 1

请在下面找到一种使用 plotly 的填充区域图的方法：

library(shiny)
library(plotly)
library(shinyWidgets)

DF <- data.frame(
    x = c(cos(seq(0.01, 10, 0.01)) * 1000:1 + 1000, cos(seq(0.01, 10, 0.01)) * 1000:1 + 1500),
    y = rep(1:1000, 2),
    id = c(rep("trace_1", 1000), rep("trace_2", 1000))
  )

ui <- fluidPage(
  br(),
  column(
    2,
    noUiSliderInput(
      inputId = "noui2",
      label = "Slider vertical:",
      min = 0,
      max = 1000,
      step = 50,
      value = c(100, 400),
      margin = 100,
      orientation = "vertical",
      direction = c("rtl"),
      width = "100px",
      height = "350px"
    )
  ),
  column(4, plotlyOutput("plot")),
  verbatimTextOutput(outputId = "res2")
)

server <- function(input, output, session) {
  output$res2 <- renderPrint(input$noui2)
  
  plotDF <- reactive({
    plotDF <- DF[DF$y %in% input$noui2[1]:input$noui2[2], ]
    plotDF$id <- paste0("filtered_", plotDF$id)
    plotDF
  })
  
  output$plot <- renderPlotly({
    fig <- plot_ly(
        rbind(DF, plotDF()),
        x = ~ x,
        y = ~ y,
        split = ~ id,
        type = "scatter",
        mode = "lines",
        color = I("black"),
        fillcolor = 'red',
        showlegend = FALSE
      ) |> style(fill = 'tonexty', traces = 2)
  })
}

shinyApp(ui, server)

Answer 2

这是第一次尝试，alignment 并不完美，但它传达了这个想法。 请注意绘图框仍然存在，以便更深入地了解对齐时发生的情况。

library( shiny )
library( shinyWidgets )

ui <- fluidPage(
  
  tags$br(),
  fluidRow(
  column(2,noUiSliderInput(
    inputId = "noui2", label = "Slider vertical:",
    min = 0, max = 1000, step = 50,
    value = c(100, 400), margin = 100,
    orientation = "vertical",
    width = "100px", height = "300px"
  )),column(10,plotOutput("plot",height = "330px"))
  ),
  verbatimTextOutput(outputId = "res2")
  
)

server <- function(input, output, session) {
  
  output$res2 <- renderPrint(input$noui2)
  output$plot<-renderPlot({
    par(mar=c(0,0,1.5,0))
    plot(type='n',0:1*1000,0:1*1000, xlab='', ylab='', xaxt='n', yaxt='n')
    rect(100, 1000-input$noui2[2], 300,1000-input$noui2[1] , col='red')
  })
}

shinyApp(ui, server)