1

我正在编写一个闪亮的应用程序来通过拖放操作每个时间间隔的呼叫到达的每日百分比分布。我试图仅通过 selectInput 显示一天。但是，当我选择星期一以外的另一天（selectInput 中的第一个选项）时，DataTable 输出和绘图输出不会改变，即无论我通过 selectInput 选择什么，输出（数据表和绘图）仅显示星期一。

感谢你的帮助！先感谢您！

虚拟数据：

save_name2 <- paste("Percentage_Forecasts.csv")
df_MON<-data.frame(b=c("MON 07:00","MON 07:30","MON 08:00","MON 08:30","MON 09:00","MON 09:30","MON 10:00"),a=c(15,20,14,6,10,15,20))
df_TUE<-data.frame(b=c("TUE 07:00","TUE 07:30","TUE 08:00","TUE 08:30","TUE 09:00","TUE 09:30","TUE 10:00"),a=c(15,20,14,6,10,15,20))
df_WED<-data.frame(b=c("WED 07:00","WED 07:30","WED 08:00","WED 08:30","WED 09:00","WED 09:30","WED 10:00"),a=c(15,20,14,6,10,15,20))
df_THU<-data.frame(b=c("THU 07:00","THU 07:30","THU 08:00","THU 08:30","THU 09:00","THU 09:30","THU 10:00"),a=c(15,20,14,6,10,15,20))
df_FRI<-data.frame(b=c("FRI 07:00","FRI 07:30","FRI 08:00","FRI 08:30","FRI 09:00","FRI 09:30","FRI 10:00"),a=c(15,20,14,6,10,15,20))
df_SAT<-data.frame(b=c("SAT 07:00","SAT 07:30","SAT 08:00","SAT 08:30","SAT 09:00","SAT 09:30","SAT 10:00"),a=c(15,20,14,6,10,15,20))

这是我的 ui.R：

ui <- fluidPage( titlePanel("Prozentuale Verteilung Prognosewoche"),
                 fluidRow(

                   column(selectInput(inputId = "dataset",
                                      label = "Choose a weekday",
                                      choices = c("MON", "TUE","WED","THU","FRI","SAT")),

                          DTOutput("table"),width = 5,downloadButton("downloadData", "Save")),
                   column(12, plotlyOutput("p"))))

这是我的server.R：

server <- function(input, output, session) {

#i think here is where the problem starts!
  datasetInput <- reactive({
    switch(input$dataset,
           "MON" = df_MON,
           "TUE" = df_TUE,
           "WED" = df_WED,
           "THU" = df_THU,
           "FRI" = df_FRI,
           "SAT" = df_SAT)
  })


  rv <- reactiveValues(
    x = isolate(datasetInput())$b,
    y = isolate(datasetInput())$a)

  grid <- reactive({
    data.frame(y = rv$y, length=180)})

  output$p <- renderPlotly({
    circles <- map2(rv$x,
                    rv$y, 
                    ~list(
                      type = "circle",
                      xanchor = .x,
                      yanchor = .y,
                      x0 = -4, x1 = 4,
                      y0 = -4, y1 = 4,
                      xsizemode = "pixel", 
                      ysizemode = "pixel",
                      # other visual properties
                      fillcolor = "orange",
                      line = list(color = "transparent") ) )


    plot_ly(grid(), type="scatter", mode='lines+markers',  width = 1200, height = 300) %>%
      add_trace(y = grid()$y, x = isolate(datasetInput())$b,mode='lines+markers') %>%
      layout(shapes = circles) %>%
      config(edits = list(shapePosition = TRUE))
  })

  output$table <-renderDT(rbind({data.frame(rv$x,rv$y)}, c(NULL,sum(rv$y))),colnames=c("Weekday/Time", "Percentage"),width = 800,options = list(
    lengthMenu = list(c(15,31), list('15','31')),
    pageLength = 15,  initComplete = JS(
      "function(settings, json) {",
      "$(this.api().table().body()).css({'font-size': '70%'});",
      "}")
  ))

  observe({
    ed <- event_data("plotly_relayout")
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2) return()
    row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
    pts <- as.numeric(shape_anchors)
    rv$y[row_index] <- pts[2]
  })

  output$downloadData <- downloadHandler(
    filename = function(){save_name2}, 
    content = function(fname){
      write.table(data.frame(rv$x,rv$y), row.names=FALSE, sep=";", fname,col.names=c("Weekday/Calendar Week","Percentage"))
    })

}

shinyApp(ui, server)
4

1 回答 1

0

我编辑了这些部分并删除了isolate's：

    rv <- reactiveValues()

    observe({
        rv$x = datasetInput()$b
        rv$y = datasetInput()$a
    })

和

add_trace(y = grid()$y, x = rv$x,mode='lines+markers')

完整的服务器代码：

server <- function(input, output, session) {

    #i think here is where the problem starts!
    datasetInput <- reactive({
        switch(input$dataset,
               "MON" = df_MON,
               "TUE" = df_TUE,
               "WED" = df_WED,
               "THU" = df_THU,
               "FRI" = df_FRI,
               "SAT" = df_SAT)
    })


    rv <- reactiveValues()

    observe({
        rv$x = datasetInput()$b
        rv$y = datasetInput()$a
    })

    grid <- reactive({
        data.frame(y = rv$y, length=180)})

    output$p <- renderPlotly({
        circles <- map2(rv$x,
                        rv$y, 
                        ~list(
                            type = "circle",
                            xanchor = .x,
                            yanchor = .y,
                            x0 = -4, x1 = 4,
                            y0 = -4, y1 = 4,
                            xsizemode = "pixel", 
                            ysizemode = "pixel",
                            # other visual properties
                            fillcolor = "orange",
                            line = list(color = "transparent") ) )


        plot_ly(grid(), type="scatter", mode='lines+markers',  width = 1200, height = 300) %>%
            add_trace(y = grid()$y, x = rv$x,mode='lines+markers') %>%
            layout(shapes = circles) %>%
            config(edits = list(shapePosition = TRUE))
    })

    output$table <-renderDT(rbind({data.frame(rv$x,rv$y)}, c(NULL,sum(rv$y))),colnames=c("Weekday/Time", "Percentage"),width = 800,options = list(
        lengthMenu = list(c(15,31), list('15','31')),
        pageLength = 15,  initComplete = JS(
            "function(settings, json) {",
            "$(this.api().table().body()).css({'font-size': '70%'});",
            "}")
    ))

    observe({
        ed <- event_data("plotly_relayout")
        shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
        if (length(shape_anchors) != 2) return()
        row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
        pts <- as.numeric(shape_anchors)
        rv$y[row_index] <- pts[2]
    })

    output$downloadData <- downloadHandler(
        filename = function(){save_name2}, 
        content = function(fname){
            write.table(data.frame(rv$x,rv$y), row.names=FALSE, sep=";", fname,col.names=c("Weekday/Calendar Week","Percentage"))
        })

}

shinyApp(ui, server)
于 2019-08-20T12:56:43.917 回答