# Rdew Valley: Optimizing Farming with R

November 13, 2018
By

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)``

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")
``dim(farm_blank)``
``##  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(ncrowmin_crow){
farm <- del_crow(farm,farm_blank)
} else{
}
} 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){
}

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)min_sprink){
farm <- del_sprinkler(farm,farm_layout)
} else{
}
} 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.

# 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
pos <- which(!is.na(farm),arr.ind=T)
xy <- pos[sample(1:nrow(pos),1),]
A <- init_crow(xy,xy)
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
}

# 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+sample(c(-1,0,1),1)
ynew <- xy+sample(c(-1,0,1),1)
while((xnew==xy & ynew==xy) | xnew<1 | xnew>78 | ynew<1 | ynew>61){
xnew <- xy+sample(c(-1,0,1),1)
ynew <- xy+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,xy)
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+sample(c(-1,0,1),1)
ynew <- xy+sample(c(-1,0,1),1)
while((xnew==xy & ynew==xy) | xnew<1 | xnew>78 | ynew<1 | ynew>61){
xnew <- xy+sample(c(-1,0,1),1)
ynew <- xy+sample(c(-1,0,1),1)
}
if(!is.na(farm\$A[xnew,ynew])){
A <- init_sprinkler(xnew,ynew,xy)
farm\$A <- farm\$A+A
farm\$sprinklers <- rbind(new_spr,c(xnew,ynew,xy))
} else{
A <- init_sprinkler(xy,xy,xy)
farm\$A <- farm\$A+A
farm\$sprinklers <- rbind(new_spr,c(xy,xy,xy))
}
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.