R/heatmap_utils.R

In d2gex/seabasstfm: What the Package Does (One Line, Title Case)

library(ComplexHeatmap)

prepare_heatmap_data <-
  function(data,
           count_var,
           matrix_row_name,
           matrix_col_name,
           month_as_name = TRUE,
           by_percentage = TRUE,
           min_row_sum = 0) {
    #' @param monthly_metrics a dataframe with a single monthly metric
    #' @param metric_name name of the metric in the given dataframe to work with
    #' @param month_as_name a boolean flag to indicate if months should be represented
    #' as names
    #' @param by_percentage a boolean flag to indicate if metrics should be calculated
    #' in %
    #' @description
    
    df <- data [, c(matrix_row_name, matrix_col_name, count_var)]
    if (month_as_name) {
      df$workbench_col <- df[[matrix_col_name]]
      df <- df %>%
        # Work with a known factor and assign it to the tarteted columns
        mutate(!!matrix_col_name := paste(str_sub(workbench_col, 1, 4),
                                          month.abb[as.numeric(as.character(str_sub(workbench_col, 6, 7)))],
                                          sep = "-")) %>%
        # Get rid of the now factor as it is no longer needed
        select(c(-workbench_col))
      
    }
    df <-
      df %>%
      pivot_wider(names_from = all_of(matrix_col_name),
                  values_from =  count_var)
    df[sapply(df, is.na)] <- 0
    
    # (1) Calculate % based on columns
    if (by_percentage == TRUE) {
      df <- df %>%
        mutate_at(vars(-!!matrix_row_name), funs((. / sum(.)) * 100)) %>%
        mutate_at(vars(-!!matrix_row_name), funs(round(., 2)))
    }
    # Ensure we get only relevant rows
    # Ensure matrices are ready for heatmap's htclust function
    df[sapply(df, is.nan)] <- 0
    df[sapply(df, is.infinite)] <- 0
    if (min_row_sum != 0) {
      df <- df %>% filter(rowSums(.[-1]) >= min_row_sum)
    }
    heatmap_matrix <- as.matrix(df[,-1])
    rownames(heatmap_matrix) <- df[[matrix_row_name]]
    return (heatmap_matrix)
  }



draw_interval_heatmap <- function(heat_map_matrix,
                                  main_title,
                                  legend_title,
                                  by_col_rows_order = FALSE,
                                  font_size = 10, 
                                  col = NULL) {
  #' @param heat_map_matrix a matrix of data in a format ready for heatmap
  #' representation
  #' @param main_title the main title of the heatmap
  #' @param legend_title the title of the legend plotted alongside the heatmap
  #'  @description Return a heatmp made by the library ComplexHeatMap for a single metric
  
  
  if (by_col_rows_order) {
    heat_map <- Heatmap(
      heat_map_matrix,
      name = legend_title,
      column_title = main_title,
      column_title_side = "top",
      column_title_gp = gpar(fontsize = 12, fontface = "bold"),
      row_title_side = "right",
      show_column_dend = FALSE,
      show_row_dend = FALSE,
      rect_gp = gpar(col = "white", lwd = 1),
      row_order = order(rownames(heat_map_matrix)),
      column_order = 1:length(colnames(heat_map_matrix)),
      col=col,
      cell_fun = function(j, i, x, y, width, height, fill) {
        grid.text(sprintf("%.1f", heat_map_matrix[i, j]),
                  x,
                  y,
                  gp = gpar(fontsize = font_size))
      }
    )
  }
  else {
    heat_map <- Heatmap(
      heat_map_matrix,
      name = legend_title,
      column_title = main_title,
      column_title_side = "top",
      column_title_gp = gpar(fontsize = 12, fontface = "bold"),
      row_title_side = "right",
      show_column_dend = FALSE,
      show_row_dend = FALSE,
      rect_gp = gpar(col = "white", lwd = 1),
      col = col,
      cell_fun = function(j, i, x, y, width, height, fill) {
        grid.text(sprintf("%.1f", heat_map_matrix[i, j]),
                  x,
                  y,
                  gp = gpar(fontsize = font_size))
      }
    )
  }
  return (heat_map)
}