Search code examples
rplotlydata-visualizationinteractiver-plotly

Adding Multiple "sliders" to the same Graph

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)

enter image description here

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:

enter image description here

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

Solution

  • 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)

    enter image description here