添加多个“滑块"到同一张图 [英] Adding Multiple "sliders" to the same Graph

问题描述

我正在使用 R 编程语言.使用情节"图书馆，我能够制作以下交互式图表:

库(dplyr)图书馆(ggplot2)图书馆(闪亮)图书馆(情节)库(htmltools)图书馆(dplyr)#生成数据set.seed(123)var = rnorm(731, 100,25)date= seq(as.Date("2014/1/1"), as.Date("2016/1/1"),by="day")数据 = data.frame(var,date)瓦尔斯 <- 90:100结合 <- 向量('list', length(vals))计数 <- 0for (i in vals) {数据$var_i = i数据$new_var_i = ifelse(数据$var >i,1,0)#观察值大于 i 的百分比(每个月)aggregate_i = 数据 %>%变异(日期 = as.Date(日期))%>%group_by(month = format(date, "%Y-%m")) %>%总结(平均值=平均值(new_var_i))#合并文件聚合_i$var = iaggregate_i$var = as.factor(aggregate_i$var)计数 <- 计数 + 1combine[[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.frame(var,date)瓦尔斯 <- 90:100结合 <- 向量('list', length(vals))计数 <- 0for (i in vals) {数据$var_i = i数据$new_var_i = ifelse(数据$var >i,1,0)#观察值大于 i 的百分比(每个月)aggregate_i = 数据 %>%变异(日期 = as.Date(日期))%>%group_by(month = format(date, "%Y-%m")) %>%总结(平均值=平均值(new_var_i))#合并文件聚合_i$var = iaggregate_i$var = as.factor(aggregate_i$var)计数 <- 计数 + 1combine[[count]] <- aggregate_i}result_2 <- bind_rows(combine)result_2$group = "group_b";result_2$group = as.factor(result_2$group)#合并所有文件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(标题")gg = ggplotly(gg)

现在，我正在尝试制作两个独立的滑块".:一个滑块"；对于group_a"和另一个滑块"对于group_b".看起来像这样的东西:

我的逻辑是，框架"；ggplot()"中的参数声明应该有两个层次:

gg <-ggplot(final, aes(frame = c(var,group), color = group)) + geom_line(aes(x=month, y=mean, group=1))+ 主题(axis.text.x = element_text(angle=90)) + ggtitle(标题")gg错误:美学长度必须为 1 或与数据 (550) 相同:帧

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

谢谢

解决方案

我不认为你可以用标准的 plotly API 做到这一点.

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

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

其实有一种保持动画方面的方法我不知道，但你需要深入了解shiny/plotly.看看

I am using the R programming language. Using the "plotly" library, I was able to make the following interactive graph:

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)

Now, I am trying to make two separate "sliders" : one "slider" for "group_a" and another "slider" for "group_b". Something that looks like this:

My logic is, the "frame" argument within the "ggplot()" statement should have two levels:

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

Can someone please show me how to fix this?

Thanks

解决方案

I don't think you can do this with the standard plotly API.

I think for cases like this it is better to use shiny and create a web application. You can add as many sliders as you need and then filter the data as needed to update the plots.

The downside to this is that you are just redrawing the plots with new data, as opposed to doing animations like before. So you end up loosing the smooth transitions that you had before.

There is actually a way of keeping the animation aspect that I didn't know, but you need to go deeper into shiny/plotly. Take a look at this link. I didn't know about this, so I didn't try to do it. But i will take a look at it later!

Here is my solution with shiny:

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)

这篇关于添加多个“滑块"到同一张图的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！