Inconsistent behavior with numeric/non-numeric z values in heatmap

[violetr]

Hi,
I have a problem with a plotly heatmap in a shiny app, it is ok in Chrome but wrong in Firefox (Windows 10). And it happens until you click the heatmap. Here is the built app where I got the problem: https://violetr.shinyapps.io/tidytuesdaytweets/. Any idea?

Code to generate an app with only the heatmap:

library(shiny)
library(plotly)
#> Loading required package: ggplot2
#> 
#> Attaching package: 'plotly'
#> The following object is masked from 'package:ggplot2':
#> 
#>     last_plot
#> The following object is masked from 'package:stats':
#> 
#>     filter
#> The following object is masked from 'package:graphics':
#> 
#>     layout
library(tidyverse)
library(lubridate)
#> 
#> Attaching package: 'lubridate'
#> The following object is masked from 'package:base':
#> 
#>     date

# Define UI for application that draws a histogram
ui <- shinyUI(fluidPage(

  # Application title
  title = "example_firefox",
  h2("The graph:"),
  plotlyOutput("distPlot", height = "160px", width = "550px"),
  hr()
))


server <- shinyServer(function(input, output) {
  all_dates_period <-
    tibble(gen_date = as_date(as_date("2018-04-01"):as_date("2018-12-22"))) %>%
    mutate(
      month_name = month(gen_date, TRUE),
      week_num = epiweek(gen_date), # to  start on Sun
      week_day = wday(gen_date, TRUE),
      n = 0
    )

  base_to_heatmap <- all_dates_period %>%
    select(-month_name, -gen_date)

  output$distPlot <- renderPlotly({
    to_heatmap <-
      base_to_heatmap %>%
      spread(key = week_num, value = n) %>%
      as.data.frame()

    matrix_heatmap <- as.matrix(to_heatmap)
    matrix_heatmap <- matrix_heatmap[ nrow(matrix_heatmap):1, ]

    mycols <- c("#ebedf0", "#c6e48b", "#7bc96f", "#239a3b", "#196127")
    mypalette <- colorRamp(mycols)
    library(plotly)
    plot_ly(
      z = matrix_heatmap,
      type = "heatmap",
      colors = mypalette, xgap = 0.5, ygap = 0.5,
      showscale = FALSE
    ) %>%
      layout(
        yaxis = list(
          ticks = "",
          # ticktext = lab_row_days,
          tickmode = "array",
          tickfont = list(color = "86888A"),
          tickvals = 0:6,
          zeroline = FALSE
        ),
        xaxis = list(
          side = "top",
          # ticktext = lab_column_months,
          ticks = "",
          tickmode = "array", tickangle = 0,
          tickfont = list(color = "86888A"),
          tickvals = 0:38,
          zeroline = FALSE
        )
      ) %>%
      config(displayModeBar = FALSE)
  })
})

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

Shiny applications not supported in static R Markdown documents

^{Created on 2019-01-08 by the reprex package (v0.2.1)}

[cpsievert]

Thanks for the report! Interestingly, the problem seems to go away if you render this plot outside of shiny...can you confirm that it goes away for you?

all_dates_period <-
  tibble(gen_date = as_date(as_date("2018-04-01"):as_date("2018-12-22"))) %>%
  mutate(
    month_name = month(gen_date, TRUE),
    week_num = epiweek(gen_date), # to  start on Sun
    week_day = wday(gen_date, TRUE),
    n = 0
  )

base_to_heatmap <- all_dates_period %>%
  select(-month_name, -gen_date)

to_heatmap <-
  base_to_heatmap %>%
  spread(key = week_num, value = n) %>%
  as.data.frame()

matrix_heatmap <- as.matrix(to_heatmap)
matrix_heatmap <- matrix_heatmap[ nrow(matrix_heatmap):1, ]

