fix svm ablines

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: animint2
 Title: Animated Interactive Grammar of Graphics
-Version: 2025.1.27
+Version: 2025.1.26
 URL: https://animint.github.io/animint2/
 BugReports: https://github.com/animint/animint2/issues
 Authors@R: c(

NEWS.md

@@ -1,4 +1,10 @@
-# Changes in version 2025.1.27 (PR#184)
+# Changes in version 2025.1.26
+
+## PR#186
+
+- `geom_abline()`: fix and vectorize `pre_process()` method.
+
+## PR#184
 
 - Add simple Hello world example to ?animint.
 - Increase text size of "a" in legend SVG.

R/geom-abline.r

@@ -113,36 +113,29 @@ geom_abline <- function(mapping = NULL, data = NULL,
 GeomAbline <- gganimintproto("GeomAbline", Geom,
   draw_panel = function(data, panel_scales, coord) {
     ranges <- coord$range(panel_scales)
-
     data$x    <- ranges$x[1]
     data$xend <- ranges$x[2]
     data$y    <- ranges$x[1] * data$slope + data$intercept
     data$yend <- ranges$x[2] * data$slope + data$intercept
-
     GeomSegment$draw_panel(unique(data), panel_scales, coord)
   },
-
   pre_process = function(g, g.data, ranges) {
-    ## loop through each set of slopes/intercepts
-
-    ## TODO: vectorize this code!
-    for(i in 1:nrow(g.data)) {
-
-    # "Trick" ggplot coord_transform into transforming the slope and intercept
-    g.data[i, "x"] <- ranges[[ g.data$PANEL[i] ]]$x.range[1]
-    g.data[i, "xend"] <- ranges[[ g.data$PANEL[i] ]]$x.range[2]
-    g.data[i, "y"] <- g.data$slope[i] * g.data$x[i] + g.data$intercept[i]
-    g.data[i, "yend"] <- g.data$slope[i] * g.data$xend[i] + g.data$intercept[i]
-
-    # make sure that lines don't run off the graph
-    if(g.data$y[i] < ranges[[ g.data$PANEL[i] ]]$y.range[1] ) {
-        g.data$y[i] <- ranges[[ g.data$PANEL[i] ]]$y.range[1]
-        g.data$x[i] <- (g.data$y[i] - g.data$intercept[i]) / g.data$slope[i]
-    }
-    if(g.data$yend[i] > ranges[[ g.data$PANEL[i] ]]$y.range[2]) {
-        g.data$yend[i] <- ranges[[ g.data$PANEL[i] ]]$y.range[2]
-        g.data$xend[i] <- (g.data$yend[i] - g.data$intercept[i]) / g.data$slope[i]
+    range.mats <- list()
+    for(xy in c("x","y")){
+      range.mats[[xy]] <- do.call(rbind, lapply(ranges, "[[", paste0(xy, ".range")))[g.data$PANEL,,drop=FALSE]
     }
+    suffix.list <- c("","end")
+    for(idx in seq_along(suffix.list)){
+      suffix <- suffix.list[[idx]]
+      maybe.x <- range.mats$x[,idx]
+      maybe.y <- maybe.x*g.data$slope+g.data$intercept
+      inv <- function(y)(y-g.data$intercept)/g.data$slope
+      g.data[[paste0("x",suffix)]] <- ifelse(
+        maybe.y < range.mats$y[,1], inv(range.mats$y[,1]), ifelse(
+          maybe.y > range.mats$y[,2], inv(range.mats$y[,2]), maybe.x))
+      g.data[[paste0("y",suffix)]] <- ifelse(
+        maybe.y < range.mats$y[,1], range.mats$y[,1], ifelse(
+          maybe.y > range.mats$y[,2], range.mats$y[,2], maybe.y))
     }
     ## ggplot2 defaults to adding a group aes for ablines!
     ## Remove it since it is meaningless.
@@ -151,9 +144,7 @@ GeomAbline <- gganimintproto("GeomAbline", Geom,
     g$geom <- "segment"
     return(list(g = g, g.data = g.data))
   },
-
   default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
   required_aes = c("slope", "intercept"),
-
   draw_key = draw_key_abline
 )

tests/testthat/test-renderer1-geom-abline.R

@@ -1,9 +1,9 @@
 acontext("geom_abline")
 
-p <- qplot(wt, mpg, data = mtcars) + 
+viz <- animint(p=qplot(wt, mpg, data = mtcars) + 
   geom_abline(intercept = c(20, 5), slope = c(1,4)) + 
-  facet_wrap(~cyl)
-info <- animint2HTML(list(p = p))
+  facet_wrap(~cyl))
+info <- animint2HTML(viz)
 
 tsv.file <- file.path("animint-htmltest", "geom2_abline_p_chunk1.tsv")
 tsv.data <- read.table(tsv.file, header=TRUE, comment.char = "")
@@ -29,3 +29,49 @@ test_that("Start and end of ablines are not NA", {
 test_that("lines do not exceed ranges of plot", {
   expect_true(all(as.numeric(start_ends) >= 0))
 })
+
+if(FALSE){
+  (ab.df <- rbind(
+    data.frame(sign="neg", i=1, s=-seq(1,5), i.fac=c('a','b','c','a','b')),
+    data.frame(sign="pos", i=c(-0.5,0,0.5),s=1,i.fac=c('a','b','a'))))
+  viz <- animint(
+    p=ggplot()+
+      geom_abline(aes(
+        intercept=i,slope=s,color=i.fac),
+        showSelected="sign",
+        data=ab.df)+
+      geom_point(aes(
+        x,x),
+        clickSelects="sign",
+        size=5,
+        data=data.frame(x=0:1, sign=c('pos','neg')))
+  )    
+  viz
+}
+
+viz <- animint(
+  p=ggplot()+
+    geom_abline(aes(
+      intercept=i,slope=s),
+      data=data.frame(i=10, s=-2))+
+    geom_point(aes(
+      x,x),
+      data=data.frame(x=c(0,10)))+
+    geom_point(aes(
+      x,y),
+      data=data.frame(x=5,y=0))
+)
+info <- animint2HTML(viz)
+get_num <- function(cls, el, at){
+  xpath <- sprintf("//g[@class='%s']//%s", cls, el)
+  out <- as.numeric(xmlAttrs(getNodeSet(info$html, xpath)[[1]])[at])
+  names(out) <- at
+  as.list(out)
+}
+cxy <- get_num("geom3_point_p","circle",c("cx","cy"))
+abl <- get_num('geom1_abline_p',"line",c("x1","x2","y1","y2"))
+(slope <- with(abl, (y1-y2)/(x1-x2)))
+abline.at.5 <- slope*(cxy$cx-abl$x1)+abl$y1
+test_that("abline with negative slope intersects point", {
+  expect_equal(abline.at.5, cxy$cy)
+})