将多个“滑块”添加到同一个图表

Question

我正在使用 R 编程语言。使用“plotly”库，我能够制作以下交互式图表：

library(dplyr)
library(ggplot2)
library(shiny)
library(plotly)
library(htmltools)

library(dplyr)
#generate data
set.seed(123)

var = rnorm(731, 100,25)
date= seq(as.Date("2014/1/1"), as.Date("2016/1/1"),by="day")
data = data.frame(var,date)

vals <- 90:100
combine <- vector('list', length(vals))
count <- 0
for (i in vals) {
    
    data$var_i = i
    data$new_var_i = ifelse(data$var >i,1,0)
    
    #percent of observations greater than i (each month)
    aggregate_i = data %>%
        mutate(date = as.Date(date)) %>%
        group_by(month = format(date, "%Y-%m")) %>%
        summarise( mean = mean(new_var_i))
    
    #combine files together
    
    aggregate_i$var = i
    aggregate_i$var = as.factor(aggregate_i$var)
    
    count <- count + 1
    combine[[count]] <- aggregate_i
    
}

result_1 <- bind_rows(combine)
result_1$group = "group_a"
result_1$group = as.factor(result_1$group)

######

var = rnorm(731, 85,25)
date= seq(as.Date("2014/1/1"), as.Date("2016/1/1"),by="day")
data = data.frame(var,date)

vals <- 90:100
combine <- vector('list', length(vals))
count <- 0
for (i in vals) {
    
    data$var_i = i
    data$new_var_i = ifelse(data$var >i,1,0)
    
    #percent of observations greater than i (each month)
    aggregate_i = data %>%
        mutate(date = as.Date(date)) %>%
        group_by(month = format(date, "%Y-%m")) %>%
        summarise( mean = mean(new_var_i))
    
    #combine files together
    
    aggregate_i$var = i
    aggregate_i$var = as.factor(aggregate_i$var)
    
    count <- count + 1
    combine[[count]] <- aggregate_i
    
}

result_2 <- bind_rows(combine)
result_2$group = "group_b"
result_2$group = as.factor(result_2$group)

#combine all files

final = rbind(result_1, result_2)

gg <-ggplot(final, aes(frame = var, color = group)) + geom_line(aes(x=month, y=mean, group=1))+ theme(axis.text.x = element_text(angle=90)) + ggtitle("title")

gg = ggplotly(gg)

现在，我正在尝试制作两个单独的“滑块”：一个“滑块”用于“group_a”，另一个“滑块”用于“group_b”。看起来像这样的东西：

我的逻辑是，“ggplot()”语句中的“frame”参数应该有两个层次：

gg <-ggplot(final, aes(frame = c(var,group), color = group)) + geom_line(aes(x=month, y=mean, group=1))+ theme(axis.text.x = element_text(angle=90)) + ggtitle("title")

gg
Error: Aesthetics must be either length 1 or the same as the data (550): frame

谁能告诉我如何解决这个问题？

谢谢

Answer 1

我认为您不能使用标准的 plotly API 做到这一点。

我认为对于这种情况，最好使用shiny 并创建一个 Web 应用程序。您可以根据需要添加任意数量的滑块，然后根据需要过滤数据以更新绘图。

这样做的缺点是您只是用新数据重新绘制绘图，而不是像以前那样制作动画。因此，您最终会失去以前的平滑过渡。

其实有一种保持动画方面的方法我不知道，但你需要深入了解shiny/plotly。看看this link。我不知道这件事，所以我没有尝试这样做。不过我以后会看的！

这是我的闪亮解决方案：

library(shiny)
library(plotly)
library(dplyr)

gendata <- function(){
    #generate data
    set.seed(123)
    
    var = rnorm(731, 100,25)
    date= seq(as.Date("2014/1/1"), as.Date("2016/1/1"),by="day")
    data = data.frame(var,date)
    
    vals <- 90:100
    combine <- vector('list', length(vals))
    count <- 0
    for (i in vals) {
        
        data$var_i = i
        data$new_var_i = ifelse(data$var >i,1,0)
        
        #percent of observations greater than i (each month)
        aggregate_i = data %>%
            dplyr::mutate(date = as.Date(date)) %>%
            dplyr::group_by(month = format(date, "%Y-%m")) %>%
            dplyr::summarise(mean = mean(new_var_i), .groups='drop')
        
        #combine files together
        
        aggregate_i$var = i
        aggregate_i$var = as.factor(aggregate_i$var)
        
        count <- count + 1
        combine[[count]] <- aggregate_i
        
    }
    
    result_1 <- bind_rows(combine)
    result_1$group = "group_a"
    result_1$group = as.factor(result_1$group)
    
    ######
    
    var = rnorm(731, 85,25)
    date= seq(as.Date("2014/1/1"), as.Date("2016/1/1"),by="day")
    data = data.frame(var,date)
    
    vals <- 90:100
    combine <- vector('list', length(vals))
    count <- 0
    for (i in vals) {
        
        data$var_i = i
        data$new_var_i = ifelse(data$var >i,1,0)
        
        #percent of observations greater than i (each month)
        aggregate_i = data %>%
            dplyr::mutate(date = as.Date(date)) %>%
            dplyr::group_by(month = format(date, "%Y-%m")) %>%
            dplyr::summarise(mean = mean(new_var_i), .groups='drop')
        
        #combine files together
        
        aggregate_i$var = i
        aggregate_i$var = as.factor(aggregate_i$var)
        
        count <- count + 1
        combine[[count]] <- aggregate_i
        
    }
    
    result_2 <- bind_rows(combine)
    result_2$group = "group_b"
    result_2$group = as.factor(result_2$group)
    
    # combine all files
    # note: sliderInput needs numeric data, so I converted values of "var" to numeric
    final <- rbind(result_1, result_2)
    final$var <- as.integer(as.character(final$var))

    return(final)
}

final <- gendata()

ui <- fluidPage(
    fluidRow(column=12,
             plotlyOutput("lineplot")),
    fluidRow(column=12,
             # create slider for group a
             sliderInput("groupa", "Group A:",
                         min = min(final$var), max = max(final$var),
                         value = min(final$var), step = 1,
                         animate =
                             animationOptions(interval = 300, loop = FALSE),
                         width='95%')),
    fluidRow(column=12,
             # create slider for group b
             sliderInput("groupb", "Group B:",
                         min = min(final$var), max = max(final$var),
                         value = min(final$var), step = 1,
                         animate =
                             animationOptions(interval = 300, loop = FALSE),
                         width='95%')))

server <- function(input, output, session){
    
    # create a reactive dataframe with filtered data for group a at current value of var
    df.a <- reactive({
        final %>% dplyr::filter(group == 'group_a') %>%
            dplyr::filter(var == input$groupa)
    })
    
    # create a reactive dataframe with filtered data for group b at current value of var
    df.b <- reactive({
        final %>% dplyr::filter(group == 'group_b') %>%
            dplyr::filter(var == input$groupb)
    })
    
    # Create plotly with filtered data
    output$lineplot <- renderPlotly({
        plot_ly() %>%
            add_trace(data=df.a(), x=~month, y=~mean, color=~group, type = 'scatter', mode = 'lines', colors = 'Set1') %>%
            add_trace(data=df.b(), x=~month, y=~mean, color=~group, type = 'scatter', mode = 'lines', colors = 'Set1')
    })
}

shinyApp(ui, server)