R/graph_metrics/metric_heatmapping.R

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

source("R/heatmap_utils.R")

build_metric_dataframe_from_graph <- function(g, metric_names) {
  #' @description Build a dataframe with the metric values of the given graph
  
  df_metrics <- data.frame(station = V(g)$name)
  for (i in seq_along(metric_names)) {
    m_name <- metric_names[i]
    metric_values <- vertex_attr(g, m_name)
    if (!is.null(metric_values)) {
      df_metrics[[m_name]] <- metric_values
    }
  }
  return(df_metrics)
}

get_montly_metrics <-
  function(g_c, period_name) {
    #' @description build a list of dataframes summarising the metric per
    #' by month
    full_graph <- g_c$simple_g
    simple_graph <- g_c$no_loops_simple_graph
    only_loops_graph <- g_c$only_loops_g
    metrics <- list(full = NULL, loops = NULL)
    
    if (is.null(full_graph) & is.null(only_loops_graph)) {
      return (metrics)
    }
    
    if (!is.null(full_graph)) {
      # Full graph metrics
      metrics$full <-
        build_metric_dataframe_from_graph(full_graph, g_c$simple_g_metric_names)
      metrics$full$period <- period_name
      
      # Simplified version of full graph metrics
      metrics$simple_graph <-
        build_metric_dataframe_from_graph(simple_graph, g_c$simple_g_metric_names)
      metrics$simple_graph$period <- period_name
      
    }
    
    if (!is.null(only_loops_graph)) {
      metrics$loops <-
        build_metric_dataframe_from_graph(only_loops_graph,
                                          g_c$only_loops_metric_names)
      metrics$loops$period <- period_name
      
    }
    return (metrics)
    
  }

build_timeseries_metrics_by_graph_type <-
  function(metric_data,
           main_title,
           min_row_sum = 0,
           by_col_rows_order = FALSE) {
    #' @param metric_data a dataframe with the long timeseries metrics
    #' @param main_title main title of the graph
    #' @description Build the heatmaps for all metrics of a single graph type
    
    # (1) Get only the column names that are related to metrics
    heatmap_plots <- list()
    discard_col_names <- c("station", "period")
    metric_only_col_names <- names(metric_data)
    metric_only_col_names <-
      metric_only_col_names[!(metric_only_col_names %in% discard_col_names)]
    
    # (2) Create all heatmaps for the full graph
    for (i in seq_along(metric_only_col_names)) {
      metric_name <- metric_only_col_names[i]
      heatmap_matrix <-
        prepare_heatmap_data(metric_data,
                             metric_name,
                             'station',
                             'period',
                             min_row_sum = min_row_sum)
      if (grepl('loops', str_to_lower(metric_name), fixed = TRUE)) {
        title <- paste(str_to_title(metric_name),
                       main_title)
      }
      else {
        title <- paste(str_to_title(metric_name),
                       "centrality metric",
                       main_title)
      }
      legend_title <- paste(str_to_title(metric_name), "(%)")
      heatmap_plots[[i]] <- draw_interval_heatmap(heatmap_matrix,
                                                  title,
                                                  legend_title,
                                                  by_col_rows_order)
    }
    return(heatmap_plots)
    
    
  }

combine_monthly_metric_by_graph_type <-
  function(metrics_by_interval) {
    #' @description combine all metrics split by intervals into one long time series
    #' for both the full graph and the loops.
    full_df <- data.frame()
    simple_df <- data.frame()
    only_loops_df <- data.frame()
    
    for (i in seq_along(metrics_by_interval)) {
      full_metrics_within_interval <- metrics_by_interval[[i]][['full']]
      simplified_metrics_within_interval <-
        metrics_by_interval[[i]][['simple_graph']]
      only_loops_metrics_within_interval <-
        metrics_by_interval[[i]][['loops']]
      
      # Any metrics for the current interval being processed for the full graph?
      if (!is.null(full_metrics_within_interval)) {
        full_df <-
          rbind(full_df, full_metrics_within_interval)
        simple_df <-
          rbind(simple_df, simplified_metrics_within_interval)
      }
      
      # Any metrics for the current interval being processed for the only-loops graph?
      if (!is.null(only_loops_metrics_within_interval)) {
        only_loops_df <-
          rbind(only_loops_df, only_loops_metrics_within_interval)
      }
    }
    # No metrics at all for the whole interval for the different graph types?
    if (!nrow(full_df)) {
      full_df <- NULL
      simple_df <- NULL
    }
    if (!nrow(only_loops_df)) {
      only_loops_df <- NULL
    }
    
    return(list(
      full_df = full_df,
      simple_df = simple_df,
      only_loops_df = only_loops_df
    ))
  }


build_all_timeseries_metrics <-
  function(metrics_by_interval,
           main_title,
           min_row_sum = 0,
           by_col_rows_order = FALSE) {
    #' @param metrics_by_interval a list of two dataframes representing
    #' the full and only_loops graph metrics
    #' @param main_title main title per graph
    #' @description Build the heatmaps for all metrics for all graph types of an
    #' individual - full and loops.
    metrics <-
      combine_monthly_metric_by_graph_type (metrics_by_interval)
    heat_maps <- c()
    
    # Do we have any metrics for the given interval period for the full graph?
    if (!is.null(metrics$full_df)) {
      # Generate heatmap for all metrics for the full graph
      title <- paste(main_title, "for full graph")
      heat_maps <-
        append(
          heat_maps,
          build_timeseries_metrics_by_graph_type (metrics$full_df,
                                                  title,
                                                  min_row_sum,
                                                  by_col_rows_order = by_col_rows_order)
        )
      
      # Generate heatmap for all metrics for the simple graph
      title <- paste(main_title, "for simple graph")
      heat_maps <-
        append(
          heat_maps,
          build_timeseries_metrics_by_graph_type (metrics$simple_df,
                                                  title,
                                                  min_row_sum,
                                                  by_col_rows_order = by_col_rows_order)
        )
    }
    
    # Do we have any metrics for the given interval period for the loops-only graph?
    if (!is.null(metrics$only_loops_df)) {
      heat_maps <- append(
        heat_maps,
        build_timeseries_metrics_by_graph_type (
          metrics$only_loops_df,
          main_title,
          min_row_sum,
          by_col_rows_order = by_col_rows_order
        )
      )
    }
    # Do we have any heatmap at all?
    if (!length(heat_maps)) {
      return (NULL)
    }
    
    return (heat_maps)
    
  }