implement test-hjust-text-anchor.R

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: animint
 Maintainer: Toby Dylan Hocking <tdhock5@gmail.com>
 Author: Toby Dylan Hocking, Susan VanderPlas, Carson Sievert
-Version: 2015.01.27
+Version: 2015.03.23
 License: GPL-3
 Title: Interactive animations
 Description: An interactive animation can be defined using a list of

NEWS

@@ -126,10 +126,7 @@ http://fr.wikipedia.org/wiki/Histoire_démographique_de_la_France
 http://www.populstat.info/Asia/japanc.htm
 http://www.populstat.info/Americas/canadac.htm
 
-RENDER: Is it possible to fix geom_rect and geom_text alignment? The
-underlying problem is that there is no equivalent of R's vjust in SVG
-(the equivalent of R's hjust=0.5|1|0 is CSS text-anchor:
-middle|end|start). See examples/align_rect_text.R.
+RENDER: Is it possible to fix geom_rect and geom_text vertical alignment? There is no equivalent of R's vjust in SVG. See examples/align_rect_text.R.
 
 DSL: if there was no duration specified, should
 time=list(variable=2000) imply duration=list(variable=1000)?
@@ -153,6 +150,10 @@ does not respond to mouse clicks while the data is loading.
 DSL: Implement shape aesthetic with d3.svg.symbol()
 https://github.com/mbostock/d3/wiki/SVG-Shapes#symbol_type
 
+2015.03.23
+
+BUGFIX: hjust aesthetic for geom_text. R's valid hjust=0.5|1|0 is equivalent to CSS text-anchor: middle|end|start.
+
 2015.01.27
 
 Translate R/ggplot

R/animint.R

