Назначьте случайные цвета в R
У меня есть этот код на R для моделирования страны с разными районами:
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"
)
Однако это просто присвоение случайных цветов каждому узлу.
Я пытаюсь объединить цвета в «кластеры», чтобы они напоминали более естественный узор, вот так:
Можно ли это сделать в R?
Вторая попытка:
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)
Ответы:
Не совсем понятно, чего вы пытаетесь достичь, поэтому я не уверен, поможет ли это, но вот действительно грубое решение, которое случайным образом назначает цвет в кластерах графику в вашем примере.
library(igraph)
#>
#> Attaching package: 'igraph'
#> The following objects are masked from 'package:stats':
#>
#> decompose, spectrum
#> The following object is masked from 'package:base':
#>
#> union
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
colors <- NULL
i <- 1
while(i <= num_nodes){
# Set a size for the cluster randomly
cluster_size <- sample(seq(5, 50), 1)
# Set the color for the cluster randomly
cluster_color <- sample(c("red", "blue"), 1, replace = TRUE)
# Assign the cluster color for each node in the cluster or as many that remain in the graph
if ((i + cluster_size - 1) <= num_nodes){
cluster_colors <- sample(cluster_color, cluster_size, replace = TRUE)
} else {
cluster_colors <- sample(cluster_color, num_nodes - i + 1, replace = TRUE)
}
colors <- append(colors, cluster_colors)
i <- i + cluster_size
}
V(g)$color <- colors
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"
)
Created on 2024-09-04 with reprex v2.1.1
Это интересный вопрос, и я уверен, что есть несколько способов подойти к нему. Одним из способов было бы создать функцию, которая случайным образом создает n кластерных «семен» (nclust), расширяет их до заданного размера (clustsize), а затем случайным образом равномерно подвергает их цензуре, чтобы создать «неоднородность» (censoring):
set.seed(123)
clust_fun <- function(v_g,
nclust = 10,
clustsize = 20,
censoring = 0.1){
clust_seed <- sort(sample(length(v_g), nclust))
xx <- unique(unlist(purrr::map2(clust_seed - (clustsize / 2), clust_seed + (clustsize / 2), seq)))
xx[runif (length(xx)) <= (1 - censoring) & xx > 0 & xx < length(v_g)]
}
nn <- length(V(g))
V(g)$color <- rep("blue", nn)
V(g)$color[clust_fun(v_g = V(g))] <- "red"
plot(g, layout = cbind(V(g)$x, V(g)$y),
vertex.size = 7,
vertex.label = NA,
edge.arrow.size = 0.5,
edge.color = "lightgray"
)
Здесь я по умолчанию выбрал 10 семян с максимальным размером кластера 20 с небольшой «пятнистостью» (10%). Вы можете поиграть, чтобы сделать их более точными в соответствии с тем, что вы себе представляете.
Одним из простых вариантов является применение ядра сглаживания к матричному/растровому представлению числовых значений сетки, для этого мы можем использовать terra::focal().
В качестве первого шага мы построим SpatRaster для terra из таблицы вершин графика (x, y, color), затем мы сможем использовать focal(fun = "mean", ...), который по умолчанию использует скользящее окно 3x3 для расчета средних значений для каждой ячейки. Установив пороговые значения/сгруппировав средние значения, мы можем вернуться к категориальным показателям, таким как цвета.
Чтобы настроить полученные шаблоны, можно применить несколько раз focal() и отрегулировать пороговое значение. Мы также можем изменить вектор вероятности в sample(), чтобы изменить соотношение красного и синего входных данных.
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"
)
)
Хотя, если вы можете параметризовать свои кластеры и/или хотите получить более контролируемый результат, вам определенно стоит обратить внимание на spatstat.