mycols <- c("#ebedf0", "#c6e48b", "#7bc96f", "#239a3b", "#196127")
mypalette <- colorRamp(mycols)
plot_ly(
  z = matrix_heatmap,
  type = "heatmap",
  colors = mypalette, xgap = 0.5, ygap = 0.5,
  showscale = FALSE
) %>%
  layout(
    yaxis = list(
      ticks = "",
      # ticktext = lab_row_days,
      tickmode = "array",
      tickfont = list(color = "86888A"),
      tickvals = 0:6,
      zeroline = FALSE
    ),
    xaxis = list(
      side = "top",
      # ticktext = lab_column_months,
      ticks = "",
      tickmode = "array", tickangle = 0,
      tickfont = list(color = "86888A"),
      tickvals = 0:38,
      zeroline = FALSE
    )
  ) %>%
  config(displayModeBar = FALSE)

[cpsievert]

Whoops, nevermind, the issue is still there...I think this is related to the fact that there are non-numeric values in z:

matrix_heatmap[,1:2]

     week_day 14 
[1,] "Sat"    "0"
[2,] "Fri"    "0"
[3,] "Thu"    "0"
[4,] "Wed"    "0"
[5,] "Tue"    "0"
[6,] "Mon"    "0"
[7,] "Sun"    "0"

Getting rid of these 'NaN' values should fix the problem

[violetr]

Yes , it goes also for me.
The first column was the problem you said but that's another thing. I forgot to put column_to_rownames()

to_heatmap <-
  base_to_heatmap %>%
  spread(key = week_num, value = n) %>%
  as.data.frame()%>%
  column_to_rownames("week_day")

[cpsievert]

Great, feel free to reopen if you still have any issues

[violetr]

But I need it inside shiny :S And still renders it wrong inside the server for firefox.
Should I ask shiny team?

[cpsievert]

Should I ask shiny team?

No need. I suspect the issue in your shiny app is due to a similar problem (a mix of numeric and non-numeric z values in the heatmap).

If you can share the code, I might be able to help remove the non-numeric values.

[cpsievert]

I'll reopen since plotly.js could handle this behavior better (i.e., make it consistent between browsers), but it isn't really clear what the right behavior should be when you have both numeric and non-numeric values

[violetr]

Here is the app with the data .rds:

https://github.com/violetr/tidytuesday/tree/master/2019_01_01_shiny.

And here a reduced version only with the heatmap:

library(shiny)
library(plotly)
library("magrittr")
library(tidyverse)
library(lubridate)

# Define UI for application that draws a histogram
ui <- shinyUI(fluidPage(

  # Application title
  title = "example_firefox",
  h2("The graph:"),
  plotlyOutput("distPlot", height = "160px", width = "550px"),
  hr()
))

median_week <- function(month_i, data_wm) {
  median_week <-
    data_wm %>%
    dplyr::filter(month_name == month_i) %>%
    pull(week_num) %>%
    unique() %>%
    as.integer() %>%
    median() %>%
    round() %>%
    as.integer()

  median_week
}

compute_hover <- function(matrix_heatmap_ij, date_ij) {
  hover <- ""
  if (matrix_heatmap_ij == 0) {
    hover <- "No contributions, on "
  } else if (matrix_heatmap_ij == 1) {
    hover <- "1 contribution, on "
  } else {
    hover <- paste0(matrix_heatmap_ij, " contributions, on")
  }
  return(paste0(hover, " ", month(date_ij, TRUE), " ", day(date_ij), ", 2018"))
}


