new binary/trinary sets functions

.gitignore

@@ -49,10 +49,14 @@ po/*~
 rsconnect/
 
 # macos things
+.DS_Store
 */.DS_Store
 
 # data sources
 data-raw/*
 inst/doc
 /doc/
 /Meta/
+
+# old files
+*/old

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: spatialops
 Title: Spatial operations that comes in handy
-Version: 0.1.3
+Version: 0.1.4
 Authors@R: 
     person("Arthur", "Bazolli", email = "[email protected]", role = c("aut", "cre"))
 Description: Mainly spatial operations, like calculating distances or classifying catchment areas, 
@@ -9,7 +9,7 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Imports: 
     basedosdados,
     colorspace,
@@ -23,7 +23,6 @@ Imports:
     rlang,
     scales,
     sf,
-    stringr,
     tibble,
     tidyr,
     units

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 export("%>%")
+export(binary_sets)
 export(coef_rqs)
 export(count_features)
 export(dist_nearest)
@@ -17,8 +18,10 @@ export(maphub_tidy_lines)
 export(maphub_tidy_stations)
 export(maphub_to_sf)
 export(shp_extract_read)
+export(summarise_set)
 export(theme_abnq)
 export(theme_abnq_map)
+export(trim_set)
 export(trinary_sets)
 import(dplyr)
 import(ggplot2)

R/binary_sets.R

@@ -0,0 +1,54 @@
+#' Binary sets
+#' @description
+#' Divide space in two transitive sets and one additional category. This is a "lite" version
+#'  of `trinary_sets`.
+#' @param df A `sf` object.
+#' @param cat1 <data-masking> Column containing the set classes. If more than two classes are
+#'  present, any class different from those provided on `cat1_order` (or the first two if
+#'  `cat1_order` is `NULL`) are ignored.
+#' @param cat2 <data-masking> Second category to guide sets classification.
+#' @param cat1_order A vector with size 2 with cat1 class names in order of importance: the first
+#'  one dominates the second if they overlap. If `NULL`, the order in which they appear in data
+#'  will be taken (or the `levels` order, if `cat1` is a `factor`).
+#' @export
+#' @returns A `sf` object
+#' @details
+#' Current implementation uses `dplyr::group_by`, which groups data in ascending order (numerical or
+#' alphabetical). If `cat2` is `numeric`, smaller numbers dominate larger ones when
+#' they overlap; similarly, if `cat2` is `character` or `factor`, the hierarchy will be alphabetical.
+
+
+
+# function ------------------------------------------------------------------------------------
+
+binary_sets <- function(df, cat1, cat2, cat1_order = NULL) {
+
+  if(dplyr::n_distinct(dplyr::pull(df, {{cat1}})) < 2) {
+    stop("'", deparse(substitute(cat1)), "' should have at least two classes, only one is present")
+  } else {
+    if(dplyr::n_distinct(dplyr::pull(df, {{cat1}})) > 2) {
+      message("More than two categories present in '", deparse(substitute(cat1)),
+              "'. Geometries in other categories will be ignored.")
+    }
+  }
+
+  sf::st_geometry(df) <- "geometry"
+
+  ## WIP - not implemented
+  # df <- if(is.null(cat2_order)) {
+  #   df
+  # } else {
+  #   if(cat2_order == "asc") {
+  #     dplyr::arrange(df, {{cat2}})
+  #   } else
+  #     if(cat2_order == "desc") {
+  #       dplyr::arrange(df, desc({{cat2}}))
+  #     }
+  # }
+
+  set_1 <- summarise_set(df, {{cat1}}, {{cat2}}, cat1_order, 1)
+  set_2 <- summarise_set(df, {{cat1}}, {{cat2}}, cat1_order, 2)
+
+  trim_set(set_1, set_2, {{cat1}}, F) %>%
+    return()
+}

R/trinary_sets.R

@@ -1,213 +1,49 @@
 #' Trinary sets
 #' @description
-#' Perform spatial operations in sets of three classes and an additional category.
+#' Divide space in three transitive sets and one additional category.
 #' @param df A `sf` object.
-#' @param cat1 <data-masking> Column containing the object classes. Cannot contain more than three
-#' distinct classes.
+#' @param cat1 <data-masking> Column containing the set classes. If more than three classes are
+#'  present, any class different from those provided on `cat1_order` (or the first three if
+#'  `cat1_order` is `NULL`) are ignored.
 #' @param cat2 <data-masking> Second category to guide sets classification.
-#' @param keep.overlap Should overlapping sets (i.e. entire sets and unions) be included? Defaults
-#' to `FALSE`.
+#' @param cat1_order A vector with size 3 with cat1 class names in order of importance: the first
+#'  one dominates the second if they overlap and so on. If `NULL`, the order in which they appear in data
+#'  will be taken (or the `levels` order, if `cat1` is a `factor`).
 #' @export
 #' @returns A `sf` object
 #' @details
