Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
I recently picked up a copy of my favorite game Stardew Valley again. If you don’t know the game, I can highly recommend it! You inherit a pixel farm and you are in charge of everything. Crops, animals, fishing, mining and never forget to socialize. My plan was to shut off work for at least a few hours while playing. But at one point you inevitably start optimizing your farm. In most cases, the layout of crops. Aaaaaaaand that’s how you turn a farming game into an optimization problem you try to solve with R.
library(tidyverse)
Your farm
If you start a standard farm, this is what you can work with.
The first step is to get the layout into R. Luckily, I found a reddit post, where someone posted the layout as an excel file. I converted the file into a matrix and a long data frame. The data frame is for plotting and the matrix for the actual optimization.
farm_blank <- readRDS("farm_blank.RDS")
map <- read_csv("fun_projects/stardew/map.csv")
dim(farm_blank)
## [1] 78 61
ggplot(map)+geom_tile(aes(x,y,fill=val))+
scale_fill_manual(values=c("c"="#458B00", "w"="#1874CD",
"h"="#8B0000","b"="#B0B0B0","e"="#CD2626",
"x"="black"))+
ggraph::theme_graph()+
theme(legend.position = "none")+
coord_fixed()
The green tiles are the ones we can use for farming. In theory, we could plant 3414 crops there. But the tiles are totally unprotected against the nasty crows that would eat all your precious crops. We need scarecrows to protect them.
Scarecrows
When you plant your crops, you should make sure that your crops fall into the range of a placed scarecrow. No crow will ever touch anything there.
A single scarecrow can protect 248 tiles. And now we have our first optimization problem: Where should we place scarecrows on the farm to maximize the protected area?
Optimizing scarecrow placement
Now of course we could just blindly put them on the map until everything is covered. But this would a) reduce the number of tiles we can use for growing crops and b) result in a lot of unnecessary overlap between scarecrow ranges. So the goal is to maximize the covered area and minimize the overlap of scarecrows. This is not an easy task though. If you want to place one crow somewhere on the farm, you have 3414 possibilities to do so. For two crows 5,825,991 and for three 6,626,093,764. So it is definitely not a viable option to try out all possible placements, especially when the number of crows increases. We will not be able to get the optimal solution, but we can try to come as close as possible.
Simulated annealing
There are certainly several heuristics we could use but I decided to apply simulated annealing. The general idea is very simple. In each iteration, try out a new solution. If it is better then the old one, keep it. If it is worse, accept it with a certain probability. This second step is very important, since it allows us to get out of local maxima. The probability to accept worse solution decreases over time, since we assume that we come closer to the “true” maximum. New solutions are of course not chosen randomly, but constructed from previous solutions. In our case, I decided to implement four potential alterations of the current solution:
- add a scarecrow on a random unoccupied tile
- delete a random scarecrow
- teleport a scarecrow to a random unoccupied tile
- move a scarecrow to random neighboring tile
This is the theory, now to the code.
R code
The code of the helper functions (add/delete/move/teleport scarecrows) can be found at the end of this post.
We can use the init_farm() function to get an initial scarecrow layout
farm <- farm_max <- init_farm(farm_blank,no = 10) opt_val <- opt_val_max <- opt_func(farm)
This initial solution covers 820 tiles. Now onto the optimization.
#initialize variables
temp <- 100
max_crow <- 35
min_crow <- 3
steps <- c("a","d","m")
#annealing
while(temp>=0.1){
for(i in 1:1000){
ncrow <- nrow(locate_crows(farm,farm_blank))
farm_old <- farm
t <- sample(steps,1)
if(t=="a"){
if(ncrow<max_crow){
farm <- add_crow(farm)
} else{
farm <- del_crow(farm,farm_blank)
}
} else if(t=="d"){
if(ncrow>min_crow){
farm <- del_crow(farm,farm_blank)
} else{
farm <- add_crow(farm)
}
} else if(t=="m"){
p <- exp(temp-100)
if(runif(1)<=p){
farm <- teleport_crow(farm,farm_blank)
} else{
farm <- move_crow(farm,farm_blank)
}
}
#evaluate
farm_val <- opt_func(farm)
if(farm_val>opt_val){
opt_val <- farm_val
if(opt_val>opt_val_max){
opt_val_max <- opt_val
farm_max <- farm
print(c(temp,opt_val_max))
}
} else{
p <- exp((farm_val-opt_val)/temp)
if(runif(1)<=p){
opt_val <- farm_val
} else{
farm <- farm_old
}
}
}
temp <- temp*0.99
}
Note that this will run for a while (R and loops, you know). If you want to optimize the runtime,
implementing it in C++ with Rcpp might do the trick.
Below is the best layout found during the optimization.
crows <- as_tibble(locate_crows(farm_max,farm_blank))
idx <- which(farm_max>=1,arr.ind = T)
crow_area <- tibble(x=idx[,1],y=idx[,2],val=farm_max[which(farm_max>=1)])
ggplot(map)+geom_tile(aes(x,y,fill=val))+
scale_fill_manual(values=c("c"="#458B00", "w"="#1874CD","h"="#8B0000","b"="#B0B0B0","e"="#CD2626","x"="black"))+
geom_tile(aes(x=x,y=y),fill=c("#104E8B"),alpha=0.25,data=crow_area[crow_area$val==1,])+
geom_tile(aes(x=x,y=y),fill=c("#104E8B"),alpha=0.35,data=crow_area[crow_area$val>1,])+
geom_point(aes(x=row,y=col),data=crows,col="#CD9B1D")+
theme(legend.position = "none",
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
axis.line = element_blank(),
panel.background = element_blank(),
panel.grid = element_blank())
The number of placed scarecrows is 18. 3119 tiles are uniquely protected and 88 are protected by more than one scarecrow. That leaves 207 tiles outside of the crow ranges. So we can now safely plant 3207 crops without crows attacking them. But wait, there is more! We also need to water them…
Optimizing sprinkler placement
I am sure nobody wants to water those crops manually, so we need to place sprinkler. To optimize their placement, we do exactly the same as for scarecrows. Our optimization goal is to maximize the number of protected and watered tiles.
farm <- list(A=farm_blank,sprinklers=matrix(0,0,3))
farm$A[is.na(farm_max) & !is.na(farm_blank)] <- NA
farm_layout <- farm$A
for(i in 1:50){
farm <- add_sprinkler(farm)
}
temp <- 100
max_sprink <- 400
min_sprink <- 3
steps <- c("a","d","m")
farm_opt <- farm
while(temp>=0.1){
for(i in 1:1000){
if(nrow(farm$sprinklers)==3){
stop()
}
farm_old <- farm
t <- sample(steps,1,prob =c(0.4,0.4,0.2))
if(t=="a"){
if(nrow(farm$sprinklers)<max_sprink){
farm <- add_sprinkler(farm)
} else{
farm <- del_sprinkler(farm,farm_layout)
}
} else if(t=="d"){
if(nrow(farm$sprinklers)>min_sprink){
farm <- del_sprinkler(farm,farm_layout)
} else{
farm <- add_sprinkler(farm)
}
} else if(t=="m"){
p <- exp(temp-100)
if(runif(1)<=p){
farm <- teleport_sprinkler(farm,farm_layout)
} else{
farm <- move_sprinkler(farm,farm_layout)
}
}
#evaluate
farm_val <- opt_func1(farm,farm_max)
if(farm_val>opt_val){
opt_val <- farm_val
if(opt_val>opt_val_max){
opt_val_max <- opt_val
farm_opt <- farm
print(c(temp,opt_val_max))
}
} else{
p <- exp((farm_val-opt_val)/temp)
if(runif(1)<=p){
opt_val <- farm_val
} else{
farm <- farm_old
}
}
}
temp <- temp*0.99
}
This is the final layout. The dark blue tiles are the ones that are watered and protected by a scarecrow. light blue tiles are only watered, dark green tiles only protected and light green ones are neither.
sprinklers <- as_tibble(farm_opt$sprinklers)
idx <- which(farm_opt$A>=1,arr.ind = T)
sprinkler_area <- tibble(x=idx[,1],y=idx[,2],val=farm_opt$A[which(farm_opt$A>=1)])
ggplot(map)+
geom_tile(aes(x,y,fill=val))+
scale_fill_manual(values=c("c"="#458B00", "w"="#1874CD","h"="#8B0000","b"="#B0B0B0","e"="#CD2626","x"="black"))+
geom_tile(aes(x=x,y=y),fill=c("#104E8B"),alpha=1,data=sprinkler_area[sprinkler_area$val>=1,])+
geom_tile(aes(x=x,y=y),fill="black",alpha=0.1,data=crow_area[crow_area$val>=1,])+
geom_point(aes(x=row,y=col),data=crows,col="#CD9B1D")+
geom_point(aes(x=V1,y=V2,col=factor(V3)),data=sprinklers,size=2,shape=10)+
scale_color_manual(values=c("#C1CDCD", "#8B4726", "#CD00CD"))+
theme(legend.position = "none",
axis.text = element_blank(),
axis.ticks = element_blank(),
axis.title = element_blank(),
axis.line = element_blank(),
panel.background = element_blank(),
panel.grid = element_blank())
This layout gives us 3144 watered tiles with 180 sprinkler and 2998 of those are protected by a scarecrow.
Notes
If you run this code by yourself, you will notice that you might get different (even better!) results. Simulated annealing is not deterministic, hence it produces different nearly optimal solutions in each run.
helper functions for scarecrow placement
#place a crow on given coordinates
init_crow <- function(x,y){
A <- matrix(0,78,61)
idx <-(x-4):(x+4)
idy <- (y-8):(y+8)
A[idx[idx<=78 & idx>=1],idy[idy<=61 & idy>=1]] <- 1
idx <-(x-8):(x+8)
idy <- (y-4):(y+4)
A[idx[idx<=78 & idx >=1],idy[idy<=61 & idy>=1]] <- 1
idx <- (x-7):(x+7)
k <- 5
while(y+k<=61 & k<=8){
A[idx[idx<=78 & idx>=1],y+k] <- 1
k <- k+1
idx <- idx[-c(1,length(idx))]
}
idx <- (x-7):(x+7)
k <- 5
while(y-k>=1 & k<=8){
A[idx[idx<=78 & idx>=1],y-k] <- 1
k <- k+1
idx <- idx[-c(1,length(idx))]
}
A[x,y] <- NA
A
}
# find the crows on the map
locate_crows <- function(farm,farm_blank){
which(is.na(farm) & farm_blank==0,arr.ind = T)
}
# add a scarecrow on a random empty tile
add_crow <- function(farm){
pos <- which(!is.na(farm),arr.ind=T)
xy <- pos[sample(1:nrow(pos),1),]
A <- init_crow(xy[1],xy[2])
farm+A
}
# delete a random scarecrow
del_crow <- function(farm,farm_blank){
pos <- locate_crows(farm,farm_blank)
del <- sample(1:nrow(pos),1)
pos <- pos[-del,]
farm <- farm_blank
for(i in 1:nrow(pos)){
farm <- farm+init_crow(pos[i,1],pos[i,2])
}
farm
}
# helper function to find overlapping rows in two matrices
overlap <- function(m1,m2){
outer(seq_len(nrow(m1)), seq_len(nrow(m2)), Vectorize(
function(i, j) all(m1[i,]==m2[j,])
))
}
# teleport a scarecrow
teleport_crow <- function(farm,farm_blank){
farm <- del_crow(farm,farm_blank)
farm <- add_crow(farm)
farm
}
# move a scarecrow on a neighboring tile
move_crow <- function(farm,farm_blank){
cur_crow <- locate_crows(farm,farm_blank)
farm <- del_crow(farm,farm_blank)
new_crow <- locate_crows(farm,farm_blank)
deleted <- which(apply(!overlap(cur_crow,new_crow),1,function(x) all(x)))
xy <- cur_crow[deleted,]
xnew <- xy[1]+sample(c(-1,0,1),1)
ynew <- xy[2]+sample(c(-1,0,1),1)
while((xnew==xy[1] & ynew==xy[2]) | xnew<1 | xnew>78 | ynew<1 | ynew>61){
xnew <- xy[1]+sample(c(-1,0,1),1)
ynew <- xy[2]+sample(c(-1,0,1),1)
}
if(!is.na(farm[xnew,ynew])){
A <- init_crow(xnew,ynew)
farm <- farm+A
} else{
A <- init_crow(xy[1],xy[2])
farm <- farm+A
}
farm
}
# initialize a first solution
init_farm <- function(farm,no=3){
for(i in 1:no){
x <- sample(1:78,1)
y <- sample(1:61,1)
while(is.na(farm[x,y])){
x <- sample(1:78,1)
y <- sample(1:61,1)
}
A <- init_crow(x,y)
farm <- farm+A
}
farm
}
#optimization function
opt_func <- function(A){
sum(A==1,na.rm = T)
}
helper functions for sprinkler placement
add_sprinkler <- function(farm){
A <- matrix(0,78,61)
types <- c("n","q","i")
x <- sample(1:78,1)
y <- sample(1:61,1)
while(is.na(farm$A[x,y])){
x <- sample(1:78,1)
y <- sample(1:61,1)
}
t <- sample(types,1)
if(t=="n"){
idx <- (x-1):(x+1)
A[idx[idx>=1 & idx<=78],y] <- 1
idy <- (y-1):(y+1)
A[x,idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
farm$sprinklers <- rbind(farm$sprinklers,c(x,y,1))
} else if(t=="q"){
idx <- (x-1):(x+1)
idy <- (y-1):(y+1)
A[idx[idx>=1 & idx<=78],idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
farm$sprinklers <- rbind(farm$sprinklers,c(x,y,2))
} else if(t=="i"){
idx <- (x-2):(x+2)
idy <- (y-2):(y+2)
A[idx[idx>=1 & idx<=78],idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
farm$sprinklers <- rbind(farm$sprinklers,c(x,y,3))
}
farm$A <- farm$A+A
farm
}
del_sprinkler <- function(farm,farm_layout){
del <- sample(1:nrow(farm$sprinklers),1)
farm$sprinklers <- farm$sprinklers[-del,]
farm$A <- farm_layout
for(i in 1:nrow(farm$sprinklers)){
farm$A <- farm$A + init_sprinkler(farm$sprinklers[i,1],farm$sprinklers[i,2],farm$sprinklers[i,3])
}
farm
}
move_sprinkler <- function(farm,farm_layout){
cur_spr <- farm$sprinklers
farm <- del_sprinkler(farm,farm_layout)
new_spr <- farm$sprinklers
deleted <- which(apply(!overlap(cur_spr,new_spr),1,function(x) all(x)))
xy <- cur_spr[deleted,]
xnew <- xy[1]+sample(c(-1,0,1),1)
ynew <- xy[2]+sample(c(-1,0,1),1)
while((xnew==xy[1] & ynew==xy[2]) | xnew<1 | xnew>78 | ynew<1 | ynew>61){
xnew <- xy[1]+sample(c(-1,0,1),1)
ynew <- xy[2]+sample(c(-1,0,1),1)
}
if(!is.na(farm$A[xnew,ynew])){
A <- init_sprinkler(xnew,ynew,xy[3])
farm$A <- farm$A+A
farm$sprinklers <- rbind(new_spr,c(xnew,ynew,xy[3]))
} else{
A <- init_sprinkler(xy[1],xy[2],xy[3])
farm$A <- farm$A+A
farm$sprinklers <- rbind(new_spr,c(xy[1],xy[2],xy[3]))
}
farm
}
teleport_sprinkler <- function(farm,farm_layout){
cur_spr <- farm$sprinklers
farm <- del_sprinkler(farm,farm_layout)
new_spr <- farm$sprinklers
deleted <- which(apply(!overlap(cur_spr,new_spr),1,function(x) all(x)))
t <- c("n","q","i")[cur_spr[deleted,3]]
x <- sample(1:78,1)
y <- sample(1:61,1)
while(is.na(farm$A[x,y])){
x <- sample(1:78,1)
y <- sample(1:61,1)
}
A <- matrix(0,78,61)
if(t=="n"){
idx <- (x-1):(x+1)
A[idx[idx>=1 & idx<=78],y] <- 1
idy <- (y-1):(y+1)
A[x,idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
farm$sprinklers <- rbind(farm$sprinklers,c(x,y,1))
} else if(t=="q"){
idx <- (x-1):(x+1)
idy <- (y-1):(y+1)
A[idx[idx>=1 & idx<=78],idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
farm$sprinklers <- rbind(farm$sprinklers,c(x,y,2))
} else if(t=="i"){
idx <- (x-2):(x+2)
idy <- (y-2):(y+2)
A[idx[idx>=1 & idx<=78],idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
farm$sprinklers <- rbind(farm$sprinklers,c(x,y,3))
}
farm$A <- farm$A+A
farm
}
init_sprinkler <- function(x,y,type){
t <- c("n","q","i")[type]
A <- matrix(0,78,61)
if(t=="n"){
idx <- (x-1):(x+1)
A[idx[idx>=1 & idx<=78],y] <- 1
idy <- (y-1):(y+1)
A[x,idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
} else if(t=="q"){
idx <- (x-1):(x+1)
idy <- (y-1):(y+1)
A[idx[idx>=1 & idx<=78],idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
} else if(t=="i"){
idx <- (x-2):(x+2)
idy <- (y-2):(y+2)
A[idx[idx>=1 & idx<=78],idy[idy>=1 & idy<=61]] <- 1
A[x,y] <- NA
}
A
}
opt_func1 <- function(farm,farm_max){
sum(farm$A==1 & farm_max>0,na.rm=T)
}
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.