server <- shinyServer(function(input, output) {
  Sys.setlocale("LC_TIME", "English") # for day names

  data_tweets_tt <- readRDS("tidytuesday_tweets.rds")

  all_dates_period <-
    tibble(gen_date = as_date(as_date("2018-04-01"):as_date("2018-12-22"))) %>%
    mutate(
      month_name = month(gen_date, TRUE),
      week_num = epiweek(gen_date), # to  start on Sun
      week_day = wday(gen_date, TRUE)
    )

  # chosen <- eventReactive(input$go, {
  #   input$select
  # })

  base_to_heatmap <- all_dates_period %>%
    select(-month_name, -gen_date)

  output$distPlot <- renderPlotly({
    filter_by <- ""
    if (is.null(input$select) || !(input$select %in% vector_tw)) {
      filter_by <- "drob"
    } else {
      filter_by <- input$select
    }
    data_calendar <- data_tweets_tt %>%
      mutate(created_at = lubridate::as_date(created_at)) %>%
      dplyr::filter(screen_name == filter_by) %>%
      select(created_at) %>%
      mutate(
        month_name = month(created_at, TRUE),
        week_num = epiweek(created_at), # to  start on Sun
        week_day = wday(created_at, TRUE)
      ) %>%
      arrange(created_at) %>%
      group_by(week_num, week_day) %>%
      summarize(
        month_name = first(month_name),
        n = dplyr::n(),
        or_date = first(created_at)
      )

    data_to_heatmap <- data_calendar %>%
      select(-month_name, -or_date)

    to_heatmap <-
      base_to_heatmap %>%
      left_join(data_to_heatmap, by = c(
        "week_num" = "week_num",
        "week_day" = "week_day"
      )) %>%
      spread(key = week_num, value = n) %>%
      as.data.frame() %>%
      column_to_rownames("week_day") %>%
      replace(., is.na(.), 0)

    # axis labels ####

    median_weeks <- purrr::map_int(month.abb, median_week, data_wm = all_dates_period)

    setNames(median_weeks, month.abb)

    row_days <- rownames(to_heatmap)
    lab_row_days <- rev(rownames(to_heatmap))
    lab_row_days[c(1, 3, 5, 7)] <- rep(" ", 4)

    data_wm_worep <-
      all_dates_period %>%
      select(week_num, month_name) %>%
      distinct() %>%
      group_by(week_num) %>%
      summarize(month_name = last(month_name))

    column_months <- as.character(data_wm_worep$month_name)
    lab_column_months <- as.character(data_wm_worep$month_name)
    lab_column_months[!data_wm_worep$week_num %in% median_weeks] <- " "

    matrix_heatmap <- as.matrix(to_heatmap)
    matrix_heatmap <- matrix_heatmap[ nrow(matrix_heatmap):1, ]

    # hover ####

    # I suppose year == 2018
    get_date_weeknum_daynum_year <- function(dataset, weeknum, weekday) {
      fechas <- dataset %>%
        dplyr::filter(
          week_num == weeknum,
          week_day == weekday
        ) %$%
        gen_date
      return(fechas)
    }

    week_numbers <- unique(all_dates_period$week_num)
    matrix_dates <- matrix(rep(NA, 7 * ncol(to_heatmap)), nrow = 7)
    for (i in 1:7) {
      for (j in 1:ncol(to_heatmap)) {
        matrix_dates[i, j] <- get_date_weeknum_daynum_year(
          all_dates_period,
          week_numbers[j],
          row_days[i]
        )
      }
    }

    matrix_dates <- matrix_dates[nrow(matrix_dates):1, ]

    dates_vec <- (lubridate::as_date(as.vector(matrix_dates), origin = lubridate::origin))
    hover_heatmap <- matrix(purrr::map2_chr(
      as.vector(matrix_heatmap),
      dates_vec,
      ~ compute_hover(.x, .y)
    ),
    nrow = 7
    )

    # github colors:
    # grey 0 #ebedf0
    # light green #c6e48b
    # green #7bc96f
    # super green #239a3b
    # super super green #196127

    mycols <- c("#ebedf0", "#c6e48b", "#7bc96f", "#239a3b", "#196127")
    mypalette <- colorRamp(mycols)
    library(plotly)
    plot_ly(
      z = matrix_heatmap,
      type = "heatmap",
      colors = mypalette, xgap = 0.5, ygap = 0.5,
      showscale = FALSE, hoverinfo = "text",
      text = hover_heatmap
    ) %>%
      layout(
        yaxis = list(
          ticktext = lab_row_days, ticks = "",
          tickmode = "array",
          tickfont = list(color = "86888A"),
          tickvals = 0:6,
          zeroline = FALSE
        ),
        xaxis = list(
          side = "top", ticktext = lab_column_months, ticks = "",
          tickmode = "array", tickangle = 0,
          tickfont = list(color = "86888A"),
          tickvals = 0:38,
          zeroline = FALSE
        )
      ) %>%
      config(displayModeBar = FALSE)
  })
})

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

[violetr]

I tried without rownames. I also checked z but there are only numeric values. The problem persists.