rigraph

How to tell if a point has been colored twice in R?

This is a follow-up question from my previous question Assign Random Colors in R

(After much trial and error) I wrote this function which randomly colors some nodes on a network and colors 3 of their neighbors with the same color (notice the coloring scale - dark color for the original node, light color for the neighbors).

library(igraph)
library(colorspace)


create_colored_network <- function(width, height, colors, source_nodes, neighbor_degree = 3) {
    num_nodes <- width * height
    
    # Create a grid
    x <- rep(1:width, each = height)
    y <- rep(1:height, times = width)
    
    g <- make_empty_graph(n = num_nodes, directed = FALSE)
    
    # Function to get node index
    get_node_index <- function(i, j) (i - 1) * height + j
    
    # Add edges
    edges <- c()
    for(i in 1:width) {
        for(j in 1:height) {
            current_node <- get_node_index(i, j)
            
            # Connect to right neighbor
            if(i < width) edges <- c(edges, current_node, get_node_index(i + 1, j))
            
            # Connect to bottom neighbor
            if(j < height) edges <- c(edges, current_node, get_node_index(i, j + 1))
        }
    }
    
    g <- add_edges(g, edges)
    
    V(g)$x <- x
    V(g)$y <- y
    
    # Select random nodes and color them
    all_nodes <- 1:num_nodes
    V(g)$color <- "white"
    
    for (i in 1:length(colors)) {
        available_nodes <- all_nodes[!all_nodes %in% unlist(sapply(colors[1:i-1], function(c) V(g)[color == c]))]
        source <- sample(available_nodes, source_nodes[i])
        V(g)[source]$color <- colors[i]
        
        # Color neighbors
        neighbors <- unique(unlist(neighborhood(g, order = neighbor_degree, nodes = source)))
        neighbor_color <- lighten(colors[i], amount = 0.7)  # Create a lighter version of the color
        V(g)[neighbors]$color <- ifelse(V(g)[neighbors]$color == "white", neighbor_color, V(g)[neighbors]$color)
    }
    
    plot(g, vertex.size = 7, vertex.label = NA, main = "Colored Network")
    
    
    legend_colors <- c(colors, sapply(colors, function(c) lighten(c, amount = 0.7)), "white")
    legend_labels <- c(paste(capitalize(colors), "nodes"), 
                       paste(capitalize(colors), "neighbors"), 
                       "Other nodes")
    
    legend("bottom", 
           legend = legend_labels,
           col = legend_colors, 
           pch = 19, 
           pt.cex = 1.5, 
           cex = 0.8, 
           bty = "n", 
           horiz = TRUE)
}

capitalize <- function(x) {
    paste0(toupper(substr(x, 1, 1)), substr(x, 2, nchar(x)))
}

Here is how to call this function:

width <- 30
height <- 20
colors <- c("red", "blue", "green", "purple")
source_nodes <- c(2, 2, 3, 9)

create_colored_network(width, height, colors, source_nodes)

enter image description here

I am trying to make the following changes to this:

enter image description here

Is it possible to track which nodes have been colored over by multiple colors?

Much appreciated ...

Solution

  • This might not be quite what you asked, instead of traversing through graph and tracking / updating node attributes it aims to partition all nodes into clusters.

    Voronoi diagram is often used for such task and it's also available in igraph through voronoi_cells(). Usability of resulting clusters probably depends on your actual use case, though a bit smarter approach for sampling source node locations should provide finer control over resulting cluster distribution (perhaps spatstat.random::runifpoint() for uniform distribution, or spatstat.random::rstrat() to generate spatially stratified point locations) .

    library(igraph, warn.conflicts = FALSE)

# width, height - lattice dimensions
# colors        - character vector of colors
# source_nodes  - number of source nodes for each color in `colors`
# tiebreaker    - what to do when a vertex is at the same distance from multiple generators
#                 ("random", "first", "last")
create_colored_network <- function(width, height, colors, source_nodes, tiebreaker = "random") {
  # create lattice graph 
  g <- make_lattice(dimvector = c(height,width))
  V(g)$x <- rep(seq_len(width),  each  = height) 
  V(g)$y <- rep(seq_len(height), times = width)
  
  # generate a shuffled vector of source nodes, colors as names
  # Named num [1:16] 375 101 229 490 199 132 586 36 571 178 ...
  # - attr(*, "names")= chr [1:16] "green" "purple" "red" "blue" ...
  
  # sample from graph vertex sequnece
  # source_idx <- 
  #   sample(vcount(g), sum(source_nodes)) |> 
  #   setNames(rep(colors, source_nodes) |> sample())
  
  # sample through x-y coordinates
  source_idx <- 
    # sample x & w coordinates for source nodes
    sapply(list(width, height), sample, sum(source_nodes)) |> 
    # calculate node inidices from sampled coordinates
    apply(MARGIN = 1, \(xy, h) (xy[1] - 1) * h + xy[2], h = height) |> 
    # shuffle colors, affects tiebreaking in voronoi_cells    
    setNames(rep(colors, source_nodes) |> sample())
  

  # use Voronoi partitioning to cluster all network nodes by source_idx nodes,
  # clu$membership includes source node sequence number (0-based)
  clu <- voronoi_cells(g, source_idx, tiebreaker = tiebreaker)
  
  # set all node colors to lightened varaiants of colors from source_idx names
  V(g)$color <- 
    # sequence numbers are 0-based
    source_idx[clu$membership + 1] |> 
    names() |> 
    colorspace::lighten(amount = 0.7)
  
  # override source node colors  
  V(g)$color[source_idx] <- names(source_idx)
  
  # store source node flag and cluster id in vertex attributes
  V(g)$is_source  <- FALSE
  V(g)$is_source[source_idx] <- TRUE
  V(g)$membership <- clu$membership
  
  # return graph
  g
}

set.seed(42)
g <- create_colored_network(
  width = 30, height = 20, 
  colors = c("red", "blue", "green", "purple"), 
  source_nodes = c(2, 2, 3, 9),
  tiebreaker = "first")

withr::with_par(
  list(mar = c(0,0,0,0)),
  plot(g, layout = cbind(V(g)$x, V(g)$y), 
       vertex.size = 7,  
       vertex.label = V(g)$membership,
       vertex.label.cex = .75,
       vertex.frame.color = V(g)$membership,
       vertex.frame.width = .5,
       edge.arrow.size = 0.5,
       edge.color = "lightgray")
)

    You might also want test with other tiebreaker values of voronoi_cells(), default is "random", which is more likely to result with some scattered nodes surrounded by another cluster. Here are all 3 options, ("random", "first", "last"):

    withr::with_par(
  list(mfrow = c(1, 3), mar = c(10,0,5,0)),
  lapply(c("random", "first", "last"), 
         \(tb) {
           set.seed(42)
           create_colored_network(width = 30, height = 20, 
                                        colors = c("red", "blue", "green", "purple"), 
                                        source_nodes = c(2, 2, 3, 9), tiebreaker = tb) |>
             plot(layout = cbind(V(g)$x, V(g)$y), vertex.size = 7,  
                  vertex.label = V(g)$membership, vertex.label.cex = .75,
                  vertex.frame.color = V(g)$membership, vertex.frame.width = .5,
                  edge.arrow.size = 0.5, edge.color = "lightgray",
                  main = paste0("tiebreaker = ", tb))
           }
         )
  )

    Created on 2024-09-05 with reprex v2.1.1