Merge pull request great-northern-diver#7 from z267xu/main

section tour is implemented
z267xu · Sep 25, 2021 · 42084dd · 42084dd
2 parents 037283c + 9bf35d3
commit 42084dd
Show file tree

Hide file tree

Showing 28 changed files with 439 additions and 139 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,7 @@
 Package: loon.tourr
 Type: Package
 Title: Tour in 'Loon'
-Version: 0.1.2
-Date: 2021-05-06
+Version: 0.1.3
 Authors@R: c(person(given = "Zehao", family = "Xu", 
                     email = "z267xu@uwaterloo.ca", 
                     role = c("aut", "cre")),

diff --git a/NEWS.md b/NEWS.md
@@ -1,6 +1,10 @@
+# loon.tourr 0.1.3
+
+`section` tour is implemented (not for compound widgets yet)
+
 # loon.tourr 0.1.2
 
-To accommodate the changes in the new version of `tourr` that, for `guided_tour()`, users have to define a tibble `record` in the `parent.frame()` environment, else error occurs.  
+To accommodate the changes in the new version of `tourr` that, for `guided_tour()`, users have to define a tibble `record` in the `parent.frame()` environment, else error occurs.
 
 # loon.tourr 0.1.1
 

diff --git a/R/callback_pairs.R b/R/callback_pairs.R
@@ -66,11 +66,6 @@ callback_pairs <- function(widget, initialTour, tours, var = 0L, ...) {
                          allColor = color,
                          allProjections = projections,
                          allInitialTour = initialTour)
-
-           if(inherits(w, "l_plot") || inherits(w, "l_hist")) {
-             loon::l_scaleto_world(w)
-           }
-
          })
 
   return(invisible())

