我有三个下拉菜单可以过滤两个独立的数据框。此外，在特定过滤期间，侧边栏面板中会显示一个复选框，用于生成动态图。
问题在于：1。多个滑块出现，但它们不是动态的; 2.我似乎无法根据滑块调整多个绘图b / c滑块不是动态的。我删除了一堆正常工作的代码，因为它使服务器端代码更长，并且与此问题无关。
基于故障排除，我认为问题如下：1。变量输入$ meterslider是一个列表，并没有在observe（{}）或int对象plots（）中正确加载。道歉，如果这实际上是一个简单的解决方案 - 我一直在寻找一个没有太多运气的答案。任何帮助非常感谢！为长代码道歉，但我希望尽可能全面。
shinyUI(fluidPage(
sidebarPanel(
uiOutput("selectsector"),
uiOutput("selectfacility"),
uiOutput("selectcurvename"),
uiOutput("selectms"),
actionButton("do", "Click me to get new plots"),
mainPanel(
tabsetPanel(
tabPanel(
fluidRow(
column(12,
uiOutput("meterslider"),
plotOutput("metersites", height = 750, width = 1000), style = 'padding:50px'))
)
)
)
)
))
x <- c("shiny", "data.table", "dplyr", "lubridate", "stringr", "extrafont",
"ggplot2", "httr", "tidyr", "gridExtra", "scales")
lapply(x, require, character.only = T)
MC <- MC %>%
mutate(Building_Category = ifelse(Building_Category ==
"manufacturing", "Manufacturing", Building_Category),
Sector = ifelse(Curve_Name_Match == "CommercialIndustrial",
"Multiple", Sector),
DOW = as.character(as.factor(wday(DateHour, label = T, abbr =
T))))
OHcurves <- OHcurves %>%
mutate(Building_Category = ifelse(Building_Category == "All
Residential", "Residential", Building_Category),
Curve_Name_Match = ifelse(grepl("^Intlight_Manu",
Curve_Name_Match), "IntlightManufacturingCEUSBlend",
Curve_Name_Match),
DOW = as.character(as.factor(wday(Hour, label = T, abbr =
T))))
function(input, output, session) {
sec <- unique(OHcurves$Sector)
fac <- unique(OHcurves$Building_Category)
cn <- unique(OHcurves$Curve_Name_Match)
meter <- unique(MC$Customer)
output$selectsector <- renderUI({
selectInput("sector", "Select Sector", as.list(sec), selected = sec[1])
})
output$selectfacility <- renderUI({
if(is.null(input$sector)) {
return()
} else if(input$sector == "RS") {
res <- selectizeInput("facility", "Select Facility",
as.list("Residential"), selected = "Residential")
return(res)
} else if(input$sector == "Multiple") {
mult <- selectizeInput("facility", "Select Facility",
as.list("Other"), selected = "Other")
return(mult)
}
fac <- fac[fac != "Residential"]
selectizeInput("facility", "Select Facility", as.list(fac),
selected = fac[1])
})
output$selectcurvename <- renderUI({
if(is.null(input$sector)) {
return()
} else if(is.null(input$facility)) {
return()
} else if(input$sector == "RS") {
rescn <- OHcurves %>% filter(Sector == "RS")
rescn <- sort(unique(rescn$Curve_Name_Match))
res <- selectizeInput("curvename", "Select Curve Name",
as.list(rescn), selected = rescn[1])
return(res)
} else if(input$sector == "Multiple") {
mult <- selectizeInput("curvename", "Select Curve Name",
as.list("CommercialIndustrial"), selected =
"CommercialIndustrial")
return(mult)
} else if (input$sector == "CI") {
cicn <- OHcurves[which((OHcurves$Sector == input$sector) &
(OHcurves$Building_Category == input$facility)),
]
cicn <- unique(cicn$Curve_Name_Match)
selectizeInput("curvename", "Select Curve Name", as.list(cicn), selected = cicn[1])
}
})
output$selectms <- renderUI({
if(is.null(input$sector)) {
return()
} else if(is.null(input$facility)) {
return()
} else if(is.null(input$curvename)) {
return()
} else if(input$sector == "RS") {
cust <- OHcurves[which((OHcurves$Sector %in% input$sector) & (OHcurves$Building_Category %in% input$facility) & (OHcurves$Curve_Name_Match %in% input$curvename)), ]
cust <- unique(cust$Curve_Name_Match)
rs <- MC %>% filter(Sector == "RS" & Building_Category == "Residential")
cust <- rs[cust %in% rs$Curve_Name_Match]
cust <- unique(cust$Customer)
checkboxGroupInput("selectms", "Metered Sites: ", c(cust), c(cust))
} else if(input$sector == "Multiple") {
cust <- OHcurves[which((OHcurves$Sector %in% input$sector) & (OHcurves$Building_Category %in% input$facility) & (OHcurves$Curve_Name_Match %in% input$curvename)), ]
cust <- unique(cust$Curve_Name_Match)
mult <- MC %>% filter(Sector == "Multiple" & Building_Category == "Other")
cust <- mult[cust %in% mult$Curve_Name_Match]
cust <- unique(cust$Customer)
checkboxGroupInput("selectms", "Metered Sites: ", c(cust), c(cust))
} else if(input$sector == "CI") {
ci <- MC[((MC$Sector %in% input$sector) & (MC$Building_Category %in% input$facility) & (MC$Curve_Name_Match %in% input$curvename)),]
ci <- unique(ci$Customer)
checkboxGroupInput("selectms", "Metered Sites: ", c(ci), c(ci))
}
})
output$meterslider <- renderUI({
if(is.null(input$do) || input$do == 0) {
return(NULL)
}
if(length(input$selectms) == 0 || is.null(input$selectms) ||
input$selectms == 0){
return(NULL)
}
else{
subset <- MC[which((MC$Sector %in% input$sector) &
(MC$Building_Category %in% input$facility) &
(MC$Curve_Name_Match %in% input$curvename) &
(MC$Customer %in% input$selectms)), ]
sub <- split(subset, input$selectms)
dates <- lapply(1:length(sub), function(x)
x <- sub[[x]] %>%
dplyr::select(DateHour))
names(dates) <- unique(subset$Customer)
ms.min <- lapply(1:length(dates), function(x)
as.POSIXct(min(dates[[x]]$DateHour), origin ='1970-01-01', tz = "EST")
)
ms.max <-lapply(1:length(dates), function(x)
as.POSIXct(max(dates[[x]]$DateHour), origin ='1970-01-01', tz = "EST")
)
lapply(1:length(dates), function(x)
sliderInput("slider", paste(names(dates)[[x]], "Adjust Dates Here:", sep = " "),
min = as.POSIXct(ms.min[[x]], origin ='1970-01-01', tz = "EST"),
max = as.POSIXct(ms.max[[x]], origin ='1970-01-01', tz = "EST"),
value = c(as.POSIXct(ms.min[[x]], origin ='1970-01-01', tz = "EST"),
as.POSIXct(ms.max[[x]], origin ='1970-01-01', tz = "EST"))))
}
})
observe({
slide <- input$meterslider
lapply(1:length(slide), function(x)
updateSliderInput(session, "meterslider", value = c(slide[[x]], slide[[x]])))
})
plots <- reactive({
input$do
isolate({
if(is.null(input$sector)) {
return(NULL)
}
if(is.null(input$facility)) {
return(NULL)
}
if(is.null(input$curvename)) {
return(NULL)
}
if(is.null(input$selectms)) {
return(NULL)
}
if(length(input$selectms) > 0) {
subset <- MC[which((MC$Sector %in% input$sector) &
(MC$Building_Category %in% input$facility) &
(MC$Curve_Name_Match %in% input$curvename) &
(MC$Customer %in% input$selectms)), ]
sub <- split(subset, input$selectms)
if (is.null(input$meterslider) || input$meterslider == 0) {
sub <- lapply(1:length(sub), function(x)
p <- ggplot(sub[[x]], aes(x = DateHour, y = HourlyCurve)) + geom_line() + ylab("Energy Savings") +
xlab("Time") + ggtitle(sub[[x]]$Customer) +
theme(legend.position = "bottom", text=element_text(size=14, family="Gill Sans MT"),
panel.grid.minor.x = element_blank(),
panel.background = element_rect(fill = 'white'), panel.grid.minor.y = element_blank(),
axis.line.x = element_line(color = "black", size = 1),
axis.ticks = (element_line(color = "black", size = 1)),
axis.line.y = element_line(color = "black", size = 1),
axis.text = element_text(color = "black")))
return(sub)
}
if (!(is.null(input$meterslider))|| input$meterslider != 0) {
slide <- input$meterslider
slide <- lapply(1:length(slide), function(x)
x <- seq(min(slide[[x]]), max(slide[[x]]), by = "hour"))
sub <- lapply(1:length(sub), function(x)
sub[[x]] %>% filter(DateHour %in% slide[[x]]))
sub <- lapply(1:length(sub), function(x)
p <- ggplot(sub[[x]], aes(x = DateHour, y = HourlyCurve)) + geom_line() + ylab("Energy Savings") +
xlab("Time") + ggtitle(sub[[x]]$Customer) +
theme(legend.position = "bottom", text=element_text(size=14, family="Gill Sans MT"),
panel.grid.minor.x = element_blank(),
panel.background = element_rect(fill = 'white'), panel.grid.minor.y = element_blank(),
axis.line.x = element_line(color = "black", size = 1),
axis.ticks = (element_line(color = "black", size = 1)),
axis.line.y = element_line(color = "black", size = 1),
axis.text = element_text(color = "black")))
return(sub)
}
}
else {
return(NULL)
}
})
})
output$metersites <- renderPlot({
if(length(plots()) > 0) {
print(do.call("grid.arrange", c(plots(), ncol = 2)))
} else {
return(NULL)
}
})
}