diff --git a/.Rbuildignore b/.Rbuildignore index 84b244a..7ae103a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,15 +1,18 @@ -^LICENSE\.md$ -^\.github$ -^\.git$ -^issues$ -^cran-comments\.md$ -^README\.Rmd$ -^README\.html$ -^CRAN-SUBMISSION$ -^_pkgdown\.yml$ -^docs$ -^pkgdown$ -^doc$ -^Meta$ -^vignettes/articles$ -^revdep$ \ No newline at end of file +^LICENSE\.md$ +^\.github$ +^\.git$ +^issues$ +^cran-comments\.md$ +^README\.Rmd$ +^README\.html$ +^CRAN-SUBMISSION$ +^_pkgdown\.yml$ +^docs$ +^pkgdown$ +^doc$ +^Meta$ +^vignettes/articles$ +^revdep$ +^dev.R$ +^codemeta\.json$ +^Rplot\.pdf$ \ No newline at end of file diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 3670045..d46a617 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -1,52 +1,52 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, master] - pull_request: - branches: [main, master] - -name: R-CMD-check.yaml - -permissions: read-all - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: macos-latest, r: 'release'} - - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'oldrel-1'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - - steps: - - uses: actions/checkout@v4 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::rcmdcheck - needs: check - - - uses: r-lib/actions/check-r-package@v2 - with: - upload-snapshots: true - build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: R-CMD-check.yaml + +permissions: read-all + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macos-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/check-no-suggests.yaml b/.github/workflows/check-no-suggests.yaml index 3fd8b8c..27340b0 100644 --- a/.github/workflows/check-no-suggests.yaml +++ b/.github/workflows/check-no-suggests.yaml @@ -1,60 +1,60 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -# -# NOTE: This workflow only directly installs "hard" dependencies, i.e. Depends, -# Imports, and LinkingTo dependencies. Notably, Suggests dependencies are never -# installed, with the exception of testthat, knitr, and rmarkdown. The cache is -# never used to avoid accidentally restoring a cache containing a suggested -# dependency. -on: - push: - branches: [main, master] - pull_request: - branches: [main, master] - -name: check-no-suggests.yaml - -permissions: read-all - -jobs: - check-no-suggests: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: ubuntu-latest, r: 'release'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - - steps: - - uses: actions/checkout@v4 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - dependencies: '"hard"' - cache: false - extra-packages: | - any::rcmdcheck - any::testthat - any::knitr - any::rmarkdown - needs: check - - - uses: r-lib/actions/check-r-package@v2 - with: - upload-snapshots: true - build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +# +# NOTE: This workflow only directly installs "hard" dependencies, i.e. Depends, +# Imports, and LinkingTo dependencies. Notably, Suggests dependencies are never +# installed, with the exception of testthat, knitr, and rmarkdown. The cache is +# never used to avoid accidentally restoring a cache containing a suggested +# dependency. +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: check-no-suggests.yaml + +permissions: read-all + +jobs: + check-no-suggests: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: ubuntu-latest, r: 'release'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + dependencies: '"hard"' + cache: false + extra-packages: | + any::rcmdcheck + any::testthat + any::knitr + any::rmarkdown + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index eba864f..8e78458 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -1,59 +1,59 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# and https://github.com/nwtgck/actions-netlify -on: - push: - branches: [main, master] - pull_request: - branches: [main, master] - release: - types: [published] - workflow_dispatch: - -name: pkgdown.yaml - -permissions: read-all - -jobs: - pkgdown: - runs-on: ubuntu-latest - # Only restrict concurrency for non-PR jobs - concurrency: - group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - permissions: - contents: write - steps: - - uses: actions/checkout@v4 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::pkgdown, local::. - needs: website - - - uses: r-lib/actions/setup-tinytex@v2 - - - name: Build site - run: pkgdown::build_site(new_process = FALSE, install = FALSE) - shell: Rscript {0} - - - name: Deploy to Netlify - uses: nwtgck/actions-netlify@v3.0 - with: - publish-dir: 'docs' - production-branch: master - github-token: ${{ secrets.GITHUB_TOKEN }} - deploy-message: "Deploy from GitHub Actions" - enable-pull-request-comment: false - enable-commit-comment: true - overwrites-pull-request-comment: true - env: - NETLIFY_AUTH_TOKEN: ${{ secrets.NETLIFY_AUTH_TOKEN }} - NETLIFY_SITE_ID: ${{ secrets.NETLIFY_SITE_ID }} - timeout-minutes: 5 +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# and https://github.com/nwtgck/actions-netlify +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + release: + types: [published] + workflow_dispatch: + +name: pkgdown.yaml + +permissions: read-all + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::pkgdown, local::. + needs: website + + - uses: r-lib/actions/setup-tinytex@v2 + + - name: Build site + run: pkgdown::build_site(new_process = FALSE, install = FALSE) + shell: Rscript {0} + + - name: Deploy to Netlify + uses: nwtgck/actions-netlify@v3.0 + with: + publish-dir: 'docs' + production-branch: master + github-token: ${{ secrets.GITHUB_TOKEN }} + deploy-message: "Deploy from GitHub Actions" + enable-pull-request-comment: false + enable-commit-comment: true + overwrites-pull-request-comment: true + env: + NETLIFY_AUTH_TOKEN: ${{ secrets.NETLIFY_AUTH_TOKEN }} + NETLIFY_SITE_ID: ${{ secrets.NETLIFY_SITE_ID }} + timeout-minutes: 5 diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 4af5a8f..9882260 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,61 +1,61 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, master] - pull_request: - branches: [main, master] - -name: test-coverage.yaml - -permissions: read-all - -jobs: - test-coverage: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v4 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::covr, any::xml2 - needs: coverage - - - name: Test coverage - run: | - cov <- covr::package_coverage( - quiet = FALSE, - clean = FALSE, - install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") - ) - covr::to_cobertura(cov) - shell: Rscript {0} - - - uses: codecov/codecov-action@v4 - with: - fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} - file: ./cobertura.xml - plugin: noop - disable_search: true - token: ${{ secrets.CODECOV_TOKEN }} - - - name: Show testthat output - if: always() - run: | - ## -------------------------------------------------------------------- - find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true - shell: bash - - - name: Upload test results - if: failure() - uses: actions/upload-artifact@v4 - with: - name: coverage-test-failures - path: ${{ runner.temp }}/package +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage.yaml + +permissions: read-all + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr, any::xml2 + needs: coverage + + - name: Test coverage + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v4 + with: + fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} + file: ./cobertura.xml + plugin: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v4 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/.gitignore b/.gitignore index 8689455..31d0f34 100644 --- a/.gitignore +++ b/.gitignore @@ -11,4 +11,6 @@ inst/doc docs /doc/ /Meta/ -/revdep/ \ No newline at end of file +/revdep/ +cran-comments.md +dev.R \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 9335582..8ee10d2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: centerline Title: Extract Centerline from Closed Polygons -Version: 0.2.3 +Version: 0.2.4 Authors@R: c( person(given = "Anatoly", diff --git a/NEWS.md b/NEWS.md index 9e15b4c..ddf253c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,10 @@ +# centerline 0.2.4 (2025-09-09) +========================= + +### UPDATES + + * compatibility with ggplot2 4.0.0 + centerline 0.2.3 (2025-03-19) ========================= diff --git a/R/cnt_path_guess.R b/R/cnt_path_guess.R index 4b39de4..6938d09 100644 --- a/R/cnt_path_guess.R +++ b/R/cnt_path_guess.R @@ -1,323 +1,323 @@ -#' Guess polygon's centerline -#' -#' @description -#' This function, as follows from the title, tries to guess -#' the polygon centerline by connecting the most distant -#' points from each other. First, it finds the point most -#' distant from the polygon's centroid, then it searches -#' for a second point, which is most distant from the first. -#' The line connecting these two points will be the desired -#' centerline. -#' -#' @param input \code{sf}, \code{sfc} or \code{SpatVector} polygons object -#' @param skeleton \code{NULL} (default) or [centerline::cnt_skeleton()] output. -#' If \code{NULL} then polygon's skeleton would be estimated in the background -#' using specified parameters (see inherit params below). -#' @param return_geos \code{FALSE} (default). A logical flag that controls -#' whether the \code{geos_geometry} should be returned. -#' -#' @inheritDotParams cnt_skeleton -#' -#' @return An \code{sf}, \code{sfc} or \code{SpatVector} class -#' object of a \code{LINESTRING} geometry -#' @export -#' -#' @examples -#' library(sf) -#' library(geos) -#' lake <- -#' sf::st_read( -#' system.file("extdata/example.gpkg", package = "centerline"), -#' layer = "lake", -#' quiet = TRUE -#' ) |> -#' geos::as_geos_geometry() -#' # Find lake's centerline -#' lake_centerline <- cnt_path_guess(input = lake, keep = 1) -#' # Plot -#' plot(lake) -#' plot(lake_centerline, col = "firebrick", lwd = 2, add = TRUE) -#' -cnt_path_guess <- - function(input, skeleton = NULL, return_geos = FALSE, ...) { - UseMethod("cnt_path_guess") - } - -#' @export -cnt_path_guess.geos_geometry <- - function(input, skeleton = NULL, ...) { - # Check if input is of geometry type 'POLYGON' - stopifnot(check_polygons(input)) - input_geom_type <- get_geom_type(input) - - # Save CRS - crs <- wk::wk_crs(input) - - # Find skeleton - if (base::is.null(skeleton)) { - skeleton_geos <- cnt_skeleton(input = input, ...) - } else if (inherits(skeleton, "geos_geometry")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- skeleton - } else if (inherits(skeleton, "SpatVector")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- terra_to_geos(skeleton) - } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- geos::as_geos_geometry(skeleton) - } else { - warning("skeleton is not of supported class, rebuilding it...") - skeleton_geos <- cnt_skeleton(input = input, ...) - } - - longest_path_geos <- - do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) - - # Set CRS - wk::wk_crs(longest_path_geos) <- crs - - longest_path_geos - } - -#' @export -cnt_path_guess.sf <- - function(input, skeleton = NULL, return_geos = FALSE, ...) { - # Check if input is of class 'sf' or 'sfc' and 'POLYGON' - stopifnot(check_polygons(input)) - - # Save CRS - crs <- sf::st_crs(input) - - # Transform to geos_geometry - input_geos <- geos::as_geos_geometry(input) - input_geom_type <- geos::geos_type(input) - - # Find skeleton - if (base::is.null(skeleton)) { - skeleton_geos <- cnt_skeleton(input = input_geos, ...) - } else if (inherits(skeleton, "geos_geometry")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- skeleton - } else if (inherits(skeleton, "SpatVector")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- terra_to_geos(skeleton) - } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- geos::as_geos_geometry(skeleton) - } else { - warning("skeleton is not of supported class, rebuilding it...") - skeleton_geos <- cnt_skeleton(input = input_geos, ...) - } - - # Find the longest path - longest_path_geos <- - do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) - - if (return_geos) { - # Return the `geos_geometry` object - return(longest_path_geos) - } else { - # Return the `sf` object - longest_path_geos |> - sf::st_as_sf() |> - sf::st_set_crs(crs) |> - cbind(sf::st_drop_geometry(input)) - } - } - -#' @export -cnt_path_guess.sfc <- - function(input, skeleton = NULL, return_geos = FALSE, ...) { - # Check if input is of class 'POLYGON' - stopifnot(check_polygons(input)) - - # Save CRS - crs <- sf::st_crs(input) - - # Transform to geos_geometry - input_geos <- geos::as_geos_geometry(input) - input_geom_type <- geos::geos_type(input) - - # Find skeleton - if (base::is.null(skeleton)) { - skeleton_geos <- cnt_skeleton(input = input_geos, ...) - } else if (inherits(skeleton, "geos_geometry")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- skeleton - } else if (inherits(skeleton, "SpatVector")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- terra_to_geos(skeleton) - } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- geos::as_geos_geometry(skeleton) - } else { - warning("skeleton is not of supported class, rebuilding it...") - skeleton_geos <- cnt_skeleton(input = input_geos, ...) - } - - # Find the longest path - longest_path_geos <- - do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) - - if (return_geos) { - # Return the `geos_geometry` object - return(longest_path_geos) - } else { - # Return the `sfc` object - longest_path_geos |> - sf::st_as_sfc() |> - sf::st_set_crs(crs) - } - } - -#' @export -cnt_path_guess.SpatVector <- - function(input, skeleton = NULL, return_geos = FALSE, ...) { - # Check if input is of class 'POLYGON' - stopifnot(check_polygons(input)) - - # Input attributes - input_data <- terra::as.data.frame(input) - - # Save CRS - crs <- terra::crs(input) - - # Transform to geos_geometry - input_geos <- terra_to_geos(input) - input_geom_type <- geos::geos_type(input_geos) - - # Find skeleton - if (base::is.null(skeleton)) { - skeleton_geos <- cnt_skeleton(input = input_geos, ...) - } else if (inherits(skeleton, "geos_geometry")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- skeleton - } else if (inherits(skeleton, "SpatVector")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- terra_to_geos(skeleton) - } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { - stopifnot(check_lines(skeleton)) - skeleton_geos <- geos::as_geos_geometry(skeleton) - } else { - warning("skeleton is not of supported class, rebuilding it...") - skeleton_geos <- cnt_skeleton(input = input_geos, ...) - } - - # Find the longest path - longest_path_geos <- - do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) - - if (return_geos) { - # Return the `geos_geometry` object - return(longest_path_geos) - } else { - # Return the `SpatVector` object - longest_path_geos <- geos_to_terra(longest_path_geos) - - if (nrow(input_data) == 0) { - return(geos_to_terra(longest_path_geos)) - } else if (nrow(input_data) == nrow(longest_path_geos)) { - longest_path_geos <- - longest_path_geos |> - cbind(input_data) - return(longest_path_geos) - } else if (nrow(input_data) == 1 && nrow(longest_path_geos) > 1) { - longest_path_geos <- - longest_path_geos |> - cbind(input_data[rep(1, nrow(longest_path_geos)), ]) - return(longest_path_geos) - } else { - warning( - "input and centerline have different number of rows, - returning centerline without attributes" - ) - return(longest_path_geos) - } - } - } - -cnt_path_guess_master <- - function(skeleton_geos) { - if (geos::geos_type(skeleton_geos) == "multilinestring") { - skeleton_geos <- - geos::geos_unnest(skeleton_geos, keep_multi = FALSE) - } - - skeleton_sf <- sf::st_as_sf(skeleton_geos) - # Convert skeleton to sfnetworks - pol_network <- - sfnetworks::as_sfnetwork( - x = skeleton_sf, - directed = FALSE, - length_as_weight = TRUE, - edges_as_lines = TRUE - ) - # Convert sfnetworks to igraph - # pol_graph <- igraph::as.igraph(pol_network) - df_graph <- igraph::as_data_frame(pol_network) - names(df_graph)[3] <- "geometry" - df_graph <- df_graph[, c("weight", "geometry")] - df_graph$weight <- as.numeric(df_graph$weight) - - # Find border points of skeleton - closest_points <- - find_closest_nodes( - pol_network, - find_outer_nodes(skeleton_geos) - ) - - # Find the most distant point from center - # It will serve as the end point - closest_end_points <- - closest_points[which.min( - igraph::closeness(pol_network, vid = closest_points) - )] - - # Find paths - paths <- - base::suppressWarnings( - sfnetworks::st_network_paths( - pol_network, - to = closest_points[closest_points != closest_end_points], - from = closest_end_points, - weights = "weight" - ) - ) - - # Paths lengths in counts - paths_length <- - base::vapply( - paths$edge_paths, - length, - FUN.VALUE = integer(1), - USE.NAMES = FALSE - ) - - # Filter non-zero paths - paths_length_flag <- paths_length > 1 - paths_length_nonzero <- paths_length[paths_length_flag] - edge_paths_nonzero <- paths$edge_paths[paths_length_flag] - - # Estimate paths lengths - edge_paths_vec <- unlist(edge_paths_nonzero, use.names = FALSE) - edge_paths_groups <- - rep( - seq_along(edge_paths_nonzero), - times = paths_length_nonzero - ) - edge_paths_length <- df_graph[edge_paths_vec, "weight"] - - # Sum paths lengths in meters - true_paths_igraph <- - tapply(edge_paths_length, edge_paths_groups, FUN = sum) - - # Return the longest path - longest_path_igraph <- which.max(true_paths_igraph) - longest_path_geos <- - df_graph[edge_paths_nonzero[[longest_path_igraph]], "geometry"] |> - geos::as_geos_geometry() |> - geos::geos_make_collection() |> - geos::geos_line_merge() - - longest_path_geos - } +#' Guess polygon's centerline +#' +#' @description +#' This function, as follows from the title, tries to guess +#' the polygon centerline by connecting the most distant +#' points from each other. First, it finds the point most +#' distant from the polygon's centroid, then it searches +#' for a second point, which is most distant from the first. +#' The line connecting these two points will be the desired +#' centerline. +#' +#' @param input \code{sf}, \code{sfc} or \code{SpatVector} polygons object +#' @param skeleton \code{NULL} (default) or [centerline::cnt_skeleton()] output. +#' If \code{NULL} then polygon's skeleton would be estimated in the background +#' using specified parameters (see inherit params below). +#' @param return_geos \code{FALSE} (default). A logical flag that controls +#' whether the \code{geos_geometry} should be returned. +#' +#' @inheritDotParams cnt_skeleton +#' +#' @return An \code{sf}, \code{sfc} or \code{SpatVector} class +#' object of a \code{LINESTRING} geometry +#' @export +#' +#' @examples +#' library(sf) +#' library(geos) +#' lake <- +#' sf::st_read( +#' system.file("extdata/example.gpkg", package = "centerline"), +#' layer = "lake", +#' quiet = TRUE +#' ) |> +#' geos::as_geos_geometry() +#' # Find lake's centerline +#' lake_centerline <- cnt_path_guess(input = lake, keep = 1) +#' # Plot +#' plot(lake) +#' plot(lake_centerline, col = "firebrick", lwd = 2, add = TRUE) +#' +cnt_path_guess <- + function(input, skeleton = NULL, return_geos = FALSE, ...) { + UseMethod("cnt_path_guess") + } + +#' @export +cnt_path_guess.geos_geometry <- + function(input, skeleton = NULL, ...) { + # Check if input is of geometry type 'POLYGON' + stopifnot(check_polygons(input)) + input_geom_type <- get_geom_type(input) + + # Save CRS + crs <- wk::wk_crs(input) + + # Find skeleton + if (base::is.null(skeleton)) { + skeleton_geos <- cnt_skeleton(input = input, ...) + } else if (inherits(skeleton, "geos_geometry")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- skeleton + } else if (inherits(skeleton, "SpatVector")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- terra_to_geos(skeleton) + } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- geos::as_geos_geometry(skeleton) + } else { + warning("skeleton is not of supported class, rebuilding it...") + skeleton_geos <- cnt_skeleton(input = input, ...) + } + + longest_path_geos <- + do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) + + # Set CRS + wk::wk_crs(longest_path_geos) <- crs + + longest_path_geos + } + +#' @export +cnt_path_guess.sf <- + function(input, skeleton = NULL, return_geos = FALSE, ...) { + # Check if input is of class 'sf' or 'sfc' and 'POLYGON' + stopifnot(check_polygons(input)) + + # Save CRS + crs <- sf::st_crs(input) + + # Transform to geos_geometry + input_geos <- geos::as_geos_geometry(input) + input_geom_type <- geos::geos_type(input) + + # Find skeleton + if (base::is.null(skeleton)) { + skeleton_geos <- cnt_skeleton(input = input_geos, ...) + } else if (inherits(skeleton, "geos_geometry")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- skeleton + } else if (inherits(skeleton, "SpatVector")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- terra_to_geos(skeleton) + } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- geos::as_geos_geometry(skeleton) + } else { + warning("skeleton is not of supported class, rebuilding it...") + skeleton_geos <- cnt_skeleton(input = input_geos, ...) + } + + # Find the longest path + longest_path_geos <- + do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) + + if (return_geos) { + # Return the `geos_geometry` object + return(longest_path_geos) + } else { + # Return the `sf` object + longest_path_geos |> + sf::st_as_sf() |> + sf::st_set_crs(crs) |> + cbind(sf::st_drop_geometry(input)) + } + } + +#' @export +cnt_path_guess.sfc <- + function(input, skeleton = NULL, return_geos = FALSE, ...) { + # Check if input is of class 'POLYGON' + stopifnot(check_polygons(input)) + + # Save CRS + crs <- sf::st_crs(input) + + # Transform to geos_geometry + input_geos <- geos::as_geos_geometry(input) + input_geom_type <- geos::geos_type(input) + + # Find skeleton + if (base::is.null(skeleton)) { + skeleton_geos <- cnt_skeleton(input = input_geos, ...) + } else if (inherits(skeleton, "geos_geometry")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- skeleton + } else if (inherits(skeleton, "SpatVector")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- terra_to_geos(skeleton) + } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- geos::as_geos_geometry(skeleton) + } else { + warning("skeleton is not of supported class, rebuilding it...") + skeleton_geos <- cnt_skeleton(input = input_geos, ...) + } + + # Find the longest path + longest_path_geos <- + do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) + + if (return_geos) { + # Return the `geos_geometry` object + return(longest_path_geos) + } else { + # Return the `sfc` object + longest_path_geos |> + sf::st_as_sfc() |> + sf::st_set_crs(crs) + } + } + +#' @export +cnt_path_guess.SpatVector <- + function(input, skeleton = NULL, return_geos = FALSE, ...) { + # Check if input is of class 'POLYGON' + stopifnot(check_polygons(input)) + + # Input attributes + input_data <- terra::as.data.frame(input) + + # Save CRS + crs <- terra::crs(input) + + # Transform to geos_geometry + input_geos <- terra_to_geos(input) + input_geom_type <- geos::geos_type(input_geos) + + # Find skeleton + if (base::is.null(skeleton)) { + skeleton_geos <- cnt_skeleton(input = input_geos, ...) + } else if (inherits(skeleton, "geos_geometry")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- skeleton + } else if (inherits(skeleton, "SpatVector")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- terra_to_geos(skeleton) + } else if (inherits(skeleton, "sf") || inherits(skeleton, "sfc")) { + stopifnot(check_lines(skeleton)) + skeleton_geos <- geos::as_geos_geometry(skeleton) + } else { + warning("skeleton is not of supported class, rebuilding it...") + skeleton_geos <- cnt_skeleton(input = input_geos, ...) + } + + # Find the longest path + longest_path_geos <- + do.call(c, lapply(skeleton_geos, cnt_path_guess_master)) + + if (return_geos) { + # Return the `geos_geometry` object + return(longest_path_geos) + } else { + # Return the `SpatVector` object + longest_path_geos <- geos_to_terra(longest_path_geos) + + if (nrow(input_data) == 0) { + return(geos_to_terra(longest_path_geos)) + } else if (nrow(input_data) == nrow(longest_path_geos)) { + longest_path_geos <- + longest_path_geos |> + cbind(input_data) + return(longest_path_geos) + } else if (nrow(input_data) == 1 && nrow(longest_path_geos) > 1) { + longest_path_geos <- + longest_path_geos |> + cbind(input_data[rep(1, nrow(longest_path_geos)), ]) + return(longest_path_geos) + } else { + warning( + "input and centerline have different number of rows, + returning centerline without attributes" + ) + return(longest_path_geos) + } + } + } + +cnt_path_guess_master <- + function(skeleton_geos) { + if (geos::geos_type(skeleton_geos) == "multilinestring") { + skeleton_geos <- + geos::geos_unnest(skeleton_geos, keep_multi = FALSE) + } + + skeleton_sf <- sf::st_as_sf(skeleton_geos) + # Convert skeleton to sfnetworks + pol_network <- + sfnetworks::as_sfnetwork( + x = skeleton_sf, + directed = FALSE, + length_as_weight = TRUE, + edges_as_lines = TRUE + ) + # Convert sfnetworks to igraph + # pol_graph <- igraph::as.igraph(pol_network) + df_graph <- igraph::as_data_frame(pol_network) + names(df_graph)[3] <- "geometry" + df_graph <- df_graph[, c("weight", "geometry")] + df_graph$weight <- as.numeric(df_graph$weight) + + # Find border points of skeleton + closest_points <- + find_closest_nodes( + pol_network, + find_outer_nodes(skeleton_geos) + ) + + # Find the most distant point from center + # It will serve as the end point + closest_end_points <- + closest_points[which.min( + igraph::closeness(pol_network, vid = closest_points) + )] + + # Find paths + paths <- + base::suppressWarnings( + sfnetworks::st_network_paths( + pol_network, + to = closest_points[closest_points != closest_end_points], + from = closest_end_points, + weights = "weight" + ) + ) + + # Paths lengths in counts + paths_length <- + base::vapply( + paths$edge_paths, + length, + FUN.VALUE = integer(1), + USE.NAMES = FALSE + ) + + # Filter non-zero paths + paths_length_flag <- paths_length > 1 + paths_length_nonzero <- paths_length[paths_length_flag] + edge_paths_nonzero <- paths$edge_paths[paths_length_flag] + + # Estimate paths lengths + edge_paths_vec <- unlist(edge_paths_nonzero, use.names = FALSE) + edge_paths_groups <- + rep( + seq_along(edge_paths_nonzero), + times = paths_length_nonzero + ) + edge_paths_length <- df_graph[edge_paths_vec, "weight"] + + # Sum paths lengths in meters + true_paths_igraph <- + tapply(edge_paths_length, edge_paths_groups, FUN = sum) + + # Return the longest path + longest_path_igraph <- which.max(true_paths_igraph) + longest_path_geos <- + df_graph[edge_paths_nonzero[[longest_path_igraph]], "geometry"] |> + geos::as_geos_geometry() |> + geos::geos_make_collection() |> + geos::geos_line_merge() + + longest_path_geos + } diff --git a/R/geom_cnt.R b/R/geom_cnt.R index c027def..92c4996 100644 --- a/R/geom_cnt.R +++ b/R/geom_cnt.R @@ -1,288 +1,315 @@ -#' Plot centerline with ggplot2 -#' -#' @description Binding for [ggplot2::geom_sf()], therefore it supports -#' only `sf` objects. -#' -#' @param simplify logical, if \code{TRUE} (default) then the -#' centerline will be smoothed with [smoothr::smooth_ksmooth()] -#' -#' @inheritParams cnt_skeleton -#' @inheritParams ggplot2::geom_sf -#' -#' @inheritSection ggplot2::geom_sf CRS -#' @inheritSection ggplot2::geom_sf Combining sf layers and regular geoms -#' -#' @seealso [geom_cnt_text()], [geom_cnt_label()], [ggplot2::geom_sf()] -#' -#' @return A `Layer` ggproto object that can be added to a plot. -#' -#' @export -#' -#' @examplesIf requireNamespace("geomtextpath", quietly = TRUE) -#' library(sf) -#' library(ggplot2) -#' -#' lake <- -#' sf::st_read( -#' system.file("extdata/example.gpkg", package = "centerline"), -#' layer = "lake", -#' quiet = TRUE -#' ) -#' -#' ggplot() + -#' geom_sf(data = lake) + -#' geom_cnt( -#' data = lake, -#' keep = 1, -#' simplify = TRUE -#' ) + -#' theme_void() -geom_cnt <- - function( - mapping = ggplot2::aes(), - data = NULL, - stat = "sf", - position = "identity", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE, - keep = 0.5, - method = c("voronoi", "straight"), - simplify = TRUE, - ... - ) { - check_package("ggplot2") - - # Check if the input data is an sf object - checkmate::assert_class(data, "sf") - check_polygons(data) - checkmate::assert_logical(simplify) - - data_centerline_geos <- - cnt_path_guess( - input = data, - keep = keep, - method = method, - return_geos = TRUE - ) - - if (simplify) { - check_package("smoothr") - data_centerline <- - geos_ksmooth(data_centerline_geos) |> - sf::st_as_sf() |> - cbind(sf::st_drop_geometry(data)) - } else { - data_centerline <- - sf::st_as_sf(data_centerline_geos) |> - cbind(sf::st_drop_geometry(data)) - } - - ggplot2::geom_sf( - mapping = mapping, - data = data_centerline, - stat = stat, - position = position, - na.rm = na.rm, - show.legend = show.legend, - inherit.aes = inherit.aes, - ... - ) - } - -#' Plot label or text on centerline with ggplot2 -#' @rdname geom_cnt_text -#' -#' @description Binding for [geomtextpath::geom_textsf()] and -#' [geomtextpath::geom_labelsf()] -#' -#' @param simplify logical, if \code{TRUE} (default) then the -#' centerline will be smoothed with [smoothr::smooth_ksmooth()] -#' -#' @inheritParams cnt_skeleton -#' @inheritParams geomtextpath::geom_textsf -#' -#' @details -#' ## Aesthetics -#' \code{geom_cnt_text()} understands the following aesthetics: -#' \itemize{ -#' \item `x` -#' \item `y` -#' \item `label` -#' \item `alpha` -#' \item `angle` -#' \item `colour` -#' \item `family` -#' \item `fontface` -#' \item `group` -#' \item `hjust` -#' \item `linecolour` -#' \item `lineheight` -#' \item `linetype` -#' \item `linewidth` -#' \item `size` -#' \item `spacing` -#' \item `textcolour` -#' \item `vjust` -#' } -#' -#' In addition to aforementioned aesthetics, \code{geom_cnt_label()} also -#' understands: -#' \itemize{ -#' \item `boxcolour` -#' \item `boxlinetype` -#' \item `boxlinewidth` -#' \item `fill` -#' } -#' -#' @seealso [geom_cnt()], [geomtextpath::geom_textsf()], -#' [geomtextpath::geom_labelsf()], [ggplot2::geom_sf()] -#' -#' @export -#' -#' @examplesIf requireNamespace("geomtextpath", quietly = TRUE) -#' library(sf) -#' library(ggplot2) -#' -#' lake <- -#' sf::st_read( -#' system.file("extdata/example.gpkg", package = "centerline"), -#' layer = "lake", -#' quiet = TRUE -#' ) -#' -#' # Plot centerline and lake name as text -#' ggplot() + -#' geom_sf(data = lake) + -#' geom_cnt_text( -#' data = lake, -#' aes(label = "Lake Ohau"), -#' size = 8, -#' simplify = TRUE -#' ) + -#' theme_void() -#' -#' # Plot lake name as label -#' ggplot() + -#' geom_sf(data = lake) + -#' geom_cnt_label( -#' data = lake, -#' aes(label = "Lake Ohau"), -#' linecolor = NA, # disable line drawing -#' size = 10, -#' method = "s", -#' simplify = TRUE -#' ) + -#' theme_void() -#' -geom_cnt_text <- - function( - mapping = ggplot2::aes(), - data = NULL, - stat = "sf", - position = "identity", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE, - keep = 0.5, - method = c("voronoi", "straight"), - simplify = TRUE, - ... - ) { - check_package("geomtextpath") - - # Check if the input data is an sf object - checkmate::assert_class(data, "sf") - check_polygons(data) - checkmate::assert_logical(simplify) - - data_centerline_geos <- - cnt_path_guess( - input = data, - keep = keep, - method = method, - return_geos = TRUE - ) - - if (simplify) { - check_package("smoothr") - data_centerline <- - geos_ksmooth(data_centerline_geos) |> - sf::st_as_sf() |> - cbind(sf::st_drop_geometry(data)) - } else { - data_centerline <- - sf::st_as_sf(data_centerline_geos) |> - cbind(sf::st_drop_geometry(data)) - } - - # Call geomtextpath::geom_textsf() with the transformed data - geomtextpath::geom_textsf( - mapping = mapping, - data = data_centerline, - stat = stat, - position = position, - na.rm = na.rm, - show.legend = show.legend, - inherit.aes = inherit.aes, - ... - ) - } - - -#' @export -#' @rdname geom_cnt_text -#' @inheritParams cnt_skeleton -geom_cnt_label <- - function( - mapping = ggplot2::aes(), - data = NULL, - stat = "sf", - position = "identity", - na.rm = FALSE, - show.legend = NA, - inherit.aes = TRUE, - keep = 0.5, - method = c("voronoi", "straight"), - simplify = TRUE, - ... - ) { - check_package("geomtextpath") - - # Check if the input data is an sf object - checkmate::assert_class(data, "sf") - check_polygons(data) - checkmate::assert_logical(simplify) - - data_centerline_geos <- - cnt_path_guess( - input = data, - keep = keep, - method = method, - return_geos = TRUE - ) - - if (simplify) { - check_package("smoothr") - data_centerline <- - geos_ksmooth(data_centerline_geos) |> - sf::st_as_sf() |> - cbind(sf::st_drop_geometry(data)) - } else { - data_centerline <- - sf::st_as_sf(data_centerline_geos) |> - cbind(sf::st_drop_geometry(data)) - } - - # Call geomtextpath::geom_textsf() with the transformed data - geomtextpath::geom_labelsf( - mapping = mapping, - data = data_centerline, - stat = stat, - position = position, - na.rm = na.rm, - show.legend = show.legend, - inherit.aes = inherit.aes, - ... - ) - } +# TODO: +# Update documentation to use ggplot2::geom_sf() instead of ggplot2::layer() +# as soon as ggplot2 4.0.0 is released + +#' Plot centerline with ggplot2 +#' +#' @description Binding for [ggplot2::geom_sf()], therefore it supports +#' only `sf` objects. +#' +#' @param mapping Set of aesthetic mappings created by [ggplot2::aes()]. See +#' [ggplot2::geom_sf()] for details. +#' +#' @param data The data to be displayed in this layer. See [ggplot2::geom_sf()] +#' for details. +#' +#' @param stat The statistical transformation to use on the data for this layer. +#' See [ggplot2::geom_sf()] for details. +#' +#' @param position A position adjustment to use on the data for this layer. +#' See [ggplot2::geom_sf()] for details. +#' +#' @param na.rm If \code{FALSE}, the default, missing values are removed with +#' a warning. If \code{TRUE}, missing values are silently removed. +#' +#' @param show.legend logical. Should this layer be included in the legends? +#' See [ggplot2::geom_sf()] for details. +#' +#' @param inherit.aes If \code{FALSE}, overrides the default aesthetics, +#' rather than combining with them. See [ggplot2::geom_sf()] for details. +#' +#' @param simplify logical, if \code{TRUE} (default) then the +#' centerline will be smoothed with [smoothr::smooth_ksmooth()] +#' +#' @param ... Other arguments passed on to [ggplot2::layer()]. See +#' [ggplot2::geom_sf()] for details. +#' +#' @inheritParams cnt_skeleton +#' +#' @inheritSection ggplot2::geom_sf CRS +#' @inheritSection ggplot2::geom_sf Combining sf layers and regular geoms +#' +#' @seealso [geom_cnt_text()], [geom_cnt_label()], [ggplot2::geom_sf()] +#' +#' @return A `Layer` ggproto object that can be added to a plot. +#' +#' @export +#' +#' @examplesIf requireNamespace("geomtextpath", quietly = TRUE) +#' library(sf) +#' library(ggplot2) +#' +#' lake <- +#' sf::st_read( +#' system.file("extdata/example.gpkg", package = "centerline"), +#' layer = "lake", +#' quiet = TRUE +#' ) +#' +#' ggplot() + +#' geom_sf(data = lake) + +#' geom_cnt( +#' data = lake, +#' keep = 1, +#' simplify = TRUE +#' ) + +#' theme_void() +geom_cnt <- + function( + mapping = ggplot2::aes(), + data = NULL, + stat = "sf", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + keep = 0.5, + method = c("voronoi", "straight"), + simplify = TRUE, + ... + ) { + check_package("ggplot2") + + # Check if the input data is an sf object + checkmate::assert_class(data, "sf") + check_polygons(data) + checkmate::assert_logical(simplify) + + data_centerline_geos <- + cnt_path_guess( + input = data, + keep = keep, + method = method, + return_geos = TRUE + ) + + if (simplify) { + check_package("smoothr") + data_centerline <- + geos_ksmooth(data_centerline_geos) |> + sf::st_as_sf() |> + cbind(sf::st_drop_geometry(data)) + } else { + data_centerline <- + sf::st_as_sf(data_centerline_geos) |> + cbind(sf::st_drop_geometry(data)) + } + + ggplot2::geom_sf( + mapping = mapping, + data = data_centerline, + stat = stat, + position = position, + na.rm = na.rm, + show.legend = show.legend, + inherit.aes = inherit.aes, + ... + ) + } + +#' Plot label or text on centerline with ggplot2 +#' @rdname geom_cnt_text +#' +#' @description Binding for [geomtextpath::geom_textsf()] and +#' [geomtextpath::geom_labelsf()] +#' +#' @param simplify logical, if \code{TRUE} (default) then the +#' centerline will be smoothed with [smoothr::smooth_ksmooth()] +#' +#' @inheritParams cnt_skeleton +#' @inheritParams geomtextpath::geom_textsf +#' +#' @details +#' ## Aesthetics +#' \code{geom_cnt_text()} understands the following aesthetics: +#' \itemize{ +#' \item `x` +#' \item `y` +#' \item `label` +#' \item `alpha` +#' \item `angle` +#' \item `colour` +#' \item `family` +#' \item `fontface` +#' \item `group` +#' \item `hjust` +#' \item `linecolour` +#' \item `lineheight` +#' \item `linetype` +#' \item `linewidth` +#' \item `size` +#' \item `spacing` +#' \item `textcolour` +#' \item `vjust` +#' } +#' +#' In addition to aforementioned aesthetics, \code{geom_cnt_label()} also +#' understands: +#' \itemize{ +#' \item `boxcolour` +#' \item `boxlinetype` +#' \item `boxlinewidth` +#' \item `fill` +#' } +#' +#' @seealso [geom_cnt()], [geomtextpath::geom_textsf()], +#' [geomtextpath::geom_labelsf()], [ggplot2::geom_sf()] +#' +#' @export +#' +#' @examplesIf requireNamespace("geomtextpath", quietly = TRUE) +#' library(sf) +#' library(ggplot2) +#' +#' lake <- +#' sf::st_read( +#' system.file("extdata/example.gpkg", package = "centerline"), +#' layer = "lake", +#' quiet = TRUE +#' ) +#' +#' # Plot centerline and lake name as text +#' ggplot() + +#' geom_sf(data = lake) + +#' geom_cnt_text( +#' data = lake, +#' aes(label = "Lake Ohau"), +#' size = 8, +#' simplify = TRUE +#' ) + +#' theme_void() +#' +#' # Plot lake name as label +#' ggplot() + +#' geom_sf(data = lake) + +#' geom_cnt_label( +#' data = lake, +#' aes(label = "Lake Ohau"), +#' linecolor = NA, # disable line drawing +#' size = 10, +#' method = "s", +#' simplify = TRUE +#' ) + +#' theme_void() +#' +geom_cnt_text <- + function( + mapping = ggplot2::aes(), + data = NULL, + stat = "sf", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + keep = 0.5, + method = c("voronoi", "straight"), + simplify = TRUE, + ... + ) { + check_package("geomtextpath") + + # Check if the input data is an sf object + checkmate::assert_class(data, "sf") + check_polygons(data) + checkmate::assert_logical(simplify) + + data_centerline_geos <- + cnt_path_guess( + input = data, + keep = keep, + method = method, + return_geos = TRUE + ) + + if (simplify) { + check_package("smoothr") + data_centerline <- + geos_ksmooth(data_centerline_geos) |> + sf::st_as_sf() |> + cbind(sf::st_drop_geometry(data)) + } else { + data_centerline <- + sf::st_as_sf(data_centerline_geos) |> + cbind(sf::st_drop_geometry(data)) + } + + # Call geomtextpath::geom_textsf() with the transformed data + geomtextpath::geom_textsf( + mapping = mapping, + data = data_centerline, + stat = stat, + position = position, + na.rm = na.rm, + show.legend = show.legend, + inherit.aes = inherit.aes, + ... + ) + } + + +#' @export +#' @rdname geom_cnt_text +#' @inheritParams cnt_skeleton +geom_cnt_label <- + function( + mapping = ggplot2::aes(), + data = NULL, + stat = "sf", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + keep = 0.5, + method = c("voronoi", "straight"), + simplify = TRUE, + ... + ) { + check_package("geomtextpath") + + # Check if the input data is an sf object + checkmate::assert_class(data, "sf") + check_polygons(data) + checkmate::assert_logical(simplify) + + data_centerline_geos <- + cnt_path_guess( + input = data, + keep = keep, + method = method, + return_geos = TRUE + ) + + if (simplify) { + check_package("smoothr") + data_centerline <- + geos_ksmooth(data_centerline_geos) |> + sf::st_as_sf() |> + cbind(sf::st_drop_geometry(data)) + } else { + data_centerline <- + sf::st_as_sf(data_centerline_geos) |> + cbind(sf::st_drop_geometry(data)) + } + + # Call geomtextpath::geom_textsf() with the transformed data + geomtextpath::geom_labelsf( + mapping = mapping, + data = data_centerline, + stat = stat, + position = position, + na.rm = na.rm, + show.legend = show.legend, + inherit.aes = inherit.aes, + ... + ) + } diff --git a/R/transformers.R b/R/transformers.R index 4ab105c..7da3388 100644 --- a/R/transformers.R +++ b/R/transformers.R @@ -1,51 +1,51 @@ -# Inter-class transformers ----------------------------------------------- -# Terra to SF transformer -# This function is five time faster than -# st::st_as_sf() due to {wk} package -terra_to_sf <- - function(input) { - spatial_data <- - terra::as.data.frame(input) - - if (length(spatial_data) == 0) { - terra::geom(input, wk = TRUE) |> - wk::as_wkt() |> - sf::st_as_sf() |> - sf::st_set_crs(terra::crs(input)) - } else { - terra::geom(input, wk = TRUE) |> - wk::as_wkt() |> - sf::st_as_sf() |> - sf::st_set_crs(terra::crs(input)) |> - cbind(terra::as.data.frame(spatial_data)) - } - } - -# Terra to GEOS transformer -terra_to_geos <- - function(input) { - input |> - sf::st_as_sf() |> - geos::as_geos_geometry() - # input |> - # terra::geom(wkt = TRUE) |> - # geos::as_geos_geometry(crs = sf::st_crs(input)) - } - -# GEOS to terra transformer -geos_to_terra <- - function(input) { - wk_input <- wk::as_wkt(input) - - terra::vect( - as.character(wk_input), - crs = wk::wk_crs(wk_input)$wkt - ) - } - -# geos_geometry polygon to matrix of coordinates -geos_to_matrix <- - function(geos_obj) { - coords <- wk::wk_coords(geos_obj) - matrix(c(coords$x, coords$y), ncol = 2) - } +# Inter-class transformers ----------------------------------------------- +# Terra to SF transformer +# This function is five time faster than +# st::st_as_sf() due to {wk} package +terra_to_sf <- + function(input) { + spatial_data <- + terra::as.data.frame(input) + + if (length(spatial_data) == 0) { + terra::geom(input, wk = TRUE) |> + wk::as_wkt() |> + sf::st_as_sf() |> + sf::st_set_crs(terra::crs(input)) + } else { + terra::geom(input, wk = TRUE) |> + wk::as_wkt() |> + sf::st_as_sf() |> + sf::st_set_crs(terra::crs(input)) |> + cbind(terra::as.data.frame(spatial_data)) + } + } + +# Terra to GEOS transformer +terra_to_geos <- + function(input) { + input |> + sf::st_as_sf() |> + geos::as_geos_geometry() + # input |> + # terra::geom(wkt = TRUE) |> + # geos::as_geos_geometry(crs = sf::st_crs(input)) + } + +# GEOS to terra transformer +geos_to_terra <- + function(input) { + wk_input <- wk::as_wkt(input) + + terra::vect( + as.character(wk_input), + crs = wk::wk_crs(wk_input)$wkt + ) + } + +# geos_geometry polygon to matrix of coordinates +geos_to_matrix <- + function(geos_obj) { + coords <- wk::wk_coords(geos_obj) + matrix(c(coords$x, coords$y), ncol = 2) + } diff --git a/R/types-check.R b/R/types-check.R index aeb6217..43779ad 100644 --- a/R/types-check.R +++ b/R/types-check.R @@ -1,115 +1,115 @@ -# Check is package installed -check_package <- - function(package) { - if (!requireNamespace(package, quietly = TRUE)) { - stop(paste(package, "is required but not installed.")) - } - } - -# Check that all objects share the same class -check_same_class <- - function(obj1, obj2, obj3) { - class1 <- class(obj1) - class2 <- class(obj2) - class3 <- class(obj3) - - class_check <- - base::identical(class1, class2) && - base::identical(class1, class3) - - if (!class_check) { - stop("All objects must share the same class.") - } - } - -# Get geometry type of the spatial object -get_geom_type <- - function(input) { - if (inherits(input, "sf") || inherits(input, "sfc")) { - sf::st_geometry_type(input, by_geometry = TRUE) - } else if (inherits(input, "SpatVector")) { - terra::geomtype(input) - } else if (inherits(input, "geos_geometry")) { - geos::geos_type(input) - } - } - -# Checks for polygon geometries -check_polygons <- - function(input) { - # Check if input is of class 'sf', 'sfc', 'SpatVector', or 'geos_geometry' - if (!inherits(input, c("sf", "sfc", "SpatVector", "geos_geometry"))) { - stop( - "Input is not of - class 'sf', 'sfc', 'SpatVector', or 'geos_geometry'." - ) - } - - # Check if geometry type is POLYGON - geom_type <- get_geom_type(input) - if ( - !all( - geom_type %in% - c("POLYGON", "polygons", "polygon", "multipolygon", "MULTIPOLYGON") - ) - ) { - stop("Input does not contain 'POLYGON' or 'MULTIPOLYGON' geometries.") - } - - # If checks pass - return(TRUE) - } - -# Checks for linestring geometries -check_lines <- - function(input) { - # Check if input is of class 'sf', 'sfc', 'SpatVector', or 'geos_geometry' - if (!inherits(input, c("sf", "sfc", "SpatVector", "geos_geometry"))) { - stop( - "Input skeleton is not of - class 'sf', 'sfc', 'SpatVector', or 'geos_geometry'." - ) - } - - # Check if geometry type is LINESTRING - geom_type <- get_geom_type(input) - if ( - !all( - geom_type %in% - c( - "LINESTRING", - "lines", - "linestring", - "multilinestring", - "MULTILINESTRING" - ) - ) - ) { - stop("Input skeleton does not contain 'LINESTRING' geometry.") - } - - # If checks pass - return(TRUE) - } - -# Checks for points geometries -check_points <- - function(input) { - # Check if input is of class 'sf', 'sfc', - # 'SpatVector', or 'geos_geometry' - if (!inherits(input, c("sf", "sfc", "SpatVector", "geos_geometry"))) { - stop( - "Input point is not of - class 'sf', 'sfc', 'SpatVector', or 'geos_geometry'." - ) - } - - # Check if geometry type is POINT - geom_type <- get_geom_type(input) - if (!all(geom_type %in% c("POINT", "points", "point"))) { - stop("Input point does not contain 'POINT' geometry.") - } - - # If checks pass - return(TRUE) - } +# Check is package installed +check_package <- + function(package) { + if (!requireNamespace(package, quietly = TRUE)) { + stop(paste(package, "is required but not installed.")) + } + } + +# Check that all objects share the same class +check_same_class <- + function(obj1, obj2, obj3) { + class1 <- class(obj1) + class2 <- class(obj2) + class3 <- class(obj3) + + class_check <- + base::identical(class1, class2) && + base::identical(class1, class3) + + if (!class_check) { + stop("All objects must share the same class.") + } + } + +# Get geometry type of the spatial object +get_geom_type <- + function(input) { + if (inherits(input, "sf") || inherits(input, "sfc")) { + sf::st_geometry_type(input, by_geometry = TRUE) + } else if (inherits(input, "SpatVector")) { + terra::geomtype(input) + } else if (inherits(input, "geos_geometry")) { + geos::geos_type(input) + } + } + +# Checks for polygon geometries +check_polygons <- + function(input) { + # Check if input is of class 'sf', 'sfc', 'SpatVector', or 'geos_geometry' + if (!inherits(input, c("sf", "sfc", "SpatVector", "geos_geometry"))) { + stop( + "Input is not of + class 'sf', 'sfc', 'SpatVector', or 'geos_geometry'." + ) + } + + # Check if geometry type is POLYGON + geom_type <- get_geom_type(input) + if ( + !all( + geom_type %in% + c("POLYGON", "polygons", "polygon", "multipolygon", "MULTIPOLYGON") + ) + ) { + stop("Input does not contain 'POLYGON' or 'MULTIPOLYGON' geometries.") + } + + # If checks pass + return(TRUE) + } + +# Checks for linestring geometries +check_lines <- + function(input) { + # Check if input is of class 'sf', 'sfc', 'SpatVector', or 'geos_geometry' + if (!inherits(input, c("sf", "sfc", "SpatVector", "geos_geometry"))) { + stop( + "Input skeleton is not of + class 'sf', 'sfc', 'SpatVector', or 'geos_geometry'." + ) + } + + # Check if geometry type is LINESTRING + geom_type <- get_geom_type(input) + if ( + !all( + geom_type %in% + c( + "LINESTRING", + "lines", + "linestring", + "multilinestring", + "MULTILINESTRING" + ) + ) + ) { + stop("Input skeleton does not contain 'LINESTRING' geometry.") + } + + # If checks pass + return(TRUE) + } + +# Checks for points geometries +check_points <- + function(input) { + # Check if input is of class 'sf', 'sfc', + # 'SpatVector', or 'geos_geometry' + if (!inherits(input, c("sf", "sfc", "SpatVector", "geos_geometry"))) { + stop( + "Input point is not of + class 'sf', 'sfc', 'SpatVector', or 'geos_geometry'." + ) + } + + # Check if geometry type is POINT + geom_type <- get_geom_type(input) + if (!all(geom_type %in% c("POINT", "points", "point"))) { + stop("Input point does not contain 'POINT' geometry.") + } + + # If checks pass + return(TRUE) + } diff --git a/R/utils.R b/R/utils.R index 0310a2a..9951989 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,184 +1,184 @@ -# Polygon simplifications ------------------------------------------------ -# Fast simplification, similiar to {mapshaper} ms_simplify -geos_ms_simplify <- - function(geom, keep) { - perimeter_length <- - geos::geos_length(geom) - - point_count <- - geom |> - geos::geos_num_coordinates() - - point_density <- - perimeter_length / point_count - - geos::geos_simplify( - geom, - tolerance = point_density / (keep * 7) - ) - } - -# Fast densification, similar behavior to {mapshaper} ms_simplify -geos_ms_densify <- - function(geom, keep) { - perimeter_length <- - geos::geos_length(geom) - - point_count <- - geom |> - geos::geos_num_coordinates() - - point_density <- - perimeter_length / point_count - - geos::geos_densify( - geom, - tolerance = point_density / (keep) - ) - } - -geos_ksmooth <- - function(input) { - do.call(c, lapply(input, geos_ksmooth_master)) - } - -geos_ksmooth_master <- - function(input) { - check_package("smoothr") - checkmate::assert_class(input, "geos_geometry") - - crs <- wk::wk_crs(input) - - num_coords <- - geos::geos_num_coordinates(input) - cent_length <- - geos::geos_length(input) - simpl_tolerance <- cent_length / num_coords - - m <- input |> - geos::geos_simplify(tolerance = simpl_tolerance) |> - geos_to_matrix() - - m <- smoothr::smooth_ksmooth(m, wrap = FALSE) - - geos::geos_make_linestring(m[, 1], m[, 2], crs = crs) - } - -# Reverse lines if needed ------------------------------------------------ -# Check if we need to reverse the lines -reverse_lines_if_needed <- - function(lines_list_geos, end_point) { - start_centerline <- geos::geos_point_start(lines_list_geos[[1]]) - end_centerline <- geos::geos_point_end(lines_list_geos[[1]]) - end_geos <- geos::as_geos_geometry(end_point) - - start_tail <- geos::geos_distance(end_geos, start_centerline) - end_tail <- geos::geos_distance(end_geos, end_centerline) - - if (start_tail < end_tail) { - lines_list_geos |> - lapply(geos::geos_reverse) |> - lapply(geos::geos_make_collection) |> - lapply(geos::geos_line_merge) - } else { - lines_list_geos |> - lapply(geos::geos_make_collection) |> - lapply(geos::geos_line_merge) - } - } - -# Outer nodes of the skeleton -------------------------------------------- -# Faster alternative to igraph::centr_betw() -find_outer_nodes <- - function(skeleton_geos) { - all_index <- geos::geos_strtree(skeleton_geos) - - start_points <- geos::geos_point_start(skeleton_geos) - end_points <- geos::geos_point_end(skeleton_geos) - - start_intersects <- geos::geos_intersects_matrix(start_points, all_index) - end_intersects <- geos::geos_intersects_matrix(end_points, all_index) - - lonely_start <- start_points[ - vapply( - start_intersects, - FUN = function(x) length(x) == 1, - FUN.VALUE = logical(1), - USE.NAMES = FALSE - ) - ] - lonely_end <- end_points[ - vapply( - end_intersects, - FUN = function(x) length(x) == 1, - FUN.VALUE = logical(1), - USE.NAMES = FALSE - ) - ] - - c(lonely_end, lonely_start) - } - -find_closest_nodes <- - function(sf_graph, nodes_geos) { - geos_graph <- - sfnetworks::activate(sf_graph, "nodes") |> - sf::st_as_sf() |> - geos::as_geos_geometry() |> - geos::geos_strtree() - - geos::geos_nearest(nodes_geos, geos_graph) - } - -# Straight skeleton helpers ---------------------------------------------- -# Extract ring from polygon -# If the i == 1, it returns the polygon itself -get_geos_ring <- - function(geos_obj, i) { - geos_obj |> - geos::geos_ring_n(i) |> - geos::geos_polygonize() |> - geos::geos_unnest() - } - -# Get list of inner rings coordinates in a form of a list of matrices -list_geos_inner_rings <- - function(geos_obj, num_rings) { - num_iter <- seq(from = 2, to = num_rings + 1) - - lapply(num_iter, function(i) { - get_geos_ring(geos_obj, i) - }) |> - lapply(geos_to_matrix) - } - -# Convert raybevel object to geos_geometry object -raybevel_to_geos <- - function(rayskeleton, crs = NULL) { - # Keep only inner links - sk_links <- rayskeleton$links[!rayskeleton$links$edge, ] - # Create a data.frame of source nodes - source_nodes <- rayskeleton$nodes[c("id", "x", "y")] - names(source_nodes) <- c("source", "start_x", "start_y") - # Create a data.frame of destination nodes - destination_nodes <- rayskeleton$nodes[c("id", "x", "y")] - names(destination_nodes) <- c("destination", "end_x", "end_y") - - # Build a linestring geometry - sk_new <- - merge(x = sk_links, y = source_nodes, by = "source", all.x = TRUE) |> - merge(y = destination_nodes, by = "destination", all.x = TRUE) - - sk_geometry <- - sprintf( - "LINESTRING(%s %s, %s %s)", - sk_new$start_x, - sk_new$start_y, - sk_new$end_x, - sk_new$end_y - ) - - geos::as_geos_geometry(sk_geometry, crs = crs) |> - geos::geos_make_collection() |> - geos::geos_line_merge() - } +# Polygon simplifications ------------------------------------------------ +# Fast simplification, similiar to {mapshaper} ms_simplify +geos_ms_simplify <- + function(geom, keep) { + perimeter_length <- + geos::geos_length(geom) + + point_count <- + geom |> + geos::geos_num_coordinates() + + point_density <- + perimeter_length / point_count + + geos::geos_simplify( + geom, + tolerance = point_density / (keep * 7) + ) + } + +# Fast densification, similar behavior to {mapshaper} ms_simplify +geos_ms_densify <- + function(geom, keep) { + perimeter_length <- + geos::geos_length(geom) + + point_count <- + geom |> + geos::geos_num_coordinates() + + point_density <- + perimeter_length / point_count + + geos::geos_densify( + geom, + tolerance = point_density / (keep) + ) + } + +geos_ksmooth <- + function(input) { + do.call(c, lapply(input, geos_ksmooth_master)) + } + +geos_ksmooth_master <- + function(input) { + check_package("smoothr") + checkmate::assert_class(input, "geos_geometry") + + crs <- wk::wk_crs(input) + + num_coords <- + geos::geos_num_coordinates(input) + cent_length <- + geos::geos_length(input) + simpl_tolerance <- cent_length / num_coords + + m <- input |> + geos::geos_simplify(tolerance = simpl_tolerance) |> + geos_to_matrix() + + m <- smoothr::smooth_ksmooth(m, wrap = FALSE) + + geos::geos_make_linestring(m[, 1], m[, 2], crs = crs) + } + +# Reverse lines if needed ------------------------------------------------ +# Check if we need to reverse the lines +reverse_lines_if_needed <- + function(lines_list_geos, end_point) { + start_centerline <- geos::geos_point_start(lines_list_geos[[1]]) + end_centerline <- geos::geos_point_end(lines_list_geos[[1]]) + end_geos <- geos::as_geos_geometry(end_point) + + start_tail <- geos::geos_distance(end_geos, start_centerline) + end_tail <- geos::geos_distance(end_geos, end_centerline) + + if (start_tail < end_tail) { + lines_list_geos |> + lapply(geos::geos_reverse) |> + lapply(geos::geos_make_collection) |> + lapply(geos::geos_line_merge) + } else { + lines_list_geos |> + lapply(geos::geos_make_collection) |> + lapply(geos::geos_line_merge) + } + } + +# Outer nodes of the skeleton -------------------------------------------- +# Faster alternative to igraph::centr_betw() +find_outer_nodes <- + function(skeleton_geos) { + all_index <- geos::geos_strtree(skeleton_geos) + + start_points <- geos::geos_point_start(skeleton_geos) + end_points <- geos::geos_point_end(skeleton_geos) + + start_intersects <- geos::geos_intersects_matrix(start_points, all_index) + end_intersects <- geos::geos_intersects_matrix(end_points, all_index) + + lonely_start <- start_points[ + vapply( + start_intersects, + FUN = function(x) length(x) == 1, + FUN.VALUE = logical(1), + USE.NAMES = FALSE + ) + ] + lonely_end <- end_points[ + vapply( + end_intersects, + FUN = function(x) length(x) == 1, + FUN.VALUE = logical(1), + USE.NAMES = FALSE + ) + ] + + c(lonely_end, lonely_start) + } + +find_closest_nodes <- + function(sf_graph, nodes_geos) { + geos_graph <- + sfnetworks::activate(sf_graph, "nodes") |> + sf::st_as_sf() |> + geos::as_geos_geometry() |> + geos::geos_strtree() + + geos::geos_nearest(nodes_geos, geos_graph) + } + +# Straight skeleton helpers ---------------------------------------------- +# Extract ring from polygon +# If the i == 1, it returns the polygon itself +get_geos_ring <- + function(geos_obj, i) { + geos_obj |> + geos::geos_ring_n(i) |> + geos::geos_polygonize() |> + geos::geos_unnest() + } + +# Get list of inner rings coordinates in a form of a list of matrices +list_geos_inner_rings <- + function(geos_obj, num_rings) { + num_iter <- seq(from = 2, to = num_rings + 1) + + lapply(num_iter, function(i) { + get_geos_ring(geos_obj, i) + }) |> + lapply(geos_to_matrix) + } + +# Convert raybevel object to geos_geometry object +raybevel_to_geos <- + function(rayskeleton, crs = NULL) { + # Keep only inner links + sk_links <- rayskeleton$links[!rayskeleton$links$edge, ] + # Create a data.frame of source nodes + source_nodes <- rayskeleton$nodes[c("id", "x", "y")] + names(source_nodes) <- c("source", "start_x", "start_y") + # Create a data.frame of destination nodes + destination_nodes <- rayskeleton$nodes[c("id", "x", "y")] + names(destination_nodes) <- c("destination", "end_x", "end_y") + + # Build a linestring geometry + sk_new <- + merge(x = sk_links, y = source_nodes, by = "source", all.x = TRUE) |> + merge(y = destination_nodes, by = "destination", all.x = TRUE) + + sk_geometry <- + sprintf( + "LINESTRING(%s %s, %s %s)", + sk_new$start_x, + sk_new$start_y, + sk_new$end_x, + sk_new$end_y + ) + + geos::as_geos_geometry(sk_geometry, crs = crs) |> + geos::geos_make_collection() |> + geos::geos_line_merge() + } diff --git a/README.Rmd b/README.Rmd index 014e88e..c9f210c 100644 --- a/README.Rmd +++ b/README.Rmd @@ -1,328 +1,328 @@ ---- -output: github_document ---- - -```{r setup, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - warn = FALSE, - message = FALSE -) - -requireNamespace("ggplot2", quietly = TRUE) -requireNamespace("geomtextpath", quietly = TRUE) -requireNamespace("smoothr", quietly = TRUE) -``` - -# centerline - - -[![Website](https://img.shields.io/website?label=centerline.anatolii.nz&url=https%3A%2F%2Fcenterline.anatolii.nz%2F)](https://centerline.anatolii.nz/) -[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) -[![R-CMD-check](https://github.com/atsyplenkov/centerline/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/atsyplenkov/centerline/actions/workflows/R-CMD-check.yaml) -[![Check CRAN status](https://github.com/atsyplenkov/centerline/actions/workflows/CRAN-checks.yaml/badge.svg)](https://github.com/atsyplenkov/centerline/actions/workflows/CRAN-checks.yaml) -[![Codecov test coverage](https://codecov.io/gh/atsyplenkov/centerline/graph/badge.svg)](https://app.codecov.io/gh/atsyplenkov/centerline) -[![CRAN status](https://www.r-pkg.org/badges/version/centerline)](https://CRAN.R-project.org/package=centerline) -[![Monthly downloads](https://cranlogs.r-pkg.org/badges/centerline)](https://CRAN.R-project.org/package=centerline) -[![Total downloads](http://cranlogs.r-pkg.org/badges/grand-total/centerline)](https://cran.r-project.org/package=centerline) - - -The `centerline` R package simplifies the extraction of linear features from complex polygons, such as roads or rivers, by computing their centerlines (or median-axis) based on skeletons. It uses the super-fast [`geos`](https://paleolimbot.github.io/geos/index.html) library in the background and have bindings for your favorite spatial data library ([`sf`](https://r-spatial.github.io/sf/), [`terra`](https://rspatial.github.io/terra/) and [`geos`](https://paleolimbot.github.io/geos/index.html)). - -## Installation - -```{r, eval = FALSE} -# The easiest way to get centerline is to install it from CRAN: -install.packages("centerline") - -# Or the development version from GitHub: -# install.packages("pak") -pak::pak("atsyplenkov/centerline") -``` - -## Examples for closed geometries - -At the heart of this package is the `cnt_skeleton` function, which efficiently computes the skeleton of closed 2D polygonal geometries. The function uses [`geos::geos_simplify`](https://paleolimbot.github.io/geos/reference/geos_centroid.html) by default to keep the most important nodes and reduce noise from the beginning. However, it has option to densify the amount of points using [`geos::geos_densify`](https://paleolimbot.github.io/geos/reference/geos_centroid.html), which can produce more smooth results. Otherwise, you can set the parameter `keep = 1` to work with the initial geometry. - -```{r skeleton_lake, warn=FALSE, message=FALSE} -library(sf) -library(centerline) - -lake <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "lake", - quiet = TRUE - ) - -# Original -lake_skeleton <- - cnt_skeleton(lake, keep = 1) - -# Simplified -lake_skeleton_s <- - cnt_skeleton(lake, keep = 0.1) - -# Densified -lake_skeleton_d <- - cnt_skeleton(lake, keep = 2) - -``` - -
-cnt_skeleton() code 👇 -```{r skeletons_plot} -library(ggplot2) - -skeletons <- - rbind(lake_skeleton, lake_skeleton_s, lake_skeleton_d) -skeletons$type <- factor( - c("Original", "Simplified", "Densified"), - levels = c("Original", "Simplified", "Densified") -) - -skeletons_plot <- - ggplot() + - geom_sf( - data = lake, - fill = "#c8e8f1", - color = NA - ) + - geom_sf( - data = skeletons, - lwd = 0.2, - alpha = 0.5, - color = "#263238" - ) + - coord_sf(expand = FALSE, clip = "off") + - labs(caption = "cnt_skeleton() example") + - facet_wrap(~type) + - theme_void() + - theme( - plot.caption = element_text(family = "mono", size = 6), - plot.background = element_rect(fill = "white", color = NA), - strip.text = element_text(face = "bold", hjust = 0.25, size = 12), - plot.margin = margin(0.2, -0.5, 0.2, -0.5, unit = "lines"), - panel.spacing.x = unit(-2, "lines") - ) -``` - -
- -```{r save_skeletons, include=FALSE} -ggsave( - "man/figures/README-skeletons_plot.png", - skeletons_plot, - dpi = 500, - width = 10, - height = 6, - units = "cm" -) -``` -```{r, echo=FALSE, out.width = "80%", fig.align = "center"} -knitr::include_graphics("man/figures/README-skeletons_plot.png") -``` - -
- -However, the above-generated lines are not exactly a centerline of a polygon. One way to find the centerline of a closed polygon is to define both `start` and `end` points with the `cnt_path()` function. For example, in the case of landslides, it could be the landslide initiation point and landslide terminus. - -```{r} -# Load Polygon Of Interest (POI) -polygon <- - sf::st_read( - system.file( - "extdata/example.gpkg", - package = "centerline" - ), - layer = "polygon", - quiet = TRUE - ) - -# Load points data -points <- - sf::st_read( - system.file( - "extdata/example.gpkg", - package = "centerline" - ), - layer = "polygon_points", - quiet = TRUE - ) |> - head(n = 2) -points$id <- seq_len(nrow(points)) - -# Find POI's skeleton -pol_skeleton <- cnt_skeleton(polygon, keep = 1.5) - -# Connect points -# For original skeleton -pol_path <- - cnt_path( - skeleton = pol_skeleton, - start_point = subset(points, points$type == "start"), - end_point = subset(points, points$type == "end") - ) -``` - -
-cnt_path() code 👇 -```{r path_plot} -path_plot <- ggplot() + - geom_sf( - data = polygon, - fill = "#d2d2d2", - color = NA - ) + - geom_sf( - data = pol_path, - lwd = 1, - color = "black" - ) + - geom_sf( - data = points, - aes( - shape = type, - fill = type - ), - color = "white", - lwd = rel(1), - size = rel(3) - ) + - scale_fill_manual( - name = "", - values = c( - "start" = "dodgerblue", - "end" = "firebrick" - ) - ) + - scale_shape_manual( - name = "", - values = c( - "start" = 21, - "end" = 22 - ) - ) + - coord_sf(expand = FALSE, clip = "off") + - labs(caption = "cnt_path() example") + - theme_void() + - theme( - legend.position = "inside", - legend.position.inside = c(0.85, 0.2), - legend.key.spacing.y = unit(-0.5, "lines"), - plot.caption = element_text(family = "mono", size = 6), - plot.background = element_rect(fill = "white", color = NA), - strip.text = element_text(face = "bold", hjust = 0.25, size = 12), - plot.margin = margin(0.2, -0.5, 0.2, -0.5, unit = "lines"), - panel.spacing.x = unit(-2, "lines") - ) -``` -
- -```{r save_path_plot, include=FALSE} -ggsave( - "man/figures/README-path_plot.png", - path_plot, - dpi = 500, - width = 7, - height = 6, - units = "cm" -) -``` -```{r, echo=FALSE, out.width = "50%", fig.align = "center"} -knitr::include_graphics("man/figures/README-path_plot.png") -``` - -
- -And what if we don't know the starting and ending locations? What if we just want to place our label accurately in the middle of our polygon? In this case, one may find the `cnt_path_guess` function useful. It returns the line connecting the most distant points, i.e., the polygon's length. Such an approach is used in limnology for measuring [lake lengths](https://www.lakescientist.com/lake-shape/), for example. - -```{r} -lake_centerline <- cnt_path_guess(lake, keep = 1) -``` - -You can plot polygon centerline with the `geom_cnt_*` functions family: - -
-cnt_path_guess() code 👇 -```{r centerline_plot} -library(ggplot2) - -lakes <- rbind(lake, lake) -lakes$lc <- c("black", NA_character_) - -centerline_plot <- - ggplot() + - geom_sf( - data = lakes, - fill = "#c8e8f1", - color = NA - ) + - geom_cnt_text( - data = lakes, - aes( - label = name, - linecolor = lc - ), - keep = 1 - ) + - facet_wrap(~lc) + - labs( - caption = "cnt_path_guess() and geom_cnt_text() examples" - ) + - theme_void() + - theme( - legend.position = "inside", - legend.position.inside = c(0.85, 0.2), - legend.key.spacing.y = unit(-0.5, "lines"), - plot.caption = element_text(family = "mono", size = 6), - plot.background = element_rect(fill = "white", color = NA), - strip.text = element_blank(), - plot.margin = margin(0.2, -0.5, 0.2, -0.5, unit = "lines"), - panel.spacing.x = unit(-2, "lines") - ) -``` -
- -```{r save_centerline_plot, include=FALSE} -ggsave( - "man/figures/README-centerline_plot.png", - centerline_plot, - dpi = 500, - width = 8, - height = 6, - units = "cm" -) -``` -```{r, echo=FALSE, out.width = "80%", fig.align = "center"} -knitr::include_graphics("man/figures/README-centerline_plot.png") -``` - - -## Roadmap - -``` -centerline 📦 -├── Closed geometries (e.g., lakes, landslides) -│ ├── When we do know starting and ending points (e.g., landslides) ✅ -│ │ ├── centerline::cnt_skeleton ✅ -│ │ └── centerline::cnt_path ✅ -│ └── When we do NOT have points (e.g., lakes) ✅ -│ ├── centerline::cnt_skeleton ✅ -│ └── centerline::cnt_path_guess ✅ -├── Linear objects (e.g., roads or rivers) 🔲 -└── Collapse parallel lines to centerline 🔲 -``` - -## Alternatives -- **R** - - [midlines](https://github.com/RichardPatterson/midlines) - A more hydrology-oriented library that provides a multi-step approach to generate a smooth centerline of complex curved polygons (like rivers). - - [cmgo](https://github.com/AntoniusGolly/cmgo) - The main aim of the package is to propose a workflow to extract channel bank metrics, and as a part of that workflow, centerline extraction was implemented. - - [raybevel](https://github.com/tylermorganwall/raybevel) - Provides a way to generate **straight** skeletons of polygons. This approach is implemented in the `cnt_skeleton(method = "straight")` function of the current package. -- 🐍 Python: - - [centerline](https://github.com/fitodic/centerline/tree/master) library -- 🦀 Rust: - - [centerline_rs](https://codeberg.org/eadf/centerline_rs) library -- **JS** Javascript: - - [Centerline labeling blogpost](https://observablehq.com/@veltman/centerline-labeling) +--- +output: github_document +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + warn = FALSE, + message = FALSE +) + +requireNamespace("ggplot2", quietly = TRUE) +requireNamespace("geomtextpath", quietly = TRUE) +requireNamespace("smoothr", quietly = TRUE) +``` + +# centerline + + +[![Website](https://img.shields.io/website?label=centerline.anatolii.nz&url=https%3A%2F%2Fcenterline.anatolii.nz%2F)](https://centerline.anatolii.nz/) +[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) +[![R-CMD-check](https://github.com/atsyplenkov/centerline/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/atsyplenkov/centerline/actions/workflows/R-CMD-check.yaml) +[![Check CRAN status](https://github.com/atsyplenkov/centerline/actions/workflows/CRAN-checks.yaml/badge.svg)](https://github.com/atsyplenkov/centerline/actions/workflows/CRAN-checks.yaml) +[![Codecov test coverage](https://codecov.io/gh/atsyplenkov/centerline/graph/badge.svg)](https://app.codecov.io/gh/atsyplenkov/centerline) +[![CRAN status](https://www.r-pkg.org/badges/version/centerline)](https://CRAN.R-project.org/package=centerline) +[![Monthly downloads](https://cranlogs.r-pkg.org/badges/centerline)](https://CRAN.R-project.org/package=centerline) +[![Total downloads](http://cranlogs.r-pkg.org/badges/grand-total/centerline)](https://cran.r-project.org/package=centerline) + + +The `centerline` R package simplifies the extraction of linear features from complex polygons, such as roads or rivers, by computing their centerlines (or median-axis) based on skeletons. It uses the super-fast [`geos`](https://paleolimbot.github.io/geos/index.html) library in the background and have bindings for your favorite spatial data library ([`sf`](https://r-spatial.github.io/sf/), [`terra`](https://rspatial.github.io/terra/) and [`geos`](https://paleolimbot.github.io/geos/index.html)). + +## Installation + +```{r, eval = FALSE} +# The easiest way to get centerline is to install it from CRAN: +install.packages("centerline") + +# Or the development version from GitHub: +# install.packages("pak") +pak::pak("atsyplenkov/centerline") +``` + +## Examples for closed geometries + +At the heart of this package is the `cnt_skeleton` function, which efficiently computes the skeleton of closed 2D polygonal geometries. The function uses [`geos::geos_simplify`](https://paleolimbot.github.io/geos/reference/geos_centroid.html) by default to keep the most important nodes and reduce noise from the beginning. However, it has option to densify the amount of points using [`geos::geos_densify`](https://paleolimbot.github.io/geos/reference/geos_centroid.html), which can produce more smooth results. Otherwise, you can set the parameter `keep = 1` to work with the initial geometry. + +```{r skeleton_lake, warn=FALSE, message=FALSE} +library(sf) +library(centerline) + +lake <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "lake", + quiet = TRUE + ) + +# Original +lake_skeleton <- + cnt_skeleton(lake, keep = 1) + +# Simplified +lake_skeleton_s <- + cnt_skeleton(lake, keep = 0.1) + +# Densified +lake_skeleton_d <- + cnt_skeleton(lake, keep = 2) + +``` + +
+cnt_skeleton() code 👇 +```{r skeletons_plot} +library(ggplot2) + +skeletons <- + rbind(lake_skeleton, lake_skeleton_s, lake_skeleton_d) +skeletons$type <- factor( + c("Original", "Simplified", "Densified"), + levels = c("Original", "Simplified", "Densified") +) + +skeletons_plot <- + ggplot() + + geom_sf( + data = lake, + fill = "#c8e8f1", + color = NA + ) + + geom_sf( + data = skeletons, + lwd = 0.2, + alpha = 0.5, + color = "#263238" + ) + + coord_sf(expand = FALSE, clip = "off") + + labs(caption = "cnt_skeleton() example") + + facet_wrap(~type) + + theme_void() + + theme( + plot.caption = element_text(family = "mono", size = 6), + plot.background = element_rect(fill = "white", color = NA), + strip.text = element_text(face = "bold", hjust = 0.25, size = 12), + plot.margin = margin(0.2, -0.5, 0.2, -0.5, unit = "lines"), + panel.spacing.x = unit(-2, "lines") + ) +``` + +
+ +```{r save_skeletons, include=FALSE} +ggsave( + "man/figures/README-skeletons_plot.png", + skeletons_plot, + dpi = 500, + width = 10, + height = 6, + units = "cm" +) +``` +```{r, echo=FALSE, out.width = "80%", fig.align = "center"} +knitr::include_graphics("man/figures/README-skeletons_plot.png") +``` + +
+ +However, the above-generated lines are not exactly a centerline of a polygon. One way to find the centerline of a closed polygon is to define both `start` and `end` points with the `cnt_path()` function. For example, in the case of landslides, it could be the landslide initiation point and landslide terminus. + +```{r} +# Load Polygon Of Interest (POI) +polygon <- + sf::st_read( + system.file( + "extdata/example.gpkg", + package = "centerline" + ), + layer = "polygon", + quiet = TRUE + ) + +# Load points data +points <- + sf::st_read( + system.file( + "extdata/example.gpkg", + package = "centerline" + ), + layer = "polygon_points", + quiet = TRUE + ) |> + head(n = 2) +points$id <- seq_len(nrow(points)) + +# Find POI's skeleton +pol_skeleton <- cnt_skeleton(polygon, keep = 1.5) + +# Connect points +# For original skeleton +pol_path <- + cnt_path( + skeleton = pol_skeleton, + start_point = subset(points, points$type == "start"), + end_point = subset(points, points$type == "end") + ) +``` + +
+cnt_path() code 👇 +```{r path_plot} +path_plot <- ggplot() + + geom_sf( + data = polygon, + fill = "#d2d2d2", + color = NA + ) + + geom_sf( + data = pol_path, + lwd = 1, + color = "black" + ) + + geom_sf( + data = points, + aes( + shape = type, + fill = type + ), + color = "white", + lwd = rel(1), + size = rel(3) + ) + + scale_fill_manual( + name = "", + values = c( + "start" = "dodgerblue", + "end" = "firebrick" + ) + ) + + scale_shape_manual( + name = "", + values = c( + "start" = 21, + "end" = 22 + ) + ) + + coord_sf(expand = FALSE, clip = "off") + + labs(caption = "cnt_path() example") + + theme_void() + + theme( + legend.position = "inside", + legend.position.inside = c(0.85, 0.2), + legend.key.spacing.y = unit(-0.5, "lines"), + plot.caption = element_text(family = "mono", size = 6), + plot.background = element_rect(fill = "white", color = NA), + strip.text = element_text(face = "bold", hjust = 0.25, size = 12), + plot.margin = margin(0.2, -0.5, 0.2, -0.5, unit = "lines"), + panel.spacing.x = unit(-2, "lines") + ) +``` +
+ +```{r save_path_plot, include=FALSE} +ggsave( + "man/figures/README-path_plot.png", + path_plot, + dpi = 500, + width = 7, + height = 6, + units = "cm" +) +``` +```{r, echo=FALSE, out.width = "50%", fig.align = "center"} +knitr::include_graphics("man/figures/README-path_plot.png") +``` + +
+ +And what if we don't know the starting and ending locations? What if we just want to place our label accurately in the middle of our polygon? In this case, one may find the `cnt_path_guess` function useful. It returns the line connecting the most distant points, i.e., the polygon's length. Such an approach is used in limnology for measuring [lake lengths](https://www.lakescientist.com/lake-shape/), for example. + +```{r} +lake_centerline <- cnt_path_guess(lake, keep = 1) +``` + +You can plot polygon centerline with the `geom_cnt_*` functions family: + +
+cnt_path_guess() code 👇 +```{r centerline_plot} +library(ggplot2) + +lakes <- rbind(lake, lake) +lakes$lc <- c("black", NA_character_) + +centerline_plot <- + ggplot() + + geom_sf( + data = lakes, + fill = "#c8e8f1", + color = NA + ) + + geom_cnt_text( + data = lakes, + aes( + label = name, + linecolor = lc + ), + keep = 1 + ) + + facet_wrap(~lc) + + labs( + caption = "cnt_path_guess() and geom_cnt_text() examples" + ) + + theme_void() + + theme( + legend.position = "inside", + legend.position.inside = c(0.85, 0.2), + legend.key.spacing.y = unit(-0.5, "lines"), + plot.caption = element_text(family = "mono", size = 6), + plot.background = element_rect(fill = "white", color = NA), + strip.text = element_blank(), + plot.margin = margin(0.2, -0.5, 0.2, -0.5, unit = "lines"), + panel.spacing.x = unit(-2, "lines") + ) +``` +
+ +```{r save_centerline_plot, include=FALSE} +ggsave( + "man/figures/README-centerline_plot.png", + centerline_plot, + dpi = 500, + width = 8, + height = 6, + units = "cm" +) +``` +```{r, echo=FALSE, out.width = "80%", fig.align = "center"} +knitr::include_graphics("man/figures/README-centerline_plot.png") +``` + + +## Roadmap + +``` +centerline 📦 +├── Closed geometries (e.g., lakes, landslides) +│ ├── When we do know starting and ending points (e.g., landslides) ✅ +│ │ ├── centerline::cnt_skeleton ✅ +│ │ └── centerline::cnt_path ✅ +│ └── When we do NOT have points (e.g., lakes) ✅ +│ ├── centerline::cnt_skeleton ✅ +│ └── centerline::cnt_path_guess ✅ +├── Linear objects (e.g., roads or rivers) 🔲 +└── Collapse parallel lines to centerline 🔲 +``` + +## Alternatives +- **R** + - [midlines](https://github.com/RichardPatterson/midlines) - A more hydrology-oriented library that provides a multi-step approach to generate a smooth centerline of complex curved polygons (like rivers). + - [cmgo](https://github.com/AntoniusGolly/cmgo) - The main aim of the package is to propose a workflow to extract channel bank metrics, and as a part of that workflow, centerline extraction was implemented. + - [raybevel](https://github.com/tylermorganwall/raybevel) - Provides a way to generate **straight** skeletons of polygons. This approach is implemented in the `cnt_skeleton(method = "straight")` function of the current package. +- 🐍 Python: + - [centerline](https://github.com/fitodic/centerline/tree/master) library +- 🦀 Rust: + - [centerline_rs](https://codeberg.org/eadf/centerline_rs) library +- **JS** Javascript: + - [Centerline labeling blogpost](https://observablehq.com/@veltman/centerline-labeling) diff --git a/_pkgdown.yml b/_pkgdown.yml index edab093..fe48374 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,27 +1,27 @@ -url: https://centerline.anatolii.nz - -repo: - url: - home: https://github.com/atsyplenkov/centerline - source: https://github.com/atsyplenkov/centerline/tree/master - issues: https://github.com/atsyplenkov/centerline/issues - -authors: - Anatolii Tsyplenkov: - href: https://anatolii.nz - -template: - bootstrap: 5 - light-switch: true - bslib: - base_font: {google: "Roboto"} - heading_font: {google: "Inter Tight"} - code_font: {google: "Fira Code"} - -footer: - structure: - left: [developed_by] - right: [legal] - components: - legal: "[MIT](https://opensource.org/license/mit) License | Copyright (c) 2025 centerline authors" - developed_by: Developed by [Anatolii Tsyplenkov](https://github.com/atsyplenkov) +url: https://centerline.anatolii.nz + +repo: + url: + home: https://github.com/atsyplenkov/centerline + source: https://github.com/atsyplenkov/centerline/tree/master + issues: https://github.com/atsyplenkov/centerline/issues + +authors: + Anatolii Tsyplenkov: + href: https://anatolii.nz + +template: + bootstrap: 5 + light-switch: true + bslib: + base_font: {google: "Roboto"} + heading_font: {google: "Inter Tight"} + code_font: {google: "Fira Code"} + +footer: + structure: + left: [developed_by] + right: [legal] + components: + legal: "[MIT](https://opensource.org/license/mit) License | Copyright (c) 2025 centerline authors" + developed_by: Developed by [Anatolii Tsyplenkov](https://github.com/atsyplenkov) diff --git a/codemeta.json b/codemeta.json new file mode 100644 index 0000000..fe537e8 --- /dev/null +++ b/codemeta.json @@ -0,0 +1,218 @@ +{ + "@context": "https://doi.org/10.5063/schema/codemeta-2.0", + "@type": "SoftwareSourceCode", + "identifier": "centerline", + "description": "Generates skeletons of closed 2D polygons using Voronoi diagrams. It provides methods for 'sf', 'terra', and 'geos' objects to compute polygon centerlines based on the generated skeletons. Voronoi, G. (1908) .", + "name": "centerline: Extract Centerline from Closed Polygons", + "relatedLink": "https://centerline.anatolii.nz", + "codeRepository": "https://github.com/atsyplenkov/centerline", + "issueTracker": "https://github.com/atsyplenkov/centerline/issues", + "license": "https://spdx.org/licenses/MIT", + "version": "0.2.4", + "programmingLanguage": { + "@type": "ComputerLanguage", + "name": "R", + "url": "https://r-project.org" + }, + "runtimePlatform": "R version 4.5.1 Patched (2025-06-20 r88332 ucrt)", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "author": [ + { + "@type": "Person", + "givenName": "Anatoly", + "familyName": "Tsyplenkov", + "email": "atsyplenkov@fastmail.com", + "@id": "https://orcid.org/0000-0003-4144-8402" + } + ], + "copyrightHolder": [ + { + "@type": "Person", + "givenName": "Anatoly", + "familyName": "Tsyplenkov", + "email": "atsyplenkov@fastmail.com", + "@id": "https://orcid.org/0000-0003-4144-8402" + } + ], + "maintainer": [ + { + "@type": "Person", + "givenName": "Anatoly", + "familyName": "Tsyplenkov", + "email": "atsyplenkov@fastmail.com", + "@id": "https://orcid.org/0000-0003-4144-8402" + } + ], + "softwareSuggestions": [ + { + "@type": "SoftwareApplication", + "identifier": "smoothr", + "name": "smoothr", + "version": ">= 1.0.0", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=smoothr" + }, + { + "@type": "SoftwareApplication", + "identifier": "testthat", + "name": "testthat", + "version": ">= 3.0.0", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=testthat" + }, + { + "@type": "SoftwareApplication", + "identifier": "geomtextpath", + "name": "geomtextpath", + "version": ">= 0.1.5", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=geomtextpath" + }, + { + "@type": "SoftwareApplication", + "identifier": "terra", + "name": "terra", + "version": ">= 1.7", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=terra" + }, + { + "@type": "SoftwareApplication", + "identifier": "igraph", + "name": "igraph", + "version": ">= 2.0.0", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=igraph" + }, + { + "@type": "SoftwareApplication", + "identifier": "ggplot2", + "name": "ggplot2", + "version": ">= 3.1.0", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=ggplot2" + }, + { + "@type": "SoftwareApplication", + "identifier": "raybevel", + "name": "raybevel", + "version": ">= 0.2.0", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=raybevel" + } + ], + "softwareRequirements": { + "1": { + "@type": "SoftwareApplication", + "identifier": "R", + "name": "R", + "version": ">= 4.1.0" + }, + "2": { + "@type": "SoftwareApplication", + "identifier": "wk", + "name": "wk", + "version": ">= 0.9", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=wk" + }, + "3": { + "@type": "SoftwareApplication", + "identifier": "sf", + "name": "sf", + "version": ">= 1.0", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=sf" + }, + "4": { + "@type": "SoftwareApplication", + "identifier": "geos", + "name": "geos", + "version": ">= 0.2.4", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=geos" + }, + "5": { + "@type": "SoftwareApplication", + "identifier": "sfnetworks", + "name": "sfnetworks", + "version": ">= 0.6", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=sfnetworks" + }, + "6": { + "@type": "SoftwareApplication", + "identifier": "checkmate", + "name": "checkmate", + "provider": { + "@id": "https://cran.r-project.org", + "@type": "Organization", + "name": "Comprehensive R Archive Network (CRAN)", + "url": "https://cran.r-project.org" + }, + "sameAs": "https://CRAN.R-project.org/package=checkmate" + }, + "SystemRequirements": null + }, + "fileSize": "2954.932KB" +} diff --git a/cran-comments.md b/cran-comments.md deleted file mode 100644 index 5f66934..0000000 --- a/cran-comments.md +++ /dev/null @@ -1,32 +0,0 @@ -# centerline v0.2.2 -Major release of centerline package, introducing website, new family of -`geom_cnt_*()` functions and new method to generate polygon skeletons. This update also solves the current CRAN ERRORs and NOTES associated with a missing R >= 4.1.0 dependency. - -## Test environments -* local Windows 10 install, R 4.4.1 patched -* local Debian 12 install, R 4.4.2 patched -* winbuilder Windows Server 2022 x64 (build 20348), R unstable (2025-03-12 r87950 ucrt) -* github actions Microsoft Windows Server 2022 10.0.20348, R 4.4.3 -* github actions macOS (ARM64) 14.6.1, R 4.4.3 -* github actions Ubuntu 24.04.02, R 4.4.3 -* github actions Ubuntu 24.04.02, R 4.4.3 (No Suggests) -* github actions Ubuntu 24.04.05, R-devel -* github actions Ubuntu 24.04.05, R 4.3.3 - -## remote CMD check results -0 errors | 0 warnings | 0 notes - -## local R CMD check results -0 errors | 0 warnings | 1 notes - -> Notes below appear to be related to my local testing environment, since I haven't seen them during remote testing - -* checking for future file timestamps ... NOTE - unable to verify current time - -## revdepcheck results - -We checked 0 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. - - * We saw 0 new problems - * We failed to check 0 packages diff --git a/man/figures/README-centerline_plot.png b/man/figures/README-centerline_plot.png index 228aeeb..e3ae5a7 100644 Binary files a/man/figures/README-centerline_plot.png and b/man/figures/README-centerline_plot.png differ diff --git a/man/figures/README-skeletons_plot.png b/man/figures/README-skeletons_plot.png index b04c877..867fbe3 100644 Binary files a/man/figures/README-skeletons_plot.png and b/man/figures/README-skeletons_plot.png differ diff --git a/man/geom_cnt.Rd b/man/geom_cnt.Rd index 469a429..81a14ce 100644 --- a/man/geom_cnt.Rd +++ b/man/geom_cnt.Rd @@ -19,66 +19,26 @@ geom_cnt( ) } \arguments{ -\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and -\code{inherit.aes = TRUE} (the default), it is combined with the default mapping -at the top level of the plot. You must supply \code{mapping} if there is no plot -mapping.} +\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{ggplot2::aes()}}. See +\code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} for details.} -\item{data}{The data to be displayed in this layer. There are three -options: - -If \code{NULL}, the default, the data is inherited from the plot -data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}. - -A \code{data.frame}, or other object, will override the plot -data. All objects will be fortified to produce a data frame. See -\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created. - -A \code{function} will be called with a single argument, -the plot data. The return value must be a \code{data.frame}, and -will be used as the layer data. A \code{function} can be created -from a \code{formula} (e.g. \code{~ head(.x, 10)}).} +\item{data}{The data to be displayed in this layer. See \code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} +for details.} \item{stat}{The statistical transformation to use on the data for this layer. -When using a \verb{geom_*()} function to construct a layer, the \code{stat} -argument can be used the override the default coupling between geoms and -stats. The \code{stat} argument accepts the following: -\itemize{ -\item A \code{Stat} ggproto subclass, for example \code{StatCount}. -\item A string naming the stat. To give the stat as a string, strip the -function name of the \code{stat_} prefix. For example, to use \code{stat_count()}, -give the stat as \code{"count"}. -\item For more information and other ways to specify the stat, see the -\link[ggplot2:layer_stats]{layer stat} documentation. -}} - -\item{position}{A position adjustment to use on the data for this layer. This -can be used in various ways, including to prevent overplotting and -improving the display. The \code{position} argument accepts the following: -\itemize{ -\item The result of calling a position function, such as \code{position_jitter()}. -This method allows for passing extra arguments to the position. -\item A string naming the position adjustment. To give the position as a -string, strip the function name of the \code{position_} prefix. For example, -to use \code{position_jitter()}, give the position as \code{"jitter"}. -\item For more information and other ways to specify the position, see the -\link[ggplot2:layer_positions]{layer position} documentation. -}} +See \code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} for details.} + +\item{position}{A position adjustment to use on the data for this layer. +See \code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} for details.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} \item{show.legend}{logical. Should this layer be included in the legends? -\code{NA}, the default, includes if any aesthetics are mapped. -\code{FALSE} never includes, and \code{TRUE} always includes. - -You can also set this to one of "polygon", "line", and "point" to -override the default legend.} +See \code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} for details.} \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, -rather than combining with them. This is most useful for helper functions -that define both data and aesthetics and shouldn't inherit behaviour from -the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.} +rather than combining with them. See \code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} for details.} \item{keep}{numeric, proportion of points to retain (0.05-5.0; default 0.5). See Details.} @@ -90,33 +50,8 @@ See Details.} \item{simplify}{logical, if \code{TRUE} (default) then the centerline will be smoothed with \code{\link[smoothr:smooth_ksmooth]{smoothr::smooth_ksmooth()}}} -\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}'s \code{params} argument. These -arguments broadly fall into one of 4 categories below. Notably, further -arguments to the \code{position} argument, or aesthetics that are required -can \emph{not} be passed through \code{...}. Unknown arguments that are not part -of the 4 categories below are ignored. -\itemize{ -\item Static aesthetics that are not mapped to a scale, but are at a fixed -value and apply to the layer as a whole. For example, \code{colour = "red"} -or \code{linewidth = 3}. The geom's documentation has an \strong{Aesthetics} -section that lists the available options. The 'required' aesthetics -cannot be passed on to the \code{params}. Please note that while passing -unmapped aesthetics as vectors is technically possible, the order and -required length is not guaranteed to be parallel to the input data. -\item When constructing a layer using -a \verb{stat_*()} function, the \code{...} argument can be used to pass on -parameters to the \code{geom} part of the layer. An example of this is -\code{stat_density(geom = "area", outline.type = "both")}. The geom's -documentation lists which parameters it can accept. -\item Inversely, when constructing a layer using a -\verb{geom_*()} function, the \code{...} argument can be used to pass on parameters -to the \code{stat} part of the layer. An example of this is -\code{geom_area(stat = "density", adjust = 0.5)}. The stat's documentation -lists which parameters it can accept. -\item The \code{key_glyph} argument of \code{\link[ggplot2:layer]{layer()}} may also be passed on through -\code{...}. This can be one of the functions described as -\link[ggplot2:draw_key]{key glyphs}, to change the display of the layer in the legend. -}} +\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{ggplot2::layer()}}. See +\code{\link[ggplot2:ggsf]{ggplot2::geom_sf()}} for details.} } \value{ A \code{Layer} ggproto object that can be added to a plot. diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf deleted file mode 100644 index 5d11bf9..0000000 Binary files a/tests/testthat/Rplots.pdf and /dev/null differ diff --git a/tests/testthat/test-cnt_path.R b/tests/testthat/test-cnt_path.R index ee58357..69c1927 100644 --- a/tests/testthat/test-cnt_path.R +++ b/tests/testthat/test-cnt_path.R @@ -1,421 +1,421 @@ -test_that( - "cnt_path handles 'terra' geometries", - { - skip_if_not_installed("terra") - - polygon <- - terra::vect( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "polygon" - ) - start_point <- - terra::vect( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'start'" - ) - end_point <- - terra::vect( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'end'" - ) - - # Find polygon's skeleton - skeleton <- cnt_skeleton(polygon, keep = 1) - - # Two starting points - result <- - cnt_path( - skeleton, - start_point, - end_point - ) - - # One starting point - result_one <- - cnt_path( - skeleton, - start_point[1, ], - end_point - ) - - # Test Output Structure - expect_length(result, 2) - expect_length(result_one, 1) - expect_contains(get_geom_type(result), "lines") - expect_contains(get_geom_type(result_one), "lines") - # Class, CRS and attributes are inherited - expect_true(inherits(result, c("SpatVector"))) - expect_true(inherits(result_one, c("SpatVector"))) - expect_equal(terra::crs(result), terra::crs(polygon)) - expect_equal(terra::crs(result_one), terra::crs(polygon)) - expect_equal(as.data.frame(result), as.data.frame(start_point)) - expect_equal(as.data.frame(result_one), as.data.frame(start_point[1, ])) - - # Invalid inputs - expect_error( - cnt_path( - skeleton = skeleton, - start_point = skeleton, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = polygon, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = "not a skeleton", - start_point = start_point, - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = "end_point" - ) - ) - } -) - -test_that( - "cnt_path handles 'sf' geometries", - { - polygon <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "polygon", - quiet = TRUE - ) - start_point <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'start'", - quiet = TRUE - ) - end_point <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'end'", - quiet = TRUE - ) - - # Find polygon's skeleton - skeleton <- cnt_skeleton(polygon, keep = 1) - - # Two starting points - result <- - cnt_path( - skeleton, - start_point, - end_point - ) - - # One starting point - result_one <- - cnt_path( - skeleton, - start_point[1, ], - end_point - ) - - # Test Output Structure - expect_equal(nrow(result), 2) - expect_equal(nrow(result_one), 1) - expect_contains(get_geom_type(result), "LINESTRING") - expect_contains(get_geom_type(result_one), "LINESTRING") - # Class, CRS and attributes are inherited - expect_true(inherits(result, c("sf"))) - expect_true(inherits(result_one, c("sf"))) - expect_equal(sf::st_crs(result), sf::st_crs(polygon)) - expect_equal(sf::st_crs(result_one), sf::st_crs(polygon)) - expect_equal( - sf::st_drop_geometry(result), - sf::st_drop_geometry(start_point) - ) - expect_equal( - sf::st_drop_geometry(result_one), - sf::st_drop_geometry(start_point[1, ]) - ) - - # Invalid inputs - expect_error( - cnt_path( - skeleton = skeleton, - start_point = skeleton, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = polygon, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = "not a skeleton", - start_point = start_point, - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = "end_point" - ) - ) - } -) - - -test_that( - "cnt_path handles 'sfc' geometries", - { - polygon <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "polygon", - quiet = TRUE - ) |> - sf::st_as_sfc() - start_point <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'start'", - quiet = TRUE - ) |> - sf::st_as_sfc() - end_point <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'end'", - quiet = TRUE - ) |> - sf::st_as_sfc() - - # Find polygon's skeleton - skeleton <- cnt_skeleton(polygon, keep = 1) - - # Two starting points - result <- - cnt_path( - skeleton, - start_point, - end_point - ) - - # One starting point - result_one <- - cnt_path( - skeleton, - start_point[1], - end_point - ) - - # Test Output Structure - expect_equal(length(result), 2) - expect_equal(length(result_one), 1) - expect_contains(get_geom_type(result), "LINESTRING") - expect_contains(get_geom_type(result_one), "LINESTRING") - # Class, CRS and attributes are inherited - expect_true(inherits(result, c("sfc"))) - expect_true(inherits(result_one, c("sfc"))) - expect_equal(sf::st_crs(result), sf::st_crs(polygon)) - expect_equal(sf::st_crs(result_one), sf::st_crs(polygon)) - - # Invalid inputs - expect_error( - cnt_path( - skeleton = skeleton, - start_point = skeleton, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = polygon, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = "not a skeleton", - start_point = start_point, - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = "end_point" - ) - ) - } -) - - -test_that( - "cnt_path handles 'geos' geometries", - { - polygon <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "polygon", - quiet = TRUE - ) |> - geos::as_geos_geometry() - start_point <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'start'", - quiet = TRUE - ) |> - geos::as_geos_geometry() - end_point <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - query = "SELECT * FROM polygon_points WHERE type IS 'end'", - quiet = TRUE - ) |> - geos::as_geos_geometry() - - # Find polygon's skeleton - skeleton <- cnt_skeleton(polygon, keep = 1) - - # Two starting points - result <- - cnt_path( - skeleton, - start_point, - end_point - ) - - # One starting point - result_one <- - cnt_path( - skeleton, - start_point[1], - end_point - ) - - # Test Output Structure - expect_equal(length(result), 2) - expect_equal(length(result_one), 1) - expect_contains(get_geom_type(result), "linestring") - expect_contains(get_geom_type(result_one), "linestring") - # Class, CRS and attributes are inherited - expect_true(inherits(result, c("geos_geometry"))) - expect_true(inherits(result_one, c("geos_geometry"))) - expect_identical(wk::wk_crs(result), wk::wk_crs(polygon)) - expect_identical(wk::wk_crs(result_one), wk::wk_crs(polygon)) - - # Invalid inputs - expect_error( - cnt_path( - skeleton = skeleton, - start_point = skeleton, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = polygon, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = end_point, - end_point = start_point - ) - ) - expect_error( - cnt_path( - skeleton = "not a skeleton", - start_point = start_point, - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = end_point - ) - ) - expect_error( - cnt_path( - skeleton = skeleton, - start_point = "start_point", - end_point = "end_point" - ) - ) - } -) - -test_that( - "cnt_path errors on incorrect input classes", - { - expect_error( - cnt_path( - skeleton = "not a skeleton", - start_point = "not a start_point", - end_point = "not an end_point" - ) - ) - } -) +test_that( + "cnt_path handles 'terra' geometries", + { + skip_if_not_installed("terra") + + polygon <- + terra::vect( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "polygon" + ) + start_point <- + terra::vect( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'start'" + ) + end_point <- + terra::vect( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'end'" + ) + + # Find polygon's skeleton + skeleton <- cnt_skeleton(polygon, keep = 1) + + # Two starting points + result <- + cnt_path( + skeleton, + start_point, + end_point + ) + + # One starting point + result_one <- + cnt_path( + skeleton, + start_point[1, ], + end_point + ) + + # Test Output Structure + expect_length(result, 2) + expect_length(result_one, 1) + expect_contains(get_geom_type(result), "lines") + expect_contains(get_geom_type(result_one), "lines") + # Class, CRS and attributes are inherited + expect_true(inherits(result, c("SpatVector"))) + expect_true(inherits(result_one, c("SpatVector"))) + expect_equal(terra::crs(result), terra::crs(polygon)) + expect_equal(terra::crs(result_one), terra::crs(polygon)) + expect_equal(as.data.frame(result), as.data.frame(start_point)) + expect_equal(as.data.frame(result_one), as.data.frame(start_point[1, ])) + + # Invalid inputs + expect_error( + cnt_path( + skeleton = skeleton, + start_point = skeleton, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = polygon, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = "not a skeleton", + start_point = start_point, + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = "end_point" + ) + ) + } +) + +test_that( + "cnt_path handles 'sf' geometries", + { + polygon <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "polygon", + quiet = TRUE + ) + start_point <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'start'", + quiet = TRUE + ) + end_point <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'end'", + quiet = TRUE + ) + + # Find polygon's skeleton + skeleton <- cnt_skeleton(polygon, keep = 1) + + # Two starting points + result <- + cnt_path( + skeleton, + start_point, + end_point + ) + + # One starting point + result_one <- + cnt_path( + skeleton, + start_point[1, ], + end_point + ) + + # Test Output Structure + expect_equal(nrow(result), 2) + expect_equal(nrow(result_one), 1) + expect_contains(get_geom_type(result), "LINESTRING") + expect_contains(get_geom_type(result_one), "LINESTRING") + # Class, CRS and attributes are inherited + expect_true(inherits(result, c("sf"))) + expect_true(inherits(result_one, c("sf"))) + expect_equal(sf::st_crs(result), sf::st_crs(polygon)) + expect_equal(sf::st_crs(result_one), sf::st_crs(polygon)) + expect_equal( + sf::st_drop_geometry(result), + sf::st_drop_geometry(start_point) + ) + expect_equal( + sf::st_drop_geometry(result_one), + sf::st_drop_geometry(start_point[1, ]) + ) + + # Invalid inputs + expect_error( + cnt_path( + skeleton = skeleton, + start_point = skeleton, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = polygon, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = "not a skeleton", + start_point = start_point, + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = "end_point" + ) + ) + } +) + + +test_that( + "cnt_path handles 'sfc' geometries", + { + polygon <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "polygon", + quiet = TRUE + ) |> + sf::st_as_sfc() + start_point <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'start'", + quiet = TRUE + ) |> + sf::st_as_sfc() + end_point <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'end'", + quiet = TRUE + ) |> + sf::st_as_sfc() + + # Find polygon's skeleton + skeleton <- cnt_skeleton(polygon, keep = 1) + + # Two starting points + result <- + cnt_path( + skeleton, + start_point, + end_point + ) + + # One starting point + result_one <- + cnt_path( + skeleton, + start_point[1], + end_point + ) + + # Test Output Structure + expect_equal(length(result), 2) + expect_equal(length(result_one), 1) + expect_contains(get_geom_type(result), "LINESTRING") + expect_contains(get_geom_type(result_one), "LINESTRING") + # Class, CRS and attributes are inherited + expect_true(inherits(result, c("sfc"))) + expect_true(inherits(result_one, c("sfc"))) + expect_equal(sf::st_crs(result), sf::st_crs(polygon)) + expect_equal(sf::st_crs(result_one), sf::st_crs(polygon)) + + # Invalid inputs + expect_error( + cnt_path( + skeleton = skeleton, + start_point = skeleton, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = polygon, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = "not a skeleton", + start_point = start_point, + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = "end_point" + ) + ) + } +) + + +test_that( + "cnt_path handles 'geos' geometries", + { + polygon <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "polygon", + quiet = TRUE + ) |> + geos::as_geos_geometry() + start_point <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'start'", + quiet = TRUE + ) |> + geos::as_geos_geometry() + end_point <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + query = "SELECT * FROM polygon_points WHERE type IS 'end'", + quiet = TRUE + ) |> + geos::as_geos_geometry() + + # Find polygon's skeleton + skeleton <- cnt_skeleton(polygon, keep = 1) + + # Two starting points + result <- + cnt_path( + skeleton, + start_point, + end_point + ) + + # One starting point + result_one <- + cnt_path( + skeleton, + start_point[1], + end_point + ) + + # Test Output Structure + expect_equal(length(result), 2) + expect_equal(length(result_one), 1) + expect_contains(get_geom_type(result), "linestring") + expect_contains(get_geom_type(result_one), "linestring") + # Class, CRS and attributes are inherited + expect_true(inherits(result, c("geos_geometry"))) + expect_true(inherits(result_one, c("geos_geometry"))) + expect_identical(wk::wk_crs(result), wk::wk_crs(polygon)) + expect_identical(wk::wk_crs(result_one), wk::wk_crs(polygon)) + + # Invalid inputs + expect_error( + cnt_path( + skeleton = skeleton, + start_point = skeleton, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = polygon, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = end_point, + end_point = start_point + ) + ) + expect_error( + cnt_path( + skeleton = "not a skeleton", + start_point = start_point, + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = end_point + ) + ) + expect_error( + cnt_path( + skeleton = skeleton, + start_point = "start_point", + end_point = "end_point" + ) + ) + } +) + +test_that( + "cnt_path errors on incorrect input classes", + { + expect_error( + cnt_path( + skeleton = "not a skeleton", + start_point = "not a start_point", + end_point = "not an end_point" + ) + ) + } +) diff --git a/tests/testthat/test-cnt_path_guess.R b/tests/testthat/test-cnt_path_guess.R index 7710d1a..2be4029 100644 --- a/tests/testthat/test-cnt_path_guess.R +++ b/tests/testthat/test-cnt_path_guess.R @@ -1,515 +1,515 @@ -# 91 POLYGONS -shapes_sf <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "shapes", - quiet = TRUE - ) -shapes_sf$id <- seq_len(nrow(shapes_sf)) - -# One POLYGON -polygon_sf <- subset(shapes_sf, id == 89) -skeleton_sf <- cnt_skeleton(polygon_sf, keep = 1) - -# One MULTIPOLYGON -multipolygon_sf <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "lake_island", - quiet = TRUE - ) - -test_that( - "cnt_path_guess inherits params", - { - skip_if_not_installed("raybevel") - - polygon <- polygon_sf - skeleton <- skeleton_sf - - result <- cnt_path_guess(polygon) - result_keep1 <- cnt_path_guess(polygon, keep = 1) - result_straight <- cnt_path_guess(polygon, method = "straight") - result_straight_geos <- - cnt_path_guess(polygon, method = "s", return_geos = TRUE) - - # All objects should be 'sf' - expect_s3_class(result, "sf") - expect_s3_class(result_keep1, "sf") - expect_s3_class(result_straight, "sf") - - # All geometries should be 'LINESTRING' - expect_contains(get_geom_type(result), "LINESTRING") - expect_contains(get_geom_type(result_keep1), "LINESTRING") - expect_contains(get_geom_type(result_straight), "LINESTRING") - - ## Check classes and CRS of the GEOS geometry - expect_s3_class(result_straight_geos, c("geos_geometry")) - expect_contains(get_geom_type(result_straight_geos), "linestring") - expect_equal(wk::wk_crs(result_straight_geos), wk::wk_crs(polygon)) - - # Outputs are different - expect_false( - identical( - sf::st_length(result), - sf::st_length(result_straight) - ) - ) - - # Expect errors and warnings - expect_error(cnt_path_guess(polygon, keep = 10)) - expect_error(cnt_path_guess(polygon, keep = -1)) - expect_error(cnt_path_guess(polygon, method = "asdf")) - expect_error(cnt_path_guess(polygon, keep = 1, method = "asdf")) - expect_warning(cnt_path_guess(polygon, method = "straight", keep = 1.1)) - } -) - -test_that( - "cnt_path_guess works with 'sf' geometries", - { - polygon <- polygon_sf - skeleton <- skeleton_sf - result <- cnt_path_guess(polygon, keep = 1) - result_geos <- cnt_path_guess(polygon, keep = 1, return_geos = TRUE) - - ## Check classes and CRS - expect_s3_class(result, c("sf")) - expect_contains(get_geom_type(result), "LINESTRING") - expect_equal(wk::wk_crs(result), wk::wk_crs(polygon)) - - ## Check classes and CRS of the GEOS geometry - expect_s3_class(result_geos, c("geos_geometry")) - expect_contains(get_geom_type(result_geos), "linestring") - expect_equal(wk::wk_crs(result_geos), wk::wk_crs(polygon)) - - ## Check centerline lengths - expect_equal(nrow(result), 1) - expect_equal( - as.numeric(round(sf::st_length(result), 5)), - 50.95459 - ) - - # Various input classes are OK - result2 <- cnt_path_guess(polygon, skeleton_sf) - - expect_s3_class(result2, c("sf")) - expect_contains(get_geom_type(result2), "LINESTRING") - expect_equal(wk::wk_crs(result2), wk::wk_crs(polygon)) - expect_equal(result, result2) - - # Path guessing should work with any 'keep' parameter - keep_list <- - lapply(seq(0.1, 2, by = 0.2), function(x) { - tryCatch( - cnt_path_guess(polygon, keep = x), - error = \(e) NA - ) - }) - - ## Estimate lengths - keep_lengths <- - vapply( - keep_list, sf::st_length, - FUN.VALUE = numeric(1), - USE.NAMES = FALSE - ) - - ## Check that all paths are not NA nor NULL nor zero - expect_true(all(!is.na(keep_list))) - expect_true(all(!is.null(keep_lengths))) - expect_true(all(keep_lengths > 0)) - expect_vector(keep_lengths, ptype = double(), size = 10) - expect_gt(length(unique(keep_lengths)), 1) - - # Several POLYGON objects are handled correctly - shapes <- shapes_sf - shapes_centerline <- cnt_path_guess(shapes) - - expect_s3_class(shapes_centerline, c("sf")) - expect_contains(get_geom_type(shapes_centerline), "LINESTRING") - expect_equal(wk::wk_crs(shapes_centerline), wk::wk_crs(shapes)) - expect_equal( - nrow(shapes_centerline), - nrow(shapes) - ) - expect_identical( - sf::st_drop_geometry(shapes_centerline), - sf::st_drop_geometry(shapes) - ) - - # MULTIPOLYGON objects are handled correctly - multipolygon <- multipolygon_sf - multipolygon_centerline <- cnt_path_guess(multipolygon) - - expect_s3_class(multipolygon_centerline, c("sf")) - expect_contains(get_geom_type(multipolygon_centerline), "LINESTRING") - expect_equal( - wk::wk_crs(multipolygon_centerline), - wk::wk_crs(multipolygon) - ) - expect_equal(nrow(multipolygon_centerline), 8L) - expect_identical( - sf::st_drop_geometry(multipolygon_centerline)[1, ], - sf::st_drop_geometry(multipolygon) - ) - - # Incorrect inputs - expect_error( - cnt_path_guess( - input = polygon, - skeleton = polygon - ) - ) - expect_error( - cnt_path_guess( - input = skeleton - ) - ) - expect_error( - cnt_path_guess( - skeleton = polygon - ) - ) - } -) - -test_that( - "cnt_path_guess works with 'sfc' geometries", - { - polygon <- sf::st_as_sfc(polygon_sf) - skeleton <- sf::st_as_sfc(skeleton_sf) - result <- cnt_path_guess(polygon, keep = 1) - result_geos <- cnt_path_guess(polygon, keep = 1, return_geos = TRUE) - - ## Check classes and CRS - expect_s3_class(result, c("sfc")) - expect_contains(get_geom_type(result), "LINESTRING") - expect_equal(wk::wk_crs(result), wk::wk_crs(polygon)) - - ## Check classes and CRS of the GEOS geometry - expect_s3_class(result_geos, c("geos_geometry")) - expect_contains(get_geom_type(result_geos), "linestring") - expect_equal(wk::wk_crs(result_geos), wk::wk_crs(polygon)) - - ## Check centerline lengths - expect_length(result, 1) - expect_equal( - as.numeric(round(sf::st_length(result), 5)), - 50.95459 - ) - - # Various input classes are OK - result2 <- cnt_path_guess(polygon, skeleton_sf) - - expect_s3_class(result2, c("sfc")) - expect_contains(get_geom_type(result2), "LINESTRING") - expect_equal(wk::wk_crs(result2), wk::wk_crs(polygon)) - expect_equal( - sf::st_as_sf(result), - sf::st_as_sf(result2) - ) - - # Path guessing should work with any 'keep' parameter - keep_list <- - lapply(seq(0.1, 2, by = 0.2), function(x) { - tryCatch( - cnt_path_guess(polygon, keep = x), - error = \(e) NA - ) - }) - - ## Estimate lengths - keep_lengths <- - vapply( - keep_list, sf::st_length, - FUN.VALUE = numeric(1), - USE.NAMES = FALSE - ) - - ## Check that all paths are not NA nor NULL nor zero - expect_true(all(!is.na(keep_list))) - expect_true(all(!is.null(keep_lengths))) - expect_true(all(keep_lengths > 0)) - expect_vector(keep_lengths, ptype = double(), size = 10) - expect_gt(length(unique(keep_lengths)), 1) - - # Several POLYGON objects are handled correctly - shapes <- sf::st_as_sfc(shapes_sf) - shapes_centerline <- cnt_path_guess(shapes) - - expect_s3_class(shapes_centerline, c("sfc")) - expect_contains(get_geom_type(shapes_centerline), "LINESTRING") - expect_equal(wk::wk_crs(shapes_centerline), wk::wk_crs(shapes)) - expect_equal( - length(shapes_centerline), - length(shapes) - ) - - # MULTIPOLYGON objects are handled correctly - multipolygon <- sf::st_as_sfc(multipolygon_sf) - multipolygon_centerline <- cnt_path_guess(multipolygon) - - expect_s3_class(multipolygon_centerline, c("sfc")) - expect_contains(get_geom_type(multipolygon_centerline), "LINESTRING") - expect_equal( - wk::wk_crs(multipolygon_centerline), - wk::wk_crs(multipolygon) - ) - expect_equal(length(multipolygon_centerline), 8L) - - # Incorrect inputs - expect_error( - cnt_path_guess( - input = polygon, - skeleton = polygon - ) - ) - expect_error( - cnt_path_guess( - input = skeleton - ) - ) - expect_error( - cnt_path_guess( - skeleton = polygon - ) - ) - } -) - -test_that( - "cnt_path_guess works with 'geos' geometries", - { - polygon <- geos::as_geos_geometry(polygon_sf) - skeleton <- geos::as_geos_geometry(skeleton_sf) - result <- cnt_path_guess(polygon, keep = 1) - - ## Check classes and CRS - expect_s3_class(result, c("geos_geometry")) - expect_contains(get_geom_type(result), "linestring") - expect_equal(wk::wk_crs(result), wk::wk_crs(polygon)) - - ## Check centerline lengths - expect_length(result, 1) - expect_equal( - round(geos::geos_length(result), 5), - 50.95459 - ) - - # Various input classes are OK - result2 <- cnt_path_guess(polygon, skeleton_sf) - - expect_s3_class(result2, c("geos_geometry")) - expect_contains(get_geom_type(result2), "linestring") - expect_equal(wk::wk_crs(result2), wk::wk_crs(polygon)) - expect_equal( - sf::st_as_sf(result), - sf::st_as_sf(result2) - ) - - # Path guessing should work with any 'keep' parameter - keep_list <- - lapply(seq(0.1, 2, by = 0.2), function(x) { - tryCatch( - cnt_path_guess(polygon, keep = x), - error = \(e) NA - ) - }) - - ## Estimate lengths - keep_lengths <- - vapply( - keep_list, geos::geos_length, - FUN.VALUE = numeric(1), - USE.NAMES = FALSE - ) - - ## Check that all paths are not NA nor NULL nor zero - expect_true(all(!is.na(keep_list))) - expect_true(all(!is.null(keep_lengths))) - expect_true(all(keep_lengths > 0)) - expect_vector(keep_lengths, ptype = double(), size = 10) - expect_gt(length(unique(keep_lengths)), 1) - - # Several POLYGON objects are handled correctly - shapes <- geos::as_geos_geometry(shapes_sf) - shapes_centerline <- cnt_path_guess(shapes) - - expect_s3_class(shapes_centerline, c("geos_geometry")) - expect_contains(get_geom_type(shapes_centerline), "linestring") - expect_equal(wk::wk_crs(shapes_centerline), wk::wk_crs(shapes)) - expect_equal( - length(shapes_centerline), - length(shapes) - ) - - # MULTIPOLYGON objects are handled correctly - multipolygon <- geos::as_geos_geometry(multipolygon_sf) - multipolygon_centerline <- cnt_path_guess(multipolygon) - - expect_s3_class(multipolygon_centerline, c("geos_geometry")) - expect_contains(get_geom_type(multipolygon_centerline), "linestring") - expect_equal( - wk::wk_crs(multipolygon_centerline), - wk::wk_crs(multipolygon) - ) - expect_equal(length(multipolygon_centerline), 8L) - - # Incorrect inputs - expect_error( - cnt_path_guess( - input = polygon, - skeleton = polygon - ) - ) - expect_error( - cnt_path_guess( - input = skeleton - ) - ) - expect_error( - cnt_path_guess( - skeleton = polygon - ) - ) - } -) - - -test_that( - "cnt_path_guess works with 'terra' geometries", - { - skip_if_not_installed("terra") - - polygon <- terra::vect(polygon_sf) - skeleton <- terra::vect(skeleton_sf) - result <- cnt_path_guess(polygon, keep = 1) - result_geos <- cnt_path_guess(polygon, keep = 1, return_geos = TRUE) - - ## Check classes and CRS - expect_s4_class(result, c("SpatVector")) - expect_contains(get_geom_type(result), "lines") - expect_equal(terra::crs(result), terra::crs(polygon)) - - ## Check classes and CRS of the GEOS geometry - expect_s3_class(result_geos, c("geos_geometry")) - expect_contains(get_geom_type(result_geos), "linestring") - expect_equal(wk::wk_crs(result_geos), wk::wk_crs(sf::st_as_sf(polygon))) - - ## Check centerline lengths - expect_length(result, 1) - expect_equal( - round(terra::perim(result), 5), - 50.95459 - ) - - # Various input classes are OK - result2 <- cnt_path_guess(polygon, skeleton_sf) - - expect_s4_class(result2, c("SpatVector")) - expect_contains(get_geom_type(result2), "lines") - expect_equal(terra::crs(result2), terra::crs(polygon)) - expect_equal( - sf::st_as_sf(result), - sf::st_as_sf(result2) - ) - - # Path guessing should work with any 'keep' parameter - keep_list <- - lapply(seq(0.1, 2, by = 0.2), function(x) { - tryCatch( - cnt_path_guess(polygon, keep = x), - error = \(e) NA - ) - }) - - ## Estimate lengths - keep_lengths <- - vapply( - keep_list, terra::perim, - FUN.VALUE = numeric(1), - USE.NAMES = FALSE - ) - - ## Check that all paths are not NA nor NULL nor zero - expect_true(all(!is.na(keep_list))) - expect_true(all(!is.null(keep_lengths))) - expect_true(all(keep_lengths > 0)) - expect_vector(keep_lengths, ptype = double(), size = 10) - expect_gt(length(unique(keep_lengths)), 1) - - # Several POLYGON objects are handled correctly - shapes <- terra::vect(shapes_sf) - shapes_centerline <- cnt_path_guess(shapes) - - expect_s4_class(shapes_centerline, c("SpatVector")) - expect_contains(get_geom_type(shapes_centerline), "lines") - expect_equal(terra::crs(shapes_centerline), terra::crs(shapes)) - expect_equal( - nrow(shapes_centerline), - nrow(shapes) - ) - expect_identical( - terra::as.data.frame(shapes_centerline), - terra::as.data.frame(shapes) - ) - - # MULTIPOLYGON objects are handled correctly - multipolygon <- terra::vect(multipolygon_sf) - multipolygon_centerline <- cnt_path_guess(multipolygon) - - expect_s4_class(multipolygon_centerline, c("SpatVector")) - expect_contains(get_geom_type(multipolygon_centerline), "lines") - expect_equal( - terra::crs(multipolygon_centerline), - terra::crs(multipolygon) - ) - expect_equal(nrow(multipolygon_centerline), 8L) - expect_identical( - terra::as.data.frame(multipolygon_centerline)[1, ], - terra::as.data.frame(multipolygon) - ) - - # Incorrect inputs - expect_error( - cnt_path_guess( - input = polygon, - skeleton = polygon - ) - ) - expect_error( - cnt_path_guess( - input = skeleton - ) - ) - expect_error( - cnt_path_guess( - skeleton = polygon - ) - ) - } -) - - -test_that( - "cnt_path_guess errors on incorrect input classes", - { - expect_error( - cnt_path_guess( - input = "polygon_sf" - ) - ) - expect_error( - cnt_path_guess( - input = 1 - ) - ) - expect_error( - cnt_path_guess( - input = "polygon_sfc", - skeleton = polygon_sf - ) - ) - } -) +# 91 POLYGONS +shapes_sf <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "shapes", + quiet = TRUE + ) +shapes_sf$id <- seq_len(nrow(shapes_sf)) + +# One POLYGON +polygon_sf <- subset(shapes_sf, id == 89) +skeleton_sf <- cnt_skeleton(polygon_sf, keep = 1) + +# One MULTIPOLYGON +multipolygon_sf <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "lake_island", + quiet = TRUE + ) + +test_that( + "cnt_path_guess inherits params", + { + skip_if_not_installed("raybevel") + + polygon <- polygon_sf + skeleton <- skeleton_sf + + result <- cnt_path_guess(polygon) + result_keep1 <- cnt_path_guess(polygon, keep = 1) + result_straight <- cnt_path_guess(polygon, method = "straight") + result_straight_geos <- + cnt_path_guess(polygon, method = "s", return_geos = TRUE) + + # All objects should be 'sf' + expect_s3_class(result, "sf") + expect_s3_class(result_keep1, "sf") + expect_s3_class(result_straight, "sf") + + # All geometries should be 'LINESTRING' + expect_contains(get_geom_type(result), "LINESTRING") + expect_contains(get_geom_type(result_keep1), "LINESTRING") + expect_contains(get_geom_type(result_straight), "LINESTRING") + + ## Check classes and CRS of the GEOS geometry + expect_s3_class(result_straight_geos, c("geos_geometry")) + expect_contains(get_geom_type(result_straight_geos), "linestring") + expect_equal(wk::wk_crs(result_straight_geos), wk::wk_crs(polygon)) + + # Outputs are different + expect_false( + identical( + sf::st_length(result), + sf::st_length(result_straight) + ) + ) + + # Expect errors and warnings + expect_error(cnt_path_guess(polygon, keep = 10)) + expect_error(cnt_path_guess(polygon, keep = -1)) + expect_error(cnt_path_guess(polygon, method = "asdf")) + expect_error(cnt_path_guess(polygon, keep = 1, method = "asdf")) + expect_warning(cnt_path_guess(polygon, method = "straight", keep = 1.1)) + } +) + +test_that( + "cnt_path_guess works with 'sf' geometries", + { + polygon <- polygon_sf + skeleton <- skeleton_sf + result <- cnt_path_guess(polygon, keep = 1) + result_geos <- cnt_path_guess(polygon, keep = 1, return_geos = TRUE) + + ## Check classes and CRS + expect_s3_class(result, c("sf")) + expect_contains(get_geom_type(result), "LINESTRING") + expect_equal(wk::wk_crs(result), wk::wk_crs(polygon)) + + ## Check classes and CRS of the GEOS geometry + expect_s3_class(result_geos, c("geos_geometry")) + expect_contains(get_geom_type(result_geos), "linestring") + expect_equal(wk::wk_crs(result_geos), wk::wk_crs(polygon)) + + ## Check centerline lengths + expect_equal(nrow(result), 1) + expect_equal( + as.numeric(round(sf::st_length(result), 5)), + 50.95459 + ) + + # Various input classes are OK + result2 <- cnt_path_guess(polygon, skeleton_sf) + + expect_s3_class(result2, c("sf")) + expect_contains(get_geom_type(result2), "LINESTRING") + expect_equal(wk::wk_crs(result2), wk::wk_crs(polygon)) + expect_equal(result, result2) + + # Path guessing should work with any 'keep' parameter + keep_list <- + lapply(seq(0.1, 2, by = 0.2), function(x) { + tryCatch( + cnt_path_guess(polygon, keep = x), + error = \(e) NA + ) + }) + + ## Estimate lengths + keep_lengths <- + vapply( + keep_list, sf::st_length, + FUN.VALUE = numeric(1), + USE.NAMES = FALSE + ) + + ## Check that all paths are not NA nor NULL nor zero + expect_true(all(!is.na(keep_list))) + expect_true(all(!is.null(keep_lengths))) + expect_true(all(keep_lengths > 0)) + expect_vector(keep_lengths, ptype = double(), size = 10) + expect_gt(length(unique(keep_lengths)), 1) + + # Several POLYGON objects are handled correctly + shapes <- shapes_sf + shapes_centerline <- cnt_path_guess(shapes) + + expect_s3_class(shapes_centerline, c("sf")) + expect_contains(get_geom_type(shapes_centerline), "LINESTRING") + expect_equal(wk::wk_crs(shapes_centerline), wk::wk_crs(shapes)) + expect_equal( + nrow(shapes_centerline), + nrow(shapes) + ) + expect_identical( + sf::st_drop_geometry(shapes_centerline), + sf::st_drop_geometry(shapes) + ) + + # MULTIPOLYGON objects are handled correctly + multipolygon <- multipolygon_sf + multipolygon_centerline <- cnt_path_guess(multipolygon) + + expect_s3_class(multipolygon_centerline, c("sf")) + expect_contains(get_geom_type(multipolygon_centerline), "LINESTRING") + expect_equal( + wk::wk_crs(multipolygon_centerline), + wk::wk_crs(multipolygon) + ) + expect_equal(nrow(multipolygon_centerline), 8L) + expect_identical( + sf::st_drop_geometry(multipolygon_centerline)[1, ], + sf::st_drop_geometry(multipolygon) + ) + + # Incorrect inputs + expect_error( + cnt_path_guess( + input = polygon, + skeleton = polygon + ) + ) + expect_error( + cnt_path_guess( + input = skeleton + ) + ) + expect_error( + cnt_path_guess( + skeleton = polygon + ) + ) + } +) + +test_that( + "cnt_path_guess works with 'sfc' geometries", + { + polygon <- sf::st_as_sfc(polygon_sf) + skeleton <- sf::st_as_sfc(skeleton_sf) + result <- cnt_path_guess(polygon, keep = 1) + result_geos <- cnt_path_guess(polygon, keep = 1, return_geos = TRUE) + + ## Check classes and CRS + expect_s3_class(result, c("sfc")) + expect_contains(get_geom_type(result), "LINESTRING") + expect_equal(wk::wk_crs(result), wk::wk_crs(polygon)) + + ## Check classes and CRS of the GEOS geometry + expect_s3_class(result_geos, c("geos_geometry")) + expect_contains(get_geom_type(result_geos), "linestring") + expect_equal(wk::wk_crs(result_geos), wk::wk_crs(polygon)) + + ## Check centerline lengths + expect_length(result, 1) + expect_equal( + as.numeric(round(sf::st_length(result), 5)), + 50.95459 + ) + + # Various input classes are OK + result2 <- cnt_path_guess(polygon, skeleton_sf) + + expect_s3_class(result2, c("sfc")) + expect_contains(get_geom_type(result2), "LINESTRING") + expect_equal(wk::wk_crs(result2), wk::wk_crs(polygon)) + expect_equal( + sf::st_as_sf(result), + sf::st_as_sf(result2) + ) + + # Path guessing should work with any 'keep' parameter + keep_list <- + lapply(seq(0.1, 2, by = 0.2), function(x) { + tryCatch( + cnt_path_guess(polygon, keep = x), + error = \(e) NA + ) + }) + + ## Estimate lengths + keep_lengths <- + vapply( + keep_list, sf::st_length, + FUN.VALUE = numeric(1), + USE.NAMES = FALSE + ) + + ## Check that all paths are not NA nor NULL nor zero + expect_true(all(!is.na(keep_list))) + expect_true(all(!is.null(keep_lengths))) + expect_true(all(keep_lengths > 0)) + expect_vector(keep_lengths, ptype = double(), size = 10) + expect_gt(length(unique(keep_lengths)), 1) + + # Several POLYGON objects are handled correctly + shapes <- sf::st_as_sfc(shapes_sf) + shapes_centerline <- cnt_path_guess(shapes) + + expect_s3_class(shapes_centerline, c("sfc")) + expect_contains(get_geom_type(shapes_centerline), "LINESTRING") + expect_equal(wk::wk_crs(shapes_centerline), wk::wk_crs(shapes)) + expect_equal( + length(shapes_centerline), + length(shapes) + ) + + # MULTIPOLYGON objects are handled correctly + multipolygon <- sf::st_as_sfc(multipolygon_sf) + multipolygon_centerline <- cnt_path_guess(multipolygon) + + expect_s3_class(multipolygon_centerline, c("sfc")) + expect_contains(get_geom_type(multipolygon_centerline), "LINESTRING") + expect_equal( + wk::wk_crs(multipolygon_centerline), + wk::wk_crs(multipolygon) + ) + expect_equal(length(multipolygon_centerline), 8L) + + # Incorrect inputs + expect_error( + cnt_path_guess( + input = polygon, + skeleton = polygon + ) + ) + expect_error( + cnt_path_guess( + input = skeleton + ) + ) + expect_error( + cnt_path_guess( + skeleton = polygon + ) + ) + } +) + +test_that( + "cnt_path_guess works with 'geos' geometries", + { + polygon <- geos::as_geos_geometry(polygon_sf) + skeleton <- geos::as_geos_geometry(skeleton_sf) + result <- cnt_path_guess(polygon, keep = 1) + + ## Check classes and CRS + expect_s3_class(result, c("geos_geometry")) + expect_contains(get_geom_type(result), "linestring") + expect_equal(wk::wk_crs(result), wk::wk_crs(polygon)) + + ## Check centerline lengths + expect_length(result, 1) + expect_equal( + round(geos::geos_length(result), 5), + 50.95459 + ) + + # Various input classes are OK + result2 <- cnt_path_guess(polygon, skeleton_sf) + + expect_s3_class(result2, c("geos_geometry")) + expect_contains(get_geom_type(result2), "linestring") + expect_equal(wk::wk_crs(result2), wk::wk_crs(polygon)) + expect_equal( + sf::st_as_sf(result), + sf::st_as_sf(result2) + ) + + # Path guessing should work with any 'keep' parameter + keep_list <- + lapply(seq(0.1, 2, by = 0.2), function(x) { + tryCatch( + cnt_path_guess(polygon, keep = x), + error = \(e) NA + ) + }) + + ## Estimate lengths + keep_lengths <- + vapply( + keep_list, geos::geos_length, + FUN.VALUE = numeric(1), + USE.NAMES = FALSE + ) + + ## Check that all paths are not NA nor NULL nor zero + expect_true(all(!is.na(keep_list))) + expect_true(all(!is.null(keep_lengths))) + expect_true(all(keep_lengths > 0)) + expect_vector(keep_lengths, ptype = double(), size = 10) + expect_gt(length(unique(keep_lengths)), 1) + + # Several POLYGON objects are handled correctly + shapes <- geos::as_geos_geometry(shapes_sf) + shapes_centerline <- cnt_path_guess(shapes) + + expect_s3_class(shapes_centerline, c("geos_geometry")) + expect_contains(get_geom_type(shapes_centerline), "linestring") + expect_equal(wk::wk_crs(shapes_centerline), wk::wk_crs(shapes)) + expect_equal( + length(shapes_centerline), + length(shapes) + ) + + # MULTIPOLYGON objects are handled correctly + multipolygon <- geos::as_geos_geometry(multipolygon_sf) + multipolygon_centerline <- cnt_path_guess(multipolygon) + + expect_s3_class(multipolygon_centerline, c("geos_geometry")) + expect_contains(get_geom_type(multipolygon_centerline), "linestring") + expect_equal( + wk::wk_crs(multipolygon_centerline), + wk::wk_crs(multipolygon) + ) + expect_equal(length(multipolygon_centerline), 8L) + + # Incorrect inputs + expect_error( + cnt_path_guess( + input = polygon, + skeleton = polygon + ) + ) + expect_error( + cnt_path_guess( + input = skeleton + ) + ) + expect_error( + cnt_path_guess( + skeleton = polygon + ) + ) + } +) + + +test_that( + "cnt_path_guess works with 'terra' geometries", + { + skip_if_not_installed("terra") + + polygon <- terra::vect(polygon_sf) + skeleton <- terra::vect(skeleton_sf) + result <- cnt_path_guess(polygon, keep = 1) + result_geos <- cnt_path_guess(polygon, keep = 1, return_geos = TRUE) + + ## Check classes and CRS + expect_s4_class(result, c("SpatVector")) + expect_contains(get_geom_type(result), "lines") + expect_equal(terra::crs(result), terra::crs(polygon)) + + ## Check classes and CRS of the GEOS geometry + expect_s3_class(result_geos, c("geos_geometry")) + expect_contains(get_geom_type(result_geos), "linestring") + expect_equal(wk::wk_crs(result_geos), wk::wk_crs(sf::st_as_sf(polygon))) + + ## Check centerline lengths + expect_length(result, 1) + expect_equal( + round(terra::perim(result), 5), + 50.95459 + ) + + # Various input classes are OK + result2 <- cnt_path_guess(polygon, skeleton_sf) + + expect_s4_class(result2, c("SpatVector")) + expect_contains(get_geom_type(result2), "lines") + expect_equal(terra::crs(result2), terra::crs(polygon)) + expect_equal( + sf::st_as_sf(result), + sf::st_as_sf(result2) + ) + + # Path guessing should work with any 'keep' parameter + keep_list <- + lapply(seq(0.1, 2, by = 0.2), function(x) { + tryCatch( + cnt_path_guess(polygon, keep = x), + error = \(e) NA + ) + }) + + ## Estimate lengths + keep_lengths <- + vapply( + keep_list, terra::perim, + FUN.VALUE = numeric(1), + USE.NAMES = FALSE + ) + + ## Check that all paths are not NA nor NULL nor zero + expect_true(all(!is.na(keep_list))) + expect_true(all(!is.null(keep_lengths))) + expect_true(all(keep_lengths > 0)) + expect_vector(keep_lengths, ptype = double(), size = 10) + expect_gt(length(unique(keep_lengths)), 1) + + # Several POLYGON objects are handled correctly + shapes <- terra::vect(shapes_sf) + shapes_centerline <- cnt_path_guess(shapes) + + expect_s4_class(shapes_centerline, c("SpatVector")) + expect_contains(get_geom_type(shapes_centerline), "lines") + expect_equal(terra::crs(shapes_centerline), terra::crs(shapes)) + expect_equal( + nrow(shapes_centerline), + nrow(shapes) + ) + expect_identical( + terra::as.data.frame(shapes_centerline), + terra::as.data.frame(shapes) + ) + + # MULTIPOLYGON objects are handled correctly + multipolygon <- terra::vect(multipolygon_sf) + multipolygon_centerline <- cnt_path_guess(multipolygon) + + expect_s4_class(multipolygon_centerline, c("SpatVector")) + expect_contains(get_geom_type(multipolygon_centerline), "lines") + expect_equal( + terra::crs(multipolygon_centerline), + terra::crs(multipolygon) + ) + expect_equal(nrow(multipolygon_centerline), 8L) + expect_identical( + terra::as.data.frame(multipolygon_centerline)[1, ], + terra::as.data.frame(multipolygon) + ) + + # Incorrect inputs + expect_error( + cnt_path_guess( + input = polygon, + skeleton = polygon + ) + ) + expect_error( + cnt_path_guess( + input = skeleton + ) + ) + expect_error( + cnt_path_guess( + skeleton = polygon + ) + ) + } +) + + +test_that( + "cnt_path_guess errors on incorrect input classes", + { + expect_error( + cnt_path_guess( + input = "polygon_sf" + ) + ) + expect_error( + cnt_path_guess( + input = 1 + ) + ) + expect_error( + cnt_path_guess( + input = "polygon_sfc", + skeleton = polygon_sf + ) + ) + } +) diff --git a/tests/testthat/test-cnt_skeleton.R b/tests/testthat/test-cnt_skeleton.R index f5b718d..43051ee 100644 --- a/tests/testthat/test-cnt_skeleton.R +++ b/tests/testthat/test-cnt_skeleton.R @@ -1,340 +1,340 @@ -test_that("cnt_skeleton works with 'terra' objects", { - skip_if_not_installed("terra") - - polygon_sfc <- - sf::st_sfc(sf::st_polygon(list(matrix( - c(0, 0, 1, 0, 1, 1, 0, 1, 0, 0), - ncol = 2, byrow = TRUE - )))) - polygon_terra <- terra::vect(polygon_sfc) - result_terra <- cnt_skeleton(polygon_terra, keep = 1) - - # Check classes and CRS - expect_s4_class(result_terra, c("SpatVector")) - expect_contains(get_geom_type(result_terra), "lines") - expect_equal(terra::crs(result_terra), terra::crs(polygon_terra)) -}) - -test_that( - "cnt_skeleton works with 'terra' MULTIPOLYGON geometries", - { - skip_if_not_installed("terra") - # One MULTIPOLYGON - multipolygon_terra <- - terra::vect( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "lake_island" - ) - - result_terra <- cnt_skeleton(multipolygon_terra, keep = 1) - - expect_s4_class(result_terra, c("SpatVector")) - expect_equal(nrow(result_terra), 8) - expect_identical( - terra::as.data.frame(result_terra)[1, ], - terra::as.data.frame(multipolygon_terra) - ) - } -) - -test_that( - "cnt_skeleton works with 'terra' multiple POLYGON geometries", - { - skip_if_not_installed("terra") - # One MULTIPOLYGON - shapes_terra <- - terra::vect( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "shapes" - ) - shapes_terra$id <- seq_len(nrow(shapes_terra)) - - result_terra <- cnt_skeleton(shapes_terra, keep = 1) - - expect_equal( - nrow(result_terra), - nrow(shapes_terra) - ) - expect_identical( - terra::as.data.frame(result_terra), - terra::as.data.frame(shapes_terra) - ) - } -) - -test_that( - "cnt_skeleton returns same class as input with the same CRS and - geometry type MULTILINESTRING", - { - polygon_sfc <- - sf::st_sfc(sf::st_polygon(list(matrix( - c(0, 0, 1, 0, 1, 1, 0, 1, 0, 0), - ncol = 2, byrow = TRUE - )))) - - polygon_sf <- sf::st_as_sf(polygon_sfc) - polygon_geos <- geos::as_geos_geometry(polygon_sf) - - result_sfc <- cnt_skeleton(polygon_sfc, keep = 1) - result_sf <- cnt_skeleton(polygon_sf, keep = 1) - result_geos <- cnt_skeleton(polygon_geos, keep = 1) - - # Check class - expect_s3_class(result_sfc, c("sfc")) - expect_s3_class(result_sf, c("sf")) - expect_s3_class(result_geos, c("geos_geometry")) - - # Check geometry types - expect_contains(get_geom_type(result_sf), "MULTILINESTRING") - expect_contains(get_geom_type(result_sfc), "MULTILINESTRING") - expect_contains(get_geom_type(result_geos), "multilinestring") - - # Check CRS - expect_equal(sf::st_crs(result_sf), sf::st_crs(polygon_sf)) - expect_equal(sf::st_crs(result_sfc), sf::st_crs(polygon_sfc)) - expect_equal(wk::wk_crs(result_geos), wk::wk_crs(polygon_geos)) - - # Check type errors - expect_error(cnt_skeleton(polygon_geos, keep = "a")) - expect_error(cnt_skeleton(polygon_geos, keep = -10)) - expect_error(cnt_skeleton(polygon_geos, keep = 10)) - expect_error(cnt_skeleton(polygon_geos, method = "a")) - } -) - -test_that( - "'keep' parameter affects the output", - { - polygon <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "polygon", - quiet = TRUE - ) |> - geos::as_geos_geometry() - - result_simplified <- cnt_skeleton(polygon, keep = 0.1) - result_not_simplified <- cnt_skeleton(polygon, keep = 1) - result_densified <- cnt_skeleton(polygon, keep = 1.1) - - num_points_simplified <- - geos::geos_num_coordinates(result_simplified) - num_points_not_simplified <- - geos::geos_num_coordinates(result_not_simplified) - num_points_densified <- - geos::geos_num_coordinates(result_densified) - - expect_true(num_points_simplified < num_points_not_simplified) - expect_true(num_points_not_simplified < num_points_densified) - expect_true(num_points_simplified < num_points_densified) - } -) - -test_that( - "cnt_skeleton errors on incorrect input types", - { - expect_error( - cnt_skeleton("not an sf object") - ) - } -) - -test_that( - "cnt_skeleton works with any 'keep' parameter", - { - polygon <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "shapes", - quiet = TRUE - ) - polygon$id <- seq_len(nrow(polygon)) - polygon21 <- subset(polygon, id == 21) - - # Test that all paths are created without errors - # With keep parameter varying from 0 to 2 - test_list <- - lapply(seq(0.1, 2, by = 0.1), function(x) { - tryCatch( - cnt_skeleton(polygon21, keep = x), - error = \(e) NA - ) - }) - - # Check that all paths are not NA - expect_true(all(!is.na(test_list))) - } -) - -test_that( - "cnt_skeleton handles MULTIPOLYGON objects correctly and saves the - attribute table", - { - # One MULTIPOLYGON - multipolygon_sf <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "lake_island", - quiet = TRUE - ) - multipolygon_sfc <- sf::st_as_sfc(multipolygon_sf) - multipolygon_geos <- multipolygon_sf |> - geos::as_geos_geometry() - - number_of_geometries <- - multipolygon_geos |> - geos::geos_num_geometries() - - result_sfc <- cnt_skeleton(multipolygon_sfc, keep = 1) - result_sf <- cnt_skeleton(multipolygon_sf, keep = 1) - result_geos <- cnt_skeleton(multipolygon_geos, keep = 1) - - # Check class - expect_s3_class(result_sfc, c("sfc")) - expect_s3_class(result_sf, c("sf")) - expect_s3_class(result_geos, c("geos_geometry")) - - # Check length of geometries - expect_equal( - length(result_sfc), - number_of_geometries - ) - expect_equal( - nrow(result_sf), - number_of_geometries - ) - expect_equal( - length(result_geos), - number_of_geometries - ) - - # Check attribute tables - expect_identical( - sf::st_drop_geometry(result_sf)[1, ], - sf::st_drop_geometry(multipolygon_sf) - ) - } -) - -test_that( - "cnt_skeleton returns the same amount of 'MULTILINESTRING' geometries - as 'POLYGON' geometries in the input", - { - shapes <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "shapes", - quiet = TRUE - ) - shapes$id <- seq_len(nrow(shapes)) - - shapes_sfc <- sf::st_as_sfc(shapes) - shapes_geos <- geos::as_geos_geometry(shapes) - - result_sf <- cnt_skeleton(shapes, keep = 1) - result_sfc <- cnt_skeleton(shapes_sfc, keep = 1) - result_geos <- cnt_skeleton(shapes_geos, keep = 1) - - # Check length of geometries - expect_equal( - nrow(result_sf), - nrow(shapes) - ) - expect_equal( - length(result_sfc), - length(shapes_sfc) - ) - expect_equal( - length(result_geos), - length(shapes_geos) - ) - - # Compare attribute tables - expect_identical( - sf::st_drop_geometry(result_sf), - sf::st_drop_geometry(shapes) - ) - } -) - -test_that( - "cnt_skeleton generates straight skeletons", - { - skip_if_not_installed("raybevel") - - shapes <- - sf::st_read( - system.file("extdata/example.gpkg", package = "centerline"), - layer = "shapes", - quiet = TRUE - ) |> - geos::as_geos_geometry() - - shape_no_hole <- shapes[1] - shape_w_hole <- shapes[89] - - result_no_hole <- cnt_skeleton(shape_no_hole, method = "straight") - result_w_hole <- cnt_skeleton(shape_w_hole, method = "straight") - - # Check class - expect_s3_class(result_no_hole, c("geos_geometry")) - expect_s3_class(result_w_hole, c("geos_geometry")) - - # Check crs - expect_identical( - sf::st_crs(result_no_hole), - sf::st_crs(shape_no_hole) - ) - expect_identical( - sf::st_crs(result_w_hole), - sf::st_crs(shape_w_hole) - ) - - # Test that all skeletons are created without errors - # With keep parameter varying from 0 to 1 - list_no_hole <- - lapply(seq(0.1, 1, by = 0.1), function(x) { - tryCatch( - cnt_skeleton(shape_no_hole, keep = x, method = "straight"), - error = \(e) NA - ) - }) - list_w_hole <- - lapply(seq(0.1, 1, by = 0.1), function(x) { - tryCatch( - cnt_skeleton(shape_w_hole, keep = x, method = "straight"), - error = \(e) NA - ) - }) - - # Estimate lengths - lengths_w_hole <- - vapply( - list_w_hole, - geos::geos_length, - FUN.VALUE = numeric(1) - ) - lengths_no_hole <- - vapply( - list_no_hole, - geos::geos_length, - FUN.VALUE = numeric(1) - ) - - # Check that all paths are not NA - expect_true(all(!is.na(list_no_hole))) - expect_true(all(!is.na(list_w_hole))) - - # Check that first length is smaller than the median and last is larger - expect_true(lengths_no_hole[1] < median(lengths_no_hole)) - expect_true(lengths_w_hole[1] < median(lengths_w_hole)) - - # Expect warning, when keep > 1 - expect_warning( - cnt_skeleton(shape_w_hole, keep = 1.1, method = "straight") - ) - expect_warning( - cnt_skeleton(shape_no_hole, keep = 1.1, method = "straight") - ) - } -) +test_that("cnt_skeleton works with 'terra' objects", { + skip_if_not_installed("terra") + + polygon_sfc <- + sf::st_sfc(sf::st_polygon(list(matrix( + c(0, 0, 1, 0, 1, 1, 0, 1, 0, 0), + ncol = 2, byrow = TRUE + )))) + polygon_terra <- terra::vect(polygon_sfc) + result_terra <- cnt_skeleton(polygon_terra, keep = 1) + + # Check classes and CRS + expect_s4_class(result_terra, c("SpatVector")) + expect_contains(get_geom_type(result_terra), "lines") + expect_equal(terra::crs(result_terra), terra::crs(polygon_terra)) +}) + +test_that( + "cnt_skeleton works with 'terra' MULTIPOLYGON geometries", + { + skip_if_not_installed("terra") + # One MULTIPOLYGON + multipolygon_terra <- + terra::vect( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "lake_island" + ) + + result_terra <- cnt_skeleton(multipolygon_terra, keep = 1) + + expect_s4_class(result_terra, c("SpatVector")) + expect_equal(nrow(result_terra), 8) + expect_identical( + terra::as.data.frame(result_terra)[1, ], + terra::as.data.frame(multipolygon_terra) + ) + } +) + +test_that( + "cnt_skeleton works with 'terra' multiple POLYGON geometries", + { + skip_if_not_installed("terra") + # One MULTIPOLYGON + shapes_terra <- + terra::vect( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "shapes" + ) + shapes_terra$id <- seq_len(nrow(shapes_terra)) + + result_terra <- cnt_skeleton(shapes_terra, keep = 1) + + expect_equal( + nrow(result_terra), + nrow(shapes_terra) + ) + expect_identical( + terra::as.data.frame(result_terra), + terra::as.data.frame(shapes_terra) + ) + } +) + +test_that( + "cnt_skeleton returns same class as input with the same CRS and + geometry type MULTILINESTRING", + { + polygon_sfc <- + sf::st_sfc(sf::st_polygon(list(matrix( + c(0, 0, 1, 0, 1, 1, 0, 1, 0, 0), + ncol = 2, byrow = TRUE + )))) + + polygon_sf <- sf::st_as_sf(polygon_sfc) + polygon_geos <- geos::as_geos_geometry(polygon_sf) + + result_sfc <- cnt_skeleton(polygon_sfc, keep = 1) + result_sf <- cnt_skeleton(polygon_sf, keep = 1) + result_geos <- cnt_skeleton(polygon_geos, keep = 1) + + # Check class + expect_s3_class(result_sfc, c("sfc")) + expect_s3_class(result_sf, c("sf")) + expect_s3_class(result_geos, c("geos_geometry")) + + # Check geometry types + expect_contains(get_geom_type(result_sf), "MULTILINESTRING") + expect_contains(get_geom_type(result_sfc), "MULTILINESTRING") + expect_contains(get_geom_type(result_geos), "multilinestring") + + # Check CRS + expect_equal(sf::st_crs(result_sf), sf::st_crs(polygon_sf)) + expect_equal(sf::st_crs(result_sfc), sf::st_crs(polygon_sfc)) + expect_equal(wk::wk_crs(result_geos), wk::wk_crs(polygon_geos)) + + # Check type errors + expect_error(cnt_skeleton(polygon_geos, keep = "a")) + expect_error(cnt_skeleton(polygon_geos, keep = -10)) + expect_error(cnt_skeleton(polygon_geos, keep = 10)) + expect_error(cnt_skeleton(polygon_geos, method = "a")) + } +) + +test_that( + "'keep' parameter affects the output", + { + polygon <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "polygon", + quiet = TRUE + ) |> + geos::as_geos_geometry() + + result_simplified <- cnt_skeleton(polygon, keep = 0.1) + result_not_simplified <- cnt_skeleton(polygon, keep = 1) + result_densified <- cnt_skeleton(polygon, keep = 1.1) + + num_points_simplified <- + geos::geos_num_coordinates(result_simplified) + num_points_not_simplified <- + geos::geos_num_coordinates(result_not_simplified) + num_points_densified <- + geos::geos_num_coordinates(result_densified) + + expect_true(num_points_simplified < num_points_not_simplified) + expect_true(num_points_not_simplified < num_points_densified) + expect_true(num_points_simplified < num_points_densified) + } +) + +test_that( + "cnt_skeleton errors on incorrect input types", + { + expect_error( + cnt_skeleton("not an sf object") + ) + } +) + +test_that( + "cnt_skeleton works with any 'keep' parameter", + { + polygon <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "shapes", + quiet = TRUE + ) + polygon$id <- seq_len(nrow(polygon)) + polygon21 <- subset(polygon, id == 21) + + # Test that all paths are created without errors + # With keep parameter varying from 0 to 2 + test_list <- + lapply(seq(0.1, 2, by = 0.1), function(x) { + tryCatch( + cnt_skeleton(polygon21, keep = x), + error = \(e) NA + ) + }) + + # Check that all paths are not NA + expect_true(all(!is.na(test_list))) + } +) + +test_that( + "cnt_skeleton handles MULTIPOLYGON objects correctly and saves the + attribute table", + { + # One MULTIPOLYGON + multipolygon_sf <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "lake_island", + quiet = TRUE + ) + multipolygon_sfc <- sf::st_as_sfc(multipolygon_sf) + multipolygon_geos <- multipolygon_sf |> + geos::as_geos_geometry() + + number_of_geometries <- + multipolygon_geos |> + geos::geos_num_geometries() + + result_sfc <- cnt_skeleton(multipolygon_sfc, keep = 1) + result_sf <- cnt_skeleton(multipolygon_sf, keep = 1) + result_geos <- cnt_skeleton(multipolygon_geos, keep = 1) + + # Check class + expect_s3_class(result_sfc, c("sfc")) + expect_s3_class(result_sf, c("sf")) + expect_s3_class(result_geos, c("geos_geometry")) + + # Check length of geometries + expect_equal( + length(result_sfc), + number_of_geometries + ) + expect_equal( + nrow(result_sf), + number_of_geometries + ) + expect_equal( + length(result_geos), + number_of_geometries + ) + + # Check attribute tables + expect_identical( + sf::st_drop_geometry(result_sf)[1, ], + sf::st_drop_geometry(multipolygon_sf) + ) + } +) + +test_that( + "cnt_skeleton returns the same amount of 'MULTILINESTRING' geometries + as 'POLYGON' geometries in the input", + { + shapes <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "shapes", + quiet = TRUE + ) + shapes$id <- seq_len(nrow(shapes)) + + shapes_sfc <- sf::st_as_sfc(shapes) + shapes_geos <- geos::as_geos_geometry(shapes) + + result_sf <- cnt_skeleton(shapes, keep = 1) + result_sfc <- cnt_skeleton(shapes_sfc, keep = 1) + result_geos <- cnt_skeleton(shapes_geos, keep = 1) + + # Check length of geometries + expect_equal( + nrow(result_sf), + nrow(shapes) + ) + expect_equal( + length(result_sfc), + length(shapes_sfc) + ) + expect_equal( + length(result_geos), + length(shapes_geos) + ) + + # Compare attribute tables + expect_identical( + sf::st_drop_geometry(result_sf), + sf::st_drop_geometry(shapes) + ) + } +) + +test_that( + "cnt_skeleton generates straight skeletons", + { + skip_if_not_installed("raybevel") + + shapes <- + sf::st_read( + system.file("extdata/example.gpkg", package = "centerline"), + layer = "shapes", + quiet = TRUE + ) |> + geos::as_geos_geometry() + + shape_no_hole <- shapes[1] + shape_w_hole <- shapes[89] + + result_no_hole <- cnt_skeleton(shape_no_hole, method = "straight") + result_w_hole <- cnt_skeleton(shape_w_hole, method = "straight") + + # Check class + expect_s3_class(result_no_hole, c("geos_geometry")) + expect_s3_class(result_w_hole, c("geos_geometry")) + + # Check crs + expect_identical( + sf::st_crs(result_no_hole), + sf::st_crs(shape_no_hole) + ) + expect_identical( + sf::st_crs(result_w_hole), + sf::st_crs(shape_w_hole) + ) + + # Test that all skeletons are created without errors + # With keep parameter varying from 0 to 1 + list_no_hole <- + lapply(seq(0.1, 1, by = 0.1), function(x) { + tryCatch( + cnt_skeleton(shape_no_hole, keep = x, method = "straight"), + error = \(e) NA + ) + }) + list_w_hole <- + lapply(seq(0.1, 1, by = 0.1), function(x) { + tryCatch( + cnt_skeleton(shape_w_hole, keep = x, method = "straight"), + error = \(e) NA + ) + }) + + # Estimate lengths + lengths_w_hole <- + vapply( + list_w_hole, + geos::geos_length, + FUN.VALUE = numeric(1) + ) + lengths_no_hole <- + vapply( + list_no_hole, + geos::geos_length, + FUN.VALUE = numeric(1) + ) + + # Check that all paths are not NA + expect_true(all(!is.na(list_no_hole))) + expect_true(all(!is.na(list_w_hole))) + + # Check that first length is smaller than the median and last is larger + expect_true(lengths_no_hole[1] < median(lengths_no_hole)) + expect_true(lengths_w_hole[1] < median(lengths_w_hole)) + + # Expect warning, when keep > 1 + expect_warning( + cnt_skeleton(shape_w_hole, keep = 1.1, method = "straight") + ) + expect_warning( + cnt_skeleton(shape_no_hole, keep = 1.1, method = "straight") + ) + } +) diff --git a/tests/testthat/test-geom_cnt.R b/tests/testthat/test-geom_cnt.R index d9f86d9..98403cf 100644 --- a/tests/testthat/test-geom_cnt.R +++ b/tests/testthat/test-geom_cnt.R @@ -5,127 +5,131 @@ lake <- quiet = TRUE ) -shapes <- +shapes <- sf::st_read( system.file("extdata/example.gpkg", package = "centerline"), layer = "shapes", quiet = TRUE ) -test_that( - "The geom_cnt_*() creates ggproto objects", - { - skip_if_not_installed("geomtextpath") - skip_if_not_installed("geomtextpath") - skip_if_not_installed("ggplot2") - - ln <- geom_cnt(data = lake) - txt <- geom_cnt_text(data = lake, label = "label") - lbl <- geom_cnt_label(data = lake, label = "label") - - expect_s3_class(ln[[1]], "LayerInstance") - expect_s3_class(ln[[2]], "CoordSf") - expect_s3_class(txt[[1]], "LayerInstance") - expect_s3_class(txt[[2]], "CoordSf") - expect_s3_class(lbl[[1]], "LayerInstance") - expect_s3_class(lbl[[2]], "CoordSf") - } -) - -test_that( - "geom_cnt_*() create correct types", - { - skip_if_not_installed("geomtextpath") - skip_if_not_installed("ggplot2") - - ln <- - ggplot2::ggplot(lake) + - geom_cnt(data = lake) - txt <- - ggplot2::ggplot(lake) + - geom_cnt_text(data = lake, label = "label") - lbl <- - ggplot2::ggplot(lake) + - geom_cnt_label(data = lake, label = "label") - - ln_grobs <- ggplot2::layer_grob(ln)[[1]] - txt_grobs <- ggplot2::layer_grob(txt)[[1]] - lbl_grobs <- ggplot2::layer_grob(lbl)[[1]] - - expect_s3_class(ln[[2]][[1]], "LayerSf") - expect_s3_class(txt[[2]][[1]], "LayerSf") - expect_s3_class(lbl[[2]][[1]], "LayerSf") - expect_s3_class(ln[[7]], "CoordSf") - expect_s3_class(txt[[7]], "CoordSf") - expect_s3_class(lbl[[7]], "CoordSf") - expect_s3_class(ln_grobs, "polyline") - expect_s3_class(txt_grobs, "gTree") - expect_s3_class(lbl_grobs, "gTree") - } -) - -test_that( - "geom_cnt_*() smiplification works", - { - skip_if_not_installed("geomtextpath") - skip_if_not_installed("ggplot2") - skip_if_not_installed("smoothr") - - ln <- - ggplot2::ggplot(lake) + - geom_cnt(data = lake, simplify = TRUE) - txt <- - ggplot2::ggplot(lake) + - geom_cnt_text(data = lake, label = "label", simplify = TRUE) - lbl <- - ggplot2::ggplot(lake) + - geom_cnt_label(data = lake, label = "label", simplify = TRUE) - - ln_grobs <- ggplot2::layer_grob(ln)[[1]] - txt_grobs <- ggplot2::layer_grob(txt)[[1]] - lbl_grobs <- ggplot2::layer_grob(lbl)[[1]] - - expect_s3_class(ln[[2]][[1]], "LayerSf") - expect_s3_class(txt[[2]][[1]], "LayerSf") - expect_s3_class(lbl[[2]][[1]], "LayerSf") - expect_s3_class(ln[[7]], "CoordSf") - expect_s3_class(txt[[7]], "CoordSf") - expect_s3_class(lbl[[7]], "CoordSf") - expect_s3_class(ln_grobs, "polyline") - expect_s3_class(txt_grobs, "gTree") - expect_s3_class(lbl_grobs, "gTree") - } -) - -test_that( - "geom_cnt_*() smiplification works with mutiple geometries", - { - skip_if_not_installed("geomtextpath") - skip_if_not_installed("ggplot2") - skip_if_not_installed("smoothr") - - ln <- - ggplot2::ggplot(shapes) + - geom_cnt(data = shapes, simplify = TRUE) - txt <- - ggplot2::ggplot(shapes) + - geom_cnt_text(data = shapes, label = "label", simplify = TRUE) - lbl <- - ggplot2::ggplot(shapes) + - geom_cnt_label(data = shapes, label = "label", simplify = TRUE) - - ln_grobs <- ggplot2::layer_grob(ln)[[1]] - txt_grobs <- ggplot2::layer_grob(txt)[[1]] - lbl_grobs <- ggplot2::layer_grob(lbl)[[1]] - - expect_s3_class(ln[[2]][[1]], "LayerSf") - expect_s3_class(txt[[2]][[1]], "LayerSf") - expect_s3_class(lbl[[2]][[1]], "LayerSf") - expect_s3_class(ln[[7]], "CoordSf") - expect_s3_class(txt[[7]], "CoordSf") - expect_s3_class(lbl[[7]], "CoordSf") - expect_s3_class(ln_grobs, "polyline") - expect_s3_class(txt_grobs, "gTree") - expect_s3_class(lbl_grobs, "gTree") - } -) \ No newline at end of file +test_that("The geom_cnt_*() creates ggproto objects", { + skip_if_not_installed("geomtextpath") + skip_if_not_installed("ggplot2") + + skip_if_not(packageVersion("ggplot2") > "3.5.2") + + ln <- geom_cnt(data = lake) + txt <- geom_cnt_text(data = lake, label = "label") + lbl <- geom_cnt_label(data = lake, label = "label") + + expect_s3_class(ln[[1]], "LayerInstance") + expect_s3_class(ln[[2]], "CoordSf") + expect_s3_class(txt[[1]], "LayerInstance") + expect_s3_class(txt[[2]], "CoordSf") + expect_s3_class(lbl[[1]], "LayerInstance") + expect_s3_class(lbl[[2]], "CoordSf") +}) + +test_that("geom_cnt_*() create correct types", { + skip_if_not_installed("geomtextpath") + skip_if_not_installed("ggplot2") + + skip_if_not(packageVersion("ggplot2") > "3.5.2") + + ln <- + ggplot2::ggplot(lake) + + geom_cnt(data = lake) + txt <- + ggplot2::ggplot(lake) + + geom_cnt_text(data = lake, label = "label") + lbl <- + ggplot2::ggplot(lake) + + geom_cnt_label(data = lake, label = "label") + + # Suppress plot output during testing + pdf(file = NULL) + ln_grobs <- ggplot2::layer_grob(ln)[[1]] + txt_grobs <- ggplot2::layer_grob(txt)[[1]] + lbl_grobs <- ggplot2::layer_grob(lbl)[[1]] + dev.off() + + expect_s3_class(ln$layers[[1]], "LayerSf") + expect_s3_class(txt$layers[[1]], "LayerSf") + expect_s3_class(lbl$layers[[1]], "LayerSf") + expect_s3_class(ln$coordinates, "CoordSf") + expect_s3_class(txt$coordinates, "CoordSf") + expect_s3_class(lbl$coordinates, "CoordSf") + expect_s3_class(ln_grobs, "polyline") + expect_s3_class(txt_grobs, "gTree") + expect_s3_class(lbl_grobs, "gTree") +}) + +test_that("geom_cnt_*() smiplification works", { + skip_if_not_installed("geomtextpath") + skip_if_not_installed("ggplot2") + skip_if_not_installed("smoothr") + + skip_if_not(packageVersion("ggplot2") > "3.5.2") + + ln <- + ggplot2::ggplot(lake) + + geom_cnt(data = lake, simplify = TRUE) + txt <- + ggplot2::ggplot(lake) + + geom_cnt_text(data = lake, label = "label", simplify = TRUE) + lbl <- + ggplot2::ggplot(lake) + + geom_cnt_label(data = lake, label = "label", simplify = TRUE) + + # Suppress plot output during testing + pdf(file = NULL) + ln_grobs <- ggplot2::layer_grob(ln)[[1]] + txt_grobs <- ggplot2::layer_grob(txt)[[1]] + lbl_grobs <- ggplot2::layer_grob(lbl)[[1]] + dev.off() + + expect_s3_class(ln$layers[[1]], "LayerSf") + expect_s3_class(txt$layers[[1]], "LayerSf") + expect_s3_class(lbl$layers[[1]], "LayerSf") + expect_s3_class(ln$coordinates, "CoordSf") + expect_s3_class(txt$coordinates, "CoordSf") + expect_s3_class(lbl$coordinates, "CoordSf") + expect_s3_class(ln_grobs, "polyline") + expect_s3_class(txt_grobs, "gTree") + expect_s3_class(lbl_grobs, "gTree") +}) + +test_that("geom_cnt_*() smiplification works with mutiple geometries", { + skip_if_not_installed("geomtextpath") + skip_if_not_installed("ggplot2") + skip_if_not_installed("smoothr") + + skip_if_not(packageVersion("ggplot2") > "3.5.2") + + ln <- + ggplot2::ggplot(shapes) + + geom_cnt(data = shapes, simplify = TRUE) + txt <- + ggplot2::ggplot(shapes) + + geom_cnt_text(data = shapes, label = "label", simplify = TRUE) + lbl <- + ggplot2::ggplot(shapes) + + geom_cnt_label(data = shapes, label = "label", simplify = TRUE) + + # Suppress plot output during testing + pdf(file = NULL) + ln_grobs <- ggplot2::layer_grob(ln)[[1]] + txt_grobs <- ggplot2::layer_grob(txt)[[1]] + lbl_grobs <- ggplot2::layer_grob(lbl)[[1]] + dev.off() + + expect_s3_class(ln$layers[[1]], "LayerSf") + expect_s3_class(txt$layers[[1]], "LayerSf") + expect_s3_class(lbl$layers[[1]], "LayerSf") + expect_s3_class(ln$coordinates, "CoordSf") + expect_s3_class(txt$coordinates, "CoordSf") + expect_s3_class(lbl$coordinates, "CoordSf") + expect_s3_class(ln_grobs, "polyline") + expect_s3_class(txt_grobs, "gTree") + expect_s3_class(lbl_grobs, "gTree") +})