@@ -319,6 +319,15 @@ saveLayer <- function(l, d, meta){
   } else if(g$geom=="text"){
     ## group is meaningless for text, so delete it.
     g.data <- g.data[names(g.data) != "group"]
+    ## check invalid hjust value
+    if ("hjust" %in% names(g$params)) { #  hjust is parameter
+      hjust <- g$params$hjust
+    } else if ("hjust" %in% names(g.data)) { #  hjust is aesthetic
+      hjust <- unique(g.data['hjust'])
+    } else { #  default hjust
+      hjust <- 0.5
+    }
+    anchor <- hjust2anchor(hjust)
   } else if(g$geom=="rect"){
     ## group is meaningless for rects, so delete it.
     g.data <- g.data[names(g.data) != "group"]

inst/htmljs/animint.js

@@ -715,11 +715,21 @@ var animint = function (to_select, json_file) {
       fill = g_info.params.colour;
     }
     var text_anchor = "middle";
-    if (g_info.params.hjust == 0) {
-      text_anchor = "start";
-    }
-    if (g_info.params.hjust == 1) {
-      text_anchor = "end";
+    var get_text_anchor = function (d) {
+      hjust = g_info.params.hjust;
+      if (d.hasOwnProperty("hjust")) {
+        hjust = d["hjust"];
+      }
+      if (hjust == 0) {
+        text_anchor = "start";
+      }
+      if (hjust == 0.5) {
+        text_anchor = "middle";
+      }
+      if (hjust == 1) {
+        text_anchor = "end";
+      }
+      return text_anchor;
     }
 
     var eActions, eAppend;
@@ -969,7 +979,7 @@ var animint = function (to_select, json_file) {
           .attr("y", toXY("y", "y"))
 	  .style("fill", get_colour)
 	  .attr("font-size", get_size)
-          .style("text-anchor", text_anchor)
+          .style("text-anchor", get_text_anchor)
           .text(function (d) {
             return d.label;
           });

tests/testthat/test-hjust-text-anchor.R

@@ -0,0 +1,115 @@
+context("hjust text anchor")
+
+# demonstration of gradient descent algorithm from animation package
+grad.desc <- function(
+  FUN = function(x, y) x^2 + 2 * y^2, rg = c(-3, -3, 3, 3), init = c(-3, 3),
+  gamma = 0.05, tol = 0.001, gr = NULL, len = 50, nmax = 50) {
+  x <- seq(rg[1], rg[3], length = len)
+  y <- seq(rg[2], rg[4], length = len)
+  contour <- expand.grid(x = x, y = y)
+  contour$z <- as.vector(outer(x, y, FUN))
+
+  nms = names(formals(FUN))
+  grad = if (is.null(gr)) {
+    deriv(as.expression(body(FUN)), nms, function.arg = TRUE)
+  } else {
+    function(...) {
+      res = FUN(...)
+      attr(res, 'gradient') = matrix(gr(...), nrow = 1, ncol = 2)
+      res
+    }
+  }
+
+  xy <- init
+  newxy <- xy - gamma * attr(grad(xy[1], xy[2]), 'gradient')
+  z <- FUN(newxy[1], newxy[2])
+  gap <- abs(z - FUN(xy[1], xy[2]))
+  i <- 1
+  while (gap > tol && i <= nmax) {
+    xy <- rbind(xy, newxy[i, ])
+    newxy <- rbind(newxy, xy[i + 1, ] - gamma * attr(grad(xy[i + 1, 1], xy[i + 1, 2]), 'gradient'))
+    z <- c(z, FUN(newxy[i + 1, 1], newxy[i + 1, 2]))
+    gap <- abs(z[i + 1] - FUN(xy[i + 1, 1], xy[i + 1, 2]))
+    i <- i + 1
+    if (i > nmax) warning('Maximum number of iterations reached!')
+  }
+  objective <- data.frame(iteration = 1:i, x = xy[, 1], y = xy[, 2], z = z)
+  invisible(list(contour = contour, objective = objective))
+}
+
+dat <- grad.desc()
+contour <- dat$contour
+objective <- dat$objective
+objective <- ldply(objective$iteration, function(i) {
+  df <- subset(objective, iteration <= i)
+  cbind(df, iteration2 = i)
+})
+objective2 <- subset(objective, iteration == iteration2)
+
+grad.desc.viz <- function(hjust) {
+  objective2$hjust <- hjust
+
+  contour.plot <- ggplot() + 
+    geom_contour(data = contour, aes(x = x, y = y, z = z, colour = ..level..), size = .5) + 
+    scale_colour_continuous(name = "z value") + 
+    geom_path(data = objective, aes(x = x, y = y, showSelected = iteration2), 
+              colour = "red", size = 1) + 
+    geom_point(data = objective, aes(x = x, y = y, showSelected = iteration2), colour = "green", 
+               size = 2) + 
+    geom_text(data = objective2, aes(x = x, y = y - 0.2, showSelected = iteration2, label = round(z, 2))) + 
+    scale_x_continuous(expand = c(0, 0)) + 
+    scale_y_continuous(expand = c(0, 0)) + 
+    ggtitle("contour of function value") + 
+    theme_animint(width = 600, height = 600)
+
+  objective.plot <- ggplot() +
+    geom_line(data = objective2, aes(x = iteration, y = z), colour = "red") + 
+    geom_point(data = objective2, aes(x = iteration, y = z), colour = "red") + 
+    geom_tallrect(data = objective2, aes(xmin = iteration - 1 / 2, xmax = iteration + 1 / 2, 
+                                         clickSelects = iteration2), alpha = .3) + 
+    geom_text(data = objective2, aes(x = iteration, y = z + 0.3, showSelected = iteration2, 
+                                     label = iteration), hjust = hjust) + 
+    ggtitle("objective value vs. iteration") + 
+    theme_animint(width = 600, height = 600)
+
+  viz <- list(contour = contour.plot, objective = objective.plot, 
+              time = list(variable = "iteration2", ms = 2000), 
+              title = "Demonstration of Gradient Descent Algorithm")
+}
+
+getStyleValue <- function(html, xpath, style.name) {
+  nodes <- getNodeSet(html, xpath)
+  node.style <- xmlAttrs(nodes[[1]])["style"]
+  pattern <-paste0("(?<name>\\S+?)", ": *", "(?<value>.+?)", ";")
+  style.matrices <- str_match_all_perl(node.style, pattern)
+  style.value <- style.matrices[[1]][style.name, "value"]
+}
+
+test_that('geom_text(hjust=0) => <text style="text-anchor: start">', {
+  viz <- grad.desc.viz(hjust = 0)
+  info <- animint2HTML(viz)
+  style.value <- getStyleValue(info$html, '//g[@class="geom8_text_objective"]//text', 
+                               "text-anchor")
+  expect_match(style.value, "start")
+})
+
+test_that('geom_text(hjust=1) => <text style="text-anchor: end">', {
+  viz <- grad.desc.viz(hjust = 1)
+  info <- animint2HTML(viz)
+  style.value <- getStyleValue(info$html, '//g[@class="geom8_text_objective"]//text', 
+                               "text-anchor")
+  expect_match(style.value, "end")
+})
+
+test_that('geom_text(hjust=0.5) => <text style="text-anchor: middle">', {
+  viz <- grad.desc.viz(hjust = 0.5)
+  info <- animint2HTML(viz)
+  style.value <- getStyleValue(info$html, '//g[@class="geom8_text_objective"]//text', 
+                               "text-anchor")
+  expect_match(style.value, "middle")
+})
+
+test_that('geom_text(hjust=other) => unsupported value error', {
+  viz <- grad.desc.viz(hjust = 0.8)
+  expect_error(animint2HTML(viz), "animint only supports hjust values 0, 0.5, 1")
+})