Merge pull request #9 from mhahsler/cut_tour

Cut tour

.gitignore

@@ -13,4 +13,8 @@ vignettes/*.html
 vignettes/*.pdf
 .Rproj.user
 
+*.o
+*.so
+*.Rproj
+
 Work

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: TSP
 Type: Package
 Title: Traveling Salesperson Problem (TSP)
-Version: 1.1-7.1
-Date: 2019-05-22
+Version: 1.1-8
+Date: 2020-01-23
 Authors@R: c(
 	person("Michael", "Hahsler", role = c("aut", "cre", "cph"),
 	    email = "mhahsler@lyle.smu.edu"),
@@ -17,7 +17,7 @@ Classification/ACM: G.1.6, G.2.1, G.4
 URL:  https://github.com/mhahsler/TSP
 BugReports: https://github.com/mhahsler/TSP/issues
 Depends: R (>= 2.14.0)
-Imports: graphics, foreach, utils, methods, stats, grDevices
-Suggests: maps, sp, maptools, testthat
+Imports: graphics, foreach, utils, stats, grDevices
+Suggests: sp, maps, maptools, testthat
 License: GPL-3
 Copyright: All code is Copyright (C) Michael Hahsler and Kurt Hornik.

NAMESPACE

@@ -2,7 +2,6 @@ useDynLib(TSP, .registration = TRUE)
 
 importFrom(stats, as.dist, dist)
 importFrom(utils, read.table, write.table)
-importFrom(methods, is)
 importFrom(grDevices, gray.colors)
 importFrom(graphics, image.default, plot, polygon)
 importFrom(foreach, foreach, "%dopar%")

NEWS.md

@@ -1,8 +1,9 @@
-# TSP 1.1-7.1 (xx/xx/2019)
+# TSP 1.1-8 (01/23/2020)
 
 ## New Feature
 * solve_TSP for ATSP gained parameter as_TSP to solve the ATSP reformulated as a TSP.
 * Concorde and linkern can now solve ATSP using a reformulation as a TSP.
+* cut_tour can now cut a tour into multiple paths.
 
 # TSP 1.1-7 (05/22/2019)
 

R/AAAparameter.R

@@ -52,7 +52,7 @@
   }
 
   if(defaults$verbose) {
-    cat("Used parameters:\n")
+    cat("Used control parameters:\n")
     #print(defaults)
     cat(rbind(names(defaults)," = ",
       strtrim(gsub("\n"," ",as.character(defaults)), 50)),

R/cut_tour.R

@@ -16,22 +16,38 @@
 # with this program; if not, write to the Free Software Foundation, Inc.,
 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 
+cut_tour.TOUR <- function(x, cut, exclude_cut = TRUE) {
 
+    ## city label
+    if(is.character(cut)) {
+        cut <- which(as.logical(apply(sapply(cut, "==", labels(x)), MARGIN = 1, sum)))
+        if(length(cut)<1) stop("cut has to exist")
 
-cut_tour.TOUR <- function(x, cut, exclude_cut = TRUE) {
+    ## city id
+    } else {
+        if(any(is.na(cut <- match(cut, x)))) stop("cut has to exist")
+    }
+
+    if(length(cut) == 1L) { ## single path
+        path <- c(x,x)[(cut + as.numeric(exclude_cut)):(length(x) + cut - 1L)]
+
+    } else { ## multiple paths, return as a list
 
-    if(is.character(cut)) cut <- which(labels(x) == cut)
-    else cut <- which(x == cut) ## city id
-    if(length(cut)!=1) stop("cut has to exist and be unique in the tour!")
+        path_names <- labels(x)[cut]
 
-    exclude_cut <- if(exclude_cut) 1 else 0
+        ## make first cut the begining. Note we keeb the boundary at the begining and the end!
+        path <- c(x,x)[cut[1]:(length(x) + cut[1])]
+        cut2 <- c(cut - cut[1] + 1L, length(x))
+
+        path <- lapply(2:length(cut2), FUN =
+                function(i) path[(cut2[i-1L] + as.numeric(exclude_cut)):(cut2[i]-1L)])
+
+        names(path) <- path_names
+    }
 
-    path <- c(x,x)[(cut + exclude_cut):(length(x) + cut - 1)]
     path
 }
 
 ##generic
 cut_tour <- function(x, cut, exclude_cut = TRUE)
     UseMethod("cut_tour")
-
-

R/insert_dummy.R

@@ -55,4 +55,4 @@ insert_dummy.ATSP <- function(x, n = 1, const = 0, inf = Inf, label = "dummy") {
 }
 
 insert_dummy.ETSP <- function(x, n = 1, const = 0, inf = Inf, label = "dummy")
-  stop("Dummy cities cannot be used with ETSP!")
+  stop("Dummy cities cannot be used with ETSP! Convert the problem into a TSP.")

R/reformulare_ATSP_as_TSP.R

@@ -21,7 +21,7 @@
 ## create a TSP form an ATSP by doubling the cities
 
 reformulate_ATSP_as_TSP <- function(x, infeasible = Inf, cheap = -Inf) {
-    if(!is(x, "ATSP")) stop("x is not an ATSP object!")
+    if(!inherits(x, "ATSP")) stop("x is not an ATSP object!")
 
     method <- attr(x, "method")
     m <- as.matrix(x)

R/tsp_concorde.R

@@ -18,6 +18,34 @@
 
 
 
+
+## prepare distances as integers in the appropriate range [0..MAX]
+.prepare_dist_concorde <- function(x, MAX, precision) {
+  ## handle inf
+  x <- .replaceInf(x)
+
+  ## fix neg. values
+  min_x <- min(x)
+  if(min_x<0) {
+    warning("TSP contains negative distances. Shifting distances by subtracting the minimum.",
+      immediate. = TRUE)
+    x <- x - min_x
+  }
+
+  ## get max (excluding) to check for possible integer overflows
+  max_x <- max(x)
+  prec <- floor(log10(MAX / max_x))
+  x <- x * 10^prec
+
+  if(prec < precision && any((x %% 1) != 0))
+    warning(paste0("Concorde/Linken can only handle distances represented as integers. Converting the provided distances to integers with precison ", prec, ". This may lead to rounding errors."),
+      immediate. = TRUE)
+
+  storage.mode(x) <- "integer" ## so write.TSBLIB does not do precision changes
+
+  x
+}
+
 ## interface to the Concorde algorithm
 ## (can only handle TSP and no neg. distances!)
 
@@ -28,47 +56,17 @@ tsp_concorde <- function(x, control = NULL){
   ## get parameters
   control <- .get_parameters(control, list(
     clo = "",
-    precision = 6,
     exe = .find_exe(control$exe, "concorde"),
-    verbose = TRUE
+    precision = 6,
+    verbose = TRUE,
+    keep_files = FALSE
   ))
 
-  precision <- control$precision
-
   ## check x
   if(inherits(x, "TSP")){
+    if(n_of_cities(x) < 10) MAX <- 2^15 - 1 else MAX <- 2^31 - 1
+    x <- .prepare_dist_concorde(x, MAX, control$precision)
 
-    ## fix neg. values
-    min_x <- min(x)
-    if(min_x<0) x <- x - min_x
-
-    ## get max (excluding) to check for possible integer overflows
-    max_x <- max(x)
-    if(n_of_cities(x) < 10){
-      ## <10 cities: concorde can only handle max 2^15
-      MAX <- 2^15
-      if(max_x > MAX) stop("Concorde can only handle distances < 2^15 for less than 10 cities")
-
-      prec <- floor(log10(MAX / max_x))
-      if(prec < precision) {
-        precision <- prec
-        if(control$verbose)
-          warning(paste("Concorde can only handle distances < 2^15 for",
-            "less than 10 cities. Reducing precision to",
-            precision), immediate. = TRUE)
-      }
-    }else{
-      ## regular constraint on integer is 2^31 - 1
-      MAX <- 2^31 - 1
-
-      prec <- floor(log10(MAX / max_x / n_of_cities(x)))
-      if(prec < precision) {
-        precision <- prec
-        if(control$verbose)
-          warning(paste("Concorde can only handle distances < 2^31.",
-            "Reducing precision for Concorde to", precision), immediate. = TRUE)
-      }
-    }
   }else if(inherits(x, "ETSP")) {
     ## nothing to do!
   }else stop("Concorde only handles TSP and ETSP.")
@@ -88,8 +86,8 @@ tsp_concorde <- function(x, control = NULL){
   tmp_file_in  <- paste(temp_file, ".dat", sep = "")
   tmp_file_out <- paste(temp_file, ".sol", sep = "")
 
-  write_TSPLIB(x, file = tmp_file_in,
-    precision = precision)
+  ## precision is already handled!
+  write_TSPLIB(x, file = tmp_file_in, precision = 0)
 
   ## change working directory
 
@@ -112,7 +110,8 @@ tsp_concorde <- function(x, control = NULL){
   order <- order[-1] + 1L
 
   ## tidy up
-  unlink(c(tmp_file_in, tmp_file_out))
+  if(!control$keep_files) unlink(c(tmp_file_in, tmp_file_out))
+  else cat("File are in:", wd, "\n\n")
 
   order
 }
@@ -130,28 +129,20 @@ tsp_linkern <- function(x, control = NULL){
     exe = .find_exe(control$exe, "linkern"),
     clo = "",
     precision = 6,
-    verbose = TRUE
+    verbose = TRUE,
+    keep_files = FALSE
   ))
 
-  precision <- control$precision
-
   ## have to set -r for small instances <8
   if(n_of_cities(x) <=8)
     control$clo <- paste(control$clo, "-k", n_of_cities(x))
 
   ## check x
   if(inherits(x, "TSP")) {
-    ## check for possible overflows
-    max_x <- max(abs(x[is.finite(x)]))
+
     MAX <- 2^31 - 1
+    x <- .prepare_dist_concorde(x, MAX, control$precision)
 
-    prec <- floor(log10(MAX / max_x / n_of_cities(x)))
-    if(prec < precision) {
-      precision <- prec
-      if(control$verbose)
-        warning(paste("Linken can only handle distances < 2^31.",
-          "Reducing precision to", precision), immediate. = TRUE)
-    }
   }else if(inherits(x, "ETSP")) {
     ## nothing to do
   } else stop("Linkern only works for TSP and ETSP.")
@@ -164,9 +155,7 @@ tsp_linkern <- function(x, control = NULL){
   tmp_file_in  <- paste(temp_file, ".dat", sep = "")
   tmp_file_out <- paste(temp_file, ".sol", sep = "")
 
-  ## prepare data (neg_inf = 0 so everything is > 0)
-  write_TSPLIB(x, file = tmp_file_in,
-    precision = precision)
+  write_TSPLIB(x, file = tmp_file_in, precision = 0)
 
   ## change working directory
   dir <- getwd()
@@ -190,7 +179,8 @@ tsp_linkern <- function(x, control = NULL){
   order <- order + as.integer(1)
 
   ## tidy up
-  unlink(c(tmp_file_in, tmp_file_out))
+  if(!control$keep_files) unlink(c(tmp_file_in, tmp_file_out))
+  else cat("File are in:", wd, "\n\n")
 
   order
 }