Adds clip

NEWS.md

@@ -1,5 +1,9 @@
 # metR (development version)
 
+## New features
+
+-   The contour functions gain a `clip` argument to only show contours in an area defined by a polygon.
+
 # metR 0.14.1
 
 ## Breaking Changes

R/geom_contour_fill.R

@@ -66,6 +66,8 @@ geom_contour_fill <- function(mapping = NULL, data = NULL,
                          breaks = MakeBreaks(),
                          bins = NULL,
                          binwidth = NULL,
+                         proj = NULL,
+                         clip = NULL,
                          kriging = FALSE,
                          global.breaks = TRUE,
                          na.fill = FALSE,
@@ -87,6 +89,8 @@ geom_contour_fill <- function(mapping = NULL, data = NULL,
             na.rm = FALSE,
             na.fill = na.fill,
             kriging = kriging,
+            proj = proj,
+            clip = clip,
             global.breaks = global.breaks,
             ...
         )

R/geom_contour_tanaka.R

@@ -80,6 +80,9 @@ geom_contour_tanaka <- function(mapping = NULL, data = NULL,
                                 dark = "gray20",
                                 range = c(0.01, 0.5),
                                 smooth = 0,
+                                proj = NULL,
+                                clip = NULL,
+                                kriging = FALSE,
                                 na.rm = FALSE,
                                 show.legend = NA,
                                 inherit.aes = TRUE) {
@@ -102,6 +105,9 @@ geom_contour_tanaka <- function(mapping = NULL, data = NULL,
             dark = dark,
             range = range,
             smooth = smooth,
+            kriging = kriging,
+            proj = proj,
+            clip = clip,
             ...
         )
     )

R/stat_contour2.r

@@ -10,6 +10,11 @@
 #' data or for each grouping.
 #' @param kriging Logical indicating whether to perform ordinary kriging before contouring.
 #' Use this if you want to use contours with irregularly spaced data.
+#' @param proj The projection to which to project the contours to.
+#' It can be either a projection string or a function to apply to the whole
+#' contour dataset.
+#' @param clip A simple features object to be used as a clip. Contours are only
+#' drawn in the interior of this polygon.
 #'
 #' @export
 #' @section Computed variables:
@@ -24,6 +29,8 @@ stat_contour2 <- function(mapping = NULL, data = NULL,
                           breaks = MakeBreaks(),
                           bins = NULL,
                           binwidth = NULL,
+                          proj = NULL,
+                          clip = NULL,
                           kriging = FALSE,
                           global.breaks = TRUE,
                           na.rm = FALSE,
@@ -47,6 +54,8 @@ stat_contour2 <- function(mapping = NULL, data = NULL,
             binwidth = binwidth,
             global.breaks = global.breaks,
             kriging = kriging,
+            proj = proj,
+            clip = clip,
             ...
         )
     )
@@ -94,7 +103,7 @@ StatContour2 <- ggplot2::ggproto("StatContour2", ggplot2::Stat,
                            breaks = scales::fullseq, complete = TRUE,
                            na.rm = FALSE, circular = NULL, xwrap = NULL,
                            ywrap = NULL, na.fill = FALSE, global.breaks = TRUE,
-                           proj = NULL, kriging = FALSE) {
+                           proj = NULL, kriging = FALSE, clip = NULL) {
     if (isFALSE(global.breaks)) {
       breaks <- setup_breaks(data,
                              breaks = breaks,
@@ -179,6 +188,17 @@ StatContour2 <- ggplot2::ggproto("StatContour2", ggplot2::Stat,
       }
     }
 
+
+    if (!is.null(clip)) {
+        if (!is.na(sf::st_crs(clip))) {
+            sf::st_crs(clip) <- NA
+        }
+        clip <- sf::st_union(clip)
+        contours <- contours[, clip_contours(x, y, clip, type = "LINESTRING"), by = setdiff(colnames(contours), c("x", "y", "dx", "dy"))]
+        contours[, group := interaction(group, L)]
+    }
+
+
     return(contours)
   }
 )

R/stat_contour_fill.R

@@ -7,6 +7,8 @@ stat_contour_fill <- function(mapping = NULL, data = NULL,
                               bins = NULL,
                               binwidth = NULL,
                               global.breaks = TRUE,
+                              proj = NULL,
+                              clip = NULL,
                               kriging = FALSE,
                               na.fill = FALSE,
                               show.legend = NA,
@@ -28,6 +30,8 @@ stat_contour_fill <- function(mapping = NULL, data = NULL,
             binwidth = binwidth,
             global.breaks = global.breaks,
             kriging = kriging,
+            proj = proj,
+            clip = clip,
             ...
         )
     )
@@ -82,7 +86,7 @@ StatContourFill <- ggplot2::ggproto("StatContourFill", ggplot2::Stat,
                              breaks = scales::fullseq, complete = TRUE,
                              na.rm = FALSE, xwrap = NULL,
                              ywrap = NULL, na.fill = FALSE, global.breaks = TRUE,
-                             proj = NULL, kriging = FALSE) {
+                             proj = NULL, kriging = FALSE, clip = NULL) {
         data.table::setDT(data)
 
         if (isFALSE(global.breaks)) {
@@ -102,7 +106,6 @@ StatContourFill <- ggplot2::ggproto("StatContourFill", ggplot2::Stat,
                     warningf("The data must be a complete regular grid.", call. = FALSE)
                     return(data.frame())
                 } else {
-                    # data <- data.table::setDT(tidyr::complete(data, x, y, fill = list(z = NA)))
                     data <- .complete(data, x, y)
                 }
             }
@@ -156,9 +159,17 @@ StatContourFill <- ggplot2::ggproto("StatContourFill", ggplot2::Stat,
             }
         }
 
+        if (!is.null(clip)) {
+            if (!is.na(sf::st_crs(clip))) {
+                sf::st_crs(clip) <- NA
+            }
+            clip <- sf::st_union(clip)
+            cont <- cont[, clip_contours(x, y, clip), by = setdiff(colnames(cont), c("x", "y"))]
+            cont[, subgroup := interaction(subgroup, L)]
+        }
 
-        cont
 
+        cont
         }
 )
 
@@ -223,3 +234,22 @@ pretty_isoband_levels <- function(isoband_levels, dig.lab = 3) {
     # and open at their upper boundary
     sprintf("(%s, %s]", label_low, label_high)
 }
+
+
+clip_contours <- function(x, y, clip, type = "POLYGON") {
+
+    xy <- sf::st_linestring(x = matrix(c(x, y), ncol = 2)) |>
+        sf::st_cast(type) |>
+        sf::st_intersection(clip)
+
+    if (length(xy) == 0) {
+        return(NULL)
+    }
+    xy <- sf::st_coordinates(xy)
+
+    L <- do.call(interaction, lapply(seq(3, ncol(xy)), function(i) xy[, i]))
+    list(x = xy[, 1],
+         y = xy[, 2],
+         L = L)
+
+}