-#' Returned data contains one geometry for each class (A', B', C', AB, AC, BC, ABC, and overlaps
-#' when required) per additional category. Categories are renamed according to the order displayed
-#' in the message after the code runs successfully.
+#' Current implementation uses `dplyr::group_by`, which groups data in ascending order (numerical or
+#' alphabetical). If `cat2` is `numeric`, smaller numbers dominate larger ones when
+#' they overlap; similarly, if `cat2` is `character` or `factor`, the hierarchy will be alphabetical.
 
 
 
-trinary_sets <- function(df, cat1, cat2, keep.overlap = F) {
+# function ------------------------------------------------------------------------------------
 
-  x <- y <- geometry <- NULL
+trinary_sets <- function(df, cat1, cat2, cat1_order = NULL) {
 
-# ground rules --------------------------------------------------------------------------------
-
-  ## get original categores
-  cats <- df %>% dplyr::pull({{cat1}}) %>% unique()
-
-  if(length(cats) != 3) stop("Error: {df} has more than three classes") else
-
-  ## replace them by ABC
-  df <- df %>% dplyr::mutate(
-    {{cat1}} := dplyr::case_match(
-      {{cat1}},
-      cats[1] ~ "A",
-      cats[2] ~ "B",
-      cats[3] ~ "C"
-    )
-  )
-
-  ## we'll show this message in the end
-  message_1 <- paste0("Groups were renamed as follow: ", cats[1], " ~ A, ", cats[2], " ~ B, ", cats[3], " ~ C.")
-
-  cats <- df %>% dplyr::pull({{cat1}}) %>% unique()
-
-  ## get category pairs to map them
-  pairs <- tidyr::expand_grid(x = cats, y = cats, .name_repair = "unique") %>%
-    dplyr::filter(x != y) %>%
-    dplyr::slice(c(1:2, 4)) %>%
-    as.matrix(nrow = 2) %>%
-    split(1:nrow(.))
-
-  ## classify base sets
-  df <- df %>%
-    dplyr::group_by({{cat1}}, {{cat2}}) %>%
-    dplyr::summarise(geometry = sf::st_union(geometry)) %>%
-    sf::st_make_valid() %>%
-    dplyr::mutate(class = "base", .after = {{cat1}})
-
-
-
-# pairwise unions -----------------------------------------------------------------------------
-
-  message("Making pairwise unions...")
-
-  df <- pairs %>%
-    purrr::map(
-      \(pair)
-      df %>%
-        dplyr::filter({{cat1}} %in% pair) %>%
-        dplyr::group_by({{cat2}}, class) %>%
-        dplyr::summarise(geometry = sf::st_union(geometry)) %>%
-        sf::st_make_valid() %>%
-        dplyr::mutate({{cat1}} := paste0(pair[1],"u",pair[2]), class = "union", .before = {{cat2}})
-    ) %>%
-    dplyr::bind_rows() %>%
-    dplyr::bind_rows(df)
-
-  message("Done.")
-
-
-
-# extract prime sets --------------------------------------------------------------------------
-  ## prime sets are those that do not intersect with anything; e.g. A' = A - B\cupC
-
-  ## union categories need to be apart to be combined with base ones
-  cats2 <- df %>% dplyr::pull({{cat1}}) %>% unique() %>% setdiff(cats)
-
-  pairs2 <- tidyr::expand_grid(x = cats, y = cats2, .name_repair = "unique") %>%
-    dplyr::filter(stringr::str_detect(y, x) == F) %>%
-    as.matrix(nrow = 2) %>%
-    split(1:nrow(.))
-
-  ## prime sets
-
-  message("Getting prime sets...")
-
-  df <- pairs2 %>%
-    purrr::map(
-      \(pair)
-      df %>%
-        dplyr::filter({{cat1}} %in% pair) %>%
-        sf::st_difference() %>%
-        sf::st_make_valid() %>%
-        dplyr::filter({{cat1}} == pair[1]) %>%
-        dplyr::mutate({{cat1}} := paste0(pair[1],1), class = "prime", .before = {{cat2}})
-    ) %>%
-    dplyr::bind_rows() %>%
-    dplyr::bind_rows(df)
-
-  message("Done.")
-
-
-
-# triple intersection -------------------------------------------------------------------------
-
-  message("Getting triple intersection...")
-
-  df <- df %>%
-    dplyr::group_by({{cat2}}) %>%
-    dplyr::filter({{cat1}} == cats[1]) %>%
-    sf::st_intersection(df %>% dplyr::filter({{cat1}} == cats[2])) %>%
-    sf::st_make_valid() %>%
-    dplyr::filter(!sf::st_is_empty(geometry)) %>%
-    sf::st_collection_extract("POLYGON") %>%
-    sf::st_intersection(df %>% dplyr::filter({{cat1}} == cats[3])) %>%
-    sf::st_make_valid() %>%
-    dplyr::filter(!sf::st_is_empty(geometry)) %>%
-    sf::st_collection_extract("POLYGON") %>%
-    dplyr::group_by({{cat2}}) %>%
-    dplyr::summarise(geometry = sf::st_union(geometry)) %>%
-    sf::st_make_valid() %>%
-    sf::st_difference() %>%
-    dplyr::filter(!sf::st_is_empty(geometry)) %>%
-    sf::st_collection_extract("POLYGON") %>%
-    sf::st_make_valid() %>%
-    dplyr::mutate({{cat1}} := "ABC", class = "intersection", .before = {{cat2}}) %>%
-    dplyr::bind_rows(df)
-
-  message("Done.")
-
-
-
-# pairwise intersections ----------------------------------------------------------------------
-
-  message("Getting pairwise intersections...")
-
-  ## first step: get the whole pairwise intersection
-
-  message("Full XY intersection")
-
-  df_aux <- pairs %>%
-    purrr::map(
-      \(pair)
-      df %>%
-        dplyr::group_by({{cat2}}) %>%
-        dplyr::filter({{cat1}} == pair[1]) %>%
-        sf::st_intersection(df %>% dplyr::filter({{cat1}} == pair[2])) %>%
-        sf::st_make_valid() %>%
-        dplyr::filter(!sf::st_is_empty(geometry)) %>%
-        sf::st_collection_extract("POLYGON") %>%
-        sf::st_make_valid() %>%
-        dplyr::group_by({{cat2}}) %>%
-        dplyr::summarise(geometry = sf::st_union(geometry)) %>%
-        sf::st_make_valid() %>%
-        sf::st_difference() %>%
-        sf::st_make_valid() %>%
-        dplyr::filter(!sf::st_is_empty(geometry)) %>%
-        sf::st_collection_extract("POLYGON") %>%
-        sf::st_make_valid() %>%
-        dplyr::mutate({{cat1}} := paste0(pair[1], pair[2]), class = "intersection", .before = {{cat2}})
-    ) %>%
-    dplyr::bind_rows()
-
-  ## second step: remove triple intersection
+  if(dplyr::n_distinct(dplyr::pull(df, {{cat1}})) < 3) {
+    stop("'", deparse(substitute(cat1)), "' should have at least three classes, only one is present")
+  } else {
+    if(dplyr::n_distinct(dplyr::pull(df, {{cat1}})) > 3) {
+      message("More than three categories present in '", deparse(substitute(cat1)),
+              "'. Geometries in other categories will be ignored.")
+    }
+  }
 
-  message("Removing triple intersection from XY")
+  sf::st_geometry(df) <- "geometry"
 
-  df <- pairs %>%
-    purrr::map(
-      \(pair)
-      df_aux %>%
-        dplyr::group_by({{cat2}}) %>%
-        dplyr::filter({{cat1}} == paste0(pair[1], pair[2])) %>%
-        sf::st_difference(df %>% dplyr::filter({{cat1}} == "ABC") %>% sf::st_union() %>% sf::st_make_valid()) %>%
-        sf::st_make_valid() %>%
-        dplyr::filter(!sf::st_is_empty(geometry)) %>%
-        sf::st_collection_extract("POLYGON") %>%
-        dplyr::group_by({{cat2}}) %>%
-        dplyr::summarise(geometry = sf::st_union(geometry)) %>%
-        sf::st_make_valid() %>%
-        sf::st_difference() %>%
-        sf::st_make_valid() %>%
-        dplyr::mutate({{cat1}} := paste0(pair[1], pair[2]), class = "intersection", .before = {{cat2}})
-    ) %>%
-    dplyr::bind_rows() %>%
-    dplyr::bind_rows(df)
+  set_1 <- summarise_set(df, {{cat1}}, {{cat2}}, cat1_order, 1)
+  set_2 <- summarise_set(df, {{cat1}}, {{cat2}}, cat1_order, 2)
+  set_3 <- summarise_set(df, {{cat1}}, {{cat2}}, cat1_order, 3)
 
-  message("Done.")
+  set_2 <- trim_set(set_1, set_2, {{cat1}})
+  set_3 <- trim_set(set_1, set_3, {{cat1}})
 
+  dplyr::bind_rows(set_2, set_3) %>%
+    trim_set(set_1, {{cat1}}, F) %>%
+    return()
 
-# final ---------------------------------------------------------------------------------------
+}
 
-  message("Success!")
-  message(message_1)
-  if(keep.overlap) {
-    return(df)
-  } else {
-    df %>%
-      dplyr::filter(!(class %in% c("base", "union"))) %>%
-      return()
-  }
 
-}