Transportation Model with OMPR and HiGHS

Author

notesofdabbler

Published

September 10, 2022

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
# 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")
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.675
Code
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()
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