PipeOpInfo, PipeOpIsomap

R/PipeOpIsomap.R

@@ -45,85 +45,37 @@ PipeOpIsomap = R6Class("PipeOpIsomap",
   public = list(
     initialize = function(id = "isomap", param_vals = list(), get_geod = FALSE, keep_org_data = TRUE, diag = FALSE) {
       ps = ps(
-        k = p_int(default = 50, lower = 1, upper = Inf, tags = "train"), # tag isomap?
+        knn = p_int(default = 50, lower = 1, upper = Inf, tags = "train"), # tag isomap?
         ndim = p_int(default = 2, lower = 1, upper = Inf, tags = "train"), #tag isomap?
-        eps = p_dbl(default = 0, tags = "train")) # tag isomap?
-      ps$values = list(k = 50, ndim = 2, eps = 0)
+        get_geod = p_lgl(default = FALSE, tags = "train"),
+        .mute = p_uty(default = NULL, tags = "train")
+      )
+      ps$values = list(knn = 50, ndim = 2)
       super$initialize(id = id, param_set = ps, param_vals = param_vals, feature_types = c("numeric", "integer"))
-      private$.get_geod = get_geod
-      private$.keep_org_data = keep_org_data
-      private$.diag = diag
     }
   ),
-  active = list(),
   private = list(
-    .get_geod = NULL,
-    .keep_org_data = NULL,
-    .diag = NULL,
-    .make_knn_graph = function(x) {
-      pv = self$param_set$get_values(tags = "train")
-      INF_VAL = 1.340781e+15
-      NA_IDX  = 0
-      ## select parameters
-      M = nrow(x)
-      if (pv$eps == 0) searchtype = "standard" else searchtype = "priority"
-      ## RANN::nn2 returns the points in data with respect to query
-      ## e.g. the rows in the output are the points in query and the
-      ## columns the points in data.
-      nn2res = RANN::nn2(data = x, query = x, k = pv$k + 1, treetype = "kd",
-                          searchtype = searchtype, eps = pv$eps)
-      ## create graph: the first ny nodes will be y, the last nx nodes
-      ## will be x, if x != y
-      g = igraph::make_empty_graph(M, directed = TRUE)
-      g[from = if (private$.diag) rep(seq_len(M), times = pv$k + 1)
-        else      rep(seq_len(M), times = pv$k),
-        to   = if (private$.diag) as.vector(nn2res$nn.idx)
-        else      as.vector(nn2res$nn.idx[, -1]),
-        attr = "weight"] =
-        if (private$.diag)  as.vector(nn2res$nn.dists)
-      else as.vector(nn2res$nn.dists[, -1])
-      igraph::as_undirected(g, mode = "collapse", edge.attr.comb = "first")
-    },
     .train_dt = function(dt, levels, target) {
       #browser()
       pv = self$param_set$get_values(tags = "train")
-      knn_graph = private$.make_knn_graph(dt)
-      geodist = igraph::distances(knn_graph, algorithm = "dijkstra")
-      k = geodist ^ 2
-      k = .Call(stats:::C_DoubleCentre, k)
-      k = - k / 2
-      ## TODO: explicit symmetrizing
-      ## TODO: return eigenvectors?
-      e = RSpectra::eigs_sym(k, pv$ndim, which = "LA", opts = list(retvec = TRUE))
-      e_values = e$values
-      e_vectors = e$vectors
-      neig = sum(e_values > 0)
-      if (neig < pv$ndim) {
-        warning("Isomap: eigenvalues < 0, returning less dimensions!")
-        e_values = e_values[seq_len(neig)]
-        e_vectors = e_vectors[, seq_len(neig), drop = FALSE]
-      }
-      e_vectors = e_vectors * rep(sqrt(e_values), each = nrow(e_vectors))
-      colnames(e_vectors) = paste("iso", seq_len(neig))
-      self$state = list(geodist = geodist, e_vectors = e_vectors, e_values = e_values, orgdata = dt, target = target)
-      dt
+      embed_result = dimRed::embed(dt, "Isomap", knn = pv$knn, ndim = pv$ndim, .mute = NULL)
+      self$state = list(embed_result = embed_result)
+      embed_result@data@data
     },
     .predict_dt = function(dt, levels) {
-      browser()
+      #browser()
       pv = self$param_set$get_values(tags = "train")
-      if (ncol(self$state$orgdata) != ncol(dt))
-        stop("x must have the same number of dimensions as the original data")
-      nindata = nrow(dt)
-      norg = nrow(self$state$orgdata)
-      lknng = private$.make_knn_graph(rbind(dt, self$state$orgdata))
-      lgeodist = igraph::distances(lknng, seq_len(nindata), nindata + seq_len(norg))
-      dammu = sweep(lgeodist ^ 2, 2, colMeans(self$state$geodist ^ 2), "-")
-      Lsharp = sweep(self$state$e_vectors, 2, self$state$e_values, "/")
-      out = -0.5 * (dammu %*% Lsharp)
-      dt
+      predict(self$state$embed_result, dt)
     }
   )
 )
 
 mlr_pipeops$add("isomap", PipeOpIsomap)
 
