# Übungsblatt 3 - Evolutionary Algorithms (Paul Helstab & Yannik Bretschneider)
## Loading Data
```{r setwd}
# Get the current working directory
current_directory <- getwd()
# Define the folder name to check
folder_name <- "w3"
# Construct the full path to the folder
folder_path <- file.path(current_directory, folder_name)
# Check if the folder exists (means most likely in the repo root folder)
if (dir.exists(folder_path)) {
setwd(folder_path)
cat("Changed working directory to:", getwd(), "\n")
} else {
cat("Folder 'w3' does not exist in the current working directory.
Staying where we are\n")
}
```
```{r read_data}
file_path <- "./data1.txt"
print(paste0("read data from '", file_path, "'"))
data <- read.table(
file_path,
header = FALSE,
sep = " ",
# colClasses = c("numeric", "numeric", "integer", "integer")
)
colnames(data) <- c("x1", "x2", "x_bias", "label")
evaluation_set_idx <- c(90:109)
```
```r
# possible, but unnecessary here:
# grab first 10 as evaluation set
evaluation_set <- data[evaluation_set_idx, ]
# grab the rest as training set
training_set <- data[-evaluation_set_idx, ]
```
## Aufgabe 1: Perzeptron
```{r peceptron-impl}
# randomized order
random_order <- sample(nrow(data))
vecs <- data[random_order, 1:3]
classes <- data[random_order, 4]
weights <- c(0, 0, 0)
# matrix for logging weights
wlog <- matrix(weights, ncol = 3)
infer <- function(x, wghts) {
return(sign(x %*% wghts))
}
perceptron_infer <- function(x) {
return(infer(x, weights))
}
while (TRUE) {
mispredictions <- 0
for (i in seq_len(nrow(vecs))) {
vec <- as.numeric(vecs[i, ])
class <- classes[i]
# print(vec %*% weights)
error <- as.numeric(class - perceptron_infer(vec))
if (error != 0) {
mispredictions <- mispredictions + 1
print("adjusting")
weights <- weights + error * vec
wlog <- rbind(wlog, weights)
}
}
if (mispredictions == 0) {
print("No more mispredictions")
break
} else {
print(paste0("Misclassifications: ", mispredictions))
}
}
print("NOTE: for more interesting plots, run this chunk multiple times until multiple \"adjusting\" can be seen in the output")
```
```{r apply-to-data}
perceptron_reinfer <- t(sapply(seq_len(nrow(data)), function(i) {
return(c(as.numeric(data[i, 1:3]), perceptron_infer((as.numeric(data[i, 1:3])))))
}))
# perceptron_reinfer
```
### Plots
The plots show the datapoints on a 2D plot, with the colors showing the classes (`green := 1` and `red := -1`)
The separation plane defined by the normal of the weight vector is shown in increasing opacities, until the final
weights are reached.
```{r plot-weights}
perceptron_plot <- function() {
plot(data$x1, data$x2,
col = ifelse(data$label == 1, "green", "red"),
pch = 16, xlab = "x1", ylab = "x2", xlim = c(-5, 5), ylim = c(-5, 5)
)
legend("topright",
legend = c("Class 1", "Class -1"),
col = c("green", "red"), pch = 16
)
# Plot the separation planes
num_steps <- nrow(wlog)
alpha_step <- 1 / num_steps
for (i in 1:num_steps) {
a <- wlog[i, 1]
b <- wlog[i, 2]
c <- wlog[i, 3]
# Calculate the line coordinates
x <- seq(-5, 5, length.out = 100)
y <- -(a * x + c) / b
# Determine the line color based on the iteration
alpha <- i * alpha_step
line_color <- rgb(0, 0, 1, alpha)
# Plot the line
lines(x, y, col = line_color)
}
# Plot the final separation plane
a <- weights[1]
b <- weights[2]
c <- weights[3]
x <- seq(-5, 5, length.out = 100)
y <- -(a * x + c) / b
lines(x, y, col = "blue", lwd = 2)
}
perceptron_plot()
```
```{r plot-weights-pdf}
pdf("perceptron-plot.pdf", width = 8, height = 6)
perceptron_plot()
dev.off()
```
## Aufgabe 2: Perzeptron Evolutionary Algorithm (EA)
```{r peceptron-ea-impl}
# randomized order
ea_random_order <- sample(nrow(data))
ea_vecs <- data[ea_random_order, 1:3]
ea_classes <- data[ea_random_order, 4]
NUM_INDIVIDUALS <- 3
MUTATE_ALL_GENES <- FALSE
MUTATE_STEP <- function() {
return(0.5)
}
# MUTATE_STEP <- function() {
# return(runif(1, min = -1, max = 1)[1])
# }
weights <- matrix(0, ncol = 3, nrow = NUM_INDIVIDUALS)
# matrix for logging weights
ea_wlog <- matrix(0, ncol = 3)
fittest <- c(0, 0, 0)
mutate <- function(genes, step_size_fn, mutate_all) {
if (mutate_all == TRUE) {
for (i in seq_along(genes)) {
step <- step_size_fn() * sample(c(1, -1), size = 1)[1] # mutation in step_size, -step_size or not at all
genes[i] <- genes[i] + step
}
} else {
idx_to_mutate <- sample(seq_along(genes), size = 1)[1]
genes[idx_to_mutate] <- genes[idx_to_mutate] + step_size_fn() * sample(c(1, -1), size = 1)[1] # mutation in step_size or not AT all
}
return(genes)
}
infer <- function(x, wghts) {
return(sign(x %*% wghts))
}
fitness <- function(wghts) {
mispredictions <- 0
for (i in seq_len(nrow(ea_vecs))) {
vec <- as.numeric(ea_vecs[i, ])
class <- ea_classes[i]
# print(vec %*% weights)
error <- as.numeric(class - infer(vec, wghts))
if (error != 0) {
mispredictions <- mispredictions + 1
}
}
return(mispredictions)
}
while (TRUE) {
i_fittest <- weights[1, ]
i_fit <- fitness(weights[1, ])
for (individual in 2:NUM_INDIVIDUALS) {
this_fitness <- fitness(weights[individual, ])
if (this_fitness < i_fit) {
i_fittest <- weights[individual, ]
i_fit <- this_fitness
}
}
# add fittest to weights
ea_wlog <- rbind(ea_wlog, i_fittest)
if (i_fit == 0) {
print("No more mispredictions")
fittest <- i_fittest
break
} else {
print(paste0("Misclassifications: ", i_fit))
for (individual in 1:NUM_INDIVIDUALS) {
weights[individual, ] <- mutate(i_fittest, step_size_fn = MUTATE_STEP, mutate_all = MUTATE_ALL_GENES)
}
}
}
```
```{r ea-apply-to-data}
ea_reinfer <- t(sapply(seq_len(nrow(data)), function(i) {
return(c(as.numeric(data[i, 1:3]), infer((as.numeric(data[i, 1:3])), fittest)))
}))
# ea_reinfer
```
### Plots
The plots show the datapoints on a 2D plot, with the colors showing the classes (`green := 1` and `red := -1`)
The separation plane defined by the normal of the weight vector is shown in increasing opacities, until the final
weights are reached.
```{r ea-plot-weights}
ea_plot <- function() {
plot(data$x1, data$x2,
col = ifelse(data$label == 1, "green", "red"),
pch = 16, xlab = "x1", ylab = "x2", xlim = c(-5, 5), ylim = c(-5, 5)
)
legend("topright",
legend = c("Class 1", "Class -1"),
col = c("green", "red"), pch = 16
)
# Plot the separation planes
num_steps <- nrow(ea_wlog)
alpha_step <- 1 / num_steps
for (i in 1:num_steps) {
a <- ea_wlog[i, 1]
b <- ea_wlog[i, 2]
c <- ea_wlog[i, 3]
# Calculate the line coordinates
x <- seq(-5, 5, length.out = 100)
y <- -(a * x + c) / b
# Determine the line color based on the iteration
alpha <- i * alpha_step
line_color <- rgb(0, 0, 1, alpha)
# Plot the line
lines(x, y, col = line_color)
}
# Plot the final separation plane
a <- fittest[1]
b <- fittest[2]
c <- fittest[3]
x <- seq(-5, 5, length.out = 100)
y <- -(a * x + c) / b
lines(x, y, col = "blue", lwd = 2)
}
ea_plot()
```
```{r plot-weights-pdf}
pdf("ea-plot_static-delta_one.pdf", width = 8, height = 6)
ea_plot()
dev.off()
```
### Evaluation
Gaussian (Mutate All) with a high number of individuals generally acheives a correct result first-try. In our very constrained individuum pool tests with 3 individuals, this also seems to be the best choice for parameters for the EA. Its efficacy seems to increase even more with a larger gene pool.
## Aufgabe 3: Exploration vs Exploitation
```{r setup}
# generate a random binary vector of length 10
generate_individual <- function() {
sample(c(0, 1), 10, replace = TRUE)
}
# 1-point crossover
one_point_crossover <- function(parent1, parent2) {
point <- sample(1:9, 1)
child1 <- c(parent1[1:point], parent2[(point + 1):10])
child2 <- c(parent2[1:point], parent1[(point + 1):10])
return(list(child1, child2))
}
# 2-point crossover
two_point_crossover <- function(parent1, parent2) {
points <- sort(sample(1:9, 2))
child1 <- c(parent1[1:points[1]], parent2[(points[1] + 1):points[2]], parent1[(points[2] + 1):10])
child2 <- c(parent2[1:points[1]], parent1[(points[1] + 1):points[2]], parent2[(points[2] + 1):10])
return(list(child1, child2))
}
# uniform crossover
uniform_crossover <- function(parent1, parent2) {
mask <- sample(c(0, 1), 10, replace = TRUE)
child1 <- ifelse(mask == 1, parent1, parent2)
child2 <- ifelse(mask == 1, parent2, parent1)
return(list(child1, child2))
}
# Function to convert binary vector to decimal
binary_to_decimal <- function(binary_vector) {
sum(binary_vector * 2^(rev(seq_along(binary_vector) - 1)))
}
```
```{r initialize_parents}
# init parents
parent1 <- generate_individual()
parent2 <- generate_individual()
print(parent1)
print(parent2)
# Set num gens
num_generations <- 10000
# for tracking unique solutions
unique_solutions <- list()
unique_solutions[[binary_to_decimal(parent1)]] <- TRUE
unique_solutions[[binary_to_decimal(parent2)]] <- TRUE
```
```{r run_genetic_algorithm}
for (generation in 1:num_generations) {
# Choose crossover method
crossover_method <- sample(c("one_point", "two_point", "uniform"), 1)
if (crossover_method == "one_point") {
children <- one_point_crossover(parent1, parent2)
} else if (crossover_method == "two_point") {
children <- two_point_crossover(parent1, parent2)
} else {
children <- uniform_crossover(parent1, parent2)
}
# Replace
parent1 <- children[[1]]
parent2 <- children[[2]]
# Track sols
unique_solutions[[binary_to_decimal(parent1)]] <- TRUE
unique_solutions[[binary_to_decimal(parent2)]] <- TRUE
}
# Calculate number of unique solutions observed
num_unique_solutions <- length(unique_solutions)
# Calculate number of possible solutions covered
num_possible_solutions <- 2^10
num_solutions_covered <- length(unique_solutions)
# Print results
cat("Number of unique solutions observed:", num_unique_solutions, "\n")
cat("Number of possible solutions covered:", num_solutions_covered, "\n")
cat("Percentage of 10-bit numbers covered:", round(num_solutions_covered / num_possible_solutions * 100, 2), "%\n")
```
