You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
131 lines
3.1 KiB
131 lines
3.1 KiB
library(reshape)
|
|
library(tidyverse)
|
|
library(ggforce)
|
|
|
|
normalize_landscape <- function(landscape) {
|
|
min_val <- min(landscape)
|
|
max_val <- max(landscape)
|
|
range_val <- max_val - min_val
|
|
|
|
return((landscape - min_val) / range_val)
|
|
}
|
|
|
|
plot_landscape <- function(landscape) {
|
|
p <- ggplot(data=melt(landscape), aes(x=X1, y=X2, z=value)) +
|
|
geom_contour_filled()
|
|
|
|
return(p)
|
|
}
|
|
|
|
init_population <- function(landscape, n) {
|
|
|
|
population <- list()
|
|
dims <- length(dim(landscape))
|
|
|
|
for(i in 1:n) {
|
|
coords <- round(runif(dims, 0, 1) * dim(landscape))
|
|
sigmas <- rnorm(dims)
|
|
|
|
population[[i]] <- matrix(c(coords, sigmas), ncol=2)
|
|
}
|
|
|
|
return(population)
|
|
}
|
|
|
|
next_generation <- function(landscape, population) {
|
|
return(map(population, function(indiv) {
|
|
return(select_indiv(landscape, list(indiv, create_child(indiv))))
|
|
}))
|
|
}
|
|
|
|
select_indiv <- function(landscape, indivs) {
|
|
return(reduce(indivs, function(a, b) {
|
|
if(eval_indiv(landscape, a) >= eval_indiv(landscape, b)) {
|
|
return(a)
|
|
}
|
|
|
|
return(b)
|
|
}))
|
|
}
|
|
|
|
eval_indiv <- function(landscape, indiv) {
|
|
dims <- dim(landscape)
|
|
|
|
x <- indiv[1,1]
|
|
y <- indiv[2, 1]
|
|
|
|
if(x > dims[1] || y > dims[2] || x < 1 || y < 1) {
|
|
return(-1)
|
|
}
|
|
|
|
return(landscape[indiv[1,1], indiv[2,1]])
|
|
}
|
|
|
|
create_child <- function(parent) {
|
|
new_sigmas <- mutate_sigmas(parent[,2])
|
|
new_coords <- mutate_coords(parent[,1], new_sigmas)
|
|
|
|
return(matrix(c(new_coords, new_sigmas), ncol=2))
|
|
}
|
|
|
|
mutate_sigmas <- function(sigmas) {
|
|
global_rate <- 1 / sqrt(2 * length(sigmas))
|
|
local_rate <- 1 / (2 * sqrt(length(sigmas)))
|
|
|
|
global_step <- global_rate * rnorm(1)
|
|
|
|
return(map_dbl(sigmas, function(s) s * exp(global_step + local_rate * rnorm(1))))
|
|
}
|
|
|
|
mutate_coords <- function(coords, sigmas) {
|
|
return(imap_dbl(coords, function(x, i) x + sigmas[i] * rnorm(1)))
|
|
}
|
|
|
|
experiment <- function(landscape, population, gens) {
|
|
df <- population_to_df(landscape, population, 0)
|
|
|
|
for(g in 1:gens) {
|
|
population <- next_generation(landscape, population)
|
|
|
|
df <- rbind(df, population_to_df(landscape, population, g))
|
|
}
|
|
|
|
return(df)
|
|
}
|
|
|
|
population_to_df <- function(landscape, population, gen) {
|
|
df <- reduce(imap(population, function(indv, i) indiv_to_df(landscape, indv, i)), rbind)
|
|
df["generation"] <- gen
|
|
|
|
return(df)
|
|
}
|
|
|
|
indiv_to_df <- function(landscape, indiv, index) {
|
|
return(data.frame(x=indiv[1,1], y=indiv[2,1],
|
|
sx=indiv[1, 2], sy=indiv[2,2],
|
|
individual=index, value=eval_indiv(landscape, indiv)))
|
|
}
|
|
|
|
plot_generation <- function(landscape, df) {
|
|
p <-ggplot(data=df) +
|
|
geom_contour_filled(data=melt(landscape), aes(x=X1, y=X2, z=value)) +
|
|
geom_point(aes(x=x, y=y)) +
|
|
geom_ellipse(aes(x0=x, y0=y, a=sx, b=sy, angle=0))
|
|
|
|
return(p)
|
|
}
|
|
|
|
plot_experiment <- function(landscape, df, filename) {
|
|
pdf(file=filename, onefile=TRUE)
|
|
|
|
for(g in unique(df$generation)) {
|
|
tmp_df <- df[df$generation == g,]
|
|
|
|
p <- plot <- plot_generation(landscape, tmp_df)
|
|
|
|
print(p)
|
|
}
|
|
|
|
dev.off()
|
|
}
|
|
|