433 lines
11 KiB
Plaintext
433 lines
11 KiB
Plaintext
# Ü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")
|
|
```
|
|
|