search

jbkunst / highcharter

R wrapper for highcharts
http://jkunst.com/highcharter/
Other
719 stars 148 forks source link

Strange reactive update behaviour with div wrapped around highcharter objects #345

Open MartinGuth opened 7 years ago

MartinGuth commented 7 years ago

Hey Joshua (@jbkunst),

first of all: I really love your package! It makes shiny apps even better! And I would like to thank you for your quick responses here and over at Stackoverflow - saved my developer-life quit a few times now ;-)

However, I've discovered a strange reactive update/render behaviour with the charts when you wrap an object with a div and set the same name for both IDs, the div ID and the highcharter ID. I know, setting the same name for something like an ID isn't really a good idea, but I wasn't thinking about it and thus spent the last days debugging this problem. However, base R objects like barplots or a data tables do not have said problem with the same ID, i.e. they update/render properly.

Here is a small working example wich reproduces the bug. If the user changes the input in the dropdown, both charts should be redrawn. However, sometimes both do not react on the change. Sometimes only the waterfall chart reacts to the changes, but not the barchart:

library(shiny)
library(dplyr)
library(highcharter)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      uiOutput("cars")
    ),

    mainPanel(
      tabsetPanel(
        tabPanel("Linechart",
                 div(id = "hc_linechart",
                     highchartOutput("hc_linechart", height = "500px")
                 )
        ),
        tabPanel("Waterfall",
                 div(id = "hc_waterfall",
                     highchartOutput("hc_waterfall", height = "500px")
                 )   
        )
      )
    )
  )
)

server <- function(input, output) {

  output$cars <- renderUI({
    selectizeInput(
      inputId = "cars",
      label = NULL,
      choices = rownames(mtcars),
      options = list(placeholder = 'Cars')
    )
  })

  output$hc_linechart <- renderHighchart({

    data_line <- subset(mtcars, rownames(mtcars) %in% input$cars)

    hc <- highchart() %>%
      hc_chart(type = "column") %>%
      hc_title(text = rownames(data_line), useHTML = TRUE) %>%
      hc_yAxis(title = "") %>%
      hc_xAxis(title = "")

    for(i in 1:(ncol(data_line)))
    {
      hc <- hc %>%
        hc_add_series(data = data_line[,i], name = names(data_line)[i])
    }
    hc
  })

  output$hc_waterfall <- renderHighchart({
    data_line <- subset(mtcars, rownames(mtcars) %in% input$cars)
    name <- c(names(data_line),"Sum")

    y <- data_line[,1]
    color <- "#377EB8"

    for(i in 2:(ncol(data_line)))
    {
      y <- c(y, data_line[,i]-data_line[,i-1])

      if(y[i] > 0)
      {
        color <- c(color, "#4DAF4A")
      }else
      {
        color = c(color, "#E41A1C")
      }
    }

    y <- c(y, NA)
    color = c(color, "#377EB8")

    isIntermediateSum = rep(FALSE, times = 12)
    isSum <- rep(FALSE, times = 11)
    isSum <- c(isSum, TRUE)

    dataframe = data.frame(name, y, isIntermediateSum, isSum, color, stringsAsFactors = F)

    hc <- highchart() %>%
      hc_chart(type = "waterfall") %>%
      hc_title(text = rownames(data_line), useHTML = TRUE) %>%
      hc_yAxis(title = "") %>%
      hc_xAxis(title = "") %>%
      hc_add_series(data = dataframe, 
                    dataLabels = list(
                      enabled=TRUE,
                      formatter= JS("function(){ return Highcharts.numberFormat(this.y, 2, ',');}"),
                      style=list(
                        color="#FFFFFF",
                        fontWeight="bold",
                        textShadow="0px 0px 3px black"
                      )
                    )
      )
    hc
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

If you change the ID of the divs or the highcharter objects, the update mechanism works as expected. Here I change the div IDs to "_css_hclinechart" and "_css_hcwaterfall":

        tabPanel("Linechart",
                 div(id = "css_hc_linechart",
                     highchartOutput("hc_linechart", height = "500px")
                 )
        ),
        tabPanel("Waterfall",
                 div(id = "css_hc_waterfall",
                     highchartOutput("hc_waterfall", height = "500px")
                 )     
        )

Now let's take other R objects instead of the highcharter object, but use again the same IDs:

library(shiny)
library(reshape2)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      uiOutput("cars")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Linechart",
                 div(id = "hc_linechart",
                     plotOutput("hc_linechart")
                 )
        ),
        tabPanel("Waterfall",
                 div(id = "hc_waterfall",
                     dataTableOutput("hc_waterfall")
                 )      
        )
      )
    )
  )
)

