R/glpk.R

In dirkschumacher/rmpk.glpk: GLPK Bindings For RMPK

#' GLPK solver
#'
#' @param presolve yes or no
#'
#' @export
GLPK <- function(presolve = FALSE) {
  glpk_ptr <- glpk_init()
  GLPKClass$new(glpk_ptr)
}

GLPKClass <- R6::R6Class("GLPKClass",
  public = list(
    initialize = function(ptr) {
      self$glpk_ptr <- ptr
    },
    finalize = function() {
      glpk_kill(self$glpk_ptr)
    },
    add_variable = function(type, lower_bound = -Inf, upper_bound = Inf) {
      column_idx <- glpk_add_cols(self$glpk_ptr, 1L)
      type <- rmpk_col_type_to_glpk(type)
      glpk_set_col_kind(self$glpk_ptr, column_idx, type)
      if (is.finite(lower_bound) && is.finite(upper_bound)) {
        glpk_set_col_bnd(self$glpk_ptr, column_idx, glpkAPI::GLP_DB, lower_bound, upper_bound)
      } else if (is.finite(lower_bound)) {
        glpk_set_col_bnd(self$glpk_ptr, column_idx, glpkAPI::GLP_LO, lower_bound, 0)
      } else if (is.finite(upper_bound)) {
        glpk_set_col_bnd(self$glpk_ptr, column_idx, glpkAPI::GLP_UP, 0, upper_bound)
      }
      column_idx
    },
    add_linear_constraint = function(linear_expr, type, rhs) {
      row_idx <- glpk_add_rows(self$glpk_ptr, 1L)
      if (type == "<=") {
        glpk_set_row_bnd(self$glpk_ptr, row_idx, glpkAPI::GLP_UP, 0, rhs)
      } else if (type == ">=") {
        glpk_set_row_bnd(self$glpk_ptr, row_idx, glpkAPI::GLP_LO, rhs, 0)
      } else if (type == "==") {
        glpk_set_row_bnd(self$glpk_ptr, row_idx, glpkAPI::GLP_FX, rhs, rhs)
      }
      variables <- linear_expr@variables$as_list()
      # GLPK starts at 1 internally it seems
      indexes <- c(NA_integer_, vapply(variables, function(x) x@variable_index, integer(1L)))
      coefficients <- c(NA_integer_, vapply(variables, function(x) x@coefficient, numeric(1L)))
      glpk_set_mat_row(
        self$glpk_ptr,
        row_idx,
        indexes,
        coefficients
      )
      row_idx
    },
    set_variable_lb = function(variable_index, value) {
      # TODO: check if that overwrites the ub
      glpk_set_col_bnd(self$glpk_ptr, variable_index, glpkAPI::GLP_LO, value, 0)
    },
    set_variable_ub = function(variable_index, value) {
      # TODO: check if that overwrites the lb
      glpk_set_col_bnd(self$glpk_ptr, variable_index, glpkAPI::GLP_UP, 0, value)
    },
    nvars = function() {
      glpk_get_num_cols(self$glpk_ptr)
    },
    nconstraints = function() {
      glpk_get_num_rows(self$glpk_ptr)
    },
    set_linear_objective = function(linear_expr, sense) {
      for (var in linear_expr@variables$as_list()) {
        glpk_set_obj_coefs(self$glpk_ptr, var@variable_index, var@coefficient)
      }
      sense <- if (sense == "max") glpkAPI::GLP_MAX else glpkAPI::GLP_MIN
      glpk_set_obj_dir(self$glpk_ptr, sense)
    },
    optimize = function() {
      glpk_solve_simplex(self$glpk_ptr)
      #if (presolve) {
        # TODO: do it
      #}
      glpk_solve_MIP(self$glpk_ptr)
    },
    glpk_get_col_prim = function(variable) {
      glpk_get_col_prim(self$glpk_ptr, variable@variable_index)
    },
    get_variable_value = function(var_index) {
      glpk_get_mip_col_val(self$glpk_ptr, var_index);
    },
    get_objective_value = function() {
      glpk_mip_obj_val(self$glpk_ptr)
    },
    get_termination_status = function() {
      NA_integer_
    },
    set_irowgen_callback = function(fun) {
      glpk_set_irowgen_callback(self$glpk_ptr, fun)
    },
    glpk_ptr = NULL
  )
)

rmpk_col_type_to_glpk <- function(type) {
  type <- switch (type,
    continuous = glpkAPI::GLP_CV,
    integer = glpkAPI::GLP_IV,
    binary = glpkAPI::GLP_BV
  )
  if (is.null(type)) stop()
  type
}