BUG FIX project_waypoints_coloured(): Fix wrong results when projecting waypoint segments (#54 bis).

Author: rcannood

NAMESPACE

@@ -103,6 +103,7 @@ importFrom(purrr,map_dbl)
 importFrom(purrr,map_df)
 importFrom(purrr,map_int)
 importFrom(purrr,pmap)
+importFrom(purrr,pmap_df)
 importFrom(purrr,set_names)
 importFrom(stats,approx)
 importFrom(stats,as.dendrogram)

NEWS.md

@@ -1,6 +1,8 @@
 # dynplot 1.1.1
 
-* BUG FIX `project_waypoints()`: Fix refactoring issue "Must supply a symbol or a string as argument" (#54).
+* BUG FIX `project_waypoints_coloured()`: Fix refactoring issue "Must supply a symbol or a string as argument" (#54).
+
+* BUG FIX `project_waypoints_coloured()`: Fix wrong results when projecting waypoint segments (#54 bis).
 
 # dynplot 1.1.0
 

R/package.R

@@ -17,7 +17,7 @@
 #' @importFrom dynutils is_sparse list_as_tibble %all_in% calculate_distance scale_minmax
 #' @import dynwrap
 #' @importFrom dyndimred dimred_mds dimred_landmark_mds list_dimred_methods dimred_umap
-#' @importFrom purrr %>% map map_df map_chr keep pmap map2 set_names map_int map_dbl list_modify discard
+#' @importFrom purrr %>% map map_df map_chr keep pmap map2 set_names map_int map_dbl list_modify discard pmap_df
 #' @importFrom purrr map2_df map2_dbl map2_df
 #' @importFrom assertthat assert_that
 #' @importFrom tidygraph as_tbl_graph tbl_graph

R/project_waypoints.R

@@ -24,17 +24,18 @@ project_waypoints_coloured <- function(
   trajectory_projection_sd = sum(trajectory$milestone_network$length) * 0.05,
   color_trajectory = "none"
 ) {
-  waypoints$waypoint_network <- waypoints$waypoint_network %>%
+  wps <- waypoints
+  wps$waypoint_network <- wps$waypoint_network %>%
     rename(
       milestone_id_from = .data$from_milestone_id,
       milestone_id_to = .data$to_milestone_id
     )
 
   assert_that(color_trajectory %in% c("nearest", "none"))
-  assert_that(setequal(cell_positions$cell_id, colnames(waypoints$geodesic_distances)))
+  assert_that(setequal(cell_positions$cell_id, colnames(wps$geodesic_distances)))
 
-  # project waypoints to dimensionality reduction using kernel and geodesic distances
-  weights <- waypoints$geodesic_distances %>% stats::dnorm(sd = trajectory_projection_sd)
+  # project wps to dimensionality reduction using kernel and geodesic distances
+  weights <- wps$geodesic_distances %>% stats::dnorm(sd = trajectory_projection_sd)
   assert_that(all(!is.na(weights)))
 
   weights <- weights / rowSums(weights)
@@ -54,34 +55,28 @@ project_waypoints_coloured <- function(
     y
   }
 
-  if (!is.null(edge_positions)) {
-    approx_funs <-
-      edge_positions %>%
-      gather("comp_name", "comp_value", starts_with("comp_")) %>%
-      group_by(.data$from, .data$to, .data$comp_name) %>%
-      summarise(
-        approx_fun = {
-          pct <- .data$percentage
-          cv <- .data$comp_value
-          list(function(x) stats::approx(pct, cv, x)$y)
-        },
-        .groups = "drop"
-      )
+  waypoint_positions <-
+    if (!is.null(edge_positions)) {
+      comp_names <- colnames(edge_positions) %>% keep(function(x) grepl("comp_", x))
 
-    waypoint_positions <-
-      waypoints$progressions %>%
-        left_join(approx_funs, by = c("from", "to")) %>%
-        mutate(
-          comp_value = map2_dbl(.data$approx_fun, .data$percentage, function(f, pct) f(pct))
-        ) %>%
-        spread(.data$comp_name, .data$comp_value) %>%
-        select(.data$waypoint_id, starts_with("comp_")) %>%
-        left_join(waypoints$waypoints, "waypoint_id")
-  } else {
-    waypoint_positions <- (weights %*% positions) %>%
-      matrix_to_tibble("waypoint_id") %>%
-      left_join(waypoints$waypoints, "waypoint_id")
-  }
+      wps$progressions %>%
+        select(.data$from, .data$to) %>%
+        unique() %>%
+        pmap_df(function(from, to) {
+          wp_progr <- wps$progressions %>% filter(.data$from == !!from, .data$to == !!to)
+          edge_pos <- edge_positions %>% filter(.data$from == !!from, .data$to == !!to)
+          for (cn in comp_names) {
+            wp_progr[[cn]] <- approx(edge_pos$percentage, edge_pos[[cn]], wp_progr$percentage)$y
+          }
+          wp_progr
+        }) %>%
+        select(.data$waypoint_id, !!comp_names) %>%
+        left_join(wps$waypoints, "waypoint_id")
+    } else {
+      (weights %*% positions) %>%
+        matrix_to_tibble("waypoint_id") %>%
+        left_join(wps$waypoints, "waypoint_id")
+    }
 
 
   # add color of closest cell
@@ -99,7 +94,7 @@ project_waypoints_coloured <- function(
 
   segments <- left_join(
     waypoint_positions,
-    waypoints$progressions,
+    wps$progressions,
     by = "waypoint_id"
   ) %>%
     mutate(group = factor(paste0(.data$from, "---", .data$to))) %>%