diff --git a/R/callback_plot.R b/R/callback_plot.R
@@ -3,38 +3,83 @@ callback_plot <- function(widget, initialTour, tours, var = 0L, ...) {
 }
 
 callback_plot.l_hist <- function(widget, initialTour, tours, var = 0L, ...) {
+
+  args <- list(...)
+  slicing <- args$slicing %||% FALSE
+
   # histogram update
   if(var == 0) {
+
     initialTour <- unlist(initialTour)
-    # start position
-    # update hist
-
-    # for l_hist widget, as the x is modified, the binwidth and origin will be modified as default
-    loon::l_configure(widget,
-                      x = initialTour,
-                      binwidth = widget['binwidth'],
-                      origin = widget['origin']
-    )
-
-    callback_layer(widget,
-                   tours = tours,
-                   var = var,
-                   initialTour = initialTour,
-                   ...)
+
+    if(slicing) {
+
+      slicingIn <- get_slicingIn(args$start,
+                                 args$data,
+                                 args$slicingDistance)
+
+      newStates <- lapply(args$states,
+                          function(s) {
+                            s[slicingIn]
+                          })
+      newStates$target <- widget
+      newStates$x <- initialTour[slicingIn]
+      newStates$sync <- "push"
+      newStates$binwidth <- widget['binwidth']
+      newStates$origin <- widget['origin']
+      do.call(loon::l_configure, newStates)
+
+    } else {
+      # start position
+      # update hist
+
+      # for l_hist widget, as the x is modified, the binwidth and origin will be modified as default
+      loon::l_configure(widget,
+                        x = initialTour,
+                        binwidth = widget['binwidth'],
+                        origin = widget['origin']
+      )
+    }
+
   } else {
-    proj <- tours[[var]]
-    loon::l_configure(widget,
-                      x = proj,
-                      binwidth = widget['binwidth'],
-                      origin = widget['origin']
-    )
-
-    callback_layer(widget,
-                   tours = tours,
-                   var = var,
-                   initialTour = initialTour,
-                   ...)
+
+    tour <- tours[[var]]
+
+    if(slicing) {
+
+      slicingIn <- get_slicingIn(args$projections[[var]],
+                                 args$data,
+                                 args$slicingDistance)
+
+      newStates <- lapply(args$states,
+                          function(s) {
+                            s[slicingIn]
+                          })
+      newStates$target <- widget
+      newStates$x <- tour[slicingIn]
+      newStates$sync <- "push"
+      newStates$binwidth <- widget['binwidth']
+      newStates$origin <- widget['origin']
+
+      do.call(loon::l_configure, newStates)
+
+    } else {
+
+      loon::l_configure(widget,
+                        x = tour,
+                        binwidth = widget['binwidth'],
+                        origin = widget['origin']
+      )
+    }
   }
+
+  callback_layer(widget,
+                 tours = tours,
+                 var = var,
+                 initialTour = initialTour,
+                 ...)
+
+  loon::l_scaleto_plot(widget)
 }
 
 callback_plot.l_plot <- function(widget, initialTour, tours, var = 0L, ...) {
@@ -43,94 +88,171 @@ callback_plot.l_plot <- function(widget, initialTour, tours, var = 0L, ...) {
   axesLength <- args$axesLength %||% 0.2
   axes <- args$axes
   labels <- args$labels
-  start <- args$start
-  projections <- args$projections
+  slicing <- args$slicing %||% FALSE
 
   # scatter plot update
   if(var == 0) {
     # start position
     # update plot
-    loon::l_configure(widget,
-                      x = initialTour[, 1],
-                      y = initialTour[, 2]
-    )
+    if(slicing) {
+
+      slicingIn <- get_slicingIn(args$start,
+                                 args$data,
+                                 args$slicingDistance)
+
+      newStates <- lapply(args$states,
+                          function(s) {
+                            s[slicingIn]
+                          })
+      newStates$target <- widget
+      newStates$x <- initialTour[slicingIn, 1]
+      newStates$y <- initialTour[slicingIn, 2]
+      newStates$sync <- "push"
+      do.call(loon::l_configure, newStates)
+
+    } else {
+      loon::l_configure(widget,
+                        x = initialTour[, 1],
+                        y = initialTour[, 2])
+    }
 
     if(!is.null(axes))
-      loon::l_configure(axes,
-                        x = lapply(start[, 1], function(x) c(0.5, 0.5 + x * axesLength)),
-                        y = lapply(start[, 2], function(y) c(0.5, 0.5 + y * axesLength))
+      loon::l_configure(
+        axes,
+        x = lapply(start[, 1],
+                   function(x) c(0.5, 0.5 + x * axesLength)),
+        y = lapply(start[, 2],
+                   function(y) c(0.5, 0.5 + y * axesLength))
       )
 
     if(!is.null(labels))
-      loon::l_configure(labels,
-                        x = start[, 1] * axesLength + 0.5,
-                        y = start[, 2] * axesLength + 0.5
+      loon::l_configure(
+        labels,
+        x = start[, 1] * axesLength + 0.5,
+        y = start[, 2] * axesLength + 0.5
       )
 
-    callback_layer(widget,
-                   tours = tours,
-                   var = var,
-                   initialTour = initialTour,
-                   ...)
-
   } else {
-    proj <- tours[[var]]
-    loon::l_configure(widget,
-                      x = proj[, 1],
-                      y = proj[, 2])
 
-    rotation <- projections[[var]]
+    projections <- args$projections
+    tour <- tours[[var]]
+    proj <- projections[[var]]
+
+    if(slicing) {
+
+      slicingIn <- get_slicingIn(proj,
+                                 args$data,
+                                 args$slicingDistance)
+
+      newStates <- lapply(args$states,
+                          function(s) {
+                            s[slicingIn]
+                          })
+      newStates$target <- widget
+      newStates$x <- tour[slicingIn, 1]
+      newStates$y <- tour[slicingIn, 2]
+      newStates$sync <- "push"
+      do.call(loon::l_configure, newStates)
+
+    } else {
+      loon::l_configure(widget,
+                        x = tour[, 1],
+                        y = tour[, 2])
+    }
 
     if(!is.null(axes))
-      loon::l_configure(axes,
-                        x = lapply(rotation[, 1], function(x) c(0.5, 0.5 + x * (axesLength - 0.05))),
-                        y = lapply(rotation[, 2], function(y) c(0.5, 0.5 + y * (axesLength - 0.05)))
+      loon::l_configure(
+        axes,
+        x = lapply(proj[, 1],
+                   function(x)
+                     c(0.5, 0.5 + x * (axesLength - 0.05))),
+        y = lapply(proj[, 2],
+                   function(y)
+                     c(0.5, 0.5 + y * (axesLength - 0.05)))
       )
 
     if(!is.null(labels))
-      loon::l_configure(labels,
-                        x = rotation[, 1] * axesLength + 0.5,
-                        y = rotation[, 2] * axesLength + 0.5
+      loon::l_configure(
+        labels,
+        x = proj[, 1] * axesLength + 0.5,
+        y = proj[, 2] * axesLength + 0.5
       )
-
-    callback_layer(widget,
-                   tours = tours,
-                   var = var,
-                   initialTour = initialTour,
-                   ...)
   }
+
+  callback_layer(widget,
+                 tours = tours,
+                 var = var,
+                 initialTour = initialTour,
+                 ...)
+
+  loon::l_scaleto_plot(widget)
 }
 
 callback_plot.l_serialaxes <- function(widget, initialTour, tours, var = 0L, ...) {
 
-  statesNames <- loon::l_nDimStateNames(widget)
-  states <- stats::setNames(
-    lapply(statesNames,
-           function(s) {
-             widget[s]
-           }),
-    statesNames
-  )
-  # data is set by tour
-  states$data <- NULL
+  args <- list(...)
+  slicing <- args$slicing %||% FALSE
+  states <- args$states
 
   # serial axes update
   if(var == 0) {
     # start position
     # update plot
-    do.call(loon::l_configure,
-            c(
-              list(target = widget,
-                   data = initialTour),
-              states
-            ))
+    if(slicing) {
+
+      slicingIn <- get_slicingIn(args$start,
+                                 args$data,
+                                 args$slicingDistance)
+      states$data <- NULL
+      newStates <- lapply(states,
+                          function(s) {
+                            s[slicingIn]
+                          })
+      newStates$target <- widget
+      newStates$data <- initialTour[slicingIn, ]
+      newStates$sync <- "push"
+      do.call(loon::l_configure, newStates)
+
+    } else {
+
+      states$data <- NULL
+      states$target <- NULL
+      do.call(loon::l_configure,
+              c(
+                list(target = widget,
+                     data = initialTour),
+                states
+              ))
+    }
+
   } else {
-    do.call(loon::l_configure,
-            c(
-              list(target = widget,
-                   data = as.data.frame(tours[[var]])),
-              states
-            ))
+
+    tour <- as.data.frame(tours[[var]])
+    proj <- args$projections[[var]]
+
+    if(slicing) {
+
+      slicingIn <- get_slicingIn(proj,
+                                 args$data,
+                                 args$slicingDistance)
+      states$data <- NULL
+      newStates <- lapply(states,
+                          function(s) {
+                            s[slicingIn]
+                          })
+      newStates$target <- widget
+      newStates$data <- tour[slicingIn, ]
+      newStates$sync <- "push"
+      do.call(loon::l_configure, newStates)
+
+    } else {
+      do.call(loon::l_configure,
+              c(
+                list(target = widget,
+                     data = tour),
+                states
+              ))
+    }
   }
 }
 

diff --git a/R/l_getNDimStates.R b/R/l_getNDimStates.R
@@ -0,0 +1,20 @@
+l_getNDimStates <- function(widget) {
+  UseMethod("l_getNDimStates", widget)
+}
+
+l_getNDimStates.loon <- function(widget) {
+  statesNames <- loon::l_nDimStateNames(widget)
+  states <- stats::setNames(
+    lapply(statesNames,
+           function(s) {
+             if(length(widget[s]) == 0) return(NULL)
+             widget[s]
+           }),
+    statesNames)
+  # remove NULL
+  remove_null(states, as_list = FALSE)
+}
+
+l_getNDimStates.l_compound <- function(widget) {
+  lapply(widget, function(x) l_getNDimStates(x))
+}