diff --git a/DESCRIPTION b/DESCRIPTION index eafdf183..73a3abd3 100644 --- a/DESCRIPTION +++ b/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( diff --git a/NEWS.md b/NEWS.md index b61f3cb9..fe36f3e9 100644 --- a/NEWS.md +++ b/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. diff --git a/R/geom-abline.r b/R/geom-abline.r index 7dd7f537..ff84ee7f 100644 --- a/R/geom-abline.r +++ b/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 ) diff --git a/tests/testthat/test-renderer1-geom-abline.R b/tests/testthat/test-renderer1-geom-abline.R index 14a995c7..07b4b0c2 100644 --- a/tests/testthat/test-renderer1-geom-abline.R +++ b/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) +})