squish infinite thickness in a more sensible spot

R/subscale.R

@@ -52,7 +52,7 @@
 #'     subguide = "inside",
 #'     subscale = subscale_thickness(expand = expansion(c(0, 0.5)))
 #'   )
-#' @importFrom scales rescale oob_squish_infinite expand_range
+#' @importFrom scales rescale expand_range
 #' @export
 subscale_thickness = auto_partial(name = "subscale_thickness", function(
   x,
@@ -79,32 +79,40 @@ subscale_thickness = auto_partial(name = "subscale_thickness", function(
     limits = c(NA_real_, NA_real_)
   }
 
-  # infinite values get plotted at the max height (e.g. for point masses)
-  x = oob_squish_infinite(x)
-
   thickness(x, limits[1], limits[2])
 })
 
 #' Identity sub-scale for thickness aesthetic
 #'
 #' This is an identity sub-scale for the `thickness` aesthetic
 #' in \pkg{ggdist}. It returns its input as a [thickness] vector without
-#' rescaling (though it does squish infinite values). It can be used with the
-#' `subscale` parameter of [geom_slabinterval()].
+#' rescaling. It can be used with the `subscale` parameter of
+#' [geom_slabinterval()].
 #'
 #' @inheritParams subscale_thickness
 #' @returns A [thickness] vector of the same length as `x`, with infinite
 #' values in `x` squished into the data range.
 #' @family sub-scales
 #' @export
 subscale_identity = function(x) {
-  limits = range(0, 1, x, na.rm = TRUE, finite = TRUE)
-  thickness(oob_squish_infinite(x, range = limits))
+  thickness(x)
 }
 
 
 # apply a thickness subscale ----------------------------------------------
 
+#' Squish infinite values in a [thickness] vector
+#' @importFrom scale oob_squish_infinite
+#' @noRd
+squish_infinite_thickness = function(x) {
+  limits = range(
+    0, 1, field(x, "x"), thickness_lower(x), thickness_upper(x),
+    na.rm = TRUE, finite = TRUE
+  )
+  field(x, "x") = oob_squish_infinite(field(x, "x"), range = limits)
+  x
+}
+
 #' apply a thickness subscale to an object
 #' @noRd
 apply_subscale = function(x, subscale) UseMethod("apply_subscale")
@@ -116,15 +124,14 @@ apply_subscale.NULL = function(x, subscale) {
 
 #' @export
 apply_subscale.default = function(x, subscale) {
-  subscale(x)
+  squish_infinite_thickness(subscale(x))
 }
 
-#' @importFrom scales oob_squish_infinite
 #' @export
 apply_subscale.ggdist_thickness = function(x, subscale) {
   # thickness values passed directly into the geom (e.g. by
-  # scale_thickness_shared()) are not normalized again.
-  x
+  # scale_thickness_shared()) are not scaled again.
+  squish_infinite_thickness(x)
 }
 
 #' @export

tests/testthat/test.scale_thickness.R

@@ -7,7 +7,6 @@ library(dplyr)
 library(distributional)
 
 
-
 # scale_thickness ---------------------------------------------------------
 
 test_that("basic scale_thickness_shared works", {
@@ -33,59 +32,21 @@ test_that("basic scale_thickness_shared works", {
   )
 })
 
+test_that("infinite thickness is squished", {
+  p = ggplot() +
+    geom_slab(aes(x = 1:3, thickness = thickness(c(0, Inf, -Inf)))) +
+    coord_cartesian(expand = FALSE)
 
-# scale_type --------------------------------------------------------------
-
-test_that("scale_type works", {
-  expect_equal(scale_type(thickness(1)), "continuous")
-})
-
-
-# thickness type ----------------------------------------------------------
-
-test_that("thickness formatting works", {
-  expect_equal(vec_ptype_full(thickness()), "thickness")
-  expect_equal(vec_ptype_abbr(thickness()), "thk")
-  expect_equal(format(thickness()), character())
-  expect_equal(format(thickness(1:2, 3, 4)), c("1thk [3,4]", "2thk [3,4]"))
+  geom_grob = layer_grob(p)[[1]]
+  slab_grob = geom_grob$children[[1]]
+  expect_equal(slab_grob$x, unit(c(0, 0.5, 1, 1, 0.5, 0), "native"))
+  # Inf should be squished to 0.9 and -Inf to 0
+  expect_equal(slab_grob$y, unit(c(0, 0.9, 0, 0, 0, 0), "native"))
 })
 
-test_that("thickness casting works", {
-  expect_equal(vec_cast(thickness(2), double()), 2.0)
-  expect_equal(vec_cast(thickness(2L), integer()), 2L)
-  expect_equal(vec_cast(2.0, thickness()), thickness(2))
-  expect_equal(vec_cast(2L, thickness()), thickness(2))
-
-  expect_equal(c(thickness(1), thickness(2)), thickness(c(1, 2)))
-  expect_equal(c(thickness(1), 2), thickness(c(1, 2)))
-  expect_equal(c(thickness(1), 2L), thickness(c(1, 2)))
 
-  expect_equal(vec_c(2, thickness(1)), thickness(c(2, 1)))
-  expect_equal(vec_c(2L, thickness(1)), thickness(c(2, 1)))
-
-  expect_error(thickness(1) + character())
-
-  expect_equal(thickness(1) + thickness(2), thickness(3))
-  expect_equal(thickness(1) - thickness(2), thickness(-1))
-  expect_equal(thickness(1) / thickness(2), 0.5)
-  expect_error(thickness(1) * thickness(2))
-
-  expect_equal(thickness(2) * 3, thickness(6))
-  expect_equal(thickness(1) / 2, thickness(0.5))
-  expect_error(thickness(1) - 2)
-  expect_error(thickness(1) + 2)
-
-  expect_equal(2 * thickness(3), thickness(6))
-  expect_error(1 / thickness(2))
-  expect_error(1 - thickness(2))
-  expect_error(1 + thickness(2))
-})
-
-test_that("thickness compatibility testing works", {
-  expect_equal(thickness(1) + thickness(2), thickness(3))
-  expect_equal(thickness(1,1,NA) + thickness(2,NA,2), thickness(3,1,2))
-  expect_equal(thickness(1,1,2) + thickness(2,1,2), thickness(3,1,2))
+# scale_type --------------------------------------------------------------
 
-  expect_error(thickness(1,1,2) + thickness(2,0,2), class = "ggdist_incompatible_thickness_bounds")
-  expect_error(thickness(1,1,0) + thickness(2,1,2), class = "ggdist_incompatible_thickness_bounds")
+test_that("scale_type works", {
+  expect_equal(scale_type(thickness(1)), "continuous")
 })

tests/testthat/test.subscale.R

@@ -9,7 +9,7 @@
 test_that("thickness subscale works", {
   expect_equal(
     subscale_thickness(c(0, NA, Inf, -Inf)),
-    thickness(c(0, NA_real_, 1, 0), NA_real_, NA_real_)
+    thickness(c(0, NA_real_, Inf, -Inf), NA_real_, NA_real_)
   )
 
   expect_equal(
@@ -36,11 +36,11 @@ test_that("thickness subscale works", {
 test_that("identity subscale works", {
   expect_equal(
     subscale_identity(c(0, NA, Inf, -Inf)),
-    thickness(c(0, NA_real_, 1, 0), NA_real_, NA_real_)
+    thickness(c(0, NA_real_, Inf, -Inf), NA_real_, NA_real_)
   )
 
   expect_equal(
     subscale_identity(c(-3:3, NA_real_, Inf, -Inf)),
-    thickness(c(-3:3, NA_real_, 3, -3), NA_real_, NA_real_)
+    thickness(c(-3:3, NA_real_, Inf, -Inf), NA_real_, NA_real_)
   )
 })

tests/testthat/test.thickness.R

@@ -0,0 +1,57 @@
+# Tests for thickness datatype
+#
+# Author: mjskay
+###############################################################################
+
+library(dplyr)
+library(distributional)
+
+
+# thickness type ----------------------------------------------------------
+
+test_that("thickness formatting works", {
+  expect_equal(vec_ptype_full(thickness()), "thickness")
+  expect_equal(vec_ptype_abbr(thickness()), "thk")
+  expect_equal(format(thickness()), character())
+  expect_equal(format(thickness(1:2, 3, 4)), c("1thk [3,4]", "2thk [3,4]"))
+})
+
+test_that("thickness casting works", {
+  expect_equal(vec_cast(thickness(2), double()), 2.0)
+  expect_equal(vec_cast(thickness(2L), integer()), 2L)
+  expect_equal(vec_cast(2.0, thickness()), thickness(2))
+  expect_equal(vec_cast(2L, thickness()), thickness(2))
+
+  expect_equal(c(thickness(1), thickness(2)), thickness(c(1, 2)))
+  expect_equal(c(thickness(1), 2), thickness(c(1, 2)))
+  expect_equal(c(thickness(1), 2L), thickness(c(1, 2)))
+
+  expect_equal(vec_c(2, thickness(1)), thickness(c(2, 1)))
+  expect_equal(vec_c(2L, thickness(1)), thickness(c(2, 1)))
+
+  expect_error(thickness(1) + character())
+
+  expect_equal(thickness(1) + thickness(2), thickness(3))
+  expect_equal(thickness(1) - thickness(2), thickness(-1))
+  expect_equal(thickness(1) / thickness(2), 0.5)
+  expect_error(thickness(1) * thickness(2))
+
+  expect_equal(thickness(2) * 3, thickness(6))
+  expect_equal(thickness(1) / 2, thickness(0.5))
+  expect_error(thickness(1) - 2)
+  expect_error(thickness(1) + 2)
+
+  expect_equal(2 * thickness(3), thickness(6))
+  expect_error(1 / thickness(2))
+  expect_error(1 - thickness(2))
+  expect_error(1 + thickness(2))
+})
+
+test_that("thickness compatibility testing works", {
+  expect_equal(thickness(1) + thickness(2), thickness(3))
+  expect_equal(thickness(1,1,NA) + thickness(2,NA,2), thickness(3,1,2))
+  expect_equal(thickness(1,1,2) + thickness(2,1,2), thickness(3,1,2))
+
+  expect_error(thickness(1,1,2) + thickness(2,0,2), class = "ggdist_incompatible_thickness_bounds")
+  expect_error(thickness(1,1,0) + thickness(2,1,2), class = "ggdist_incompatible_thickness_bounds")
+})