+#po = po("isomap", knn = 40, ndim = 2)
+#po$train(list(tsk("iris")))
+#po$predict(list(tsk("iris")))
+
+#samp <- sample(nrow(dat), size = 70)
+#emb2 <- embed(dat[samp,], "Isomap", .mute = NULL, knn = 30)
+#emb3 <- predict(emb2, dat[-samp,])

tests/testthat/test_pipeop_info.R

@@ -1,7 +1,11 @@
 context("PipeOpInfo")
 
+
+##### pipeop$new ersetzen mit po("")
+
+
 test_that("basic properties", {
-  po = PipeOpInfo$new("info")
+  po = po("info")
   expect_pipeop(po)
   expect_pipeop_class(PipeOpInfo, list(id = "info"))
 })
@@ -17,7 +21,7 @@ test_that("check whether input and output are equal", {
   output = list("lgr::mlr3/mlr3pipelines::info", "cat", "warning", "message", "none")
   for (j in input) {
     for (i in seq_along(output)) {
-      poinfo = PipeOpInfo$new(id = "info", log_target = output[[i]])
+      poinfo = po("info", log_target = output[[i]])
       suppressMessages(suppressWarnings(invisible(capture.output(expect_identical(poinfo$train(list(j))[[1]], j)))))
       suppressMessages(suppressWarnings(invisible(capture.output(expect_identical(poinfo$predict(list(j))[[1]], j)))))
     }
@@ -39,7 +43,7 @@ test_that("console output type depending on log_target is correct", {
   expect_func = list(expect_output, expect_output, expect_warning, expect_message, expect_silent)
   for (j in input) {
     for (i in seq_along(output)) {
-      poinfo = PipeOpInfo$new(id = "info", log_target = output[[i]])
+      poinfo = po("info", log_target = output[[i]])
       expect_func[[i]](poinfo$train(list(j)))
       expect_func[[i]](poinfo$predict(list(j)))
     }
@@ -58,7 +62,7 @@ test_that("logger is addressed when log_target is set to a logger", {
   prediction = lrn_rpart$predict_newdata(mtcars)
   prediction_new = lrn_rpart$predict_newdata(mtcars_new)
   # Actual Test
-  poinfo = PipeOpInfo$new(id = "info", log_target = "lgr::debug_logger::info")
+  poinfo = po("info", log_target = "lgr::debug_logger::info")
   input = list(tsk("iris"), prediction, prediction_new, NULL, "default_string")
   for (j in input) {
     poinfo$train(list(j))
@@ -85,15 +89,15 @@ test_that("PipeOp recognizes class of input objects and prints information accor
   regex_list = list("\\$task.*\\$data", "\\$prediction.*\\$score", "\\$prediction", "NULL", "default_string")
   for (j in seq_along(input)) {
     for (i in seq_along(output)) {
-      poinfo = PipeOpInfo$new(id = "info", log_target = output[[i]])
+      poinfo = po("info", log_target = output[[i]])
       console_output_train = tryCatch(capture.output(poinfo$train(list(input[[j]]))),
-                                      warning = function(w) {as.character(conditionMessage(w))},
-                                      message = function(m) {as.character(conditionMessage(m))})
+        warning = function(w) as.character(conditionMessage(w)),
+        message = function(m) as.character(conditionMessage(m)))
       expect_match(paste0(console_output_train, collapse = ""), regex_list[[j]], all = FALSE)
       suppressMessages(suppressWarnings(capture.output(poinfo$train(list(input[[j]])))))
       console_output_predict = tryCatch(capture.output(poinfo$predict(list(input[[j]]))),
-                                      warning = function(w) {as.character(conditionMessage(w))},
-                                      message = function(m) {as.character(conditionMessage(m))})
+        warning = function(w) as.character(conditionMessage(w)),
+        message = function(m) as.character(conditionMessage(m)))
       expect_match(paste0(console_output_predict, collapse = ""), regex_list[[j]], all = FALSE)
     }
   }
@@ -102,7 +106,7 @@ test_that("PipeOp recognizes class of input objects and prints information accor
 test_that("malformed log_target handled accordingly", {
   malformed_log_target = list("malformed", "::", "::::::", "log::", "log::log_level", "log::log_level::", "log::log_level::message::", "::log")
   for (i in seq_along(malformed_log_target)) {
-    expect_error(PipeOpInfo$new("info", log_target = malformed_log_target[[i]]))
+    expect_error(po("info", log_target = malformed_log_target[[i]]))
   }
 })
 
@@ -118,16 +122,15 @@ test_that("original printer can be overwritten", {
   regex_list = list("azbycxdw", "azbycxdwev", "azbycxdwevfu", "azbycxdwevfugt")
   for (j in seq_along(input)) {
     for (i in seq_along(output)) {
-      browser()
-      poinfo = PipeOpInfo$new(id = "info", log_target = output[[i]],
-      printer = list(Task = function(x) {"azbycxdw"},
-                     Prediction = function(x) {"azbycxdwev"},
-                     `NULL` = function(x) {"azbycxdwevfu"},
-                     default= function(x) {"azbycxdwevfugt"}
+      poinfo = po("info", log_target = output[[i]],
+      printer = list(Task = function(x) "azbycxdw",
+                     Prediction = function(x) "azbycxdwev",
+                     `NULL` = function(x) "azbycxdwevfu",
+                     default = function(x) "azbycxdwevfugt"
                     ))
       console_output_train = tryCatch(capture.output(poinfo$train(list(input[[i]]))),
-                                      warning = function(w) {conditionMessage(w)},
-                                      message = function(m) {conditionMessage(m)})
+        warning = function(w) conditionMessage(w),
+        message = function(m) conditionMessage(m))
       expect_match(console_output_train, regex_list[[j]], all = FALSE)
       console_output_predict = tryCatch({
         capture.output(poinfo$train(list(input[[i]])))
@@ -150,15 +153,15 @@ test_that("handling of multiplicity objects controlled by field collect_multipli
   input = list(OVR, list(OVR))
   for (i in seq_along(output)) {
     for (j in seq_along(collect_multiplicity)) {
-      poinfo = PipeOpInfo$new(id = "info", collect_multiplicity = collect_multiplicity[[j]], log_target = output[[i]], printer = list(default = function(x) "abc",  Multiplicity = function(x) "xyz"))
+      poinfo = po("info", collect_multiplicity = collect_multiplicity[[j]], log_target = output[[i]], printer = list(default = function(x) "abc",  Multiplicity = function(x) "xyz"))
       console_output_train = tryCatch(capture.output(poinfo$train(input[[j]])),
-                                      warning = function(w) {conditionMessage(w)},
-                                      message = function(m) {conditionMessage(m)})
+        warning = function(w) conditionMessage(w),
+        message = function(m) conditionMessage(m))
       expect_match(paste0(console_output_train, collapse = ""), test_string[[j]], all = FALSE)
       suppressMessages(suppressWarnings(capture.output(poinfo$train(input[[j]]))))
       console_output_predict = tryCatch(capture.output(poinfo$predict(input[[j]])),
-                                      warning = function(w) {conditionMessage(w)},
-                                      message = function(m) {conditionMessage(m)})
+        warning = function(w) conditionMessage(w),
+        message = function(m) conditionMessage(m))
       expect_match(paste0(console_output_predict, collapse = ""), test_string[[j]], all = FALSE)
     }
   }