selectInput 只输出第一个选项
selectInput only outputs first option
我正在编写一个闪亮的应用程序来通过拖放操作每个时间间隔的每日呼叫到达百分比分布。
我试图通过 select 输入仅显示一天。
但是，当我 select 星期一以外的另一天（select 输入中的第一个选项）时，数据表输出和绘图输出不会改变，即输出（数据表和绘图）只显示星期一，无论我做什么我正在 select 通过 select 输入。
感谢您的帮助！提前致谢！
虚拟数据：
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)
我编辑了这些部分并删除了 isolate 的：
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)
我正在编写一个闪亮的应用程序来通过拖放操作每个时间间隔的每日呼叫到达百分比分布。 我试图通过 select 输入仅显示一天。 但是，当我 select 星期一以外的另一天（select 输入中的第一个选项）时，数据表输出和绘图输出不会改变，即输出（数据表和绘图）只显示星期一，无论我做什么我正在 select 通过 select 输入。
感谢您的帮助！提前致谢！
虚拟数据：
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)
我编辑了这些部分并删除了 isolate 的：
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)