R/seriate_BEA.R

Defines functions seriate_matrix_bea seriate_matrix_bea_tsp

#######################################################################
# seriation - Infrastructure for seriation
# Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.


#' @include seriate_TSP.R
.bea_tsp_contr <- .tsp_control

seriate_matrix_bea_tsp <-
  function(x, control, margin = seq_along(dim(x))) {
    if (any(x < 0))
      stop("Requires a nonnegative matrix.")

    if (1L %in% margin) {
      criterion <- as.dist(tcrossprod(x))
      row <- seriate(max(criterion) - criterion,
                     method = "TSP",
                     control = control)[[1]]
      attr(row, "method") <- "BEA_TSP"
    } else
      row <- NA

    if (2L %in% margin) {
      criterion <- as.dist(crossprod(x))
      col <- seriate(max(criterion) - criterion,
                     method = "TSP",
                     control = control)[[1]]
      attr(col, "method") <- "BEA_TSP"
    } else
      col <- NA

    list(row = row, col = col)
  }

## Bond Energy Algorithm (McCormick 1972)
.bea_contr <- list(istart = 0,
                   jstart = 0
)

attr(.bea_contr, "help") <- list(istart = "index of 1st row to be placed (0 = random)",
                                 jstart = "index of 1st column to be placed (0 = random)"
)

# BEA always does rows and columns so margin is ignored
seriate_matrix_bea <- function(x, control = NULL, margin = NULL) {
  control <- .get_parameters(control, .bea_contr)

  if (any(x < 0))
    stop("Requires a nonnegative matrix.")
  istart <- control$istart
  jstart <- control$jstart
  #rep  <- control$rep
  rep  <- 1L

  res <- replicate(rep, bea(x, istart = istart, jstart = jstart),
                   simplify = FALSE)

  best <- which.max(sapply(res, "[[", "e"))
  res <- res[[best]]

  row <- res$ib
  col <- res$jb

  names(row) <- rownames(x)[row]
  names(col) <- colnames(x)[col]

  list(row = row, col = col)
}

## register methods
set_seriation_method(
  "matrix",
  "BEA",
  seriate_matrix_bea,
  "Bond Energy Algorithm (BEA; McCormick 1972) to maximize the Measure of Effectiveness of a non-negative matrix.",
  .bea_contr,
  optimizes = .opt("ME", "Measure of effectiveness"),
  randomized = TRUE
)

set_seriation_method(
  "matrix",
  "BEA_TSP",
  seriate_matrix_bea_tsp,
  "Use a TSP to optimize the Measure of Effectiveness (Lenstra 1974).",
  .bea_tsp_contr,
  optimizes = .opt("ME", "Measure of effectiveness"),
  randomized = TRUE
)

Try the seriation package in your browser

Any scripts or data that you put into this service are public.

seriation documentation built on Nov. 27, 2023, 1:07 a.m.