Rdew Valley： Optimizing Farming with R

转载自：http://feedproxy.google.com/~r/RBloggers/~3/vfO_R93ulFY/

schochastics
发表于

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 andyou 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 pointyou 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.

1
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 areddit post,where someone posted the layout as an excel file. I converted the file into a matrix anda long data frame. The data frame is for plotting and the matrix for the actual optimization.

1
2
farm_blank <- readRDS("farm_blank.RDS")
map <- read_csv("fun_projects/stardew/map.csv")

1
dim(farm_blank)

1
## [1] 78 61

1
2
3
4
5
6
7
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 plant3414 crops there. But the tiles are totally unprotected against the nastycrows that would eat all your precious crops. We need scarecrows to protect them.

When you plant your crops, you should make sure that your crops fall into the range ofa 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 onthe farm to maximize the protected area?

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 thecovered 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 possibilitiesto 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 allpossible placements, especially when the number of crows increases. We will not be ableto get the optimal solution, but we can try to come as close as possible.

Simulated annealing

There are certainly several heuristics we could usebut I decided to apply simulated annealing.The general idea is very simple. In each iteration, try out a new solution. If it isbetter 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 wecome closer to the “true” maximum. New solutions are of course not chosen randomly, but constructed fromprevious 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

1
2
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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
#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{
 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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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 tilesare 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…

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 optimizationgoal is to maximize the number of protected and watered tiles.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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)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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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 and2998 of those are protected by a scarecrow.

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 nearlyoptimal solutions in each run.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#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)
}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
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)
}

Related