-
Notifications
You must be signed in to change notification settings - Fork 0
/
heumilkr_solution.R
137 lines (121 loc) · 3.32 KB
/
heumilkr_solution.R
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
132
133
134
135
136
137
heumilkr_solution <- function(df, distances) {
stopifnot(inherits(df, "data.frame"))
stopifnot(
c("site", "run", "order", "vehicle", "order", "distance") %in% colnames(df)
)
stopifnot(inherits(distances, "dist"))
new_heumilkr_solution(df, distances)
}
new_heumilkr_solution <- function(df, distances) {
obj <-
structure(
df,
class = c("heumilkr_solution", class(df))
)
attr(obj, "distances") <- distances
obj
}
#' Vehicle runs cost / distance
#'
#' Calculates the total distance associated to a [clarke_wright()] result.
#' This is the measure that the corresponding Capacitated Vehicle Routing
#' Problem minimizes.
#'
#' @param solution
#' A "`heumilkr_solution`" object, typically obtained by [clarke_wright()].
#'
#' @return The total traveled distance.
#' @examples
#' demand <- c(3, 2, 4, 2)
#'
#' positions <-
#' data.frame(
#' pos_x = c(0, 1, -1, 2, 3),
#' pos_y = c(0, 1, 1, 2, 3)
#' )
#'
#' solution <- clarke_wright(
#' demand,
#' dist(positions),
#' data.frame(n = NA_integer_, caps = 6)
#' )
#'
#' milkr_cost(solution)
#'
#' @export
milkr_cost <- function(solution) {
stopifnot(inherits(solution, "heumilkr_solution"))
sum(unique(solution[, c("run", "distance")])$distance)
}
#' Vehicle run saving
#'
#' Measures the saving that was achieved by the heuristic optimization
#' algorithm [clarke_wright()] compared to the naive vehicle run assignment,
#' i.e. one run per site.
#'
#' @param solution
#' A "`heumilkr_solution`" object, typically obtained by [clarke_wright()].
#' @param relative
#' Should the saving be given as dimensionful value (in units of distance as
#' provided to [clarke_wright()]), or as percentage relative to the
#' naive costs.
#' Defaults to `FALSE`, i.e. a dimensionful value.
#'
#' @return
#' The savings either as dimensionful value or as percentage relative to the
#' naive costs, depending on `relative`.
#'
#' @examples
#' demand <- c(3, 2, 4, 2)
#'
#' positions <-
#' data.frame(
#' pos_x = c(0, 1, -1, 2, 3),
#' pos_y = c(0, 1, 1, 2, 3)
#' )
#'
#' solution <- clarke_wright(
#' demand,
#' dist(positions),
#' data.frame(n = NA_integer_, caps = 6)
#' )
#'
#' print(milkr_saving(solution))
#' print(milkr_saving(solution, relative = TRUE))
#'
#' @export
milkr_saving <- function(solution, relative = FALSE) {
stopifnot(inherits(solution, "heumilkr_solution"))
stopifnot(is.logical(relative))
d <- as.matrix(attr(solution, "distances"))
naive_cost <-
sum(
vapply(
1:(dim(d)[[2]] - 1),
\(idx) 2 * d[1, idx + 1],
FUN.VALUE = 1.
)
)
saving <- naive_cost - milkr_cost(solution)
if (relative) {
saving / naive_cost
} else {
saving
}
}
milkr_perf_scale <- function(solution, optimum) {
stopifnot(inherits(solution, "heumilkr_solution"))
stopifnot(is.numeric(optimum))
cost <- milkr_cost(solution)
saving <- milkr_saving(solution)
# measures where we are on the scale between optimum and naive solution
# (= 0 when cost = naive cost, = 1 when cost = optimal cost)
1 - (cost - optimum) / (cost - optimum + saving)
}
milkr_perf_rel <- function(solution, optimum) {
stopifnot(inherits(solution, "heumilkr_solution"))
stopifnot(is.numeric(optimum))
cost <- milkr_cost(solution)
# how much better is the optimal solution compared to this one
(cost - optimum) / cost
}