R/graph_utils.R

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

source("R/config.R")
source("R/utils.R")
source("R/graph_legends.R")
source("R/graph_metrics/metric_strategies.R")
library(stringr)

build_graph_matrix <- function(data,
                               loop_or_transition = FALSE,
                               keep_duplicated_edges = FALSE,
                               keep_columns = NULL) {
  #' @description  Creates a dataframe ready to be interpreted by an igraph:
  #' a) loops and simple, b) loops and full, c) no_loops an simple, d) no loops
  #' and full
  #' @param data A dataframe
  #' @param loop_or_transition boolean parameter that indicates if we want an
  #' only-loop graph or only-transition-graph
  #' @param keep_duplicated_edges boolean indicating whether we keep duplicated
  #' edges or not
  #' @param keep_ind_name boolean indicating whether individual name es kept
  #' @return A single dataframe
  data <- data %>%
    mutate(from = c(NA, station[-n()]), to  = c(station[-1], NA))
  
  columns <- c(c('from', 'to'), c(keep_columns))
  
  if (!loop_or_transition) {
    data <- data %>% filter(from != to)
  }
  else {
    data <- data %>% filter(from == to)
  }
  
  if (keep_duplicated_edges) {
    data <- data %>% select(!!columns)
  }
  else {
    data <- data %>% group_by_at(columns) %>%
      summarise(n = n(), .groups = "drop") %>%
      select(-n)
    
  }
  
  return(data)
  
}

build_basic_graph <-
  function(data,
           loop_or_transition = FALSE,
           keep_duplicated_edges = FALSE,
           keep_ind_name = FALSE) {
    #' @description It builds a basic graph from a detections dataframe
    #' @param data detections dataframe
    #' @return a igraph object
    return(
      build_graph_matrix(data, loop_or_transition, keep_duplicated_edges) %>%
        graph_from_data_frame()
    )
  }

plot_gis_metric_graph <- function (g,
                                   metric_data,
                                   coords,
                                   gis_locs,
                                   bounding_box,
                                   coast,
                                   title,
                                   metric_name,
                                   show_legend = TRUE,
                                   show_labels = TRUE) {
  #' @param g graph
  #' @param metric_data dataframe with a summary of g's metrics
  #' @param coords dataframe with g's nodes coordinates
  #' @param gis_locs dataframe with stations and coordinates in gis format
  #' @param bounding_box dataframe with xmin, xmax, ymin and ymax
  #' @param coast coast layer over which the graph will be plot
  #' @param title string hoding the title of the plot
  #' @metric_name string providing the name of the metric to be plot
  
  
  selected_attr_name <- paste(metric_name, "_selected", sep = "")
  color_attr_name <- paste(metric_name, "_node_color", sep = "")
  
  if (show_legend) {
    # (1) Get manual colors legend and title
    legend_data <- build_by_importance_node_legend(metric_data)
    legend_title <- str_to_title(metric_name)
  }
  
  
  # (2) draw the graph
  gis_graph <- ggraph(g,
                      layout = "manual",
                      x = coords$X,
                      y = coords$Y) +
    ggtitle(title) +
    
    # # Underlying coast raster and coordinate settings
    geom_sf(data = coast, col = NA) +
    geom_sf(data = river, col = "#38afcd") +
    geom_sf(data = port, col = "black") +
    # # Set bounding box
    coord_sf(
      xlim = c(bounding_box$xmin, bounding_box$xmax),
      ylim = c(bounding_box$ymin, bounding_box$ymax)
    ) +
    
    
    geom_edge_fan(color = '#F8C471',
                  arrow = arrow(
                    angle = 30,
                    length = unit(0.05, "inches"),
                    type = "closed"
                  )) +
    
    # Node settings
    # --> We need a legend
    geom_node_point(aes(colour = metric_data$node_color)) +
    # ... then paint in the nodes
    geom_node_point(col = metric_data$node_color)
  
  # No edge printing+
  
  if (show_labels) {
    gis_graph <- gis_graph + geom_node_label(
      aes(label = ifelse(
        vertex_attr(g, selected_attr_name) == 1,
        V(g)$name,
        NA
      )),
      repel = TRUE,
      max.overlaps = Inf,
      col = metric_data$node_color,
      box.padding = unit(0.5, "lines")
    )
  }
  
  if (show_legend) {
    # Manual legend based on the colour aesthetics of the first geom_node_point
    gis_graph <- gis_graph + scale_colour_manual(
      legend_title,
      labels = legend_data$labels,
      values = legend_data$node_color,
      guide = guide_legend(override.aes = list(
        size = legend_data$marker_size, labels = c('•')
      ))
    )
  }
  
  gis_graph <- gis_graph + theme_bw() +
    theme(
      plot.title = element_text(hjust = 0.5),
      legend.position = ifelse(show_legend, "right", "none")
    ) +
    labs(x = NULL, y = NULL)
  
  return(gis_graph)
}

generate_individual_monthly_graphs <- function(data) {
  #' Generates all monthly graphs for a single individual
  #' @param data A dataframe
  #' @return A list of igraphs
  data <- data %>%
    mutate(month = as.integer(format(date_time, "%m")))
  
  unique_months <- unique(data$month)
  gs <- lapply(unique_months,
               function(x) {
                 data %>%
                   filter(month == x) %>%
                   mutate(from = c(NA, station[-n()]),
                          to   = c(station[-1], NA)) %>%
                   filter(from != to) %>%
                   group_by(from, to) %>%
                   summarise(n = n(), .groups = "drop") %>%
                   graph_from_data_frame()
               })
  names(gs) <- month.name[unique_months]
  return (gs)
  
}

generate_all_individual_monthly_graphs <-
  function (data, individual_names) {
    #' Generate all montlhy igraphs for each individual
    #' @param data A dataframe
    #' @param individuals A list of strings
    #' @return A list of lists
    
    
    all_gs <- lapply(individual_names, function(i_name) {
      data %>%
        filter(ind_name == i_name) %>%
        generate_individual_monthly_graphs()
    })
    names(all_gs) <- individual_names
    return (all_gs)
  }



plot_graph_centrality_metric <- function(g,
                                         coords,
                                         gis_locs,
                                         bounding_box,
                                         coast,
                                         title,
                                         metric_name,
                                         metric_thresholds,
                                         show_legend = TRUE,
                                         show_labels = TRUE) {
  #' Plot the graph with according to a given centrality metric
  #' @param g graph
  #' @param coords dataframe with g's nodes coordinates
  #' @param gis_locs dataframe with stations and coordinates in gis format
  #' @param bounding_box dataframe with xmin, xmax, ymin and ymax
  #' @param coast coast layer over which the graph will be plot
  #' @param title string hoding the title of the plot
  #' @metric_name string providing the name of the metric to be plot
  #' @metric_scale float by which the size of nodes need to be multiplied
  cum_data <- node_metric_cumulative_importance(g,
                                                metric_name,
                                                metric_thresholds)
  g <- cum_data$graph
  metric_data <- cum_data$metric_data
  
  return (
    plot_gis_metric_graph(
      g,
      metric_data,
      coords,
      gis_locs,
      bounding_box,
      coast,
      title,
      metric_name,
      show_legend = show_legend,
      show_labels = show_labels
    )
  )
  
}