Search code examples
r

Assign Random Colors in R

I have this code in R for simulating a country with different neighborhoods:

library(igraph)

width <- 30
height <- 20
num_nodes <- width * height

x <- rep(1:width, each = height)
y <- rep(1:height, times = width)

g <- make_empty_graph(n = num_nodes, directed = FALSE)

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)
    if(i < width) edges <- c(edges, current_node, get_node_index(i + 1, j))
    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

V(g)$color <- sample(c("red", "blue"), num_nodes, replace = TRUE)

count_patches <- function(color) {
  subgraph <- induced_subgraph(g, V(g)[V(g)$color == color])
  components <- components(subgraph)
  return(components$no)
}

plot(g, layout = cbind(V(g)$x, V(g)$y), 
     vertex.size = 7,  
     vertex.label = NA,
     edge.arrow.size = 0.5,
     edge.color = "lightgray"
     )

enter image description here

However, this is just assigning random colors to each node.

I am trying to make the colors more in "clusters" to resemble a more natural pattern like this:

enter image description here

https://commons.wikimedia.org/wiki/Category:Texas_gubernatorial_election_maps#/media/File:TXGov1990Map.png

Can this be done in R?

A second attempt:

library(igraph)

width <- 30
height <- 20
num_nodes <- width * height

x <- rep(1:width, each = height)
y <- rep(1:height, times = width)

g <- make_empty_graph(n = num_nodes, directed = FALSE)

#  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)

# set node positions
V(g)$x <- x
V(g)$y <- y

# initialize all nodes as white
V(g)$color <- "white"

#  get neighbors
get_neighbors <- function(node) {
    neighbors(g, node)
}

#define seeds
num_seeds <- 50
red_seeds <- sample(V(g), num_seeds)
blue_seeds <- sample(setdiff(V(g), red_seeds), num_seeds)

# color the seed nodes
V(g)[red_seeds]$color <- "red"
V(g)[blue_seeds]$color <- "blue"

#  initial probability for color spreading
base_spread_probability <- 0.2

# diffusion process
while(any(V(g)$color == "white")) {
    red_front <- V(g)[V(g)$color == "red"]
    blue_front <- V(g)[V(g)$color == "blue"]
    
    new_red <- unique(unlist(sapply(red_front, get_neighbors)))
    new_blue <- unique(unlist(sapply(blue_front, get_neighbors)))
    
    # color new nodes with probability, but don't overwrite existing colors
    for (node in new_red[V(g)[new_red]$color == "white"]) {
        if (runif(1) < base_spread_probability * (1 + runif(1, -0.5, 0.5))) {
            V(g)[node]$color <- "red"
        }
    }
    
    for (node in new_blue[V(g)[new_blue]$color == "white"]) {
        if (runif(1) < base_spread_probability * (1 + runif(1, -0.5, 0.5))) {
            V(g)[node]$color <- "blue"
        }
    }
    
    # If no new nodes were colored, increase probability to ensure completion
    if(all(V(g)[new_red]$color != "red" & V(g)[new_blue]$color != "blue")) {
        base_spread_probability <- min(1, base_spread_probability + 0.05)
    }
}


plot(g, layout = cbind(V(g)$x, V(g)$y), 
     vertex.size = 7, 
     vertex.label = NA, 
     edge.arrow.size = 0.5)

enter image description here

Solution

  • One low-effort option is to apply a smoothing kernel on a matrix / raster representation of numerical grid values, for this we can use terra::focal().

    As a first step, we'll build a SpatRaster for terra from graph's vertex table (x, y , color), we can then use focal(fun = "mean", ...), which by default uses 3x3 moving window to calculate mean values for each cell. By thresholding / binning mean values we can get back to categoricals, like colors.

    To tweak resulting patterns, focal() can be applied multiple times and threshold value can be adjusted. We can also change probability vector in sample() to change red / blue ratio of input data.

    library(igraph)
library(terra)

width <- 30
height <- 20
num_nodes <- width * height

x <- rep(1:width, each = height)
y <- rep(1:height, times = width)
g <- make_lattice(c(height,width))
V(g)$x <- x
V(g)$y <- y

set.seed(42)
V(g)$color <- sample(c("red", "blue"), num_nodes, replace = TRUE)

# helper function to apply mean filter (smoothing 3x3 kernel) to terra SpatRaster r, 
# repeat n times
mean_n <- \(r, n) Reduce(\(x, ...) focal(x, fun = "mean", na.rm = TRUE, expand = TRUE), x = seq_len(n), init = r)

V(g)$color <- 
  as_data_frame(g, "vertices") |> 
  # recode colors to numericals
  within(color <- c("red" = 0, "blue" = 1)[color]) |> 
  # vertex frame (x, y, numerical color) to SpatRaster
  rast() |>
  # apply focal(r, fun = "mean") twice
  mean_n(2) |> 
  # use .5 threshold value to categorize back to "red" & "blue";
  # from factor to character for plotting
  as.matrix(wide = TRUE) |> 
  cut(breaks = c(-Inf, .5, Inf), labels = c("red","blue")) |> 
  as.character() 

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 = NA,
       edge.arrow.size = 0.5,
       edge.color = "lightgray"
       )
)

    Though if you can parametrize your clusters and/or are after more controlled output, you definitely should look into spatstat.