Skip to content

Commit

Permalink
Improves clip
Browse files Browse the repository at this point in the history
  • Loading branch information
@eliocamp
eliocamp committed Nov 6, 2023
1 parent 75dff21 commit 2830c57
Show file tree
Hide file tree
Showing 4 changed files with 162 additions and 92 deletions.
5 changes: 5 additions & 0 deletions NEWS.md
View file
Expand Up @@ -5,6 +5,11 @@
- The contour functions gain a `clip` argument to only show contours in an area defined by a polygon.
- The `kriging` argument of the contour functions now can be a numeric to control de number of pixels used.

## Breaking changes

- The `proj` argument in `geom_contour_fill()` and friends now operate over the isolines returned by the isoband package.
This might break code that used a custom function to `proj`.

# metR 0.14.1

## Breaking Changes
Expand Down
58 changes: 31 additions & 27 deletions R/stat_contour2.r
View file
Expand Up @@ -163,7 +163,7 @@ StatContour2 <- ggplot2::ggproto("StatContour2", ggplot2::Stat,


data.table::setDF(data)
contours <- data.table::as.data.table(.contour_lines(data, breaks, complete = complete))
contours <- data.table::as.data.table(.contour_lines(data, breaks, complete = complete, clip = clip, proj = proj))

if (length(contours) == 0) {
warningf("Not possible to generate contour data.", call. = FALSE)
Expand All @@ -175,31 +175,6 @@ StatContour2 <- ggplot2::ggproto("StatContour2", ggplot2::Stat,
# contours[, start := NULL]
contours <- .order_contour(contours, data.table::setDT(data))

if (!is.null(proj)) {
if (is.function(proj)) {
contours <- proj(contours)
} else {
if (is.character(proj)) {
if (!requireNamespace("proj4", quietly = TRUE)) {
stopf("Projection requires the proj4 package. Install it with 'install.packages(\"proj4\")'.")
}
contours <- data.table::copy(contours)[, c("x", "y") := proj4::project(list(x, y), proj,
inverse = TRUE)][]

}
}
}


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)
}
Expand Down Expand Up @@ -292,7 +267,7 @@ isoband_z_matrix <- function(data) {
raster
}

.contour_lines <- function(data, breaks, complete = FALSE) {
.contour_lines <- function(data, breaks, complete = FALSE, clip = NULL, proj = NULL) {
z <- isoband_z_matrix(data)

if (is.list(z)) {
Expand All @@ -311,6 +286,35 @@ isoband_z_matrix <- function(data) {
return(data.frame())
}

if (!is.null(proj)) {
cl_class <- class(cl)
if (is.function(proj)) {
cl <- proj(cl)
} else {
if (is.character(proj)) {
if (!requireNamespace("proj4", quietly = TRUE)) {
stopf("Projection requires the proj4 package. Install it with 'install.packages(\"proj4\")'.")
}
cl <- lapply(cl, function(x) {
x[c("x", "y")] <- proj4::project(list(x$x, x$y), proj, inverse = TRUE)
return(x)
})
}
}
class(cl) <- cl_class
}


if (!is.null(clip)) {
clip <- sf::st_union(clip)

if (!is.na(sf::st_crs(clip))) {
sf::st_crs(clip) <- NA
}

cl <- clip_iso(cl, clip, "LINESTRING")
}

# Convert list of lists into single data frame

cont <- data.table::rbindlist(lapply(cl, data.table::as.data.table), idcol = "level")
Expand Down
108 changes: 78 additions & 30 deletions R/stat_contour_fill.R
View file
Expand Up @@ -140,43 +140,19 @@ StatContourFill <- ggplot2::ggproto("StatContourFill", ggplot2::Stat,


# Make contours
cont <- data.table::setDT(.contour_bands(data, breaks, complete = complete))
cont <- data.table::setDT(.contour_bands(data, breaks, complete = complete, clip = clip, proj = proj))

cont[, int.level := (level_high + level_low)/2]
cont[, level_mid := int.level]
cont[, nlevel := level_high/max(level_high)]

if (!is.null(proj)) {
if (is.function(proj)) {
cont <- proj(cont)
} else {
if (is.character(proj)) {
if (!requireNamespace("proj4", quietly = TRUE)) {
stopf("Projection requires the proj4 package. Install it with 'install.packages(\"proj4\")'.")
}
cont <- data.table::copy(cont)[, c("x", "y") := proj4::project(list(x, y), proj,
inverse = TRUE)][]

}
}
}

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
}
)


.contour_bands <- function(data, breaks, complete = FALSE) {
.contour_bands <- function(data, breaks, complete = FALSE, proj = NULL, clip = NULL) {
band <- level_high <- level_low <- NULL

# From ggplot2
Expand All @@ -189,20 +165,45 @@ StatContourFill <- ggplot2::ggproto("StatContourFill", ggplot2::Stat,
z <- matrix(NA_real_, nrow = nrow, ncol = ncol)
z[cbind(y_pos, x_pos)] <- data$z



cl <- isoband::isobands(x = sort(unique(data$x)),
y = sort(unique(data$y)),
z = z,
levels_low = breaks[-length(breaks)],
levels_high = breaks[-1])


if (length(cl) == 0) {
warningf("Not possible to generate contour data.", call. = FALSE)
return(data.frame())
}

if (!is.null(proj)) {
cl_class <- class(cl)
if (is.function(proj)) {
cl <- proj(cl)
} else {
if (is.character(proj)) {
if (!requireNamespace("proj4", quietly = TRUE)) {
stopf("Projection requires the proj4 package. Install it with 'install.packages(\"proj4\")'.")
}
cl <- lapply(cl, function(x) {
x[c("x", "y")] <- proj4::project(list(x$x, x$y), proj, inverse = TRUE)
return(x)
})
}
}
class(cl) <- cl_class
}


if (!is.null(clip)) {
clip <- sf::st_union(clip)

if (!is.na(sf::st_crs(clip))) {
sf::st_crs(clip) <- NA
}

cl <- clip_iso(cl, clip, "POLYGON")
}
# Convert list of lists into single data frame

bands <- pretty_isoband_levels(names(cl))
Expand Down Expand Up @@ -240,16 +241,25 @@ pretty_isoband_levels <- function(isoband_levels, dig.lab = 3) {

clip_contours <- function(x, y, clip, type = "POLYGON") {

if (type == "POLYGON" & length(x) < 4) {
return(NULL)
}

xy <- sf::st_linestring(x = matrix(c(x, y), ncol = 2))
xy <- sf::st_cast(xy, type)
xy <- sf::st_make_valid(xy)

xy <- sf::st_intersection(xy, clip)

if (length(xy) == 0) {
return(NULL)
}

# browser(expr = inherits(xy, "GEOMETRYCOLLECTION"))

if (inherits(xy, "GEOMETRYCOLLECTION")) {
xy <- sf::st_collection_extract(xy, type)
}

xy <- sf::st_coordinates(xy)

# Annoying st_coordinates that returns variable columns!!!
Expand All @@ -262,5 +272,43 @@ clip_contours <- function(x, y, clip, type = "POLYGON") {
list(x = xy[, 1],
y = xy[, 2],
L = L)
}



get_sf_coords <- function(x, type = "POLYGON") {
if (inherits(x, "GEOMETRYCOLLECTION")) {
x <- sf::st_collection_extract(x, type)
}

x <- sf::st_coordinates(x)

# Annoying st_coordinates that returns variable columns!!!
if (ncol(x) > 2) {
L <- do.call(interaction, lapply(seq(3, ncol(x)), function(i) x[, i]))
} else {
L <- factor("1")
}

list(x = x[, 1],
y = x[, 2],
id = L)
}


clip_iso <- function(iso, clip, type = "POLYGON") {
iso <- isoband::iso_to_sfg(iso)

iso <- lapply(iso, function(x) {
result <- sf::st_intersection(sf::st_make_valid(x), clip)
if (sf::st_is_empty(result)) {
return(NULL)
}
get_sf_coords(result, type)
})
iso <- iso[!vapply(iso, is.null, TRUE)]

class(iso) <- c("isobands", "iso")
return(iso)
}

0 comments on commit 2830c57

Please sign in to comment.