server <- function(input, output) {

  output$cars <- renderUI({
    selectizeInput(
      inputId = "cars",
      label = NULL,
      choices = rownames(mtcars),
      options = list(placeholder = 'Cars')
    )
  })

  output$hc_waterfall <- renderDataTable({
    data_line <- subset(mtcars, rownames(mtcars) %in% input$cars)
    return(data_line)
  },  options = list(orderClasses = TRUE, pageLength = 20)
  )

  output$hc_linechart <- renderPlot({
    data_line <- subset(mtcars, rownames(mtcars) %in% input$cars)
    data_line <- melt(data_line, measure.vars = 1:11)
    barplot(data_line$value,
            main=rownames(data_line),
            ylab="Numbers",
            xlab="Parts"
    )
  })

}

# Run the application 
shinyApp(ui = ui, server = server)

As you can see, the chart and the data table update properly when the user changes the input.

Lastly, my session info:

> sessionInfo()
R version 3.3.3 (2017-03-06)
Platform: x86_64-redhat-linux-gnu (64-bit)
Running under: Red Hat Enterprise Linux

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C               LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8     LC_MONETARY=en_US.UTF-8   
 [6] LC_MESSAGES=en_US.UTF-8    LC_PAPER=en_US.UTF-8       LC_NAME=C                  LC_ADDRESS=C               LC_TELEPHONE=C            
[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       

attached base packages:
[1] grid      stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] gtools_3.5.0           reshape2_1.4.2         readxl_1.0.0           microbenchmark_1.4-2.1 purrr_0.2.2            feather_0.3.1         
 [7] highcharter_0.5.0      ggplot2_2.2.1          tidyr_0.6.1            dplyr_0.5.0            rintrojs_0.1.2         shinyjs_0.9           
[13] shinyBS_0.61           data.table_1.10.4      htmlTable_1.9          shiny_1.0.3           

loaded via a namespace (and not attached):
 [1] Rcpp_0.12.10     cellranger_1.1.0 plyr_1.8.4       xts_0.9-7        tools_3.3.3      digest_0.6.12    lubridate_1.6.0  jsonlite_1.5    
 [9] tibble_1.3.0     checkmate_1.8.2  gtable_0.2.0     nlme_3.1-131     lattice_0.20-35  igraph_1.0.1     psych_1.7.5      DBI_0.6-1       
[17] yaml_2.1.14      parallel_3.3.3   stringr_1.2.0    knitr_1.15.1     hms_0.3          htmlwidgets_0.9  R6_2.2.2         foreign_0.8-68  
[25] TTR_0.23-1       magrittr_1.5     backports_1.0.5  scales_0.4.1     htmltools_0.3.6  rlist_0.4.6.1    quantmod_0.4-9   assertthat_0.2.0
[33] mnormt_1.5-5     mime_0.5         xtable_1.8-2     colorspace_1.3-2 httpuv_1.3.3     stringi_1.1.5    miniUI_0.1.1     lazyeval_0.2.0  
[41] munsell_0.4.3    broom_0.4.2      zoo_1.8-0
jbkunst commented 7 years ago

Hey @MartinGuth !

I will take a look on this!

chalioui commented 4 years ago

Hello ! I'm facing the same issue, any progress on this ?