Code
# load libraries and source functions
library(dplyr)
library(highs)
library(ompr)
library(ompr.highs)
library(gt)
library(glue)
library(visNetwork)
source("ompr_helperfns.R")
source("helper_fns.R")Transportation Model with OMPR and HiGHS
We show how to solve the transportation problem using OMPR modeling language and HiGHS solver. Transportation problem is a classic operations research problem where the objective is to find the minimum cost way to ship material from producers/plants to customers/markets. The specific instance of the problem we have used is from GAMS model library. Only portions of R code are shown here. The .qmd with all embedded R code is in this location
Code
plants = c("seattle", "sandiego")
mkts = c("newyork", "chicago", "topeka")
cap = c(350, 600) # plant capacity
dem = c(325, 300, 275) # market demand
# distance and cost between plants and markets
distdf = tibble(
plants = rep(plants, each = 3),
mkts = rep(mkts, 2),
dist = c(2.5, 1.7, 1.8, 2.5, 1.8, 1.4) # distance in thousands of miles
)
f = 90 # freight dollars per case per thousands of miles
distdf = distdf %>% mutate(cost = f * dist / 1000)
cost = function(i, j) {
p = plants[i]
m = mkts[j]
costval = distdf %>% filter(plants == p, mkts == m) %>% pull(cost)
return(costval)
}In this case there are 2 plants and 3 markets with data for the problem listed below:
Code
tibble(plant = plants, capacity = cap) %>% gt()| plant | capacity |
|---|---|
| seattle | 350 |
| sandiego | 600 |
Code
tibble(market = mkts, demand = dem) %>% gt()| market | demand |
|---|---|
| newyork | 325 |
| chicago | 300 |
| topeka | 275 |
Code
distdf %>% select(plants, mkts, cost) %>% gt()| plants | mkts | cost |
|---|---|---|
| seattle | newyork | 0.225 |
| seattle | chicago | 0.153 |
| seattle | topeka | 0.162 |
| sandiego | newyork | 0.225 |
| sandiego | chicago | 0.162 |
| sandiego | topeka | 0.126 |
Code
# visualize network
visnetdf = make_visnetdf(distdf, plants, mkts)
visnetdf$nodes_df = visnetdf$nodes_df %>% mutate(level = ifelse(id <= 2, 1, 2),
capdem = c(cap, dem),
label = paste0(node, " (", capdem,")"),
color = c(rep("red", 2), rep("green", 3)))
visNetwork(visnetdf$nodes_df, visnetdf$edges_df) %>% visEdges(arrows = "to") %>%
visHierarchicalLayout()\[ \begin{array}{llr} \min &\sum_{p=1}^P\sum_{m=1}^Mc_{pm}x_{pm} & (a) \\ &\sum_{m=1}^Mx_{pm} \leq cap_p, \;p=1,2,\ldots,P & (b)\\ &\sum_{p=1}^Px_{pm} \geq dem_m, \;m=1,2,\ldots,M & (c) \\ &x_{pm} \geq 0, \;p=1,2,\ldots,P;\;m=1,2,\ldots,M \end{array} \]
where
- \(x_{pm}\) is the quantity to be shipped from plant \(p\) to market \(m\) (decision variable)
- Objective (a) is to minimize shipping cost
- Constraint (b) ensures that total supply from a plant is below capacity
- Constraint (c) ensures that demand for each market is met.
np = length(plants)
nm = length(mkts)
# create ompr model
mdl = MIPModel() %>%
add_variable(x[i, j], i=1:np, j=1:nm, type = "continuous",lb = 0) %>%
# objective: min cost
set_objective(sum_over(cost(i, j) * x[i, j], i = 1:np, j = 1:nm), sense = "min") %>%
# supply from each plant is below capacity
add_constraint(sum_over(x[i, j], j = 1:nm) <= cap[i], i = 1:np) %>%
# supply to each market meets demand
add_constraint(sum_over(x[i, j], i = 1:np) >= dem[j], j = 1:nm)Code
# solve model
sol = mdl %>% solve_model(highs_optimizer())
# get solution
sol[["status"]][1] "optimal"Code
sol[["objective_value"]][1] 153.675Code
soldf = sol %>% get_solution(x[i, j])
soldf = soldf %>% mutate(plants = plants[i], mkts = mkts[j]) %>%
rename(qty = value)
soldf %>% gt()| variable | i | j | qty | plants | mkts |
|---|---|---|---|---|---|
| x | 1 | 1 | 0 | seattle | newyork |
| x | 2 | 1 | 325 | sandiego | newyork |
| x | 1 | 2 | 300 | seattle | chicago |
| x | 2 | 2 | 0 | sandiego | chicago |
| x | 1 | 3 | 0 | seattle | topeka |
| x | 2 | 3 | 275 | sandiego | topeka |
Code
soldf %>% gt()| variable | i | j | qty | plants | mkts |
|---|---|---|---|---|---|
| x | 1 | 1 | 0 | seattle | newyork |
| x | 2 | 1 | 325 | sandiego | newyork |
| x | 1 | 2 | 300 | seattle | chicago |
| x | 2 | 2 | 0 | sandiego | chicago |
| x | 1 | 3 | 0 | seattle | topeka |
| x | 2 | 3 | 275 | sandiego | topeka |
Code
# visnetwork visualization of solution
solvisnetdf = make_visnetdf(soldf %>% filter(qty > 0), plants, mkts)
solvisnetdf$nodes_df = solvisnetdf$nodes_df %>% mutate(level = ifelse(id <= 2, 1, 2),
capdem = c(cap, dem),
label = paste0(node, " (", capdem,")"),
color = c(rep("red", 2), rep("green", 3))
)
solvisnetdf$edges_df = solvisnetdf$edges_df %>% mutate(label = as.character(qty))
visNetwork(solvisnetdf$nodes_df, solvisnetdf$edges_df) %>% visEdges(arrows = "to") %>%
visHierarchicalLayout()
Session Info
Code
sessionInfo()R version 3.6.3 (2020-02-29)
Platform: x86_64-pc-linux-gnu (64-bit)
Running under: Ubuntu 20.04.3 LTS
Matrix products: default
BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0
LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
locale:
[1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
[3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
[5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8
[7] LC_PAPER=en_US.UTF-8 LC_NAME=C
[9] LC_ADDRESS=C LC_TELEPHONE=C
[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] visNetwork_2.1.0 glue_1.6.2 gt_0.7.0
[4] ompr.highs_0.0.1.9000 ompr_1.0.2 highs_0.1-2
[7] dplyr_1.0.10
loaded via a namespace (and not attached):
[1] Rcpp_1.0.9 pillar_1.8.1 compiler_3.6.3 tools_3.6.3
[5] digest_0.6.29 gtable_0.3.1 jsonlite_1.8.0 evaluate_0.16
[9] lifecycle_1.0.1 tibble_3.1.8 checkmate_2.1.0 lattice_0.20-40
[13] pkgconfig_2.0.3 rlang_1.0.5 Matrix_1.2-18 cli_3.3.0
[17] yaml_2.3.5 xfun_0.32 fastmap_1.1.0 listcomp_0.4.1
[21] stringr_1.4.1 knitr_1.40 rappdirs_0.3.3 sass_0.4.2
[25] generics_0.1.3 vctrs_0.4.1 htmlwidgets_1.5.4 grid_3.6.3
[29] tidyselect_1.1.2 data.table_1.14.2 R6_2.5.1 fansi_1.0.3
[33] rmarkdown_2.16 ggplot2_3.3.6 purrr_0.3.4 magrittr_2.0.3
[37] ellipsis_0.3.2 scales_1.2.1 backports_1.4.1 htmltools_0.5.3
[41] colorspace_2.0-3 utf8_1.2.2 stringi_1.7.8 munsell_0.5.0
[45] lazyeval_0.2.2