diff --git a/.DS_Store b/.DS_Store deleted file mode 100644 index 3c2079ff..00000000 Binary files a/.DS_Store and /dev/null differ diff --git a/.Rbuildignore b/.Rbuildignore index 66791390..d72d7e5f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -9,3 +9,17 @@ workspace ^docs$ ^pkgdown$ ^vignettes/articles$ +^\\runners$ +^runners/.*$ + +^hydrofabric3D\.Rproj$ +^\.github$ +^\\.urs_cookies$ +^\\.dodsrc$ +^[.].*$ +^.*/[.].*$ +^general_visuals\.R$ +^scraps\.R$ +^scraps2\.R$ +^scraps3\.R$ + diff --git a/.gitignore b/.gitignore index 24f174d2..4700bb1d 100644 --- a/.gitignore +++ b/.gitignore @@ -2,4 +2,21 @@ .Rhistory .RData .Ruserdata -R/scraps.R \ No newline at end of file + +.DS_Store +*.DS_Store +**/.DS_Store + +.urs_cookies +*.urs_cookies +**/.urs_cookies + +R/scraps.R + +runners/cs_runner/ +tmp_plots.R + +scraps.R +scraps2.R +scraps3.R +general_visuals.R \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 46446e41..d8240366 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: hydrofabric3D Title: hydrofabric3D -Version: 0.0.1 +Version: 0.0.96 Authors@R: c(person("Mike", "Johnson", role = c("aut", "cre"), email = "mikecp11@gmail.com"), person("Angus", "Watters", role = "aut"), person("Arash", "Modaresi", role = "ctb"), @@ -16,19 +16,27 @@ Imports: wk, terra, dplyr, - terra, tidyr, vctrs, sf, smoothr, zoo, nhdplusTools, - fastmap + fastmap, + ggplot2, + rlang, + lwgeom, + rmapshaper, + AHGestimation +Remotes: + mikejohnson51/AHGestimation Depends: R (>= 2.10) LazyData: true Config/Needs/website: rmarkdown Suggests: knitr, - rmarkdown + rmarkdown, + testthat (>= 3.0.0) VignetteBuilder: knitr +Config/testthat/edition: 3 diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..52bef021 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2023 hydrofabric3D authors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/NAMESPACE b/NAMESPACE index 21ed76ce..86dfe55c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,36 +1,83 @@ # Generated by roxygen2: do not edit by hand +export(add_angle_at_point_type) +export(add_cs_bathymetry) +export(add_middle_index_by_point_type) +export(add_point_type_counts) +export(add_relief) +export(add_tmp_id) +export(align_banks_and_bottoms) +export(angle_at_index) export(classify_points) export(cross_section_pts) +export(cross_section_pts_v2) +export(cross_section_pts_v3) export(cut_cross_sections) export(cut_transect) +export(extend_invalid_transects) +export(extend_transects) +export(extend_transects_by_distances) +export(extend_transects_by_length) +export(extend_transects_to_polygons) +export(extend_transects_to_polygons2) +export(fill_missing_ahg_coords) export(find_braids) export(find_connected_components) export(fix_braid_transects) +export(geos_extend_line) export(get_braid_list) +export(get_coords_around_parabola) +export(get_cs_bottom_length) +export(get_extensions_by_id) +export(get_point_type_counts) +export(get_relief) +export(get_transect_extension_distances_to_polygons) export(get_transects) +export(get_unique_tmp_ids) +export(improve_invalid_cs) export(is_braided) +export(make_progress_bar) +export(pct_pts_near_bottom) +export(pick_extension_pts) +export(plot_cs_pts) +export(pts_to_reevaluate) +export(rectify_cs) +export(rectify_flat_cs) +export(rectify_summary) +export(subset_polygons_in_transects) +export(subset_transects_in_polygons) export(unique_braids) export(unnpack_braids) +importFrom(AHGestimation,cross_section) importFrom(dplyr,`%>%`) importFrom(dplyr,add_count) importFrom(dplyr,all_of) +importFrom(dplyr,any_of) importFrom(dplyr,arrange) importFrom(dplyr,between) importFrom(dplyr,bind_rows) +importFrom(dplyr,case_when) +importFrom(dplyr,count) +importFrom(dplyr,ends_with) importFrom(dplyr,everything) importFrom(dplyr,filter) importFrom(dplyr,group_by) +importFrom(dplyr,lag) +importFrom(dplyr,last_col) importFrom(dplyr,lead) importFrom(dplyr,left_join) importFrom(dplyr,mutate) importFrom(dplyr,n) +importFrom(dplyr,n_distinct) importFrom(dplyr,relocate) importFrom(dplyr,rename) +importFrom(dplyr,rowwise) importFrom(dplyr,select) importFrom(dplyr,slice) +importFrom(dplyr,slice_max) importFrom(dplyr,summarise) importFrom(dplyr,summarize) +importFrom(dplyr,sym) importFrom(dplyr,tibble) importFrom(dplyr,ungroup) importFrom(fastmap,fastmap) @@ -42,19 +89,32 @@ importFrom(geos,geos_interpolate_normalized) importFrom(geos,geos_intersection) importFrom(geos,geos_intersects) importFrom(geos,geos_intersects_any) +importFrom(geos,geos_intersects_matrix) importFrom(geos,geos_is_empty) importFrom(geos,geos_length) importFrom(geos,geos_make_linestring) importFrom(geos,geos_point_end) +importFrom(geos,geos_point_start) +importFrom(geos,geos_simplify_preserve_topology) importFrom(geos,geos_type) +importFrom(geos,geos_within_matrix) importFrom(geos,geos_x) importFrom(geos,geos_y) +importFrom(ggplot2,aes) +importFrom(ggplot2,facet_grid) +importFrom(ggplot2,facet_wrap) +importFrom(ggplot2,geom_point) +importFrom(ggplot2,ggplot) +importFrom(lwgeom,st_linesubstring) importFrom(nhdplusTools,get_UT) importFrom(nhdplusTools,get_node) importFrom(nhdplusTools,get_sorted) importFrom(nhdplusTools,get_tocomid) importFrom(nhdplusTools,make_node_topology) importFrom(nhdplusTools,rename_geometry) +importFrom(rlang,as_name) +importFrom(rlang,enquo) +importFrom(rmapshaper,ms_simplify) importFrom(sf,st_as_sf) importFrom(sf,st_cast) importFrom(sf,st_centroid) @@ -65,10 +125,12 @@ importFrom(sf,st_geometry) importFrom(sf,st_intersects) importFrom(sf,st_length) importFrom(sf,st_line_sample) +importFrom(sf,st_segmentize) importFrom(sf,st_set_geometry) importFrom(sf,st_transform) importFrom(smoothr,densify) importFrom(smoothr,smooth) +importFrom(stats,median) importFrom(stats,setNames) importFrom(terra,crs) importFrom(terra,extract) @@ -77,7 +139,11 @@ importFrom(terra,project) importFrom(terra,rast) importFrom(terra,res) importFrom(terra,vect) +importFrom(tidyr,pivot_longer) +importFrom(tidyr,pivot_wider) importFrom(tidyr,unnest) +importFrom(utils,str) +importFrom(utils,txtProgressBar) importFrom(vctrs,vec_c) importFrom(wk,wk_affine_compose) importFrom(wk,wk_affine_rotate) diff --git a/R/ahg_estimates.R b/R/ahg_estimates.R new file mode 100644 index 00000000..65b2b12d --- /dev/null +++ b/R/ahg_estimates.R @@ -0,0 +1,4317 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +############################################################################### +##### ---- VERSION 2 ------ +############################################################################### + +#' Get the AHG estimated parabolas for each hy_id/cs_id cross section given a set of cross section points +#' +#' @param cross_section_pts dataframe or sf dataframe with "hy_id", "cs_id", "bottom" columns and +#' specififed "top_width", "depth", "dingman_r" columns (see top_width, depth, and dingman_r arguments) +#' @importFrom dplyr bind_rows rowwise select group_by slice ungroup filter mutate +#' @importFrom AHGestimation cross_section +#' @importFrom tidyr unnest +#' @importFrom rlang as_name enquo +#' @return dataframe with a set of AHG points for each hy_id/cs_id in the input data, with AHG estimated X, Y, A point values that form a parabola +get_ahg_parabolas <- function( + cross_section_pts = NULL +) { + + # cross_section_pts <- + # cs_ml %>% + # dplyr::slice(1:20) + # cross_section_pts = cross_section_pts + # # top_width = {{top_width}}, + # # depth = {{depth}}, + # top_width = "owp_tw_inchan" + # depth = "owp_y_inchan" + # length_col = "cs_lengthm" + # cross_section_pts = dplyr::slice(inchannel_cs, 1:10) + # top_width = "owp_tw_inchan" + # depth = "owp_y_inchan" + # dingman_r = "owp_dingman_r" + + req_cols <- c("hy_id", "cs_id", "bottom", + "TW", "DEPTH", "DINGMAN_R") + + if (is.null(cross_section_pts)) { + stop( + paste0("'cross_section_pts' is NULL, provide a dataframe with the following columns:\n > ", + paste0(req_cols, collapse = "\n > ")) + ) + } + + if (!all(req_cols %in% names(cross_section_pts))) { + stop(paste0('"cross_section_pts" is missing columns, must include all of:\n > ', paste0(req_cols, collapse = "\n > ") )) + } + + # this function will take in one of the AHG estimated parabolas, a bottom depth, and the estimated inchannel depth + # and if there are infinite/NaN/NA values in the AHG estimated parabolas depth ("Y"), + # we pin the the left and right side of the parabola to the input bottomZ and set + # the bottom depth to the input bottom minus the given inchannel depth estimate + # TODO: Probably won't be a permanent solution if the AHG estimation package ends up never returning NaN/Infinite values + make_rectangle_if_needed <- function(parabola_df, bottomZ, inchannel_depth) { + contains_nan_or_inf_y_values <- any(is.nan(parabola_df$Y)) || any(is.na(parabola_df$Y)) || any(is.infinite(parabola_df$Y)) + + if (contains_nan_or_inf_y_values) { + parabola_df[1, 'Y'] <- bottomZ + parabola_df[nrow(parabola_df), 'Y'] <- bottomZ + parabola_df[2:(nrow(parabola_df)-1), 'Y'] <- bottomZ - inchannel_depth + } + + return(parabola_df) + + } + + # set the parabola to align with the cross section points bottom most points + offset_and_partition_parabola <- function(parabola, bottomZ) { + + # indices of the left and right parabola halves + left_half = 1:(nrow(parabola) / 2) + right_half = (1 + (nrow(parabola) / 2)):nrow(parabola) + + # get the left and right side of the parabolas + left_parabola = parabola[left_half, ] + right_parabola = parabola[right_half, ] + + # shift the Z values to have there max points be at the "bottom" of the "cross_section_pts" points + left_parabola$Y <- left_parabola$Y + (bottomZ - max(left_parabola$Y)) + right_parabola$Y <- right_parabola$Y + (bottomZ - max(right_parabola$Y)) + + left_parabola$partition <- "left" + right_parabola$partition <- "right" + # left_parabola <- + # left_parabola %>% + # dplyr::mutate( + # left_max = max(x, na.rm = TRUE) + # ) + parabola <- dplyr::bind_rows( + left_parabola, + right_parabola + ) + + return(parabola) + } + + # keep only a single row for each cross section + ahg_parameters <- + cross_section_pts %>% + dplyr::select(hy_id, cs_id, bottom, + TW, DEPTH, DINGMAN_R + # dplyr::any_of(c(top_width, depth, dingman_r)) + # .data[[top_width]], + # .data[[depth]], + # .data[[dingman_r]] + # !!dplyr::sym(top_width), + # !!dplyr::sym(depth), + # !!dplyr::sym(dingman_r), + # {{top_width}}, {{depth}}, {{dingman_r}} + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + + # remove any cross sections that are missing top_width, depth, or dingman_r + set_aside <- + ahg_parameters %>% + dplyr::filter(is.na(TW) | is.na(DEPTH) | is.na(DINGMAN_R)) + # dplyr::filter(is.na(.data[[top_width]]) | is.na(.data[[depth]]) | is.na(.data[[dingman_r]]) ) + # dplyr::filter(is.na(get(top_width)) | is.na(get(depth)) | is.na(get(dingman_r)) ) + # dplyr::filter(is.na({{top_width}}) | is.na({{depth}}) | is.na({{dingman_r}}) ) + + ahg_parameters <- + ahg_parameters %>% + hydrofabric3D::add_tmp_id() %>% + dplyr::filter(!tmp_id %in% hydrofabric3D::add_tmp_id(set_aside)$tmp_id) %>% + dplyr::select(-tmp_id) %>% + dplyr::rowwise() %>% + dplyr::mutate( + parabola = list( + AHGestimation::cross_section( + r = DINGMAN_R, + TW = TW, + Ymax = DEPTH + # r = get(dingman_r), + # TW = get(top_width), + # Ymax = get(depth) + # r = .data[[dingman_r]], + # TW = .data[[top_width]], + # Ymax = .data[[depth]] + # r = {{dingman_r}}, + # TW = {{top_width}}, + # Ymax = {{depth}} + ) + # dplyr::mutate( + # Y = dplyr::case_when( + # ind == 2 ~ NaN, + # TRUE ~ Y + # ) + # ) + ) + ) + + ahg_parameters <- + ahg_parameters %>% + dplyr::rowwise() %>% + dplyr::mutate( + parabola = list( + make_rectangle_if_needed( + parabola, + bottom, + # NOTE: Not sure why i had this like this, should use the bottom as the anchor...? + # {{top_width}}, + # {{depth}} + # get(top_width), + # get(depth) + # .data[[depth]] + DEPTH + ) + # parabola = purrr::map2(parabola, bottom, {{depth}}, make_rectangle_if_needed) + ) + ) %>% + dplyr::rowwise() %>% + dplyr::mutate( + parabola = list( + offset_and_partition_parabola( + parabola, + bottom + ) + # parabola = purrr::map2(parabola, bottom, {{depth}}, make_rectangle_if_needed) + ) + ) + + # unnest the parabola dataframes and rename columns then return + ahg_parameters <- + ahg_parameters %>% + dplyr::select(hy_id, cs_id, parabola) %>% + tidyr::unnest(c(parabola)) %>% + # dplyr::group_by(hy_id, cs_id, partition) %>% + # dplyr::group_by(hy_id, cs_id) %>% + # dplyr::mutate( + # left_max = max(x, na.rm = TRUE) + # ) %>% + # dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, + ahg_index = ind, + ahg_x = x, + ahg_y = Y, + ahg_a = A, + # left_max, + partition + ) + + # plot(ahg_parameters$ahg_y) + + return(ahg_parameters) +} + + +#' Generate X/Y coordinates between a set of known points within a cross section +#' Used after inserting AHG estimated parabolas in between DEM cross sections points +#' +#' @param cross_section_pts cross section points dataframe with missing X/Y coordinates between sets of known X/Y coordinates +#' @importFrom dplyr filter group_by summarize ungroup left_join select ends_with mutate n bind_rows +#' @importFrom tidyr unnest +#' @return dataframe, input dataframe with X/Y coordinates filled in for missing hy_id/cs_id X/Y values +#' @export +fill_missing_ahg_coords <- function(cross_section_pts) { + + # cross_section_pts <- + # cs_bathy_inchannel %>% + # # dplyr::slice(1:159) + # dplyr::slice(1:171375) + + # cross_section_pts <- cs_bathy_inchannel + + #Fix the missing X/Y coordinates (NAs) from the inserted AHG Parabola points in a set of cross section points + seq_between_start_and_end <- function(start, end, n) { + # df = fix_coords + + if (n == 0) { + return(NULL) + } + + # Generate new X / Y coordinates + # coords <- seq(start, end, length.out = n ) + coords <- seq(start, end, length.out = n + 2) + + # return(coords) + return(coords[2:(length(coords) - 1)]) + } + + + # get the first and last coordinates beforee the missing NA X/Y points + start_and_end_coords <- get_coords_around_parabola(cross_section_pts) + + # + start_and_end_pts_ids <- + cross_section_pts %>% + dplyr::filter(!is_dem_point) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::summarize( + start_pt_id = min(pt_id, na.rm = TRUE) + ) %>% + dplyr::ungroup() + + # get only the rows with the parabola w/ missing X/Y coords + parabola_pts <- + cross_section_pts %>% + dplyr::filter(!is_dem_point) %>% + dplyr::left_join( + start_and_end_coords, + by = c("hy_id", "cs_id") + ) %>% + dplyr::select(hy_id, cs_id, pt_id, X, Y, + dplyr::ends_with("_start"), dplyr::ends_with("end")) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + n = dplyr::n() + ) %>% + dplyr::ungroup() + + # generate coordinates for each parabola + parabola_coords <- + parabola_pts %>% + dplyr::left_join( + start_and_end_pts_ids, + by = c("hy_id", "cs_id") + ) %>% + dplyr::select(hy_id, cs_id, start_pt_id, dplyr::ends_with("_start"), dplyr::ends_with("end"), n) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::mutate( + X = list(seq_between_start_and_end(X_start, X_end, n)), + Y = list(seq_between_start_and_end(Y_start, Y_end, n)) + ) %>% + tidyr::unnest(c(X, Y)) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + pt_id = (start_pt_id - 1) + (1:dplyr::n()) + # pt_id = start_pt_id + (0:(dplyr::n()-1)) + ) %>% + dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, pt_id, X, Y) + # dplyr::select(hy_id, cs_id, X, Y) + + # join the new parabola X/Y points with the rest of the original data, dropping the old NA X/Y coordinates + parabolas_with_coords <- + cross_section_pts %>% + dplyr::filter(!is_dem_point) %>% + dplyr::select(-X, -Y) %>% + dplyr::left_join( + parabola_coords, + by = c("hy_id", "cs_id", "pt_id") + ) + + pts_with_fixed_coords <- + dplyr::bind_rows( + dplyr::filter(cross_section_pts, is_dem_point), + parabolas_with_coords + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::arrange(relative_distance, .by_group = TRUE) %>% + # dplyr::arrange(pt_id, .by_group = TRUE) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + pt_id = 1:dplyr::n() + ) %>% + dplyr::ungroup() + + # pts_with_fixed_coords %>% + # dplyr::group_by(hy_id, cs_id) + # + # pts_with_fixed_coords %>% + # dplyr::slice(1:15000) %>% + # sf::st_as_sf(coords = c("X", "Y"), crs = 5070) %>% + # mapview::mapview() + return(pts_with_fixed_coords) +} + +#' Get the coordinates surrounding a set of missing AHG X/Y coordinates. +#' +#' @param cross_section_pts dataframe with cross section points, (required cols, "hy_id", "cs_id", "X", "Y", "is_dem_point") +#' @importFrom tidyr pivot_wider +#' @importFrom dplyr select group_by mutate lag lead case_when filter ungroup left_join +#' @return dataframe with each hy_id/cs_id cross section containing a value for X_start, X_end, Y_start, Y_end, representing the points surrounding the AHG inserted points +#' @export +get_coords_around_parabola <- function(cross_section_pts) { + + fill_value <- -999999999 + + X_coords <- + cross_section_pts %>% + dplyr::select(hy_id, cs_id, X, is_dem_point) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + X = ifelse(is.na(X), fill_value, X) + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + next_X_is_missing = dplyr::case_when( + dplyr::lead(X) == fill_value ~ TRUE, + # is_dem_point & is.na(dplyr::lead(X)) ~ TRUE, + TRUE ~ FALSE + ), + prev_X_is_missing = dplyr::case_when( + dplyr::lag(X) == fill_value ~ TRUE, + # is_dem_point & is.na(dplyr::lead(X)) ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::filter((is_dem_point & next_X_is_missing) | (is_dem_point & prev_X_is_missing)) %>% + dplyr::mutate( + start_or_end = dplyr::case_when( + # is_dem_point & is.na(dplyr::lead(X)) ~ TRUE, + (is_dem_point & next_X_is_missing) ~ "X_start", + (is_dem_point & prev_X_is_missing) ~ "X_end" + ) + ) %>% + dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, X, is_dem_point, start_or_end) + + # X_coords %>% + # dplyr::group_by(hy_id, cs_id) + + # pivot so each cross sections is a single row with a "X_start" and "X_end" point + X_coords <- + X_coords %>% + # dplyr::select(-is_dem_point) %>% + tidyr::pivot_wider( + id_cols = c(hy_id, cs_id), + names_from = start_or_end, + values_from = X + ) + + Y_coords <- + cross_section_pts %>% + dplyr::select(hy_id, cs_id, Y, is_dem_point) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + Y = ifelse(is.na(Y), fill_value, Y) + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + next_Y_is_missing = dplyr::case_when( + dplyr::lead(Y) == fill_value ~ TRUE, + TRUE ~ FALSE + ), + prev_Y_is_missing = dplyr::case_when( + dplyr::lag(Y) == fill_value ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::filter((is_dem_point & next_Y_is_missing) | (is_dem_point & prev_Y_is_missing)) %>% + dplyr::mutate( + start_or_end = dplyr::case_when( + (is_dem_point & next_Y_is_missing) ~ "Y_start", + (is_dem_point & prev_Y_is_missing) ~ "Y_end" + ) + ) %>% + dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, Y, is_dem_point, start_or_end) + + # pivot so each cross sections is a single row with a "X_start" and "X_end" point + Y_coords <- + Y_coords %>% + tidyr::pivot_wider( + id_cols = c(hy_id, cs_id), + names_from = start_or_end, + values_from = Y + ) + + coords_around_parabola <- dplyr::left_join( + X_coords, + Y_coords, + by = c("hy_id", "cs_id") + ) + + return(coords_around_parabola) +} + +#' Check that all cross sections points have a prescribed top width less than the total cross section length +#' @description +#' If a set of cross section points has a top width length that is longer than the cross sections length, then a new top width and Y max (depth) value +#' are given so that the estimated shape is able to properly fit into the cross sections. +#' The cross sections length (meters) minus 1 meter is used as the new top width and +#' the new Y max (depth) value is derived from the original ratio between the prescribed top width and Y max +#' @param cross_section_pts dataframe or sf dataframe with "hy_id", "cs_id", "pt_id", "Z", "relative_distance", "cs_lengthm", "class", "point_type", "TW", "DEPTH", "DINGMAN_R" +#' @importFrom rlang as_name enquo +#' @importFrom dplyr group_by mutate case_when sym ungroup select filter slice +#' @return cross_section_pts dataframe with updated "top_width" and "depth" column values +fix_oversized_topwidths <- function( + cross_section_pts = NULL +) { + # cross_section_pts = cross_section_pts + # top_width = top_width + # depth = depth + # length_col = "cs_lengthm" + + # cross_section_pts = dplyr::slice(inchannel_cs, 1:100000) + # top_width = cross_section_pts$owp_y_inchan + # depth = cross_section_pts$owp_y_inchan + # dingman_r = cross_section_pts$owp_dingman_r + + # use this to get a new scaled Ymax value given a known Top width, Ymax (ML generated in this case) + # and an expected new Top width (new_TW), this function is used to handle + # the case when the ML estimated top width is GREATER than the DEM cross section length + scale_DEPTH_to_TW <- function(TW, Ymax, new_TW) { + + new_DEPTH <- Ymax * (new_TW / TW) + + return(new_DEPTH) + + } + + req_cols <- c("hy_id", "cs_id", "pt_id", "Z", "relative_distance", "cs_lengthm", "class", "point_type", "TW", "DEPTH", "DINGMAN_R") + + if (is.null(cross_section_pts)) { + stop( + paste0("'cross_section_pts' is NULL, provide a dataframe with the following columns:\n > ", + paste0(req_cols, collapse = "\n > ")) + ) + } + + if (!all(req_cols %in% names(cross_section_pts))) { + stop(paste0('"cross_section_pts" is missing columns, must include all of:\n > ', paste0(req_cols, collapse = "\n > ") )) + } + + # original_cs %>% + # hydrofabric3D::plot_cs_pts(x = "relative_distance") + + + ############################################## + ############################################## + # cross_section_pts <- + # inchannel_cs %>% + # # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") + # # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("3")) + # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) + # # + # top_width = "owp_tw_inchan" + # depth = "owp_y_inchan" + # length_col = "cs_lengthm" + + # # cross_section_pts %>% + # # hydrofabric3D::plot_cs_pts(x = "relative_distance") + + ############################################## + ############################################## + + # keep track of the original column order for reordering at the end + starting_col_order <- names(cross_section_pts) + + # Determine the distance interval for each cross section + # we're going to use this value to + # derive a new Top width for each cross section if + # the cross section length is less than the prescribed top width, + # we round the distance interval UP sure we are not underestimating the interval + distance_between_pts <- + cross_section_pts %>% + dplyr::select(hy_id, cs_id, relative_distance) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + distance_interval = relative_distance - dplyr::lag(relative_distance) + ) %>% + dplyr::summarise( + distance_interval = ceiling(mean(distance_interval, na.rm = TRUE)) # TODO: round up to make sure we are not underestimating + # the interval, we're going to use this value to + # derive a new Top width for each cross section if + # the cross section length is less than the prescribed top width + ) %>% + dplyr::ungroup() + + # add the distance interval values to the cross section points + cross_section_pts <- + cross_section_pts %>% + dplyr::left_join( + distance_between_pts, + by = c("hy_id", "cs_id") + ) + + # message("Ending col order:\n> ", paste0(names(cross_section_pts), collapse = "\n> ")) + # cross_section_pts$tmp_top_width <- top_width + # cross_section_pts$tmp_depth <- depth + + updated_TW_and_Ymax <- + cross_section_pts %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + new_DEPTH = dplyr::case_when( + TW >= cs_lengthm ~ scale_DEPTH_to_TW(TW, + DEPTH, + cs_lengthm - distance_interval + # !!dplyr::sym(length_colname) - 1 # TODO: arbitrarily remove 1 meter from the length to + # TODO: make sure topwidth/depth is SMALLER than cross section length + # TODO: so the AHG parabola points can fit within cross section + # !!dplyr::sym(length_colname) + # TODO: Original method ^^^ (no subtraction) + ), + TRUE ~ DEPTH + # owp_tw_inchan >= cs_lengthm ~ scale_DEPTH_to_TW(owp_tw_inchan, owp_y_inchan, cs_lengthm), + # TRUE ~ owp_y_inchan + ), + new_TW = dplyr::case_when( + TW >= cs_lengthm ~ cs_lengthm - distance_interval, # TODO: Same arbitrary subtraction of 1 meter as above note ^^^ + # get(top_width) >= get(length_colname) ~ !!dplyr::sym(length_colname) - 1, # TODO: Same arbitrary subtraction of 1 meter as above note ^^^ + # get(top_width) >= get(length_colname) ~ !!dplyr::sym(length_colname), # TODO: Original method (no subtraction) + TRUE ~ TW + # owp_tw_inchan >= cs_lengthm ~ cs_lengthm, + # TRUE ~ owp_tw_inchan + ), + has_new_DEPTH = new_DEPTH != DEPTH, + has_new_TW = new_TW != TW, + fixed_TW = has_new_DEPTH | has_new_TW + ) %>% + dplyr::ungroup() %>% + # dplyr::relocate(hy_id, cs_id, cs_lengthm, owp_tw_inchan, + # new_TW, new_TW2, owp_y_inchan, new_DEPTH, new_DEPTH2, fixed_TW) + dplyr::select( + -has_new_DEPTH, + -has_new_TW, + -TW, + -DEPTH + ) + + # number of cross sections that had their TW/Depths changed to fit into the cross section properly + number_fixed_TWs <- + updated_TW_and_Ymax %>% + dplyr::filter(fixed_TW) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + nrow() + + if (number_fixed_TWs > 0) { + warning( + "Had to fix ", number_fixed_TWs, " cross section(s) top width/depth values to make sure", + "\nthe prescribed topwidth is not greater than or equal to the length of", + "\nthe entire cross section (meters), the cross section(s) total length is", + "\nused as the new TW and the ratio of the prescribed TW to the prescribed depth", + "\nis used to calculate a new depth (Y) value." + ) + } + + # Drop the flag column that says if the top width had to be fixed + updated_TW_and_Ymax <- dplyr::select(updated_TW_and_Ymax, + -distance_interval, + -fixed_TW + ) + + # # any starting columns in the original data + ending_col_order <- names(updated_TW_and_Ymax) + + # message("Ending col order:\n> ", paste0(names(updated_TW_and_Ymax), collapse = "\n> ")) + + # # change the new_TW and new_DEPTH columns to match the original input TW/Depth column names + ending_col_order[ending_col_order == "new_TW"] <- "TW" + ending_col_order[ending_col_order == "new_DEPTH"] <- "DEPTH" + + # # update the names + names(updated_TW_and_Ymax) <- ending_col_order + + # # reorder columns to original order + # updated_TW_and_Ymax <- updated_TW_and_Ymax[starting_col_order] + + return(updated_TW_and_Ymax) +} + +# cross_section_pts <- +# inchannel_cs %>% +# # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") +# dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) +# top_width = "owp_tw_inchan" +# depth = "owp_y_inchan" +# dingman_r = "owp_dingman_r" +# cross_section_pts$owp_tw_bf + +#' Given provide inchannel widths and depths to a set of cross section points and derive estimated shapes +#' @description +#' Still in early development phases +#' @param cross_section_pts dataframe or sf dataframe. Default is NULL +#' @importFrom dplyr bind_rows select mutate n case_when summarise ungroup group_by filter relocate left_join slice slice_max rename arrange +#' @importFrom AHGestimation cross_section +#' @importFrom stats median +#' @importFrom rlang as_name enquo +#' @return dataframe or sf dataframe with AHG estimated points injected into the input cross section points +#' @export +add_cs_bathymetry <- function( + cross_section_pts = NULL +) { + + if (is.null(cross_section_pts)) { + stop( + paste0("'cross_section_pts' is NULL, provide a dataframe with the following columns:\n> ", + paste0(c('hy_id', 'cs_id', 'Z', 'bottom', 'relative_distance', + 'point_type', 'class', + 'top_width - (specify via "top_width" argument)', + 'depth - (specify via "depth" argument)', + 'dingman_r - (specify via "dingman_r" argument)' + ), + collapse = "\n> ")) + ) + } + + ########################################################## + ########################################################## + # cross_section_pts <- + # inchannel_cs %>% + # # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") + # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) + # top_width = "owp_tw_inchan" + # depth = "owp_y_inchan" + # dingman_r = "owp_dingman_r" + # cross_section_pts <- + # inchannel_cs %>% + # dplyr::slice(1:100000) %>% + # dplyr::select(-owp_y_bf, -owp_tw_bf) %>% + # dplyr::rename( + # TW = owp_tw_inchan, + # DEPTH = owp_y_inchan, + # DINGMAN_R = owp_dingman_r + # ) + # # cross_section_pts = dplyr::slice(inchannel_cs, 1:100000) + # top_width = cross_section_pts$TW + # depth = cross_section_pts$DEPTH + # dingman_r = cross_section_pts$DINGMAN_R + + # cross_section_pts = NULL + # top_width = NULL + # depth = NULL + # dingman_r = NULL + # + ########################################################## + + + req_cols <- c("hy_id", "cs_id", "pt_id", "Z", "relative_distance", "cs_lengthm", "class", "point_type", "TW", "DEPTH", "DINGMAN_R") + + if (!all(req_cols %in% names(cross_section_pts))) { + stop(paste0('"cross_section_pts" is missing columns, must include all of:\n > ', paste0(req_cols, collapse = "\n > ") )) + } + + + + + ########################################################## + + # Replace any topwidth values that are GREATER than the actual cross section length (meters) + cross_section_pts <- fix_oversized_topwidths( + cross_section_pts = cross_section_pts + ) + + # generate AHG parabolas for each hy_id/cs_id in the cross section points + # using the provided top_widths, depths, and dingman's R + ahg_parabolas <- get_ahg_parabolas( + cross_section_pts = cross_section_pts + ) + + # ############################################## + + # plot(ahg_parabolas$ahg_y) + + # store the maximum X on the left side of the parabola for later use + ahg_left_max <- + ahg_parabolas %>% + dplyr::filter(partition == "left") %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::summarise(left_max = max(ahg_x, na.rm = TRUE)) %>% + dplyr::ungroup() + + # ------------------------------------------------------------------------------------------------ + # ---- Partition input cross section points (left/right) ---- + # ------------------------------------------------------------------------------------------------ + + # split the cross section into a left and right half, from the midpoint of the bottom + # and then join on the maximum X point of the LEFT half of the AHG parabolas + # this paritioned set of cross sections will ultimately get the AHG parabolas inserted in between the left and right partitions + partioned_cs <- + cross_section_pts %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + # relative_distance_of_bottom = point_type == "bottom" + bottom_midpoint = dplyr::case_when( + point_type == "bottom" ~ relative_distance, + TRUE ~ NA + ), + bottom_midpoint = stats::median(bottom_midpoint, na.rm = TRUE) + ) %>% + # dplyr::relocate(bottom_midpoint) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + # relative_distance_of_bottom = point_type == "bottom" + cs_partition = dplyr::case_when( + relative_distance < bottom_midpoint ~ "left_cs", + TRUE ~ "right_cs" + ) + # bottom_midpoint = stats::median(bottom_midpoint, na.rm = TRUE) + ) %>% + dplyr::left_join( + ahg_left_max, + by = c("hy_id", "cs_id") + ) %>% + # dplyr::relocate(left_max, bottom_midpoint, cs_partition) %>% + dplyr::ungroup() + + # get the midpoint value for each hy_id/cs_id so we can use them during the shifting process + midpoints <- + partioned_cs %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::select(hy_id, cs_id, bottom_midpoint) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + + # ------------------------------------------------------------------------------------------------ + # ---- Process LEFT side of cross section and parabola ---- + # ------------------------------------------------------------------------------------------------ + # # lefty <- + # partioned_cs %>% + # # dplyr::filter(cs_partition == "left_cs") %>% + # dplyr::group_by(hy_id, cs_id) %>% + # # dplyr::mutate( + # # res = bottom_midpoint - max(left_max), + # # mark = relative_distance < bottom_midpoint - max(left_max) | relative_distance == 0 + # # ) %>% + # # dplyr::relocate(res, mark, relative_distance) + # dplyr::filter( + # relative_distance < (bottom_midpoint - max(left_max)) | relative_distance == 0 + # # relative_distance < 0 + # ) + # left_new <- partioned_cs %>% + # dplyr::filter(cs_partition == "left_cs") %>% + # dplyr::group_by(hy_id, cs_id) %>% + # dplyr::filter( + # # relative_distance < (bottom_midpoint - max(left_max)) + # relative_distance < (bottom_midpoint - max(left_max)) | relative_distance == 0 # TODO: testing this new condition out + # ) + + # # TODO: look back at this tomorrow + # left_side_pt_counts <- + # partioned_cs %>% + # dplyr::filter(cs_partition == "left_cs") %>% + # dplyr::group_by(hy_id, cs_id) %>% + # dplyr::mutate( + # marked = relative_distance < (bottom_midpoint - max(left_max)) + # ) %>% + # dplyr::select(hy_id, cs_id, marked) %>% + # dplyr::summarise(total_left_side_pts = sum(marked, na.rm = TRUE)) %>% + # dplyr::ungroup() + # partioned_cs %>% + # dplyr::filter(cs_partition == "left_cs") %>% + # dplyr::left_join( + # left_side_pt_counts, + # by = c("hy_id", "cs_id") + # ) + + # grab just the left cross sections and remove any points that will be swallowed by the newly inserted AHG estimates + # And also determine the offset of the left parabolas X points, the left_start will be joined back onto the AHG parabolas + left_cs <- + partioned_cs %>% + dplyr::filter(cs_partition == "left_cs") %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter( + # relative_distance < (bottom_midpoint - max(left_max)) + relative_distance < (bottom_midpoint - max(left_max)) | relative_distance == 0 # TODO: testing this new condition out + # relative_distance < (bottom_midpoint - max(left_max)) | (relative_distance == 0 & total_left_side_pts == 0) # TODO: testing this new condition out + ) %>% + dplyr::mutate( + left_start = bottom_midpoint - max(left_max) + ) %>% + dplyr::ungroup() + + left_starts <- + left_cs %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::select(hy_id, cs_id, left_start) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + + # offset the left parabolas X points using the left_start value + left_parabolas <- + ahg_parabolas %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter(partition == "left") %>% + dplyr::ungroup() %>% + dplyr::left_join( + left_starts, + by = c("hy_id", "cs_id") + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + ahg_x = ahg_x + left_start + ) %>% + dplyr::ungroup() + + # ------------------------------------------------------------------------------------------------ + # ---- Process RIGHT side of cross section and parabola ---- + # ------------------------------------------------------------------------------------------------ + + # subset cross section to the RIGHT of the midpoint + right_cs <- + partioned_cs %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter(relative_distance > bottom_midpoint) %>% + # dplyr::filter(cs_partition == "right_cs") + dplyr::ungroup() + + right_parabolas <- + ahg_parabolas %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter(partition == "right") %>% + dplyr::ungroup() %>% + dplyr::left_join( + ahg_left_max, + by = c("hy_id", "cs_id") + ) %>% + dplyr::left_join( + midpoints, + by = c("hy_id", "cs_id") + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + right_start = bottom_midpoint + ((ahg_x) - left_max) + ) %>% + dplyr::ungroup() + + # ---------------------------------------------------------------------------------------------------------------- + # ------- Still reviewing this additon --------- + # --- This ties back to the fix_oversized_topwidths() function applied at the beginning ----- + # ---------------------------------------------------------------------------------------------------------------- + # TODO: Newly added to deal with situations where the right side of the parabola is TOO LONG, + # TODO: and will go past the outside of the predefined cross section length + # TODO: This all needs to evaluated and double checked to make sure it makes + # TODO: sense hydrologically and won't break the standard "good" case + # for each cross section, we isolate the total length of the cross section + # to make sure that the parabola is not going past the edge of the cross section + total_cross_section_length <- + right_cs %>% + dplyr::group_by(hy_id, cs_id) %>% + # dplyr::filter(relative_distance == max(relative_distance)) %>% + dplyr::slice_max(relative_distance, n = 1) %>% + dplyr::select(hy_id, cs_id, + max_right_position = relative_distance) %>% + dplyr::ungroup() + + # from the right side of the parabola, + # we remove any parabola points that would be past + # the last right side cross section points + right_parabolas <- + right_parabolas %>% + dplyr::left_join( + total_cross_section_length, + by = c("hy_id", "cs_id") + ) %>% + # dplyr::relocate(hy_id, cs_id, right_start, max_right_position) %>% + dplyr::filter(right_start < max_right_position) + + # ---------------------------------------------------------------------------------------------------------------- + # TODO: Above still needs review ^^^ + # ---------------------------------------------------------------------------------------------------------------- + + # getting the starting X value for the RIGHT side of the parabola + max_right_starting_pts <- + right_parabolas %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::summarise( + right_start_max = max(right_start, na.rm = TRUE) + ) %>% + dplyr::ungroup() + + # removing cross section point that will be replaced by right_parabola points + right_cs <- + right_cs %>% + dplyr::left_join( + max_right_starting_pts, + by = c("hy_id", "cs_id") + ) %>% + # dplyr::relocate(right_start_max) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter( + relative_distance > right_start_max + ) %>% + dplyr::ungroup() + + # --------------------------------------------------------------------------------------------------- + # ---- MERGE the left and right sides of the parabolas ----- + # --------------------------------------------------------------------------------------------------- + + right_parabolas <- + right_parabolas %>% + dplyr::select(-ahg_x) %>% + dplyr::rename(ahg_x = right_start) %>% + dplyr::select( + hy_id, cs_id, ahg_index, ahg_x, ahg_y, ahg_a, + partition + # left_max, bottom_midpoint + ) + + left_parabolas <- + left_parabolas %>% + dplyr::select( + hy_id, cs_id, ahg_index, ahg_x, ahg_y, ahg_a, + partition + ) + + # merge + parabolas <- dplyr::bind_rows(left_parabolas, right_parabolas) + + # reorder to parabolas by X values so they are in order from left to right for each hy_id/cs_id + parabolas <- + parabolas %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::arrange(ahg_x, .by_group = TRUE) %>% + dplyr::ungroup() + + # select relevant columns and adjust the names so + # the AHG parabola can be inserted nicely with the original cross sections + # NOTE: + # AHG X values == "relative_distance" in cross_section_pts + # AHG Y values == "Z" in cross_section_pts + parabolas <- + parabolas %>% + dplyr::select( + hy_id, cs_id, + relative_distance = ahg_x, + Z = ahg_y + ) + + # --------------------------------------------------------------------------------------------------- + # ---- Insert the parabolas in between the LEFT and RIGHT cross section partitions ----- + # --------------------------------------------------------------------------------------------------- + + # drop unneeded columns + left_cs <- dplyr::select(left_cs, + -left_start, -left_max, -bottom_midpoint, -cs_partition) + right_cs <- dplyr::select(right_cs, + -right_start_max, -left_max, -bottom_midpoint, -cs_partition) + + # combine left cross section points, parabola, and right cross section points + # and then reorder each cross section (hy_id/cs_id) by the relative distance + # so all the points are in correct order + out_cs <- + dplyr::bind_rows( + # left_cs, + # parabolas, + # right_cs + dplyr::mutate(left_cs, is_dem_point = TRUE), + dplyr::mutate(parabolas, is_dem_point = FALSE), + dplyr::mutate(right_cs, is_dem_point = TRUE), + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter(relative_distance >= 0) %>% # TODO: testing out this condition as well + dplyr::arrange(relative_distance, .by_group = TRUE) %>% + dplyr::ungroup() + + # Assign / renumber the "pt_ids" and + # set the "point_types" of the inserted parabola points to "bottom" type + out_cs <- + out_cs %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + pt_id = 1:dplyr::n(), + class = dplyr::case_when( + is.na(class) ~ "bottom", + TRUE ~ class + ), + point_type = dplyr::case_when( + is.na(point_type) ~ "bottom", + TRUE ~ point_type + ) + ) %>% + dplyr::ungroup() + + # parabolas %>% + # hydrofabric3D::add_tmp_id() %>% + # ggplot2::ggplot() + + # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z)) + + # ggplot2::facet_wrap(~tmp_id) + # out_cs %>% + # hydrofabric3D::plot_cs_pts(x = "relative_distance", color = "is_dem_point") + + tryCatch({ + message("Generate XY coordinates for AHG estimated points...") + out_cs <- fill_missing_ahg_coords(out_cs) + + }, error = function(cond) { + + message("Failed to fix X/Y coordinates for estimated bathymetry points, returning cross section points with inserted bathymetry with missing X/Y values") + message(conditionMessage(cond)) + + # Choose a return value in case of error + return(out_cs) + + }) + + return(out_cs) + +} + +#' ############################################################################### +#' ##### ---- VERSION 1 ------ +#' ############################################################################### +#' +#' #' Get the AHG estimated parabolas for each hy_id/cs_id cross section given a set of cross section points +#' #' +#' #' @param cross_section_pts dataframe or sf dataframe with "hy_id", "cs_id", "bottom" columns and +#' #' specififed "top_width", "depth", "dingman_r" columns (see top_width, depth, and dingman_r arguments) +#' #' @param top_width character or tidy selector column name of top width value column. Default is "owp_tw_inchan" +#' #' @param depth character or tidy selector column name of Y depth value column. Default is "owp_y_inchan" +#' #' @param dingman_r numeric, Dingman's R coeffiecient. Default is "owp_dingman_r". +#' #' @importFrom dplyr bind_rows rowwise select group_by slice ungroup filter mutate +#' #' @importFrom AHGestimation cross_section +#' #' @importFrom tidyr unnest +#' #' @importFrom rlang as_name enquo +#' #' @return dataframe with a set of AHG points for each hy_id/cs_id in the input data, with AHG estimated X, Y, A point values that form a parabola +#' get_ahg_parabolas <- function( +#' cross_section_pts, +#' top_width = "owp_tw_inchan", +#' depth = "owp_y_inchan", +#' dingman_r = "owp_dingman_r" +#' ) { +#' +#' # cross_section_pts <- +#' # cs_ml %>% +#' # dplyr::slice(1:20) +#' # cross_section_pts = cross_section_pts +#' # # top_width = {{top_width}}, +#' # # depth = {{depth}}, +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # length_col = "cs_lengthm" +#' # cross_section_pts = dplyr::slice(inchannel_cs, 1:10) +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # dingman_r = "owp_dingman_r" +#' +#' # this function will take in one of the AHG estimated parabolas, a bottom depth, and the estimated inchannel depth +#' # and if there are infinite/NaN/NA values in the AHG estimated parabolas depth ("Y"), +#' # we pin the the left and right side of the parabola to the input bottomZ and set +#' # the bottom depth to the input bottom minus the given inchannel depth estimate +#' # TODO: Probably won't be a permanent solution if the AHG estimation package ends up never returning NaN/Infinite values +#' make_rectangle_if_needed <- function(parabola_df, bottomZ, inchannel_depth) { +#' contains_nan_or_inf_y_values <- any(is.nan(parabola_df$Y)) || any(is.na(parabola_df$Y)) || any(is.infinite(parabola_df$Y)) +#' +#' if (contains_nan_or_inf_y_values) { +#' parabola_df[1, 'Y'] <- bottomZ +#' parabola_df[nrow(parabola_df), 'Y'] <- bottomZ +#' parabola_df[2:(nrow(parabola_df)-1), 'Y'] <- bottomZ - inchannel_depth +#' } +#' +#' return(parabola_df) +#' +#' } +#' +#' # set the parabola to align with the cross section points bottom most points +#' offset_and_partition_parabola <- function(parabola, bottomZ) { +#' +#' # indices of the left and right parabola halves +#' left_half = 1:(nrow(parabola) / 2) +#' right_half = (1 + (nrow(parabola) / 2)):nrow(parabola) +#' +#' # get the left and right side of the parabolas +#' left_parabola = parabola[left_half, ] +#' right_parabola = parabola[right_half, ] +#' +#' # shift the Z values to have there max points be at the "bottom" of the "cross_section_pts" points +#' left_parabola$Y <- left_parabola$Y + (bottomZ - max(left_parabola$Y)) +#' right_parabola$Y <- right_parabola$Y + (bottomZ - max(right_parabola$Y)) +#' +#' left_parabola$partition <- "left" +#' right_parabola$partition <- "right" +#' # left_parabola <- +#' # left_parabola %>% +#' # dplyr::mutate( +#' # left_max = max(x, na.rm = TRUE) +#' # ) +#' parabola <- dplyr::bind_rows( +#' left_parabola, +#' right_parabola +#' ) +#' +#' return(parabola) +#' } +#' +#' top_width_str <- rlang::as_name(rlang::enquo(top_width)) +#' depth_str <- rlang::as_name(rlang::enquo(depth)) +#' dingman_r_str <- rlang::as_name(rlang::enquo(dingman_r)) +#' +#' # message("top_width_str: ", top_width_str) +#' # message("depth_str: ", depth_str) +#' # message("dingman_r_str: ", dingman_r_str) +#' # message("class top_width_str: ", class(top_width_str)) +#' # message("class depth_str: ", class(depth_str)) +#' # message("class dingman_r_str: ", class(dingman_r_str)) +#' +#' # check that the top_width, depth, and dingman_r values are columns in the input dataframe +#' if (!top_width_str %in% names(cross_section_pts)) { +#' stop(paste0("'top_width' column '", top_width_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' if (!depth_str %in% names(cross_section_pts)) { +#' stop(paste0("'depth' column '", depth_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' if (!dingman_r_str %in% names(cross_section_pts)) { +#' stop(paste0("'dingman_r' column '", dingman_r_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' ahg_parameters <- +#' cross_section_pts %>% +#' dplyr::select(hy_id, cs_id, bottom, +#' dplyr::any_of(c(top_width, depth, dingman_r)) +#' # .data[[top_width]], +#' # .data[[depth]], +#' # .data[[dingman_r]] +#' # !!dplyr::sym(top_width), +#' # !!dplyr::sym(depth), +#' # !!dplyr::sym(dingman_r), +#' # {{top_width}}, {{depth}}, {{dingman_r}} +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::slice(1) %>% +#' dplyr::ungroup() +#' +#' # remove any cross sections that are missing top_width, depth, or dingman_r +#' set_aside <- +#' ahg_parameters %>% +#' dplyr::filter(is.na(.data[[top_width]]) | is.na(.data[[depth]]) | is.na(.data[[dingman_r]]) ) +#' # dplyr::filter(is.na(get(top_width)) | is.na(get(depth)) | is.na(get(dingman_r)) ) +#' # dplyr::filter(is.na({{top_width}}) | is.na({{depth}}) | is.na({{dingman_r}}) ) +#' +#' ahg_parameters <- +#' ahg_parameters %>% +#' hydrofabric3D::add_tmp_id() %>% +#' dplyr::filter(!tmp_id %in% hydrofabric3D::add_tmp_id(set_aside)$tmp_id) %>% +#' dplyr::select(-tmp_id) %>% +#' dplyr::rowwise() %>% +#' dplyr::mutate( +#' parabola = list( +#' AHGestimation::cross_section( +#' # r = get(dingman_r), +#' # TW = get(top_width), +#' # Ymax = get(depth) +#' r = .data[[dingman_r]], +#' TW = .data[[top_width]], +#' Ymax = .data[[depth]] +#' # r = {{dingman_r}}, +#' # TW = {{top_width}}, +#' # Ymax = {{depth}} +#' ) +#' # dplyr::mutate( +#' # Y = dplyr::case_when( +#' # ind == 2 ~ NaN, +#' # TRUE ~ Y +#' # ) +#' # ) +#' ) +#' ) +#' +#' ahg_parameters <- +#' ahg_parameters %>% +#' dplyr::rowwise() %>% +#' dplyr::mutate( +#' parabola = list( +#' make_rectangle_if_needed( +#' parabola, +#' bottom, +#' # NOTE: Not sure why i had this like this, should use the bottom as the anchor...? +#' # {{top_width}}, +#' # {{depth}} +#' # get(top_width), +#' # get(depth) +#' .data[[depth]] +#' ) +#' # parabola = purrr::map2(parabola, bottom, {{depth}}, make_rectangle_if_needed) +#' ) +#' ) %>% +#' dplyr::rowwise() %>% +#' dplyr::mutate( +#' parabola = list( +#' offset_and_partition_parabola( +#' parabola, +#' bottom +#' ) +#' # parabola = purrr::map2(parabola, bottom, {{depth}}, make_rectangle_if_needed) +#' ) +#' ) +#' +#' # unnest the parabola dataframes and rename columns then return +#' ahg_parameters <- +#' ahg_parameters %>% +#' dplyr::select(hy_id, cs_id, parabola) %>% +#' tidyr::unnest(c(parabola)) %>% +#' # dplyr::group_by(hy_id, cs_id, partition) %>% +#' # dplyr::group_by(hy_id, cs_id) %>% +#' # dplyr::mutate( +#' # left_max = max(x, na.rm = TRUE) +#' # ) %>% +#' # dplyr::ungroup() %>% +#' dplyr::select(hy_id, cs_id, +#' ahg_index = ind, +#' ahg_x = x, +#' ahg_y = Y, +#' ahg_a = A, +#' # left_max, +#' partition +#' ) +#' +#' # plot(ahg_parameters$ahg_y) +#' +#' return(ahg_parameters) +#' } +#' +#' +#' #' Generate X/Y coordinates between a set of known points within a cross section +#' #' After +#' #' +#' #' @param cross_section_pts cross section points dataframe with missing X/Y coordinates between sets of known X/Y coordinates +#' #' +#' #' @return +#' #' @export +#' #' +#' #' @examples +#' fill_missing_ahg_coords <- function(cross_section_pts) { +#' +#' # cross_section_pts <- +#' # cs_bathy_inchannel %>% +#' # # dplyr::slice(1:159) +#' # dplyr::slice(1:171375) +#' +#' # cross_section_pts <- cs_bathy_inchannel +#' +#' #Fix the missing X/Y coordinates (NAs) from the inserted AHG Parabola points in a set of cross section points +#' seq_between_start_and_end <- function(start, end, n) { +#' # df = fix_coords +#' +#' if (n == 0) { +#' return(NULL) +#' } +#' +#' # Generate new X / Y coordinates +#' # coords <- seq(start, end, length.out = n ) +#' coords <- seq(start, end, length.out = n + 2) +#' +#' # return(coords) +#' return(coords[2:(length(coords) - 1)]) +#' } +#' +#' +#' # get the first and last coordinates beforee the missing NA X/Y points +#' start_and_end_coords <- get_coords_around_parabola(cross_section_pts) +#' +#' # +#' start_and_end_pts_ids <- +#' cross_section_pts %>% +#' dplyr::filter(!is_dem_point) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::summarize( +#' start_pt_id = min(pt_id, na.rm = TRUE) +#' ) %>% +#' dplyr::ungroup() +#' +#' # get only the rows with the parabola w/ missing X/Y coords +#' parabola_pts <- +#' cross_section_pts %>% +#' dplyr::filter(!is_dem_point) %>% +#' dplyr::left_join( +#' start_and_end_coords, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' dplyr::select(hy_id, cs_id, pt_id, X, Y, +#' dplyr::ends_with("_start"), dplyr::ends_with("end")) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' n = dplyr::n() +#' ) %>% +#' dplyr::ungroup() +#' +#' # generate coordinates for each parabola +#' parabola_coords <- +#' parabola_pts %>% +#' dplyr::left_join( +#' start_and_end_pts_ids, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' dplyr::select(hy_id, cs_id, start_pt_id, dplyr::ends_with("_start"), dplyr::ends_with("end"), n) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::slice(1) %>% +#' dplyr::mutate( +#' X = list(seq_between_start_and_end(X_start, X_end, n)), +#' Y = list(seq_between_start_and_end(Y_start, Y_end, n)) +#' ) %>% +#' tidyr::unnest(c(X, Y)) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' pt_id = (start_pt_id - 1) + (1:dplyr::n()) +#' # pt_id = start_pt_id + (0:(dplyr::n()-1)) +#' ) %>% +#' dplyr::ungroup() %>% +#' dplyr::select(hy_id, cs_id, pt_id, X, Y) +#' # dplyr::select(hy_id, cs_id, X, Y) +#' +#' # join the new parabola X/Y points with the rest of the original data, dropping the old NA X/Y coordinates +#' parabolas_with_coords <- +#' cross_section_pts %>% +#' dplyr::filter(!is_dem_point) %>% +#' dplyr::select(-X, -Y) %>% +#' dplyr::left_join( +#' parabola_coords, +#' by = c("hy_id", "cs_id", "pt_id") +#' ) +#' +#' pts_with_fixed_coords <- +#' dplyr::bind_rows( +#' dplyr::filter(cross_section_pts, is_dem_point), +#' parabolas_with_coords +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::arrange(relative_distance, .by_group = TRUE) %>% +#' # dplyr::arrange(pt_id, .by_group = TRUE) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' pt_id = 1:dplyr::n() +#' ) %>% +#' dplyr::ungroup() +#' +#' # pts_with_fixed_coords %>% +#' # dplyr::group_by(hy_id, cs_id) +#' # +#' # pts_with_fixed_coords %>% +#' # dplyr::slice(1:15000) %>% +#' # sf::st_as_sf(coords = c("X", "Y"), crs = 5070) %>% +#' # mapview::mapview() +#' return(pts_with_fixed_coords) +#' } +#' +#' #' Get the coordinates surrounding a set of missing AHG X/Y coordinates. +#' #' +#' #' @param cross_section_pts dataframe with cross section points, (required cols, "hy_id", "cs_id", "X", "Y", "is_dem_point") +#' #' @importFrom tidyr pivot_wider +#' #' @importFrom select group_by mutate lag lead case_when filter ungroup left_join +#' #' @return dataframe with each hy_id/cs_id cross section containing a value for X_start, X_end, Y_start, Y_end, representing the points surrounding the AHG inserted points +#' #' @export +#' get_coords_around_parabola <- function(cross_section_pts) { +#' +#' fill_value <- -999999999 +#' +#' X_coords <- +#' cross_section_pts %>% +#' dplyr::select(hy_id, cs_id, X, is_dem_point) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' X = ifelse(is.na(X), fill_value, X) +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' next_X_is_missing = dplyr::case_when( +#' dplyr::lead(X) == fill_value ~ TRUE, +#' # is_dem_point & is.na(dplyr::lead(X)) ~ TRUE, +#' TRUE ~ FALSE +#' ), +#' prev_X_is_missing = dplyr::case_when( +#' dplyr::lag(X) == fill_value ~ TRUE, +#' # is_dem_point & is.na(dplyr::lead(X)) ~ TRUE, +#' TRUE ~ FALSE +#' ) +#' ) %>% +#' dplyr::filter((is_dem_point & next_X_is_missing) | (is_dem_point & prev_X_is_missing)) %>% +#' dplyr::mutate( +#' start_or_end = dplyr::case_when( +#' # is_dem_point & is.na(dplyr::lead(X)) ~ TRUE, +#' (is_dem_point & next_X_is_missing) ~ "X_start", +#' (is_dem_point & prev_X_is_missing) ~ "X_end" +#' ) +#' ) %>% +#' dplyr::ungroup() %>% +#' dplyr::select(hy_id, cs_id, X, is_dem_point, start_or_end) +#' +#' # X_coords %>% +#' # dplyr::group_by(hy_id, cs_id) +#' +#' # pivot so each cross sections is a single row with a "X_start" and "X_end" point +#' X_coords <- +#' X_coords %>% +#' # dplyr::select(-is_dem_point) %>% +#' tidyr::pivot_wider( +#' id_cols = c(hy_id, cs_id), +#' names_from = start_or_end, +#' values_from = X +#' ) +#' +#' Y_coords <- +#' cross_section_pts %>% +#' dplyr::select(hy_id, cs_id, Y, is_dem_point) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' Y = ifelse(is.na(Y), fill_value, Y) +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' next_Y_is_missing = dplyr::case_when( +#' dplyr::lead(Y) == fill_value ~ TRUE, +#' TRUE ~ FALSE +#' ), +#' prev_Y_is_missing = dplyr::case_when( +#' dplyr::lag(Y) == fill_value ~ TRUE, +#' TRUE ~ FALSE +#' ) +#' ) %>% +#' dplyr::filter((is_dem_point & next_Y_is_missing) | (is_dem_point & prev_Y_is_missing)) %>% +#' dplyr::mutate( +#' start_or_end = dplyr::case_when( +#' (is_dem_point & next_Y_is_missing) ~ "Y_start", +#' (is_dem_point & prev_Y_is_missing) ~ "Y_end" +#' ) +#' ) %>% +#' dplyr::ungroup() %>% +#' dplyr::select(hy_id, cs_id, Y, is_dem_point, start_or_end) +#' +#' # pivot so each cross sections is a single row with a "X_start" and "X_end" point +#' Y_coords <- +#' Y_coords %>% +#' tidyr::pivot_wider( +#' id_cols = c(hy_id, cs_id), +#' names_from = start_or_end, +#' values_from = Y +#' ) +#' +#' coords_around_parabola <- dplyr::left_join( +#' X_coords, +#' Y_coords, +#' by = c("hy_id", "cs_id") +#' ) +#' +#' return(coords_around_parabola) +#' } +#' +#' #' Check that all cross sections points have a prescribed top width less than the total cross section length +#' #' @description +#' #' If a set of cross section points has a top width length that is longer than the cross sections length, then a new top width and Y max (depth) value +#' #' are given so that the estimated shape is able to properly fit into the cross sections. +#' #' The cross sections length (meters) minus 1 meter is used as the new top width and +#' #' the new Y max (depth) value is derived from the original ratio between the prescribed top width and Y max +#' #' @param cross_section_pts dataframe or sf dataframe with hy_id, cs_id, +#' #' @param top_width character or tidy selector column name of top width value column. Default is "owp_tw_inchan" +#' #' @param depth character or tidy selector column name of Y depth value column. Default is "owp_y_inchan" +#' #' @param length_col character or tidy selector column name of the numeric total cross section length column (meters). Default is "cs_lengthm" +#' #' @importFrom rlang as_name enquo +#' #' @importFrom dplyr group_by mutate case_when sym ungroup select filter slice +#' #' @return cross_section_pts dataframe with updated "top_width" and "depth" column values +#' fix_oversized_topwidths <- function( +#' cross_section_pts = NULL, +#' top_width = "owp_tw_inchan", +#' depth = "owp_y_inchan", +#' length_col = "cs_lengthm" +#' ) { +#' +#' # use this to get a new scaled Ymax value given a known Top width, Ymax (ML generated in this case) +#' # and an expected new Top width (new_TW), this function is used to handle +#' # the case when the ML estimated top width is GREATER than the DEM cross section length +#' scale_Ymax_to_TW <- function(TW, Ymax, new_TW) { +#' +#' new_Ymax <- Ymax * (new_TW / TW) +#' +#' return(new_Ymax) +#' +#' } +#' +#' if (is.null(cross_section_pts)) { +#' stop( +#' paste0("'cross_section_pts' is NULL, provide a dataframe with the following columns:\n> ", +#' paste0(c('hy_id', 'cs_id', 'Z', 'bottom', 'relative_distance', +#' 'point_type', 'class', +#' 'top_width - (specify via "top_width" argument)', +#' 'depth - (specify via "depth" argument)', +#' 'dingman_r - (specify via "dingman_r" argument)' +#' ), +#' collapse = "\n> ")) +#' ) +#' } +#' +#' # original_cs %>% +#' # hydrofabric3D::plot_cs_pts(x = "relative_distance") +#' +#' +#' ############################################## +#' ############################################## +#' # cross_section_pts <- +#' # inchannel_cs %>% +#' # # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") +#' # # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("3")) +#' # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) +#' # # +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # length_col = "cs_lengthm" +#' +#' # # cross_section_pts %>% +#' # # hydrofabric3D::plot_cs_pts(x = "relative_distance") +#' +#' ############################################## +#' ############################################## +#' +#' top_width_str <- rlang::as_name(rlang::enquo(top_width)) +#' depth_str <- rlang::as_name(rlang::enquo(depth)) +#' length_col_str <- rlang::as_name(rlang::enquo(length_col)) +#' +#' # check that the top_width, depth, and dingman_r values are columns in the input dataframe +#' if (!top_width_str %in% names(cross_section_pts)) { +#' stop(paste0("'top_width' column '", top_width_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' if (!depth_str %in% names(cross_section_pts)) { +#' stop(paste0("'depth' column '", depth_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' if (!depth_str %in% names(cross_section_pts)) { +#' stop(paste0("'depth' column '", depth_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' # keep track of the original column order for reordering at the end +#' starting_col_order <- names(cross_section_pts) +#' +#' # Determine the distance interval for each cross section +#' # we're going to use this value to +#' # derive a new Top width for each cross section if +#' # the cross section length is less than the prescribed top width, +#' # we round the distance interval UP sure we are not underestimating the interval +#' distance_between_pts <- +#' cross_section_pts %>% +#' dplyr::select(hy_id, cs_id, relative_distance) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' distance_interval = relative_distance - dplyr::lag(relative_distance) +#' ) %>% +#' dplyr::summarise( +#' distance_interval = ceiling(mean(distance_interval, na.rm = TRUE)) # TODO: round up to make sure we are not underestimating +#' # the interval, we're going to use this value to +#' # derive a new Top width for each cross section if +#' # the cross section length is less than the prescribed top width +#' ) %>% +#' dplyr::ungroup() +#' +#' # add the distance interval values to the cross section points +#' cross_section_pts <- +#' cross_section_pts %>% +#' dplyr::left_join( +#' distance_between_pts, +#' by = c("hy_id", "cs_id") +#' ) +#' # message("Ending col order:\n> ", paste0(names(cross_section_pts), collapse = "\n> ")) +#' +#' updated_TW_and_Ymax <- +#' cross_section_pts %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' new_Ymax = dplyr::case_when( +#' get(top_width) >= get(length_col) ~ scale_Ymax_to_TW(!!dplyr::sym(top_width), +#' !!dplyr::sym(depth), +#' !!dplyr::sym(length_col) - distance_interval +#' # !!dplyr::sym(length_col) - 1 # TODO: arbitrarily remove 1 meter from the length to +#' # TODO: make sure topwidth/depth is SMALLER than cross section length +#' # TODO: so the AHG parabola points can fit within cross section +#' # !!dplyr::sym(length_col) +#' # TODO: Original method ^^^ (no subtraction) +#' ), +#' TRUE ~ !!dplyr::sym(depth) +#' # owp_tw_inchan >= cs_lengthm ~ scale_Ymax_to_TW(owp_tw_inchan, owp_y_inchan, cs_lengthm), +#' # TRUE ~ owp_y_inchan +#' ), +#' new_TW = dplyr::case_when( +#' get(top_width) >= get(length_col) ~ !!dplyr::sym(length_col) - distance_interval, # TODO: Same arbitrary subtraction of 1 meter as above note ^^^ +#' # get(top_width) >= get(length_col) ~ !!dplyr::sym(length_col) - 1, # TODO: Same arbitrary subtraction of 1 meter as above note ^^^ +#' # get(top_width) >= get(length_col) ~ !!dplyr::sym(length_col), # TODO: Original method (no subtraction) +#' TRUE ~ !!dplyr::sym(top_width) +#' # owp_tw_inchan >= cs_lengthm ~ cs_lengthm, +#' # TRUE ~ owp_tw_inchan +#' ), +#' has_new_Ymax = new_Ymax != get(depth), +#' has_new_TW = new_TW != get(top_width), +#' fixed_TW = has_new_Ymax | has_new_TW +#' ) %>% +#' dplyr::ungroup() %>% +#' # dplyr::relocate(hy_id, cs_id, cs_lengthm, owp_tw_inchan, +#' # new_TW, new_TW2, owp_y_inchan, new_Ymax, new_Ymax2, fixed_TW) +#' dplyr::select( +#' -has_new_Ymax, +#' -has_new_TW, +#' -{{top_width}}, +#' -{{depth}} +#' ) +#' +#' # number of cross sections that had their TW/Depths changed to fit into the cross section properly +#' number_fixed_TWs <- +#' updated_TW_and_Ymax %>% +#' dplyr::filter(fixed_TW) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::slice(1) %>% +#' dplyr::ungroup() %>% +#' nrow() +#' +#' if (number_fixed_TWs > 0) { +#' warning( +#' "Had to fix ", number_fixed_TWs, " cross section(s) top width/depth values to make sure", +#' "\nthe prescribed topwidth is not greater than or equal to the length of", +#' "\nthe entire cross section (meters), the cross section(s) total length is", +#' "\nused as the new TW and the ratio of the prescribed TW to the prescribed depth", +#' "\nis used to calculate a new depth (Y) value." +#' ) +#' } +#' +#' # Drop the flag column that says if the top width had to be fixed +#' updated_TW_and_Ymax <- dplyr::select(updated_TW_and_Ymax, +#' -fixed_TW) +#' +#' # any starting columns in the original data +#' ending_col_order <- names(updated_TW_and_Ymax) +#' +#' # message("Ending col order:\n> ", paste0(names(updated_TW_and_Ymax), collapse = "\n> ")) +#' +#' # change the new_TW and new_Ymax columns to match the original input TW/Depth column names +#' ending_col_order[ending_col_order == "new_TW"] <- top_width_str +#' ending_col_order[ending_col_order == "new_Ymax"] <- depth_str +#' +#' # update the names +#' names(updated_TW_and_Ymax) <- ending_col_order +#' +#' # reorder columns to original order +#' updated_TW_and_Ymax <- updated_TW_and_Ymax[starting_col_order] +#' +#' return(updated_TW_and_Ymax) +#' } +#' +#' # cross_section_pts <- +#' # inchannel_cs %>% +#' # # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") +#' # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # dingman_r = "owp_dingman_r" +#' # cross_section_pts$owp_tw_bf +#' +#' #' Given provide inchannel widths and depths to a set of cross section points and derive estimated shapes +#' #' @description +#' #' Still in early development phases +#' #' @param cross_section_pts dataframe or sf dataframe. Default is NULL +#' #' @param top_width character or tidy selector column name of top width value column. Default is "owp_tw_inchan" +#' #' @param depth character or tidy selector column name of Y depth value column. Default is "owp_y_inchan" +#' #' @param dingman_r numeric, Dingman's R coeffiecient. Default is "owp_dingman_r". +#' #' @importFrom dplyr bind_rows select mutate n case_when summarise ungroup group_by filter relocate left_join slice slice_max rename arrange +#' #' @importFrom AHGestimation cross_section +#' #' @importFrom stats median +#' #' @importFrom rlang as_name enquo +#' #' @return dataframe or sf dataframe with AHG estimated points injected into the input cross section points +#' #' @export +#' add_cs_bathymetry <- function( +#' cross_section_pts = NULL, +#' top_width = "owp_tw_inchan", +#' depth = "owp_y_inchan", +#' dingman_r = "owp_dingman_r" +#' ) { +#' +#' if (is.null(cross_section_pts)) { +#' stop( +#' paste0("'cross_section_pts' is NULL, provide a dataframe with the following columns:\n> ", +#' paste0(c('hy_id', 'cs_id', 'Z', 'bottom', 'relative_distance', +#' 'point_type', 'class', +#' 'top_width - (specify via "top_width" argument)', +#' 'depth - (specify via "depth" argument)', +#' 'dingman_r - (specify via "dingman_r" argument)' +#' ), +#' collapse = "\n> ")) +#' ) +#' } +#' +#' ########################################################## +#' ########################################################## +#' # cross_section_pts <- +#' # inchannel_cs %>% +#' # # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") +#' # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # dingman_r = "owp_dingman_r" +#' +#' ########################################################## +#' ########################################################## +#' +#' top_width_str <- rlang::as_name(rlang::enquo(top_width)) +#' depth_str <- rlang::as_name(rlang::enquo(depth)) +#' dingman_r_str <- rlang::as_name(rlang::enquo(dingman_r)) +#' +#' # check that the top_width, depth, and dingman_r values are columns in the input dataframe +#' if (!top_width_str %in% names(cross_section_pts)) { +#' stop(paste0("'top_width' column '", top_width_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' if (!depth_str %in% names(cross_section_pts)) { +#' stop(paste0("'depth' column '", depth_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' if (!dingman_r_str %in% names(cross_section_pts)) { +#' stop(paste0("'dingman_r' column '", dingman_r_str, "' does not exist in cross_section_pts dataframe")) +#' } +#' +#' # Replace any topwidth values that are GREATER than the actual cross section length (meters) +#' cross_section_pts <- fix_oversized_topwidths( +#' cross_section_pts = cross_section_pts, +#' top_width = {{top_width}}, +#' depth = {{depth}}, +#' length_col = "cs_lengthm" +#' ) +#' +#' # cross_section_pts <- fix_oversized_topwidths( +#' # cross_section_pts = cross_section_pts, +#' # # top_width = {{top_width}}, +#' # # depth = {{depth}}, +#' # top_width = "owp_tw_inchan", +#' # depth = "owp_y_inchan", +#' # length_col = "cs_lengthm" +#' # ) +#' +#' # generate AHG parabolas for each hy_id/cs_id in the cross section points +#' # using the provided top_widths, depths, and dingman's R +#' ahg_parabolas <- get_ahg_parabolas( +#' cross_section_pts = cross_section_pts, +#' top_width = {{top_width}}, +#' depth = {{depth}}, +#' dingman_r = {{dingman_r}} +#' ) +#' +#' # ahg_parabolas %>% +#' # hydrofabric3D::add_tmp_id() %>% +#' # ggplot2::ggplot() + +#' # ggplot2::geom_point(ggplot2::aes(x = ahg_x, y = ahg_y)) + +#' # ggplot2::facet_wrap(hy_id~cs_id) +#' +#' # bads <- cs_bathy_inchannel %>% +#' # dplyr::group_by(hy_id, cs_id) %>% +#' # dplyr::filter(owp_tw_inchan >= cs_lengthm) %>% +#' # dplyr::mutate( new_Ymax = scale_Ymax_to_TW(owp_tw_inchan, owp_y_inchan, cs_lengthm)) %>% +#' # dplyr::select(hf_id, hy_id, cs_id, cs_lengthm, owp_tw_inchan, owp_y_inchan, new_Ymax) +#' +#' # ############################################## +#' # ################# Testing area ############### +#' # ############################################## +#' # +#' # cross_section_pts <- +#' # inchannel_cs %>% +#' # # dplyr::filter(hy_id == "wb-1002477", cs_id == "2") +#' # dplyr::filter(hy_id == "wb-1002477", cs_id %in% c("2", "3")) +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # dingman_r = "owp_dingman_r" +#' +#' # cross_section_pts <- bad_inchannels +#' # top_width = "owp_tw_inchan" +#' # depth = "owp_y_inchan" +#' # dingman_r = "owp_dingman_r" +#' +#' # cross_section_pts <- fix_oversized_topwidths( +#' # cross_section_pts = cross_section_pts, +#' # top_width = "owp_tw_inchan", +#' # depth = "owp_y_inchan", +#' # length_col = "cs_lengthm" +#' # ) +#' # +#' # ahg_parabolas <- get_ahg_parabolas( +#' # cross_section_pts = cross_section_pts, +#' # top_width = "owp_tw_inchan", +#' # depth = "owp_y_inchan", +#' # dingman_r = "owp_dingman_r" +#' # ) +#' +#' # ahg_parabolas[ahg_parabolas$cs_id == 2, ]$ahg_y %>% plot() +#' # ahg_parabolas[ahg_parabolas$cs_id == 3, ]$ahg_y %>% plot() +#' # +#' # ############################################## +#' # ############################################## +#' +#' # plot(ahg_parabolas$ahg_y) +#' +#' # store the maximum X on the left side of the parabola for later use +#' ahg_left_max <- +#' ahg_parabolas %>% +#' dplyr::filter(partition == "left") %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::summarise(left_max = max(ahg_x, na.rm = TRUE)) %>% +#' dplyr::ungroup() +#' +#' # ------------------------------------------------------------------------------------------------ +#' # ---- Partition input cross section points (left/right) ---- +#' # ------------------------------------------------------------------------------------------------ +#' +#' # split the cross section into a left and right half, from the midpoint of the bottom +#' # and then join on the maximum X point of the LEFT half of the AHG parabolas +#' # this paritioned set of cross sections will ultimately get the AHG parabolas inserted in between the left and right partitions +#' partioned_cs <- +#' cross_section_pts %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' # relative_distance_of_bottom = point_type == "bottom" +#' bottom_midpoint = dplyr::case_when( +#' point_type == "bottom" ~ relative_distance, +#' TRUE ~ NA +#' ), +#' bottom_midpoint = stats::median(bottom_midpoint, na.rm = TRUE) +#' ) %>% +#' # dplyr::relocate(bottom_midpoint) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' # relative_distance_of_bottom = point_type == "bottom" +#' cs_partition = dplyr::case_when( +#' relative_distance < bottom_midpoint ~ "left_cs", +#' TRUE ~ "right_cs" +#' ) +#' # bottom_midpoint = stats::median(bottom_midpoint, na.rm = TRUE) +#' ) %>% +#' dplyr::left_join( +#' ahg_left_max, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' # dplyr::relocate(left_max, bottom_midpoint, cs_partition) %>% +#' dplyr::ungroup() +#' +#' # get the midpoint value for each hy_id/cs_id so we can use them during the shifting process +#' midpoints <- +#' partioned_cs %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::select(hy_id, cs_id, bottom_midpoint) %>% +#' dplyr::slice(1) %>% +#' dplyr::ungroup() +#' +#' # ------------------------------------------------------------------------------------------------ +#' # ---- Process LEFT side of cross section and parabola ---- +#' # ------------------------------------------------------------------------------------------------ +#' # # lefty <- +#' # partioned_cs %>% +#' # # dplyr::filter(cs_partition == "left_cs") %>% +#' # dplyr::group_by(hy_id, cs_id) %>% +#' # # dplyr::mutate( +#' # # res = bottom_midpoint - max(left_max), +#' # # mark = relative_distance < bottom_midpoint - max(left_max) | relative_distance == 0 +#' # # ) %>% +#' # # dplyr::relocate(res, mark, relative_distance) +#' # dplyr::filter( +#' # relative_distance < (bottom_midpoint - max(left_max)) | relative_distance == 0 +#' # # relative_distance < 0 +#' # ) +#' # left_new <- partioned_cs %>% +#' # dplyr::filter(cs_partition == "left_cs") %>% +#' # dplyr::group_by(hy_id, cs_id) %>% +#' # dplyr::filter( +#' # # relative_distance < (bottom_midpoint - max(left_max)) +#' # relative_distance < (bottom_midpoint - max(left_max)) | relative_distance == 0 # TODO: testing this new condition out +#' # ) +#' +#' # # TODO: look back at this tomorrow +#' # left_side_pt_counts <- +#' # partioned_cs %>% +#' # dplyr::filter(cs_partition == "left_cs") %>% +#' # dplyr::group_by(hy_id, cs_id) %>% +#' # dplyr::mutate( +#' # marked = relative_distance < (bottom_midpoint - max(left_max)) +#' # ) %>% +#' # dplyr::select(hy_id, cs_id, marked) %>% +#' # dplyr::summarise(total_left_side_pts = sum(marked, na.rm = TRUE)) %>% +#' # dplyr::ungroup() +#' # partioned_cs %>% +#' # dplyr::filter(cs_partition == "left_cs") %>% +#' # dplyr::left_join( +#' # left_side_pt_counts, +#' # by = c("hy_id", "cs_id") +#' # ) +#' +#' # grab just the left cross sections and remove any points that will be swallowed by the newly inserted AHG estimates +#' # And also determine the offset of the left parabolas X points, the left_start will be joined back onto the AHG parabolas +#' left_cs <- +#' partioned_cs %>% +#' dplyr::filter(cs_partition == "left_cs") %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::filter( +#' # relative_distance < (bottom_midpoint - max(left_max)) +#' relative_distance < (bottom_midpoint - max(left_max)) | relative_distance == 0 # TODO: testing this new condition out +#' # relative_distance < (bottom_midpoint - max(left_max)) | (relative_distance == 0 & total_left_side_pts == 0) # TODO: testing this new condition out +#' ) %>% +#' dplyr::mutate( +#' left_start = bottom_midpoint - max(left_max) +#' ) %>% +#' dplyr::ungroup() +#' +#' left_starts <- +#' left_cs %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::select(hy_id, cs_id, left_start) %>% +#' dplyr::slice(1) %>% +#' dplyr::ungroup() +#' +#' # offset the left parabolas X points using the left_start value +#' left_parabolas <- +#' ahg_parabolas %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::filter(partition == "left") %>% +#' dplyr::ungroup() %>% +#' dplyr::left_join( +#' left_starts, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' ahg_x = ahg_x + left_start +#' ) %>% +#' dplyr::ungroup() +#' +#' # ------------------------------------------------------------------------------------------------ +#' # ---- Process RIGHT side of cross section and parabola ---- +#' # ------------------------------------------------------------------------------------------------ +#' +#' # subset cross section to the RIGHT of the midpoint +#' right_cs <- +#' partioned_cs %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::filter(relative_distance > bottom_midpoint) %>% +#' # dplyr::filter(cs_partition == "right_cs") +#' dplyr::ungroup() +#' +#' right_parabolas <- +#' ahg_parabolas %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::filter(partition == "right") %>% +#' dplyr::ungroup() %>% +#' dplyr::left_join( +#' ahg_left_max, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' dplyr::left_join( +#' midpoints, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' right_start = bottom_midpoint + ((ahg_x) - left_max) +#' ) %>% +#' dplyr::ungroup() +#' +#' # ---------------------------------------------------------------------------------------------------------------- +#' # ------- Still reviewing this additon --------- +#' # --- This ties back to the fix_oversized_topwidths() function applied at the beginning ----- +#' # ---------------------------------------------------------------------------------------------------------------- +#' # TODO: Newly added to deal with situations where the right side of the parabola is TOO LONG, +#' # TODO: and will go past the outside of the predefined cross section length +#' # TODO: This all needs to evaluated and double checked to make sure it makes +#' # TODO: sense hydrologically and won't break the standard "good" case +#' # for each cross section, we isolate the total length of the cross section +#' # to make sure that the parabola is not going past the edge of the cross section +#' total_cross_section_length <- +#' right_cs %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' # dplyr::filter(relative_distance == max(relative_distance)) %>% +#' dplyr::slice_max(relative_distance, n = 1) %>% +#' dplyr::select(hy_id, cs_id, +#' max_right_position = relative_distance) %>% +#' dplyr::ungroup() +#' +#' # from the right side of the parabola, +#' # we remove any parabola points that would be past +#' # the last right side cross section points +#' right_parabolas <- +#' right_parabolas %>% +#' dplyr::left_join( +#' total_cross_section_length, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' # dplyr::relocate(hy_id, cs_id, right_start, max_right_position) %>% +#' dplyr::filter(right_start < max_right_position) +#' +#' # ---------------------------------------------------------------------------------------------------------------- +#' # TODO: Above still needs review ^^^ +#' # ---------------------------------------------------------------------------------------------------------------- +#' +#' # getting the starting X value for the RIGHT side of the parabola +#' max_right_starting_pts <- +#' right_parabolas %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::summarise( +#' right_start_max = max(right_start, na.rm = TRUE) +#' ) %>% +#' dplyr::ungroup() +#' +#' # removing cross section point that will be replaced by right_parabola points +#' right_cs <- +#' right_cs %>% +#' dplyr::left_join( +#' max_right_starting_pts, +#' by = c("hy_id", "cs_id") +#' ) %>% +#' # dplyr::relocate(right_start_max) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::filter( +#' relative_distance > right_start_max +#' ) %>% +#' dplyr::ungroup() +#' +#' # --------------------------------------------------------------------------------------------------- +#' # ---- MERGE the left and right sides of the parabolas ----- +#' # --------------------------------------------------------------------------------------------------- +#' +#' right_parabolas <- +#' right_parabolas %>% +#' dplyr::select(-ahg_x) %>% +#' dplyr::rename(ahg_x = right_start) %>% +#' dplyr::select( +#' hy_id, cs_id, ahg_index, ahg_x, ahg_y, ahg_a, +#' partition +#' # left_max, bottom_midpoint +#' ) +#' +#' left_parabolas <- +#' left_parabolas %>% +#' dplyr::select( +#' hy_id, cs_id, ahg_index, ahg_x, ahg_y, ahg_a, +#' partition +#' ) +#' +#' # merge +#' parabolas <- dplyr::bind_rows(left_parabolas, right_parabolas) +#' +#' # reorder to parabolas by X values so they are in order from left to right for each hy_id/cs_id +#' parabolas <- +#' parabolas %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::arrange(ahg_x, .by_group = TRUE) %>% +#' dplyr::ungroup() +#' +#' # select relevant columns and adjust the names so +#' # the AHG parabola can be inserted nicely with the original cross sections +#' # NOTE: +#' # AHG X values == "relative_distance" in cross_section_pts +#' # AHG Y values == "Z" in cross_section_pts +#' parabolas <- +#' parabolas %>% +#' dplyr::select( +#' hy_id, cs_id, +#' relative_distance = ahg_x, +#' Z = ahg_y +#' ) +#' +#' # --------------------------------------------------------------------------------------------------- +#' # ---- Insert the parabolas in between the LEFT and RIGHT cross section partitions ----- +#' # --------------------------------------------------------------------------------------------------- +#' +#' # drop unneeded columns +#' left_cs <- dplyr::select(left_cs, +#' -left_start, -left_max, -bottom_midpoint, -cs_partition) +#' right_cs <- dplyr::select(right_cs, +#' -right_start_max, -left_max, -bottom_midpoint, -cs_partition) +#' +#' # combine left cross section points, parabola, and right cross section points +#' # and then reorder each cross section (hy_id/cs_id) by the relative distance +#' # so all the points are in correct order +#' out_cs <- +#' dplyr::bind_rows( +#' # left_cs, +#' # parabolas, +#' # right_cs +#' dplyr::mutate(left_cs, is_dem_point = TRUE), +#' dplyr::mutate(parabolas, is_dem_point = FALSE), +#' dplyr::mutate(right_cs, is_dem_point = TRUE), +#' ) %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::filter(relative_distance >= 0) %>% # TODO: testing out this condition as well +#' dplyr::arrange(relative_distance, .by_group = TRUE) %>% +#' dplyr::ungroup() +#' +#' # Assign / renumber the "pt_ids" and +#' # set the "point_types" of the inserted parabola points to "bottom" type +#' out_cs <- +#' out_cs %>% +#' dplyr::group_by(hy_id, cs_id) %>% +#' dplyr::mutate( +#' pt_id = 1:dplyr::n(), +#' class = dplyr::case_when( +#' is.na(class) ~ "bottom", +#' TRUE ~ class +#' ), +#' point_type = dplyr::case_when( +#' is.na(point_type) ~ "bottom", +#' TRUE ~ point_type +#' ) +#' ) %>% +#' dplyr::ungroup() +#' +#' # parabolas %>% +#' # hydrofabric3D::add_tmp_id() %>% +#' # ggplot2::ggplot() + +#' # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z)) + +#' # ggplot2::facet_wrap(~tmp_id) +#' # out_cs %>% +#' # hydrofabric3D::plot_cs_pts(x = "relative_distance", color = "is_dem_point") +#' +#' tryCatch({ +#' message("Generate XY coordinates for AHG estimated points...") +#' out_cs <- fill_missing_ahg_coords(out_cs) +#' +#' }, error = function(cond) { +#' +#' message("Failed to fix X/Y coordinates for estimated bathymetry points, returning cross section points with inserted bathymetry with missing X/Y values") +#' message(conditionMessage(cond)) +#' +#' # Choose a return value in case of error +#' return(out_cs) +#' +#' }) +#' +#' return(out_cs) +#' +#' } +#' +#' +#' #Fix the missing X/Y coordinates (NAs) from the inserted AHG Parabola points in a set of cross section points +#' fix_xy <- function(df) { +#' # df = fix_coords +#' +#' missing_coords_indices <- which(is.na(df$X)) +#' +#' if (length(missing_coords_indices) == 0) { +#' return(df) +#' } +#' +#' first_NA <- missing_coords_indices[1] +#' last_NA <- missing_coords_indices[length(missing_coords_indices)] +#' number_of_points <- length(missing_coords_indices) +#' +#' # Get the start / end X / Y points +#' start_X <- df$X[first_NA - 1] +#' end_X <- df$X[last_NA + 1] +#' start_Y <- df$Y[first_NA - 1] +#' end_Y <- df$Y[last_NA + 1] +#' +#' # Generate new X / Y coordinates +#' X_coords <- seq(start_X, end_X, length.out = number_of_points + 2) +#' Y_coords <- seq(start_Y, end_Y, length.out = number_of_points + 2) +#' +#' # Insert the new coordinates into the original missing rows +#' df[first_NA:last_NA, ]$X <- X_coords[2:(length(X_coords) - 1)] +#' df[first_NA:last_NA, ]$Y <- Y_coords[2:(length(Y_coords) - 1)] +#' +#' return(df) +#' } +#' +#' # TODO: DELETE DEPRECATED +#' +#' #' Given provide inchannel widths and depths to a set of cross section points and derive estimated shapes +#' #' @description +#' #' Still in early development phases +#' #' @param cross_section_pts dataframe or sf dataframe +#' #' @param r numeric, R coefficient +#' #' @param inchannel_width numeric +#' #' @param inchannel_depth numeric +#' #' @param drop_negative_depths logical, whether to remove any depths that are negative, default is FALSE (probably Deprecated at this point) +#' #' @importFrom dplyr bind_rows select mutate n case_when +#' #' @importFrom AHGestimation cross_section +#' #' @importFrom stats median +#' #' @return dataframe or sf dataframe with AHG estimated points injected into the input cross section points +#' #' @export +#' cs_inchannel_estimate <- function( +#' cross_section_pts, +#' r = 3, +#' inchannel_width, +#' inchannel_depth, +#' drop_negative_depths = FALSE +#' ) { +#' +#' ##################################### +#' +#' ##################################### +#' +#' primary_z <- cross_section_pts$Z +#' rel_distance <- cross_section_pts$relative_distance +#' channel_point_type <- cross_section_pts$point_type +#' +#' # hydrofabric3D::plot_cs_pts(cross_section_pts, color = "point_type") +#' # plot(primary_z) +#' +#' # cross_section_pts %>% +#' # ggplot2::ggplot() + +#' # ggplot2::scale_y_continuous(limits = c(0, max(cross_section_pts$Z)), +#' # breaks = seq(0, max(cross_section_pts$Z), +#' # by = (max(cross_section_pts$Z) - min(cross_section_pts$Z)) / 4)) + +#' # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = point_type) )+ +#' # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = point_type) )+ +#' # ggplot2::facet_grid(hy_id~cross_section_pts_id, scale = "free_y") +#' +#' # # relative distance of the bottoms +#' bottom <- rel_distance[channel_point_type == "bottom"] +#' bottomZ <- primary_z[channel_point_type == "bottom"] +#' +#' # # find the middle of the bottom +#' midpoint <- stats::median(bottom) +#' +#' # generate AHG estimates +#' ahg_est <- AHGestimation::cross_section( +#' r = r, +#' TW = inchannel_width, +#' Ymax = inchannel_depth +#' ) +#' +#' # plot(ahg_est$Y) +#' +#' # indices of the left and right parabola halves +#' left_half = 1:(nrow(ahg_est) / 2) +#' right_half = (1 + (nrow(ahg_est) / 2)):nrow(ahg_est) +#' +#' # get the left and right side of the parabolas +#' left_parabola = ahg_est[left_half, ] +#' right_parabola = ahg_est[right_half, ] +#' +#' # shift the Z values to have there max points be at the "bottom" of the "cross_section_pts" points +#' left_parabola$Y <- left_parabola$Y + (bottomZ[1] - max(left_parabola$Y)) +#' right_parabola$Y <- right_parabola$Y + (bottomZ[1] - max(right_parabola$Y)) +#' +#' # set any negative values in parabola to 0 +#' if (drop_negative_depths) { +#' left_parabola$Y [left_parabola$Y < 0] = 0 +#' right_parabola$Y[right_parabola$Y < 0] = 0 +#' } +#' +#' # Offset LEFT parabola (X values) +#' +#' # original maximum left X value (to use for offsetting right_parabola in a future step) +#' left_max <- max(left_parabola$x) +#' +#' # subset cross section to the LEFT of the midpoint +#' left_cs <- cross_section_pts[rel_distance < midpoint, ] +#' +#' # removing cross section point that will be replaced by left_parabola points +#' left_cs <- left_cs[left_cs$relative_distance < (midpoint - max(left_parabola$x)), ] +#' +#' # getting the starting X value for the LEFT side of the parabola +#' left_start <- midpoint - max(left_parabola$x) +#' +#' # offset X values to fit within cross_section_pts points +#' left_parabola$x <- left_start + left_parabola$x +#' +#' +#' # Offset RIGHT parabola (X values) +#' +#' # subset cross section to the RIGHT of the midpoint +#' right_cs <- cross_section_pts[rel_distance > midpoint, ] +#' +#' # getting the starting X value for the RIGHT side of the parabola +#' right_start <- midpoint + ((right_parabola$x) - left_max) +#' +#' # removing cross section point that will be replaced by right_parabola points +#' right_cs <- right_cs[right_cs$relative_distance > max(right_start), ] +#' # right_cs <- right_cs[right_cs$relative_distance > (midpoint + max(right_parabola$x)), ] +#' +#' # offset X values to fit within cs points +#' right_parabola$x <- right_start +#' +#' # # get the last point on the LEFT side of parabola +#' # last_left <- dplyr::slice_tail(left_parabola) +#' # +#' # # get the first point on the RIGHT side of parabola +#' # first_right <- dplyr::slice_head(right_parabola) +#' # +#' # # create an additional point in the middle between the left and right parabolas +#' # extra_midpoint <- data.frame( +#' # ind = last_left$ind + 1, +#' # x = median(c(last_left$x, first_right$x)), +#' # Y = median(c(last_left$Y, first_right$Y)), +#' # A = median(c(last_left$A, first_right$A)) +#' # ) +#' +#' # combine all parts of the parabola back together +#' parabola <- dplyr::bind_rows(left_parabola, right_parabola) +#' # parabola <- dplyr::bind_rows(left_parabola, extra_midpoint, right_parabola) +#' +#' # select relevant columns and adjust the names +#' parabola <- +#' parabola %>% +#' dplyr::select( +#' relative_distance = x, +#' Z = Y +#' ) +#' +#' # combine left cross section points, parabola, and right cross section points +#' out_cs <- dplyr::bind_rows( +#' left_cs, +#' parabola, +#' right_cs +#' ) +#' +#' # Add new pt_id to account for inserted parabola points, and assign all parabola points to have a point_type of "bottom" +#' out_cs <- +#' out_cs %>% +#' dplyr::mutate( +#' pt_id = 1:dplyr::n(), +#' point_type = dplyr::case_when( +#' is.na(point_type) ~ "bottom", +#' TRUE ~ point_type +#' ) +#' ) +#' +#' # Add back ID data +#' out_cs$hy_id <- cross_section_pts$hy_id[1] +#' out_cs$cs_id <- cross_section_pts$cs_id[1] +#' out_cs$cs_lengthm <- cross_section_pts$cs_lengthm[1] +#' # out_cs$Z_source <- cross_section_pts$Z_source[1] +#' +#' # ahg_est +#' # plot(ahg_est$Y) +#' # plot(out_cs$Z) +#' +#' # plot_df <- dplyr::bind_rows( +#' # dplyr::mutate(cs, +#' # source = "DEM" +#' # ), +#' # dplyr::mutate(out_cs, +#' # source = "AHG Estimate (In channel)" +#' # ) +#' # ) +#' # plot_df %>% +#' # ggplot2::ggplot() + +#' # ggplot2::scale_y_continuous(limits = c(-1, 2), +#' # breaks = seq(-5, 2, +#' # by = 0.5)) + +#' # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = point_type) )+ +#' # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = point_type) )+ +#' # ggplot2::facet_wrap(source~., scale = "free_y") +#' # +#' # out_cs %>% +#' # ggplot2::ggplot() + +#' # ggplot2::scale_y_continuous(limits = c(-1, 2), +#' # breaks = seq(-5, 2, +#' # by = 0.5)) + +#' # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = point_type) )+ +#' # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +#' +#' return(out_cs) +#' +#' } + +# #########W #########W #########W #########W#########W #########W #########W #########W#########W #########W #########W #########W +# #########W #########W #########W #########W UNCOMMENT ABOVE #########W #########W #########W #########W#########W #########W #########W #########W +# #########W #########W #########W #########W#########W #########W #########W #########W#########W #########W #########W #########W +# +# cs_bf_estimate <- function(cs, bf_width, bf_depth) { +# library(dplyr) +# #########W #########W #########W #########W +# #########W #########W #########W #########W +# #########W #########W #########W #########W +# cs_pts = arrow::read_parquet("/Users/anguswatters/Desktop/lynker-spatial/02_cs_pts/nextgen_12_cross_sections.parquet") +# ml_widths <- arrow::read_parquet("/Users/anguswatters/Downloads/conus_width_depth_ml.parquet") +# # ml_widths %>% +# # dplyr::filter(FEATUREID == 5587412) +# +# net = arrow::open_dataset('s3://lynker-spatial/v20.1/conus_net.parquet') %>% +# dplyr::filter(vpu == 12) +# aoi <- +# net %>% +# dplyr::collect() +# +# # fab <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg", layer = "flowpaths") +# # sf::st_layers("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg") +# +# # tmp_i <- 32771 +# tmp_i <- 33437 +# # tmp_i <- 33298 +# which(aoi$id == "wb-2398332") +# # which(aoi$id == "wb-2398289") +# +# mlw <- +# ml_widths %>% +# dplyr::filter(FEATUREID == aoi$hf_id[tmp_i]) +# # which(aoi$id == "wb-2398284") +# # cs_points %>% +# cs_pts %>% +# dplyr::filter(hy_id == aoi$id[tmp_i]) %>% +# ggplot2::ggplot() + +# # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# +# cs <- +# cs_pts %>% +# dplyr::filter(hy_id == aoi$id[tmp_i], cs_id == 3) +# +# bf_width <- mlw$owp_tw_bf +# bf_depth <- mlw$owp_y_bf +# +# #########W #########W #########W #########W +# #########W #########W #########W #########W +# #########W #########W #########W #########W +# +# +# primary_z <- cs$Z +# rel_distance <- cs$relative_distance +# channel_class <- cs$class +# # max_z = round(max(cs_points$Z), 2) +# # total_length <- cs_points$cs_lengthm[1] +# +# ahg_est <- AHGestimation::cross_section( +# r = 3, +# TW = bf_width, +# Ymax = bf_depth +# ) +# plot(ahg_est$Y) +# plot(cs$Z~cs$relative_distance) +# # channel_class +# # rel_distance +# +# # relative distance of the bottoms +# bottoms <- rel_distance[channel_class == "bottom"] +# # bottoms <- rel_distance[channel_class %in% c("channel", "bottom")] +# +# # find the middle of the bottom +# middle_pt <- median(bottoms) +# +# message("middle_pt: ", round(middle_pt, 3)) +# +# # AHG Estimated X and Y values +# ahg_x <- ahg_est$x +# ahg_z <- ahg_est$Y +# +# # plot(ahg_est$Y) +# +# # distnace in both directios from the middle of the channel bottom +# middle_to_left <- abs(rel_distance - (middle_pt - (max(ahg_x)/2))) +# middle_to_right <- abs(rel_distance - (middle_pt + (max(ahg_x)/2))) +# +# # indices to "pin" AHG estimate into original Z values +# left_bank <- which.min(middle_to_left) +# # right_bank <- which.min(middle_to_right) +# right_bank <- which.min(middle_to_right) +# +# # extract the relative distance (x) values to the left and right of the channel bottom, +# # these X values will be the distance along the cross section for each point, +# # we'll be inserting the AHG X values between the left and right relative distances +# left_side <- rel_distance[1:(left_bank-1)] +# right_side <- rel_distance[(1 + right_bank):length(rel_distance)] +# # left_side <- rel_distance[1:(left_bank)] +# # right_side <- rel_distance[(right_bank):length(rel_distance)] +# # +# # insert the AHG X distances between the original X relative distances +# final_x <- c(left_side, left_side[length(left_side)] + ahg_x, right_side) +# final_x <- round(final_x, 2) +# +# # cs_points %>% +# # dplyr::filter(class == "left_bank") %>% +# # dplyr::slice_min(Z) %>% +# # dplyr::slice_max(pt_id) +# # # dplyr::slice_max(pt_id) +# # +# # cs_points %>% +# # dplyr::filter(class == "right_bank") %>% +# # dplyr::slice_min(Z) %>% +# # dplyr::slice_min(pt_id) +# # cs_points$Z %>% which.max() +# +# # extract the Z values to the left and right of the channel bottom, these Z values will "surround" the AHG estimate Z values +# left_z <- primary_z[1:(left_bank-1)] +# right_z <- primary_z[(1 + right_bank):length(primary_z)] +# +# shift_ahg_z <- ahg_z + (left_z[length(left_z)] - max(ahg_z)) +# +# final_z <- c(left_z, shift_ahg_z, right_z) +# # final_z <- c(left_z, ahg_z, right_z) +# +# plot(final_z) +# +# final_z <- round(final_z, 2) +# ahg_z + left_z[length(left_z)] +# final_class <- c( +# rep("left_bank", length(left_z)), +# rep("bottom", length(ahg_z)), +# rep("right_bank", length(right_z)) +# ) +# +# output <- data.frame( +# x = final_x, +# z = final_z, +# class = final_class +# ) %>% +# dplyr::tibble() %>% +# dplyr::mutate( +# is_ahg_estimate = dplyr::case_when( +# class == "bottom" ~ TRUE, +# TRUE ~ FALSE +# ) +# ) +# plot(cs$Z~cs$relative_distance) +# plot(output$z~output$x) +# ggplot2::ggplot() + +# ggplot2::scale_y_continuous(limits = c(0, 25), breaks = seq(0, 15, by = 5)) + +# # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # ggplot2::geom_point(data = cs, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # size = 8, +# # alpha = 0.4, +# # shape = 18 +# # ) + +# ggplot2::geom_point(data = output, +# ggplot2::aes(x = x, y = z, color = is_ahg_estimate), +# size = 3 +# ) + +# # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# ggplot2::theme(legend.position = "bottom") +# ggplot2::ggplot() + +# ggplot2::scale_y_continuous(limits = c(0, 25), breaks = seq(0, 15, by = 5)) + +# # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# ggplot2::geom_point(data = cs, ggplot2::aes(x = relative_distance, y = Z, color = class), +# size = 8, +# alpha = 0.4, +# shape = 18 +# ) + +# ggplot2::geom_point(data = output, +# ggplot2::aes(x = x, y = z, color = class), +# size = 3 +# ) + +# # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# ggplot2::theme(legend.position = "bottom") +# +# } +# # # cs_bf_estimate <- function(cs, bf_width, bf_depth) { +# # # library(dplyr) +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # cs_pts = arrow::read_parquet("/Users/anguswatters/Desktop/lynker-spatial/02_cs_pts/nextgen_12_cross_sections.parquet") +# # # ml_widths <- arrow::read_parquet("/Users/anguswatters/Downloads/conus_width_depth_ml.parquet") +# # # # ml_widths %>% +# # # # dplyr::filter(FEATUREID == 5587412) +# # # +# # # net = arrow::open_dataset('s3://lynker-spatial/v20.1/conus_net.parquet') %>% +# # # dplyr::filter(vpu == 12) +# # # aoi <- +# # # net %>% +# # # dplyr::collect() +# # # +# # # # fab <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg", layer = "flowpaths") +# # # # sf::st_layers("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg") +# # # +# # # # tmp_i <- 32771 +# # # tmp_i <- 33437 +# # # # tmp_i <- 33298 +# # # which(aoi$id == "wb-2398332") +# # # # which(aoi$id == "wb-2398289") +# # # +# # # mlw <- +# # # ml_widths %>% +# # # dplyr::filter(FEATUREID == aoi$hf_id[tmp_i]) +# # # # which(aoi$id == "wb-2398284") +# # # # cs_points %>% +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i]) %>% +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # cs <- +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i], cs_id == 3) +# # # +# # # bf_width <- mlw$owp_tw_bf +# # # bf_depth <- mlw$owp_y_bf +# # # +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # +# # # +# # # primary_z <- cs$Z +# # # rel_distance <- cs$relative_distance +# # # channel_class <- cs$class +# # # # max_z = round(max(cs_points$Z), 2) +# # # # total_length <- cs_points$cs_lengthm[1] +# # # +# # # ahg_est <- AHGestimation::cross_section( +# # # r = 3, +# # # TW = bf_width, +# # # Ymax = bf_depth +# # # ) +# # # plot(ahg_est$Y) +# # # plot(cs$Z~cs$relative_distance) +# # # # channel_class +# # # # rel_distance +# # # +# # # # relative distance of the bottoms +# # # bottoms <- rel_distance[channel_class == "bottom"] +# # # # bottoms <- rel_distance[channel_class %in% c("channel", "bottom")] +# # # +# # # # find the middle of the bottom +# # # middle_pt <- median(bottoms) +# # # +# # # message("middle_pt: ", round(middle_pt, 3)) +# # # +# # # # AHG Estimated X and Y values +# # # ahg_x <- ahg_est$x +# # # ahg_z <- ahg_est$Y +# # # +# # # # plot(ahg_est$Y) +# # # +# # # # distnace in both directios from the middle of the channel bottom +# # # middle_to_left <- abs(rel_distance - (middle_pt - (max(ahg_x)/2))) +# # # middle_to_right <- abs(rel_distance - (middle_pt + (max(ahg_x)/2))) +# # # +# # # # indices to "pin" AHG estimate into original Z values +# # # left_bank <- which.min(middle_to_left) +# # # # right_bank <- which.min(middle_to_right) +# # # right_bank <- which.min(middle_to_right) +# # # +# # # # extract the relative distance (x) values to the left and right of the channel bottom, +# # # # these X values will be the distance along the cross section for each point, +# # # # we'll be inserting the AHG X values between the left and right relative distances +# # # left_side <- rel_distance[1:(left_bank-1)] +# # # right_side <- rel_distance[(1 + right_bank):length(rel_distance)] +# # # # left_side <- rel_distance[1:(left_bank)] +# # # # right_side <- rel_distance[(right_bank):length(rel_distance)] +# # # # +# # # # insert the AHG X distances between the original X relative distances +# # # final_x <- c(left_side, left_side[length(left_side)] + ahg_x, right_side) +# # # final_x <- round(final_x, 2) +# # # +# # # # cs_points %>% +# # # # dplyr::filter(class == "left_bank") %>% +# # # # dplyr::slice_min(Z) %>% +# # # # dplyr::slice_max(pt_id) +# # # # # dplyr::slice_max(pt_id) +# # # # +# # # # cs_points %>% +# # # # dplyr::filter(class == "right_bank") %>% +# # # # dplyr::slice_min(Z) %>% +# # # # dplyr::slice_min(pt_id) +# # # # cs_points$Z %>% which.max() +# # # +# # # # extract the Z values to the left and right of the channel bottom, these Z values will "surround" the AHG estimate Z values +# # # left_z <- primary_z[1:(left_bank-1)] +# # # right_z <- primary_z[(1 + right_bank):length(primary_z)] +# # # +# # # shift_ahg_z <- ahg_z + (left_z[length(left_z)] - max(ahg_z)) +# # # +# # # final_z <- c(left_z, shift_ahg_z, right_z) +# # # # final_z <- c(left_z, ahg_z, right_z) +# # # +# # # plot(final_z) +# # # +# # # final_z <- round(final_z, 2) +# # # ahg_z + left_z[length(left_z)] +# # # final_class <- c( +# # # rep("left_bank", length(left_z)), +# # # rep("bottom", length(ahg_z)), +# # # rep("right_bank", length(right_z)) +# # # ) +# # # +# # # output <- data.frame( +# # # x = final_x, +# # # z = final_z, +# # # class = final_class +# # # ) %>% +# # # dplyr::tibble() %>% +# # # dplyr::mutate( +# # # is_ahg_estimate = dplyr::case_when( +# # # class == "bottom" ~ TRUE, +# # # TRUE ~ FALSE +# # # ) +# # # ) +# # # plot(cs$Z~cs$relative_distance) +# # # plot(output$z~output$x) +# # # ggplot2::ggplot() + +# # # ggplot2::scale_y_continuous(limits = c(0, 25), breaks = seq(0, 15, by = 5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # # ggplot2::geom_point(data = cs, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # # size = 8, +# # # # alpha = 0.4, +# # # # shape = 18 +# # # # ) + +# # # ggplot2::geom_point(data = output, +# # # ggplot2::aes(x = x, y = z, color = is_ahg_estimate), +# # # size = 3 +# # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # ggplot2::ggplot() + +# # # ggplot2::scale_y_continuous(limits = c(0, 25), breaks = seq(0, 15, by = 5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # ggplot2::geom_point(data = output, +# # # ggplot2::aes(x = x, y = z, color = class), +# # # size = 3 +# # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # } +# # # +# # # #########W #########W #########W #########W +# # # # ######### EXAMPLE DATA ######### +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # cs_pts = arrow::read_parquet("/Users/anguswatters/Desktop/lynker-spatial/02_cs_pts/nextgen_12_cross_sections.parquet") +# # # ml_widths <- arrow::read_parquet("/Users/anguswatters/Downloads/conus_width_depth_ml.parquet") +# # # # ml_widths %>% +# # # # dplyr::filter(FEATUREID == 5587412) +# # # ml_widths$owp_y_inchan/ml_widths$owp_y_bf %>% hist(breaks = 10) +# # # +# # # ml_widths %>% +# # # dplyr::mutate( +# # # ratio = owp_y_bf/owp_y_inchan +# # # ) %>% +# # # # .$ratio %>% +# # # # max() +# # # dplyr::filter(ratio < 5) %>% +# # # .$ratio %>% +# # # hist() +# # # +# # # +# # # bottom_distances <- +# # # cs_pts %>% +# # # dplyr::filter(class == "bottom") %>% +# # # # dplyr::filter(hy_id == "wb-2398282", class == "bottom") %>% +# # # dplyr::group_by(hy_id, cs_id) %>% +# # # dplyr::mutate( +# # # bottom_width = max(relative_distance) - min(relative_distance) +# # # ) %>% +# # # dplyr::select(hy_id, cs_id, relative_distance, X, Y, Z, bottom_width) %>% +# # # dplyr::slice(1) %>% +# # # dplyr::ungroup() +# # # +# # # bottom_distances <- +# # # bottom_distances %>% +# # # dplyr::left_join( +# # # dplyr::select(aoi, id, hf_id), +# # # by = c("hy_id" = "id") +# # # ) +# # # +# # # bottom_distances <- +# # # bottom_distances %>% +# # # dplyr::mutate(hf_id = as.character(hf_id)) %>% +# # # dplyr::left_join( +# # # ml_widths, +# # # by = c("hf_id" = "FEATUREID") +# # # ) +# # # +# # # plot_df <- +# # # bottom_distances %>% +# # # dplyr::mutate( +# # # ratio = (bottom_width) / owp_tw_inchan +# # # ) +# # # plot_df +# # # plot_df %>% +# # # dplyr::filter(hy_id == "wb-2412339") +# # # cs_bottoms <- +# # # cs_pts %>% +# # # dplyr::mutate( +# # # tmp_id = paste0(hy_id, "_", cs_id) +# # # ) %>% +# # # dplyr::left_join( +# # # dplyr::select(dplyr::mutate(plot_df, +# # # tmp_id = paste0(hy_id, "_", cs_id) +# # # ), +# # # tmp_id, bottom_width, owp_tw_inchan, ratio), +# # # by = "tmp_id" +# # # ) +# # # # dplyr::filter(ratio < 1) +# # # # dplyr::filter(hy_id %in% dplyr::filter(plot_df, ratio < 1)$hy_id) +# # # cs_bottoms %>% +# # # dplyr::filter(ratio < 1, ratio > 0) %>% +# # # dplyr::slice(1:1000) %>% +# # # sf::st_as_sf(coords = c("X", "Y"), crs = 5070) %>% +# # # mapview::mapview() +# # # plot_df %>% +# # # dplyr::filter(ratio > 100) %>% +# # # sf::st_as_sf(coords = c("X", "Y"), crs = 5070) %>% +# # # mapview::mapview() +# # # plot_df$ratio %>% max(na.rm = T) +# # # +# # # # plot_df$owp_tw_inchan %>% is.na() +# # # plot_df %>% +# # # dplyr::slice(1:50000) %>% +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(ggplot2::aes(x = bottom_width, y = owp_tw_bf)) +# # # +# # # dplyr::filter(FEATUREID == aoi$hf_id[tmp_i]) +# # # +# # # +# # # +# # # net = arrow::open_dataset('s3://lynker-spatial/v20.1/conus_net.parquet') %>% +# # # dplyr::filter(vpu == 12) +# # # aoi <- +# # # net %>% +# # # dplyr::collect() +# # # +# # # aoi %>% +# # # dplyr::filter(hf_id == 5523848) %>% +# # # .$hf_areasqkm +# # # +# # # net_vpu11 = arrow::open_dataset('s3://lynker-spatial/v20.1/conus_net.parquet') %>% +# # # dplyr::filter(vpu == 11) +# # # +# # # aoi_vpu11 <- +# # # net_vpu11 %>% +# # # dplyr::collect() +# # # aoi_vpu11 +# # # # fab <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg", layer = "flowpaths") +# # # # sf::st_layers("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg") +# # # +# # # +# # # aoi$id %>% unique() +# # # which(aoi$id == "wb-2398332") +# # # which(aoi$id == "wb-2408548") +# # # which(aoi$id == "wb-2408566") +# # # which(aoi$id == "wb-2398282") +# # # +# # # tmp <- +# # # cs_pts %>% +# # # dplyr::group_by(hy_id, cs_id, class) %>% +# # # dplyr::summarize(total_rows = n()) %>% +# # # dplyr::ungroup() %>% +# # # dplyr::filter(class %in% c("channel", "bottom")) %>% +# # # dplyr::filter(total_rows > 1) %>% +# # # # dplyr::filter(total_rows == 5) %>% +# # # dplyr::arrange(-total_rows) +# # # +# # # tmp_i <-which(aoi$id == "wb-2398332")[1] +# # # tmp_i <-which(aoi$id == "wb-2408548")[1] +# # # # tmp_i <-which(aoi$id == "wb-2408566")[1] +# # # tmp_i <-which(aoi$id == "wb-2398282")[1] +# # # tmp_i <- which(aoi$id == "wb-2429329")[1] +# # # tmp_i <- which(aoi$id == "wb-2398282")[1] +# # # # 2398282 +# # # # tmp_i <- which(aoi$id == "wb-2398686")[1] +# # # +# # # tmp_i <- which(aoi$id == "wb-2398687")[1] +# # # # tmp_i <- which(aoi$id == "wb-2398287")[1] +# # # +# # # # "wb-2408566" +# # # # which(aoi$id == "wb-2398289") +# # # +# # # # tmp_i <- 32771 +# # # # tmp_i <- 33437 +# # # # tmp_i <- 1129 +# # # # tmp_i <- 1239 +# # # # tmp_i <- 32769 +# # # # tmp_i <- 33298 +# # # # tmp_id <- which(aoi$id == "wb-2398282") +# # # # aoi$id[32770] +# # # +# # # model_widths <- +# # # ml_widths %>% +# # # dplyr::filter(FEATUREID == aoi$hf_id[tmp_i]) +# # # # dplyr::filter(FEATUREID == aoi_vpu11$hf_id[tmp_i]) +# # # # which(aoi$id == "wb-2398284") +# # # # cs_points %>% +# # # +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i]) +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i]) %>% +# # # .$cs_id %>% +# # # unique() +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i]) %>% +# # # # dplyr::filter(hy_id == aoi_vpu11$id[tmp_i]) %>% +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # cs <- +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i], cs_id == 7) +# # # # dplyr::filter(hy_id == aoi_vpu11$id[tmp_i], cs_id == 2) +# # # cs %>% +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class)) + +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # bf_width <- model_widths$owp_tw_bf +# # # bf_depth <- model_widths$owp_y_bf +# # # +# # # inchannel_width <- mlw$owp_tw_inchan +# # # inchannel_depth <- mlw$owp_y_inchan +# # # +# # # # drop_negative_depths = TRUE +# # # drop_negative_depths = FALSE +# # # +# # # bf_cs_base <- cs_bankfull_estimate( +# # # cs = cs, +# # # r = 3, +# # # bf_width = bf_width, +# # # bf_depth = bf_depth, +# # # drop_negative_depths = FALSE, +# # # keep_observed = FALSE, +# # # only_bottom = FALSE +# # # ) +# # # +# # # bf_cs_keep_observed <- cs_bankfull_estimate( +# # # cs = cs, +# # # r = 3, +# # # bf_width = bf_width, +# # # bf_depth = bf_depth, +# # # drop_negative_depths = FALSE, +# # # keep_observed = TRUE, +# # # only_bottom = FALSE +# # # ) +# # # +# # # bf_cs_keep_only_bottom <- cs_bankfull_estimate( +# # # cs = cs, +# # # r = 3, +# # # bf_width = bf_width, +# # # bf_depth = bf_depth, +# # # drop_negative_depths = FALSE, +# # # keep_observed = TRUE, +# # # only_bottom = TRUE +# # # ) +# # # +# # # inchannel_cs <- cs_inchannel_estimate( +# # # cs = cs, +# # # r = 3, +# # # inchannel_width = inchannel_width, +# # # inchannel_depth = inchannel_depth, +# # # drop_negative_depths = FALSE +# # # ) +# # # +# # # cs %>% +# # # sf::st_as_sf(coords = c("X", "Y"), crs = 5070) %>% +# # # mapview::mapview() +# # # +# # # plot_df <- dplyr::bind_rows( +# # # dplyr::mutate(cs, +# # # source = "DEM" +# # # ), +# # # dplyr::mutate(inchannel_cs, +# # # source = "IN CHANNEL" +# # # ), +# # # dplyr::mutate(bf_cs_base, +# # # source = "BANKFUL - (drop DEM POINTS)" +# # # ), +# # # dplyr::mutate(bf_cs_keep_observed, +# # # source = "BANKFUL - (kept DEM points)" +# # # ), +# # # dplyr::mutate(bf_cs_keep_only_bottom, +# # # source = "BANKFUL - (replace ONLY bottom)" +# # # ) +# # # ) +# # # +# # # plot_df %>% +# # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # breaks = seq(-5, 2, +# # # # by = 0.5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class), size = 3)+ +# # # # ggplot2::facet_wrap(source~., scale = "free_y") +# # # # ggplot2::facet_wrap(source~., nrow = 1) +# # # ggplot2::facet_grid(source~.) +# # # +# # # +# # # +# # # plot_df %>% +# # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # breaks = seq(-5, 2, +# # # # by = 0.5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class), size = 3)+ +# # # # ggplot2::facet_wrap(source~., scale = "free_y") +# # # ggplot2::facet_wrap(source~., nrow = 1) +# # # +# # # model_widths +# # # +# # # +# # # +# # # +# # # +# # # # out_cs %>% +# # # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # breaks = seq(-5, 2, +# # # # by = 0.5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # +# # # #########W #########W #########W #########W +# # # # ######### EXAMPLE DATA ######### +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # cs_bankfull_estimate <- function(cs, +# # # r = 3, +# # # bf_width, +# # # bf_depth, +# # # drop_negative_depths = TRUE, +# # # keep_observed = FALSE, +# # # only_bottom = FALSE +# # # ) { +# # # +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # +# # # # cs = cs +# # # # r = 3 +# # # # bf_width = bf_width +# # # # bf_depth = bf_depth +# # # # drop_negative_depths = FALSE +# # # # keep_observed = TRUE +# # # +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # +# # # primary_z <- cs$Z +# # # rel_distance <- cs$relative_distance +# # # channel_class <- cs$class +# # # +# # # # plot(primary_z) +# # # +# # # # cs %>% +# # # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(0, max(cs$Z)), +# # # # breaks = seq(0, max(cs$Z), +# # # # by = (max(cs$Z) - min(cs$Z)) / 4)) + +# # # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # start_z <- +# # # cs %>% +# # # dplyr::filter(class %in% c("right_bank", "left_bank")) %>% +# # # dplyr::slice_min(Z, with_ties = FALSE) %>% +# # # .$Z +# # # +# # # # # relative distance of the bottoms +# # # bottom <- rel_distance[channel_class == "bottom"] +# # # bottomZ <- primary_z[channel_class == "bottom"] +# # # +# # # # # find the middle of the bottom +# # # midpoint <- median(bottom) +# # # +# # # # generate AHG estimates +# # # ahg_est <- AHGestimation::cross_section( +# # # r = r, +# # # TW = bf_width, +# # # Ymax = bf_depth +# # # ) +# # # +# # # +# # # # indices of the left and right parabola halves +# # # left_half = 1:(nrow(ahg_est) / 2) +# # # right_half = (1 + (nrow(ahg_est) / 2)):nrow(ahg_est) +# # # +# # # # get the left and right side of the parabolas +# # # left_parabola = ahg_est[left_half, ] +# # # right_parabola = ahg_est[right_half, ] +# # # +# # # # shift the Z values to have there max points be at the "bottom" of the "cs" points +# # # left_parabola$Y <- left_parabola$Y + (start_z - max(left_parabola$Y)) +# # # right_parabola$Y <- right_parabola$Y + (start_z - max(right_parabola$Y)) +# # # # left_parabola$Y <- left_parabola$Y + (bottomZ[1] - max(left_parabola$Y)) +# # # # right_parabola$Y <- right_parabola$Y + (bottomZ[1] - max(right_parabola$Y)) +# # # +# # # # set any negative values in parabola to 0 +# # # if (drop_negative_depths) { +# # # left_parabola$Y [left_parabola$Y < 0] = 0 +# # # right_parabola$Y[right_parabola$Y < 0] = 0 +# # # } +# # # +# # # # Offset LEFT parabola (X values) +# # # +# # # # original maximum left X value (to use for offsetting right_parabola in a future step) +# # # # left_max <- max(left_parabola$x) +# # # left_max <- left_parabola$x[nrow(left_parabola)] +# # # +# # # # # getting the starting X value for the LEFT side of the parabola +# # # # (get the last element from the left_parabola, this assumes the "x" column is sorted in non decreasing order, otherwise we can use the max() value....) +# # # left_start <- midpoint - left_parabola$x[nrow(left_parabola)] +# # # # left_start <- midpoint - max(left_parabola$x) +# # # +# # # # # offset the left starting position +# # # # left_start <- left_start * 2 +# # # +# # # # offset X values to fit within cs points +# # # left_parabola$x <- left_start + left_parabola$x +# # # +# # # +# # # # Offset RIGHT parabola (X values) +# # # +# # # # getting the starting X value for the RIGHT side of the parabola +# # # right_start <- midpoint + ((right_parabola$x) - left_max) +# # # +# # # # offset X values to fit within cs points +# # # right_parabola$x <- right_start +# # # +# # # # combine all parts of the parabola back together +# # # parabola <- dplyr::bind_rows( +# # # dplyr::mutate( +# # # left_parabola, +# # # side = "left" +# # # ), +# # # dplyr::mutate( +# # # right_parabola, +# # # side = "right" +# # # ) +# # # ) +# # # +# # # # plot(parabola$Y~parabola$x) +# # # +# # # # subset original cross section points to the left and right of midpoint and +# # # # that are greater than the minimum start_z value determined from the beginning +# # # lower_bound <- +# # # cs %>% +# # # dplyr::filter(Z >= start_z, relative_distance < midpoint) %>% +# # # # dplyr::filter(class == "bottom") %>% +# # # dplyr::slice_max(relative_distance) +# # # +# # # # if there are any points (rows), use the "relative_distance" value, otherwise assign lower_bound of 0 +# # # lower_bound <- ifelse(nrow(lower_bound) > 0, lower_bound$relative_distance, 0) +# # # +# # # # keep_right <- +# # # upper_bound <- +# # # cs %>% +# # # dplyr::filter(Z >= start_z, relative_distance > midpoint) %>% +# # # # dplyr::filter(class == "bottom") %>% +# # # dplyr::slice_min(relative_distance) +# # # +# # # # if there are any points (rows), use the "relative_distance" value, otherwise assign upper_bound of the length of the cross section +# # # upper_bound <- ifelse(nrow(upper_bound) > 0, upper_bound$relative_distance, upper_bound$cs_lengthm) +# # # +# # # +# # # # upper_bound <- +# # # # cs %>% +# # # # dplyr::filter(class == "bottom") %>% +# # # # dplyr::slice_max(relative_distance) %>% +# # # # .$relative_distance +# # # # +# # # # lower_bound <- +# # # # cs %>% +# # # # dplyr::filter(class == "bottom") %>% +# # # # dplyr::slice_min(relative_distance) %>% +# # # # .$relative_distance +# # # +# # # # subset the parabola values to just those within the original cross section bounds +# # # parabola <- +# # # parabola %>% +# # # dplyr::select( +# # # relative_distance = x, +# # # Z = Y, +# # # side +# # # ) %>% +# # # dplyr::filter( +# # # relative_distance >= lower_bound, +# # # relative_distance <= upper_bound +# # # ) +# # # +# # # # minimum point distance of LEFT parabola +# # # left_parabola_min <- dplyr::slice_head( +# # # dplyr::filter( +# # # parabola, +# # # side == "left" +# # # ) +# # # )$relative_distance +# # # +# # # # maximum point distance of RIGHT parabola +# # # right_parabola_max <- dplyr::slice_tail( +# # # dplyr::filter( +# # # parabola, +# # # side == "right" +# # # ) +# # # )$relative_distance +# # # +# # # # Get the original set of cross section points to the LEFT of the midpoint and to the LEFT of the LEFT MOST parabola point +# # # left_cs <- dplyr::filter(cs, +# # # # Z >= start_z, +# # # relative_distance < left_parabola_min, +# # # relative_distance < midpoint +# # # ) +# # # +# # # # Get the original set of cross section points to the RIGHT of the midpoint and to the RIGHT of the RIGHT MOST parabola point +# # # right_cs <- dplyr::filter(cs, +# # # # Z >= start_z, +# # # relative_distance > right_parabola_max, +# # # relative_distance > midpoint +# # # ) +# # # +# # # # filter out any parts of the parabola that have Z values that are +# # # # greater than the minimum DEM Z values of the original left and right cross section points +# # # parabola <- dplyr::bind_rows( +# # # dplyr::filter(parabola, +# # # side == "left", +# # # Z < min(left_cs$Z) +# # # ), +# # # dplyr::filter(parabola, +# # # side == "right", +# # # Z < min(right_cs$Z) +# # # ) +# # # ) +# # # +# # # # parabola <- dplyr::select(parabola, -side) +# # # +# # # # plot(para$Z~para$relative_distance) +# # # +# # # # combine the kept left cross section points, parabola points, and right cross section points together +# # # out_cs <- dplyr::bind_rows( +# # # left_cs, +# # # parabola, +# # # # dplyr::select(parabola, -side), +# # # right_cs +# # # ) +# # # # plot(out_cs$Z) +# # # +# # # # if keep_observed is TRUE, then any original cross section points are kept and +# # # # only the "bottom" classified points are filled in using the AHG estimate points that +# # # if(keep_observed) { +# # # +# # # # indices of the "bottom" points +# # # bottom_indices <- which(cs$class == "bottom") +# # # +# # # # min index is the left most bottom point and max index is the right most bottom point +# # # left_index <- min( bottom_indices ) +# # # right_index <- max( bottom_indices ) +# # # +# # # # Whether to keep bankful width parabola points out to the points just beyond the "bottom" points, +# # # # this will extend the number of "bottom" points from the AHG estimates that are included in output +# # # if(!only_bottom) { +# # # # min index is the left most bottom point and max index is the right most bottom point +# # # left_index <- left_index - 1 +# # # right_index <- right_index + 1 +# # # } +# # # +# # # # # min index is the left most bottom point and max index is the right most bottom point +# # # # left_index <- min( bottom_indices ) - 1 +# # # # right_index <- max( bottom_indices ) + 1 +# # # +# # # # get the relative distance of the left and right bottom points +# # # left_bound <- cs$relative_distance[left_index] +# # # right_bound <- cs$relative_distance[right_index] +# # # +# # # para_left <- +# # # out_cs %>% +# # # # dplyr::filter(!is.na(side)) %>% +# # # dplyr::filter(side == "left") %>% +# # # dplyr::filter(relative_distance >= left_bound) +# # # +# # # para_right <- +# # # out_cs %>% +# # # # dplyr::filter(!is.na(side)) %>% +# # # dplyr::filter(side == "right") %>% +# # # dplyr::filter(relative_distance <= right_bound) +# # # +# # # # subset LEFT SIDE of cross section that has DEM points and is NOT a "bottom" point +# # # left_cs <- dplyr::filter(cs, +# # # relative_distance <= left_bound, +# # # class != "bottom" +# # # ) +# # # +# # # # subset RIGHT SIDE of cross section that has DEM points and is NOT a "bottom" point +# # # right_cs <- dplyr::filter(cs, +# # # relative_distance >= right_bound, +# # # class != "bottom" +# # # ) +# # # +# # # +# # # out_cs <- dplyr::bind_rows( +# # # left_cs, +# # # para_left, +# # # para_right, +# # # right_cs +# # # ) +# # # +# # # # plot(out_cs$Z) +# # # +# # # } +# # # +# # # +# # # # reassign new 'pt_id' to account for inserted parabola points and +# # # # assign all NA points to "bottom" (assigning "bottom" to all NA points is probably temporary and NOT what the final result should be) +# # # out_cs <- +# # # out_cs %>% +# # # dplyr::select(-side) %>% +# # # dplyr::mutate( +# # # pt_id = 1:dplyr::n(), +# # # class = dplyr::case_when( +# # # is.na(class) ~ "bottom", +# # # TRUE ~ class +# # # ) +# # # ) +# # # +# # # # Add back ID data +# # # out_cs$hy_id <- cs$hy_id[1] +# # # out_cs$cs_id <- cs$cs_id[1] +# # # out_cs$cs_lengthm <- cs$cs_lengthm[1] +# # # out_cs$Z_source <- cs$Z_source[1] +# # # +# # # # plot_df <- dplyr::bind_rows( +# # # # dplyr::mutate(cs, +# # # # source = "DEM" +# # # # ), +# # # # dplyr::mutate(out_cs, +# # # # source = "AHG Estimate (In channel)" +# # # # ) +# # # # ) +# # # # plot_df %>% +# # # # ggplot2::ggplot() + +# # # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # # breaks = seq(-5, 2, +# # # # # by = 0.5)) + +# # # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # # ggplot2::facet_wrap(source~.) +# # # # ggplot2::facet_grid(source~.) +# # # # +# # # # out_cs %>% +# # # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # breaks = seq(-5, 2, +# # # # by = 0.5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # return(out_cs) +# # # +# # # } +# # # +# # # cs_inchannel_estimate <- function(cs, +# # # r = 3, +# # # inchannel_width, +# # # inchannel_depth, +# # # drop_negative_depths = TRUE +# # # ) { +# # # +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # +# # # +# # # primary_z <- cs$Z +# # # rel_distance <- cs$relative_distance +# # # channel_class <- cs$class +# # # +# # # # plot(primary_z) +# # # +# # # # cs %>% +# # # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(0, max(cs$Z)), +# # # # breaks = seq(0, max(cs$Z), +# # # # by = (max(cs$Z) - min(cs$Z)) / 4)) + +# # # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # # # relative distance of the bottoms +# # # bottom <- rel_distance[channel_class == "bottom"] +# # # bottomZ <- primary_z[channel_class == "bottom"] +# # # +# # # # # find the middle of the bottom +# # # midpoint <- median(bottom) +# # # +# # # # generate AHG estimates +# # # ahg_est <- AHGestimation::cross_section( +# # # r = r, +# # # TW = inchannel_width, +# # # Ymax = inchannel_depth +# # # ) +# # # +# # # +# # # # indices of the left and right parabola halves +# # # left_half = 1:(nrow(ahg_est) / 2) +# # # right_half = (1 + (nrow(ahg_est) / 2)):nrow(ahg_est) +# # # +# # # # get the left and right side of the parabolas +# # # left_parabola = ahg_est[left_half, ] +# # # right_parabola = ahg_est[right_half, ] +# # # +# # # # shift the Z values to have there max points be at the "bottom" of the "cs" points +# # # left_parabola$Y <- left_parabola$Y + (bottomZ[1] - max(left_parabola$Y)) +# # # right_parabola$Y <- right_parabola$Y + (bottomZ[1] - max(right_parabola$Y)) +# # # +# # # # set any negative values in parabola to 0 +# # # if (drop_negative_depths) { +# # # left_parabola$Y [left_parabola$Y < 0] = 0 +# # # right_parabola$Y[right_parabola$Y < 0] = 0 +# # # } +# # # +# # # # Offset LEFT parabola (X values) +# # # +# # # # original maximum left X value (to use for offsetting right_parabola in a future step) +# # # left_max <- max(left_parabola$x) +# # # +# # # # subset cross section to the LEFT of the midpoint +# # # left_cs <- cs[rel_distance < midpoint, ] +# # # +# # # # removing cross section point that will be replaced by left_parabola points +# # # left_cs <- left_cs[left_cs$relative_distance < (midpoint - max(left_parabola$x)), ] +# # # +# # # # getting the starting X value for the LEFT side of the parabola +# # # left_start <- midpoint - max(left_parabola$x) +# # # +# # # # offset X values to fit within cs points +# # # left_parabola$x <- left_start + left_parabola$x +# # # +# # # +# # # # Offset RIGHT parabola (X values) +# # # +# # # # subset cross section to the RIGHT of the midpoint +# # # right_cs <- cs[rel_distance > midpoint, ] +# # # +# # # # getting the starting X value for the RIGHT side of the parabola +# # # right_start <- midpoint + ((right_parabola$x) - left_max) +# # # +# # # # removing cross section point that will be replaced by right_parabola points +# # # right_cs <- right_cs[right_cs$relative_distance > max(right_start), ] +# # # # right_cs <- right_cs[right_cs$relative_distance > (midpoint + max(right_parabola$x)), ] +# # # +# # # # offset X values to fit within cs points +# # # right_parabola$x <- right_start +# # # +# # # # # get the last point on the LEFT side of parabola +# # # # last_left <- dplyr::slice_tail(left_parabola) +# # # # +# # # # # get the first point on the RIGHT side of parabola +# # # # first_right <- dplyr::slice_head(right_parabola) +# # # # +# # # # # create an additional point in the middle between the left and right parabolas +# # # # extra_midpoint <- data.frame( +# # # # ind = last_left$ind + 1, +# # # # x = median(c(last_left$x, first_right$x)), +# # # # Y = median(c(last_left$Y, first_right$Y)), +# # # # A = median(c(last_left$A, first_right$A)) +# # # # ) +# # # +# # # # combine all parts of the parabola back together +# # # parabola <- dplyr::bind_rows(left_parabola, right_parabola) +# # # # parabola <- dplyr::bind_rows(left_parabola, extra_midpoint, right_parabola) +# # # +# # # # select relevant columns and adjust the names +# # # parabola <- +# # # parabola %>% +# # # dplyr::select( +# # # relative_distance = x, +# # # Z = Y +# # # ) +# # # +# # # # combine left cross section points, parabola, and right cross section points +# # # out_cs <- dplyr::bind_rows( +# # # left_cs, +# # # parabola, +# # # right_cs +# # # ) +# # # +# # # # Add new pt_id to account for inserted parabola points, and assign all parabola points to have a class of "bottom" +# # # out_cs <- +# # # out_cs %>% +# # # dplyr::mutate( +# # # pt_id = 1:dplyr::n(), +# # # class = dplyr::case_when( +# # # is.na(class) ~ "bottom", +# # # TRUE ~ class +# # # ) +# # # ) +# # # +# # # # Add back ID data +# # # out_cs$hy_id <- cs$hy_id[1] +# # # out_cs$cs_id <- cs$cs_id[1] +# # # out_cs$cs_lengthm <- cs$cs_lengthm[1] +# # # out_cs$Z_source <- cs$Z_source[1] +# # # +# # # # ahg_est +# # # # plot(ahg_est$Y) +# # # +# # # # plot_df <- dplyr::bind_rows( +# # # # dplyr::mutate(cs, +# # # # source = "DEM" +# # # # ), +# # # # dplyr::mutate(out_cs, +# # # # source = "AHG Estimate (In channel)" +# # # # ) +# # # # ) +# # # # plot_df %>% +# # # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # breaks = seq(-5, 2, +# # # # by = 0.5)) + +# # # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::facet_wrap(source~., scale = "free_y") +# # # # +# # # # out_cs %>% +# # # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(-1, 2), +# # # # breaks = seq(-5, 2, +# # # # by = 0.5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # return(out_cs) +# # # +# # # } +# # # +# # # cs_bf_estimate <- function(cs, bf_width, bf_depth) { +# # # +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # #########W #########W #########W #########W +# # # +# # # +# # # primary_z <- cs$Z +# # # rel_distance <- cs$relative_distance +# # # channel_class <- cs$class +# # # # max_z = round(max(cs_points$Z), 2) +# # # # total_length <- cs_points$cs_lengthm[1] +# # # +# # # # get the left most bottom point +# # # left <- +# # # cs %>% +# # # dplyr::filter(class == "bottom") %>% +# # # dplyr::slice_min(pt_id) %>% +# # # .$pt_id +# # # +# # # # get the index to the left of the left most bottom point +# # # left = left - 1 +# # # +# # # # get the right most bottom point +# # # right <- +# # # cs %>% +# # # dplyr::filter(class == "bottom") %>% +# # # dplyr::slice_max(pt_id) %>% +# # # .$pt_id +# # # +# # # # get the index to the right of the right most bottom point +# # # right = right + 1 +# # # +# # # ahg_est <- AHGestimation::cross_section( +# # # r = 3, +# # # TW = bf_width, +# # # Ymax = bf_depth +# # # ) +# # # +# # # plot(ahg_est$Y) +# # # plot(cs$Z~cs$relative_distance) +# # # # channel_class +# # # # rel_distance +# # # +# # # # # relative distance of the bottoms +# # # # bottoms <- rel_distance[channel_class == "bottom"] +# # # # # bottoms <- rel_distance[channel_class %in% c("channel", "bottom")] +# # # # +# # # # # find the middle of the bottom +# # # # middle_pt <- median(bottoms) +# # # # +# # # # message("middle_pt: ", round(middle_pt, 3)) +# # # # +# # # # AHG Estimated X and Y values +# # # ahg_x <- ahg_est$x +# # # ahg_z <- ahg_est$Y +# # # +# # # # # plot(ahg_est$Y) +# # # # +# # # # # distnace in both directios from the middle of the channel bottom +# # # # middle_to_left <- abs(rel_distance - (middle_pt - (max(ahg_x)/2))) +# # # # middle_to_right <- abs(rel_distance - (middle_pt + (max(ahg_x)/2))) +# # # # +# # # # # indices to "pin" AHG estimate into original Z values +# # # # left_bank <- which.min(middle_to_left) +# # # # # right_bank <- which.min(middle_to_right) +# # # # right_bank <- which.min(middle_to_right) +# # # +# # # # extract the relative distance (x) values to the left and right of the channel bottom, +# # # # these X values will be the distance along the cross section for each point, +# # # # we'll be inserting the AHG X values between the left and right relative distances +# # # # left_side <- rel_distance[1:(left_bank-1)] +# # # # right_side <- rel_distance[(1 + right_bank):length(rel_distance)] +# # # # left_side <- rel_distance[1:(left_bank)] +# # # # right_side <- rel_distance[(right_bank):length(rel_distance)] +# # # # +# # # +# # # left_side <- rel_distance[1:(left)] +# # # right_side <- rel_distance[(right):length(rel_distance)] +# # # +# # # plot(ahg_est$Y) +# # # # insert the AHG X distances between the original X relative distances +# # # final_x <- c(left_side, left_side[length(left_side)] + ahg_x, right_side) +# # # final_x <- round(final_x, 2) +# # # +# # # # cs_points %>% +# # # # dplyr::filter(class == "left_bank") %>% +# # # # dplyr::slice_min(Z) %>% +# # # # dplyr::slice_max(pt_id) +# # # # # dplyr::slice_max(pt_id) +# # # # +# # # # cs_points %>% +# # # # dplyr::filter(class == "right_bank") %>% +# # # # dplyr::slice_min(Z) %>% +# # # # dplyr::slice_min(pt_id) +# # # # cs_points$Z %>% which.max() +# # # +# # # # extract the Z values to the left and right of the channel bottom, these Z values will "surround" the AHG estimate Z values +# # # # left_z <- primary_z[1:(left_bank-1)] +# # # # right_z <- primary_z[(1 + right_bank):length(primary_z)] +# # # +# # # left_z <- primary_z[1:(left)] +# # # right_z <- primary_z[(right):length(primary_z)] +# # # +# # # shift_ahg_z <- ahg_z + (left_z[length(left_z)] - max(ahg_z)) +# # # +# # # final_z <- c(left_z, shift_ahg_z, right_z) +# # # # final_z <- c(left_z, ahg_z, right_z) +# # # plot(primary_z) +# # # final_z <- round(final_z, 2) +# # # plot(final_z) +# # # +# # # # rename with the classications +# # # final_class <- c( +# # # rep("left_bank", length(left_z)), +# # # rep("bottom", length(ahg_z)), +# # # rep("right_bank", length(right_z)) +# # # ) +# # # +# # # output <- data.frame( +# # # x = final_x, +# # # z = final_z, +# # # class = final_class +# # # ) %>% +# # # dplyr::tibble() %>% +# # # dplyr::mutate( +# # # is_ahg_estimate = dplyr::case_when( +# # # class == "bottom" ~ TRUE, +# # # TRUE ~ FALSE +# # # ) +# # # ) +# # # plot(cs$Z~cs$relative_distance) +# # # plot(output$z~output$x) +# # # ggplot2::ggplot() + +# # # # ggplot2::scale_y_continuous(limits = c(0, 25), breaks = seq(0, 15, by = 5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # # ggplot2::geom_point(data = cs, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # # size = 8, +# # # # alpha = 0.4, +# # # # shape = 18 +# # # # ) + +# # # ggplot2::geom_point(data = output, +# # # ggplot2::aes(x = x, y = z, color = is_ahg_estimate), +# # # size = 3 +# # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # ggplot2::ggplot() + +# # # ggplot2::scale_y_continuous(limits = c(0, 25), breaks = seq(0, 15, by = 5)) + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # # ggplot2::geom_point(data = output, +# # # # ggplot2::aes(x = x, y = z, color = class), +# # # # size = 3 +# # # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # } +# # # +# # # +# # # cs_to_ahg <- function() { +# # # library(dplyr) +# # # +# # # cs_pts = arrow::read_parquet("/Users/anguswatters/Desktop/lynker-spatial/02_cs_pts/nextgen_12_cross_sections.parquet") +# # # +# # # cs_pts = sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/01_transects/nextgen_10L_cross_sections.parquet") +# # # +# # # ml_widths <- arrow::read_parquet("/Users/anguswatters/Downloads/conus_width_depth_ml.parquet") +# # # ml_widths %>% +# # # dplyr::filter(FEATUREID == 5587412) +# # # +# # # net = arrow::open_dataset('s3://lynker-spatial/v20.1/conus_net.parquet') %>% +# # # dplyr::filter(vpu == 12) +# # # +# # # aoi <- +# # # net %>% +# # # dplyr::collect() +# # # +# # # fab <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg", layer = "flowpaths") +# # # sf::st_layers("/Users/anguswatters/Desktop/lynker-spatial/v20.1/gpkg/nextgen_12.gpkg") +# # # fab +# # # # aoi$hf_id[1] +# # # # aoi$id[1] +# # # +# # # aoi$hf_id +# # # +# # # aoi[5000, ] +# # # # tmp_i <- 32771 +# # # tmp_i <- 33437 +# # # # tmp_i <- 33298 +# # # which(aoi$id == "wb-2398332") +# # # # which(aoi$id == "wb-2398289") +# # # # cs_pts %>% +# # # # dplyr::filter(cs_lengthm > 100) +# # # # which(cs_pts$hy_id == "wb-2398284") +# # # mlw <- +# # # ml_widths %>% +# # # dplyr::filter(FEATUREID == aoi$hf_id[tmp_i]) +# # # # which(aoi$id == "wb-2398284") +# # # # cs_points %>% +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i]) %>% +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # cs_points <- +# # # cs_pts %>% +# # # dplyr::filter(hy_id == aoi$id[tmp_i], cs_id == 3) +# # # plot(cs_points$Z) +# # # mlw +# # # +# # # +# # # +# # # ahg_est <- AHGestimation::cross_section(r = 3, +# # # # TW = max(tester$bf_width), +# # # # TW = max(tester$bf_width), +# # # # TW = 50, +# # # TW = mlw$owp_tw_inchan, +# # # # Ymax = mlw$owp_y_bf +# # # # Ymax = max(cs_points$Z) +# # # Ymax = mlw$owp_y_inchan +# # # +# # # ) +# # # +# # # plot(ahg_est$Y) +# # # plot(cs_points$Z) +# # # +# # # cs_points %>% +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(ggplot2::aes(x = relative_distance, y = Z, color = class) )+ +# # # # ggplot2::ylim(c(195, 200)) + +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # +# # # +# # # total_length <- cs_points$cs_lengthm[1] +# # # primary_z <- cs_points$Z +# # # max_z = round(max(cs_points$Z), 2) +# # # rel_distance <- cs_points$relative_distance +# # # channel_class <- cs_points$class +# # # # channel_class +# # # # rel_distance +# # # +# # # # relative distance of the bottoms +# # # bottoms <- rel_distance[channel_class == "bottom"] +# # # # bottoms <- rel_distance[channel_class %in% c("channel", "bottom")] +# # # +# # # # find the middle of the bottom +# # # middle_pt <- median(bottoms) +# # # +# # # message("middle_pt: ", round(middle_pt, 3)) +# # # +# # # # AHG Estimated X and Y values +# # # ahg_x <- ahg_est$x +# # # ahg_z <- ahg_est$Y +# # # +# # # # plot(ahg_est$Y) +# # # # ahg_est +# # # # ahg_x +# # # # +# # # # distnace in both directios from the middle of the channel bottom +# # # middle_to_left <- abs(rel_distance - (middle_pt - (max(ahg_x)/2))) +# # # middle_to_right <- abs(rel_distance - (middle_pt + (max(ahg_x)/2))) +# # # +# # # # indices to "pin" AHG estimate into original Z values +# # # left_bank <- which.min(middle_to_left) +# # # # right_bank <- which.min(middle_to_right) +# # # right_bank <- which.min(middle_to_right) +# # # +# # # rel_distance[-left_bank:-right_bank] +# # # +# # # left_bank:right_bank +# # # +# # # # extract the relative distance (x) values to the left and right of the channel bottom, +# # # # these X values will be the distance along the cross section for each point, +# # # # we'll be inserting the AHG X values between the left and right relative distances +# # # left_side <- rel_distance[1:(left_bank-1)] +# # # right_side <- rel_distance[(1 + right_bank):length(rel_distance)] +# # # # left_side <- rel_distance[1:(left_bank)] +# # # # right_side <- rel_distance[(right_bank):length(rel_distance)] +# # # # +# # # # insert the AHG X distances between the original X relative distances +# # # final_x <- c(left_side, left_side[length(left_side)] + ahg_x, right_side) +# # # final_x <- round(final_x, 2) +# # # final_x +# # # +# # # cs_points[3, ] +# # # ahg_z %>% round(2) +# # # +# # # # cs_points %>% +# # # # dplyr::filter(class == "left_bank") %>% +# # # # dplyr::slice_min(Z) %>% +# # # # dplyr::slice_max(pt_id) +# # # # # dplyr::slice_max(pt_id) +# # # # +# # # # cs_points %>% +# # # # dplyr::filter(class == "right_bank") %>% +# # # # dplyr::slice_min(Z) %>% +# # # # dplyr::slice_min(pt_id) +# # # # cs_points$Z %>% which.max() +# # # +# # # # extract the Z values to the left and right of the channel bottom, these Z values will "surround" the AHG estimate Z values +# # # left_z <- primary_z[1:(left_bank-1)] +# # # right_z <- primary_z[(1 + right_bank):length(primary_z)] +# # # # left_z <- primary_z[1:(left_bank)] +# # # # right_z <- primary_z[(right_bank):length(primary_z)] +# # # +# # # channel_class +# # # rep("left_bank", length(left_z)) +# # # left_z + ahg_z +# # # left_z[length(left_z)] +# # # final_z <- c(left_z, left_z[length(left_z)] + ahg_z, right_z) +# # # final_z <- round(final_z, 2) +# # # final_z +# # # final_class <- c( +# # # rep("left_bank", length(left_z)), +# # # rep("bottom", length(ahg_z)), +# # # rep("right_bank", length(right_z)) +# # # ) +# # # +# # # length(final_x) +# # # length(final_z) +# # # +# # # pts <- cs_points %>% sf::st_as_sf(coords = c("X", "Y"), crs = 5070) +# # # bb <- pts[1, ] %>% +# # # sf::st_buffer(10000) +# # # +# # # flines <- fab %>% +# # # sf::st_filter(bb) +# # # mapview::mapview(bb) + sf::st_as_sf(cs_points, coords = c("X", "Y"), crs = 5070) + flines +# # # cs_points %>% sf::st_as_sf(coords = c("X", "Y"), crs = 5070) %>% mapview::mapview() +# # # +# # # output <- data.frame( +# # # x = final_x, +# # # z = final_z, +# # # class = final_class +# # # ) %>% +# # # dplyr::tibble() %>% +# # # dplyr::mutate( +# # # is_ahg_estimate = dplyr::case_when( +# # # class == "bottom" ~ TRUE, +# # # TRUE ~ FALSE +# # # ) +# # # ) +# # # +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs_points, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # ggplot2::geom_point(data = output, ggplot2::aes(x = x, y = z, color = class), +# # # size = 3 +# # # ) + +# # # ggplot2::scale_y_continuous(limits = c(0, 20), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # ahgX <- dplyr::filter(output, is_ahg_estimate)$x +# # # ahgZ <- dplyr::filter(output, is_ahg_estimate)$z +# # # +# # # leftX <- dplyr::filter(output, class == "left_bank")$x +# # # leftZ <- dplyr::filter(output, class == "left_bank")$z +# # # +# # # rightX <- dplyr::filter(output, class == "right_bank")$x +# # # rightZ <- dplyr::filter(output, class == "right_bank")$z +# # # +# # # # Raise AHG estimate points as far as possible while still remaining between the left bank point +# # # # and the next point to the right of it (and same for the right bank but for the point to the left of it) +# # # # left_bound = left_bank +# # # # right_bound = right_bank - 1 +# # # +# # # +# # # left_bound = cs_points$relative_distance[left_bank] +# # # right_bound = cs_points$relative_distance[right_bank - 1] +# # # +# # # left_bankX <- +# # # +# # # newZ = ahgZ + 1 +# # # +# # # to_keep <- newZ < max_z +# # # +# # # newX <- ahgX[to_keep] +# # # newZ <- newZ[to_keep] +# # # +# # # +# # # ahgX[newZ < max_z] +# # # +# # # # output$ +# # # output$z + 1 +# # # dplyr::mutate(output, +# # # z = z + 1 +# # # ) +# # # added_z = 1 +# # # dplyr::mutate(output, +# # # z = dplyr::case_when( +# # # is_ahg_estimate ~ z + added_z, +# # # TRUE ~ z +# # # ) +# # # ) +# # # +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs_points, ggplot2::aes(x = relative_distance, y = Z), +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # ggplot2::geom_point(data =dplyr::mutate(output, +# # # z = dplyr::case_when( +# # # is_ahg_estimate ~ z + added_z, +# # # TRUE ~ z +# # # )), +# # # ggplot2::aes(x = x, y = z, +# # # color = is_ahg_estimate +# # # ), +# # # size = 3 +# # # ) + +# # # ggplot2::scale_y_continuous(limits = c(0, 15), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs_points, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # # color = "slategray", +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 15), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs_points, ggplot2::aes(x = relative_distance, y = Z, color = class), +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # ggplot2::geom_point(data = output, ggplot2::aes(x = x, y = z, color = class), +# # # size = 3 +# # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 15), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # ggplot2::ggplot() + +# # # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::geom_point(data = cs_points, ggplot2::aes(x = relative_distance, y = Z), +# # # size = 8, +# # # alpha = 0.4, +# # # shape = 18 +# # # ) + +# # # ggplot2::geom_point(data = output, ggplot2::aes(x = x, y = z, +# # # color = is_ahg_estimate +# # # ), +# # # size = 3 +# # # ) + +# # # # ggplot2::scale_y_continuous(limits = c(0, 15), breaks = seq(0, 15, by = 5)) + +# # # ggplot2::theme(legend.position = "bottom") +# # # +# # # cs_points$Z +# # # output$z +# # # +# # # # ggplot2::ylim(c(195, 200)) + +# # # ########################################################################### +# # # ########################################################################### +# # # ########################################################################### +# # # +# # # plot(ahg_est$Y) +# # # plot(cs_points$Z) +# # # cs_pts$ +# # # library(dplyr) +# # # cs_points <- +# # # cs_pts %>% +# # # # dplyr::filter(hy_id %in% c("wb-1560496", "wb-1560496", "wb-1560498", "wb-1560498", "wb-1529103")) +# # # dplyr::filter(hy_id %in% c( "wb-1560498"), cs_id == 7) +# # # unique( cs_pts$hy_id) +# # # cs_points %>% +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class) )+ +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # cs_points +# # # +# # # cs_points$Z %>% max() +# # # # ahg_est <- AHGestimation::cross_section(r = 2, +# # # # # TW = max(tester$bf_width), +# # # # # TW = max(tester$bf_width), +# # # # TW = 20, +# # # # Ymax = max(cs_points$Z) +# # # # ) +# # # +# # # ahg_est <- AHGestimation::cross_section(r = 2, +# # # # TW = max(tester$bf_width), +# # # # TW = max(tester$bf_width), +# # # # TW = 50, +# # # TW = mlw$owp_tw_bf, +# # # Ymax = max(cs_points$Z) +# # # ) +# # # +# # # total_length <- cs_points$cs_lengthm[1] +# # # primary_z <- cs_points$Z +# # # rel_distance <- cs_points$relative_distance +# # # channel_class <- cs_points$class +# # # # channel_class +# # # # rel_distance +# # # +# # # # relative distance of the bottoms +# # # bottoms <- rel_distance[channel_class == "bottom"] +# # # +# # # # find the middle of the bottom +# # # middle_pt <- median(bottoms) +# # # +# # # # AHG Estimated X and Y values +# # # ahg_x <- ahg_est$x +# # # ahg_z <- ahg_est$Y +# # # +# # # # ahg_est +# # # # ahg_x +# # # # +# # # # distnace in both directios from the middle of the channel bottom +# # # middle_to_left <- abs(rel_distance - (middle_pt - (max(ahg_x)/2))) +# # # middle_to_right <- abs(rel_distance - (middle_pt + (max(ahg_x)/2))) +# # # +# # # # indices to "pin" AHG estimate into original Z values +# # # left_bank <- which.min(middle_to_left) +# # # right_bank <- which.min(middle_to_right) +# # # +# # # rel_distance[-left_bank:-right_bank] +# # # +# # # left_bank:right_bank +# # # +# # # # extract the relative distance (x) values to the left and right of the channel bottom, +# # # # these X values will be the distance along the cross section for each point, +# # # # we'll be inserting the AHG X values between the left and right relative distances +# # # left_side <- rel_distance[1:(left_bank-1)] +# # # right_side <- rel_distance[(1 + right_bank):length(rel_distance)] +# # # +# # # # insert the AHG X distances between the original X relative distances +# # # final_x <- c(left_side, left_side[length(left_side)] + ahg_x, right_side) +# # # +# # # # extract the Z values to the left and right of the channel bottom, these Z values will "surround" the AHG estimate Z values +# # # left_z <- primary_z[1:(left_bank-1)] +# # # right_z <- primary_z[(1 + right_bank):length(primary_z)] +# # # +# # # final_z <- c(left_z, ahg_z, right_z) +# # # +# # # +# # # min(right_side) - max(left_side) +# # # ahg_x +# # # +# # # which.min(left_distance) +# # # which.min(right_distance) +# # # rel_distance - right_bank +# # # min_index <- which.min(absolute_differences) +# # # which.min(abs(rel_distance - left_bank)) +# # # +# # # plot(ahg_est$Y) +# # # plot(cs_points$Z) +# # # ahg_est$Y +# # # cs_points$Z +# # # data.frame( +# # # pt_id = 1:length(ahg_est$Y), +# # # ahg = ahg_est$Y +# # # ) +# # # dplyr::mutate(ahg_est, pt_id = 1:dplyr::n()) +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(data =dplyr::mutate( +# # # ahg_est, pt_id = 1:dplyr::n() +# # # ), +# # # ggplot2::aes(x = pt_id, y = Y), color = "red") + +# # # ggplot2::geom_point(data = cs_points, ggplot2::aes(x = pt_id, y = Z), color = "green") +# # # # ggplot2::geom_point(data =dplyr::mutate( +# # # # ahg_est, pt_id = 1:dplyr::n() +# # # # ), +# # # # ggplot2::aes(x = pt_id, y = Y), color = "red") +# # # # # install.packages("devtools") +# # # # /Users/anguswatters/Desktop/lynker-spatial/02_cs_pts +# # # # devtools::install_github("mikejohnson51/AHGestimation") +# # # # devtools::install_github("anguswg-ucsb/hydrofabric3D") +# # # # /Users/anguswatters/Desktop/lynker-spatial/02_cs_pts +# # # net = sf::read_sf("/Users/anguswatters/Desktop/test_net.gpkg") +# # # cs = sf::read_sf("/Users/anguswatters/Desktop/test_cs.gpkg") +# # # cs_pts = sf::read_sf("/Users/anguswatters/Desktop/test_cs_pts.gpkg") +# # # +# # # update_pts1 <- rectify_flat_cs( +# # # net = net, +# # # cs = cs, +# # # cs_pts = cs_pts, +# # # points_per_cs = NULL, +# # # min_pts_per_cs = 10, +# # # # dem = DEM_URL, +# # # scale = 0.5, +# # # threshold = 0 +# # # ) +# # # # Remove any cross section that has ANY missing (NA) Z values. +# # # update_pts1 <- +# # # update_pts1 %>% +# # # # dplyr::filter(hy_id %in% c("wb-849054", "wb-845736")) %>% +# # # dplyr::group_by(hy_id, cs_id) %>% +# # # dplyr::filter(!any(is.na(Z))) %>% +# # # dplyr::ungroup() +# # # +# # # profvis::profvis({ +# # # +# # # # classify the cross section points +# # # out_pts <- +# # # update_pts1 %>% +# # # dplyr::rename(cs_widths = cs_lengthm) %>% +# # # hydrofabric3D::classify_points() %>% +# # # dplyr::mutate( +# # # X = sf::st_coordinates(.)[,1], +# # # Y = sf::st_coordinates(.)[,2] +# # # ) %>% +# # # dplyr::select( +# # # hy_id, cs_id, pt_id, +# # # cs_lengthm = cs_widths, +# # # relative_distance, +# # # X, Y, Z, +# # # class +# # # ) +# # # }) +# # # +# # # # Drop point geometries, leaving just X, Y, Z values +# # # out <- sf::st_drop_geometry(out_pts) +# # # +# # # # add Z_source column for source of elevation data +# # # out <- +# # # out %>% +# # # dplyr::mutate( +# # # Z_source = "hydrofabric3D" +# # # ) %>% +# # # dplyr::relocate(hy_id, cs_id, pt_id, cs_lengthm, relative_distance, X, Y, Z, Z_source, class) +# # # tw_net <- +# # # net %>% +# # # dplyr::mutate( +# # # bf_width = exp(0.700 + 0.365* log(tot_drainage_areasqkm)) +# # # ) %>% +# # # dplyr::select(hy_id = id, bf_width) +# # # # dplyr::select(hy_id = id, tot_drainage_areasqkm, bf_width) +# # # +# # # out2 <- +# # # out %>% +# # # dplyr::left_join( +# # # sf::st_drop_geometry(tw_net), +# # # by = "hy_id" +# # # ) +# # # uids <- out2$hy_id %>% unique() +# # # picks <- uids[754:755] +# # # out2 %>% +# # # dplyr::filter(hy_id %in% picks) %>% +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z) )+ +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # tester <- out2 %>% +# # # dplyr::filter(hy_id =="wb-2639244", cs_id == 6) +# # # # dplyr::filter(hy_id =="wb-2636395", cs_id == 3) +# # # max(tester$bf_width) +# # # max(tester$Z) +# # # max(tester$Y) +# # # tester$Z %>% plot() +# # # +# # # ahg_est <- AHGestimation::cross_section(r = 2, +# # # # TW = max(tester$bf_width), +# # # # TW = max(tester$bf_width), +# # # TW = 50, +# # # Ymax = max(tester$Z) +# # # ) +# # # ahg_est +# # # +# # # tester %>% +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = class)) +# # # tester$relative_distance +# # # floor(tester$relative_distance ) +# # # ahg_est[floor(tester$relative_distance ), ] +# # # +# # # ahg_est +# # # tester %>% dplyr::select(pt_id, total_length = cs_lengthm, relative_distance, Z) +# # # tester$Z +# # # tester$Z %>% plot() +# # # ahg_est$Y +# # # tester$Z +# # # ahg_est$Y %>% plot() +# # # pinned_cs <- c(tester$Z[1:2], ahg_est$Y, tester$Z[7:length(tester$Z)]) +# # # pinned_cs %>% plot() +# # # ahg_est +# # # ahg_est$Y %>% plot() +# # # uids <- out2$hy_id %>% unique() +# # # picks <- uids[888:890] +# # # out2 %>% +# # # dplyr::filter(hy_id %in% picks) %>% +# # # ggplot2::ggplot() + +# # # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z) )+ +# # # ggplot2::facet_grid(hy_id~cs_id, scale = "free_y") +# # # cs +# # # data = AHGestimation::nwis +# # # filter_data <- +# # # data %>% +# # # AHGestimation::date_filter(10, keep_max = TRUE) %>% +# # # AHGestimation::nls_filter() %>% +# # # dplyr::select(-date, -siteID) +# # # +# # # ahg_fit = AHGestimation::ahg_estimate(filter_data)[1,] +# # # shape = AHGestimation::compute_hydraulic_params(ahg_fit) +# # # +# # # max(filter_data$TW) +# # # max(filter_data$Y) +# # # +# # # cs3 <- AHGestimation::cross_section(r = shape$r, +# # # TW = max(filter_data$TW), +# # # Ymax = max(filter_data$Y) +# # # ) +# # # dplyr::glimpse(cs) +# # # +# # # plot(cs3$Y) +# # # +# # # } \ No newline at end of file diff --git a/R/align_banks_and_bottoms.R b/R/align_banks_and_bottoms.R new file mode 100644 index 00000000..1badee21 --- /dev/null +++ b/R/align_banks_and_bottoms.R @@ -0,0 +1,226 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +#' Align banks and smooth bottoms of cross section points +#' @description +#' Ensures the bottom of each cross section is lower then or equal to that one upstream. +#' To do this, we traverse down the network making sure this condition is met, and, +#' in cases where it isn't, we will lower the in channel portion of the cross section to make it true. +#' @param cs_pts dataframe or sf dataframe of classified cross section points (output of classify_points()) +#' @importFrom dplyr group_by summarise mutate ungroup select left_join case_when +#' @importFrom sf st_drop_geometry +#' @return sf dataframe of cross section points with aligned banks and smoothed bottoms +#' @export +align_banks_and_bottoms <- function(cs_pts) { + + adjust <- function(v){ + if(length(v) == 1){ return(v)} + for(i in 2:length(v)){ + v[i] = ifelse(v[i] > v[i-1], v[i-1], v[i]) } + v + } + + slope <- + cs_pts %>% + sf::st_drop_geometry() %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::summarise(min_ch = min(Z[point_type == "channel"])) %>% + dplyr::mutate(adjust = adjust(min_ch) - min_ch) %>% + dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, adjust) + + cs_pts <- + dplyr::left_join( + cs_pts, + slope, + by = c("hy_id", "cs_id") + ) %>% + dplyr::mutate( + Z = dplyr::case_when( + point_type == "channel" ~ Z + adjust, + TRUE ~ Z + ) + ) %>% + dplyr::select(-adjust) + + return(cs_pts) + +} + +# +# #################################################################################### +# ############################ Dev testing below ############################## +# #################################################################################### +# align_banks_and_bottoms <- function(cs_pts) { +# +# +# cs_pts <- cs +# +# adjust = function(v){ +# if(length(v) == 1){ return(v)} +# for(i in 2:length(v)){ v[i] = ifelse(v[i] > v[i-1], v[i-1], v[i]) } +# v +# } +# cs_pts$point_type %>% unique() +# +# slope <- +# cs_pts %>% +# sf::st_drop_geometry() %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::summarise(min_ch = min(Z[class == "channel"])) %>% +# dplyr::mutate(adjust = adjust(min_ch) - min_ch) %>% +# dplyr::ungroup() %>% +# dplyr::select(hy_id, cs_id, adjust) +# +# cs_pts_adjusted <- +# dplyr::left_join( +# cs_pts, +# slope, +# by = c("hy_id", "cs_id") +# ) %>% +# dplyr::mutate( +# Z = dplyr::case_when( +# class == "channel" ~ Z + adjust, +# TRUE ~ Z +# ), +# is_adjusted = dplyr::case_when( +# adjust != 0 ~ TRUE, +# TRUE ~ FALSE +# ) +# ) +# # dplyr::select(-bottom, -left_bank, -right_bank, -has_relief, +# # -valid_banks, -point_type, -class) %>% +# # hydrofabric3D::classify_points() +# test_id <- +# cs_pts_adjusted %>% +# dplyr::filter(is_adjusted) %>% +# hydrofabric3D::add_tmp_id() %>% +# # dplyr::slice(555) %>% +# dplyr::pull(tmp_id) %>% +# unique() %>% +# .[3] +# +# # cs_pts %>% +# # hydrofabric3D::add_tmp_id() %>% +# # dplyr::filter(tmp_id == test_id) %>% +# # dplyr::mutate( +# # updated = "ORIGINAL" +# # ) +# # cs_pts %>% +# # hydrofabric3D::add_tmp_id() %>% +# # dplyr::filter(tmp_id == test_id) %>% +# # dplyr::mutate( +# # updated = "Reclassified" +# # ) %>% +# # classify_points3() +# +# compare_classed <- dplyr::bind_rows( +# cs_pts %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) %>% +# dplyr::mutate( +# updated = "ORIGINAL" +# ), +# cs_pts %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) %>% +# dplyr::mutate( +# updated = "ORIGINAL - Reclassified" +# ) %>% +# classify_points3(), +# cs_pts_adjusted %>% +# dplyr::filter(is_adjusted) %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) %>% +# dplyr::mutate( +# updated = "UPDATED" +# ), +# cs_pts_adjusted %>% +# dplyr::filter(is_adjusted) %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) %>% +# # dplyr::select(-bottom, -left_bank, -right_bank, -has_relief, -valid_banks, -point_type, -class) %>% +# # hydrofabric3D::classify_points() %>% +# classify_points3() %>% +# dplyr::mutate( +# updated = "UPDATED - Reclassified" +# ) +# ) +# +# compare_classed %>% +# ggplot2::ggplot() + +# ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = point_type)) + +# ggplot2::labs(title = "Reclassified set of points") + +# # ggplot2::facet_wrap(~updated, nrow = 4) +# ggplot2::facet_wrap(~updated, nrow = 1) +# ################################### ################################### +# ################################### ################################### +# compare_cs <- dplyr::bind_rows( +# cs_pts_adjusted %>% +# dplyr::filter(is_adjusted) %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) %>% +# # dplyr::select(-bottom, -left_bank, -right_bank, -has_relief, -valid_banks, -point_type, -class) %>% +# # hydrofabric3D::classify_points() %>% +# classify_points3() %>% +# dplyr::mutate( +# updated = "UPDATED" +# ), +# cs_pts %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) %>% +# dplyr::mutate( +# updated = "ORIGINAL" +# ) +# ) +# +# compare_cs %>% +# ggplot2::ggplot() + +# ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z, color = point_type)) + +# ggplot2::labs(title = "Bank alignment and bottom smoothing") + +# ggplot2::facet_wrap(~updated) +# +# } \ No newline at end of file diff --git a/R/braids.R b/R/braids.R index 1cbcfbd8..c3043e0c 100644 --- a/R/braids.R +++ b/R/braids.R @@ -1,3 +1,49 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + #' Find braids and add to a dataframe/sf dataframe #' #' Find and uniquely identify braids in a network of flowlines, given a dataframe containing comid, fromnode, tonode and divergence as columns. 'find_braids()" identifies braids as cycles in the graph representation of the river network. diff --git a/R/cs_eval.R b/R/cs_eval.R new file mode 100644 index 00000000..41ba26ba --- /dev/null +++ b/R/cs_eval.R @@ -0,0 +1,265 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +#' Add a "middle_index" column denoting the middle index of a specific point_type +#' The middle index is relative to the rest of the cross section points in each hy_id, cs_id +#' +#' @param cross_section_pts cross section points dataframe with a "point_type" column and "hy_id", "cs_id" columns +#' @param point_type character, which point type to get the middle index for. Must be one of "left_bank", "bottom", "right_bank", or "channel". Default is "bottom" +#' @param default_col_name logical, whether the output column should be named "middle_index" or if +#' the new column should take the point_type string and use that in the column name (i.e. "left_bank_middle_index" instead of "middle_index"). +#' Default is TRUE and adds a column named "middle_index" +#' +#' @return dataframe of the input cross_section_pts with an added middle index column +#' @importFrom dplyr group_by mutate n ungroup select +#' @export +add_middle_index_by_point_type <- function( + cross_section_pts, + point_type = "bottom", + default_col_name = TRUE +) { + + # cross_section_pts <- updated_pts + # # point_class = "bottom" + # point_type = "bottom" + # default_col_name = TRUE + + # Throw an error if an invalid "point_type" value is given + if(!point_type %in% c("left_bank", "bottom", "right_bank", "channel")) {{ + stop("Invalid 'point_type' value, 'point_type' must be one of: 'bottom', 'channel', 'left_bank', 'right_bank'") + }} + + # Add a middle index column for the given point type, + # if a cross section does NOT have the given point type, then + # the middle index of the entire cross section is used as a default value + cross_section_pts <- + cross_section_pts %>% + # dplyr::filter(cs_id == 3) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + default_middle = dplyr::n() %/% 2, + middle_index = ifelse( + identical(which(point_type == !!point_type)[ceiling(length(which(point_type == !!point_type)) / 2)], integer(0)), + default_middle, + which(point_type == !!point_type)[ceiling(length(which(point_type == !!point_type)) / 2)] + ) + # middle_index = which(point_type == !!point_type)[ceiling(length(which(point_type == !!point_type)) / 2)] + # middle_bottom = (length(which(point_type == "bottom")) + 1) %/% 2, + # middle_index = ceiling(length(which(point_type == "bottom")) / 2) + # middle_index = which(point_type == point_class)[ceiling(length(which(point_type == point_class)) / 2)], + # angle_at_bottom = angle_at_index(pt_id, Z, middle_bottom) + ) %>% + # dplyr::relocate(middle_index, default_middle) %>% + dplyr::ungroup() %>% + dplyr::select(-default_middle) + + # Make the custom column name to replace the default "middle_index" column name + if(!default_col_name) { + new_column_name <- paste0(point_type, "_middle_index") + names(cross_section_pts)[names(cross_section_pts) == "middle_index"] <- new_column_name + } + + return(cross_section_pts) + +} + +# Add the degree angle between the middle index of a specific point type and the maximum XY points to the left and right of the given middle index +# Uses Law of Cosines to determine angle from a given point given a set of 3 points that can form a triangle +# the rest of the cross section points in each hy_id, cs_id +# cross_section_pts - cross section points dataframe with a "point_type" column and "hy_id", "cs_id" columns +# angle_at - character, which point type to get the degree angle for. Must be one of "left_bank", "bottom", "right_bank", or "channel". Default is "bottom" +# default_col_name - logical, whether the output column should be named "angle_at" or +# if the new column should take the "point_type" string and use +# Default is TRUE and adds a column named "angle_at" +# Returns: dataframe, the cross_section_pts dataframe with an added "angle_at" column + +#' Add the degree angle between the middle index of a specific point type and the maximum XY points to the left and right of the given middle index +#' Uses Law of Cosines to determine angle from a given point given a set of 3 points that can form a triangle the rest of the cross section points in each hy_id, cs_id +#' @param cross_section_pts cross section points dataframe with a "point_type" column and "hy_id", "cs_id" columns +#' @param angle_at character, which point type to get the degree angle for. Must be one of "left_bank", "bottom", "right_bank", or "channel". Default is "bottom" +#' @param default_col_name logical, whether the output column should be named "angle_at" or +#' if the new column should take the "point_type" string and use. Default is TRUE and adds a column named "angle_at" +#' +#' @return dataframe, the cross_section_pts dataframe with an added "angle_at" column +#' @importFrom dplyr group_by mutate ungroup select +#' @export +add_angle_at_point_type <- function(cross_section_pts, + # point_type = "bottom", + angle_at = "bottom", + default_col_name = TRUE +) { + + # Throw an error if an invalid "angle_at" value is given + if(!angle_at %in% c("left_bank", "bottom", "right_bank", "channel")) {{ + stop("Invalid 'angle_at' value, 'angle_at' must be one of: 'bottom', 'channel', 'left_bank', 'right_bank'") + }} + + cross_section_pts <- + cross_section_pts %>% + add_middle_index_by_point_type(point_type = angle_at) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + angle_at = angle_at_index(pt_id, Z, middle_index[1]) + ) %>% + dplyr::ungroup() %>% + # dplyr::relocate(angle_at_point_type, middle_index) + dplyr::select(-middle_index) + + # Make the custom column name to replace the default "middle_index" column name + if(!default_col_name) { + new_column_name <- paste0("angle_at_", point_type) + names(cross_section_pts)[names(cross_section_pts) == "angle_at"] <- new_column_name + } + + return(cross_section_pts) +} + +#' Function to calculate the angle using the Law of Cosines at a given index of X, Y, points +#' +#' @param x numeric vector of size n +#' @param y numeric vector of size n +#' @param middle_index numeric value, indicating middle index X, Y point to calculate the angle at (can be obtained from add_middle_index_by_point_type()) +#' +#' @return numeric angle in degrees between the middle_index point and the maximum Y value XY points to the left and right of middle_index point +#' @export +angle_at_index <- function(x, y, middle_index = NULL) { + + # get the number of points + n <- length(x) + + # if no index is given, just use the minimum Y value index + if(is.null(middle_index)) { + middle_index <- which.min(y) + } + + # Check if the index is valid + if (middle_index < 1 || middle_index > n) { + stop("Index out of range") + } + + # Find the maximum Y value to the left of the given index (Y1 for triangle) + Y_left <- ifelse(middle_index == 1, + # -Inf, + # max(y[1:(middle_index-1)]) + NA, + # max(y[1:(middle_index-1)], na.rm = TRUE) + 0.001, + max(y[1:(middle_index-1)], na.rm = TRUE) + ) + + # find the Y value at the given index (Y2 for triangle) + Y_middle <- y[middle_index] + + # Find the maximum Y value to the right of the given index (Y3 for triangle) + Y_right <- ifelse(middle_index == n, + # -Inf, + # max(y[(middle_index+1):n]) + NA, + # max(y[(middle_index+1):n], na.rm = TRUE) + 0.001, + max(y[(middle_index+1):n], na.rm = TRUE) + ) + + # Find the corresponding X values for the maximum Y value on the LEFT side of line (X1 for triangle) + X_left <- ifelse(middle_index == 1, + # middle_index - 0.01, + NA, + x[1:(middle_index-1)][ + which.max(y[1:(middle_index-1)]) + ] + # x[which.max(y[1:(middle_index-1)])] + ) + + # Find the corresponding X values at the MIDDLE index (X2 for triangle) + X_middle <- x[middle_index] + + # Find the corresponding X values for the maximum Y value on the RIGHT side of line (X3 for triangle) + X_right <- ifelse(middle_index == n, + # middle_index + 0.01, + NA, + x[(middle_index+1):n][ + which.max(y[(middle_index+1):n]) + ] + # x[which.max(y[(middle_index+1):n])] + ) + + # TODO: come up with a better way of dealing/outputting invalid scenario (NA might be the best option but this needs more work/thought) + # if invalid (missing a proper left, right, middle point(s)), return an NA value + if (any(is.na(c(X_left, X_middle, X_right, Y_left, Y_middle, Y_right)))) { + return(NA) + } + + # Calculate the Euclidean distances for all 3 points of a triangle: + # ---> triangle points are the middle (specified index) and the 2 maximum points to the LEFT and RIGHT of the middle + + # distance from max on LEFT side to middle (bottom) + ab <- sqrt(((X_left - X_middle)**2) + ((Y_left - Y_middle)**2)) + + # distance from middle (bottom) to max on RIGHT side + bc <- sqrt(((X_middle - X_right)**2) + ((Y_middle - Y_right)**2)) + + # distance from max on LEFT side to max on RIGHT side + ac <- sqrt(((X_left - X_right)**2) + ((Y_left - Y_right)**2)) + + # # Calculate the distances and angle using the Law of Cosines + # ab <- sqrt((x[index] - X_left)^2 + (y[index] - Y_left)^2) + # bc <- sqrt((x[index] - X_right)^2 + (y[index] - Y_right)^2) + # ac <- sqrt((X_left - X_right)^2 + (Y_left - Y_right)^2) + + # TODO: come up with a better way of dealing/outputting invalid scenario (NA might be the best option but this needs more work/thought) + # if missing values, return NA + if (any(is.na(c(ab, bc, ac)))) { + return(NA) + } + + # check triangle inequality is satisfied + if (!(ab + bc <= ac || ab + ac <= bc || bc + ac <= ab)) { + angle_radians <- acos((ac^2 - ab^2 - bc^2) / (-2 * ab * bc)) + angle <- angle_radians * 180 / pi + } else { + angle <- NA + } + + return(angle) +} diff --git a/R/cs_pts.R b/R/cs_pts.R new file mode 100644 index 00000000..4024dad9 --- /dev/null +++ b/R/cs_pts.R @@ -0,0 +1,743 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +#' Get Points across transects with elevation values +#' @param cs character, Hydrographic LINESTRING Network file path +#' @param points_per_cs the desired number of points per CS. If NULL, then approximately 1 per grid cell resultion of DEM is selected. +#' @param min_pts_per_cs Minimum number of points per cross section required. +#' @param dem the DEM to extract data from +#' @return sf object cross section points along the 'cs' linestring geometries +#' @importFrom dplyr mutate group_by ungroup n select everything relocate last_col bind_rows filter +#' @importFrom terra linearUnits res rast extract project vect crs +#' @importFrom sf st_line_sample st_set_geometry st_cast +#' @export +cross_section_pts = function( + cs = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt" +){ + + ### ### ## ## ### ## ### ## + + # cs = tmp_trans + # points_per_cs = NULL + # min_pts_per_cs = 10 + # dem = DEM_URL + # scale = 5 + + ## ### ### ### ### #### ## + + # check if a cross section is given, and return NULL if missing + if (is.null(cs)) { + return(NULL) + } + + # check if a file path or not + if(is.character(cs)) { + # Read in file + cs <- sf::read_sf(cs) + } + + # add points per cross sections + cs <- add_points_per_cs( + cs = cs, + points_per_cs = points_per_cs, + min_pts_per_cs = min_pts_per_cs, + dem = dem + ) + + + # Extract DEM "Z" values for each point along cross section linestrings + cs_pts <- extract_dem_values(cs = cs, dem = dem) + + return(cs_pts) + +} + +#' Add a points per cross section column to an sf dataframe of linestrings given a DEM and min points value +#' +#' This function calculates and adds a column called 'points_per_cs' to an sf dataframe +#' representing cross-sections (linestrings) based on a provided DEM and a minimum points +#' value per cross section. +#' +#' @param cs An sf dataframe representing cross-sections (linestrings). With a required cs_lengthm column (length of cross section in meters) +#' @param points_per_cs numeric, number of points per cross section. Default is NULL +#' @param min_pts_per_cs An optional minimum points value per cross section. If not provided, +#' @param dem A SpatRaster object representing the Digital Elevation Model (DEM) or a character string referencing a remote resource. +#' the function calculates it based on the length of cross-sections and the resolution of the DEM. +#' @importFrom terra linearUnits rast res +#' @return An updated sf dataframe with the 'points_per_cs' column added. +add_points_per_cs <- function(cs, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt" +) { + + # If NULL value is given to points_per_cs argument, calculate points_per_cs values + # - IF DEM has a longitude/latitude CRS (terra::linearUnits == 0): + # -- then divide the cross section length by 111139 and divide that resulting value by the minimum resolution value from the DEM (then round the result up) + # - ELSE: + # -- just divide the cross section length by the minimum resolution value from the DEM (then round the result up) + if (is.null(points_per_cs)) { + if (terra::linearUnits(terra::rast(dem)) == 0) { + points_per_cs = ceiling( + (cs$cs_lengthm / 111139) / min(terra::res(terra::rast(dem))) + ) + } else { + points_per_cs = ceiling( + (cs$cs_lengthm) / min(terra::res(terra::rast(dem))) + ) + } + + } + # else { + # points_per_cs = min_pts_per_cs + # } + + # Take the max between the given minimum points per cross section and the derived points per cross section + cs$points_per_cs = pmax(min_pts_per_cs, points_per_cs) + + return(cs) +} + +#' Given a set of linestrings, extract DEM values at points along the linestring +#' +#' @param cs cross section sf object +#' @param dem SpatRaster DEM or character pointing to remote DEM resource +#' @importFrom dplyr mutate group_by n ungroup select everything +#' @importFrom sf st_set_geometry st_line_sample st_cast +#' @importFrom terra extract project vect crs rast +#' @return sf dataframe with Z values extracted from DEM +extract_dem_values <- function(cs, dem) { + + extract_pt_val <- function(rast, pts) { + terra::extract( + rast, + terra::project(terra::vect(pts), terra::crs(rast)) + )[, 2] + } + + suppressWarnings({ + cs_pts <- + sf::st_set_geometry(cs, sf::st_line_sample(cs, cs$points_per_cs)) %>% + sf::st_cast("POINT") %>% + dplyr::mutate(Z = extract_pt_val(terra::rast(dem), .)) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + pt_id = 1:dplyr::n(), + relative_distance = seq(from = 0, to = cs_lengthm[1], length.out = dplyr::n()) + ) %>% + dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, pt_id, Z, cs_lengthm, relative_distance, dplyr::everything()) + }) + + return(cs_pts) + +} + + +#' Classify Cross Section Points +#' @param cs_pts CS points, output of hydrofabric3D::cross_section_pts() +#' @param pct_of_length_for_relief numeric, percent of cross section length (cs_lengthm) to use as the +#' threshold depth for classifying whether a cross section has "relief". If a cross section has at least X% of its length in depth, +#' then it is classified as "having relief" (i.e. has_relief = TRUE). Value must be non negative number (greater than or equal to 0). +#' Default is 0.01 (1% of the cross sections length). +#' @return sf object +#' @importFrom dplyr filter group_by mutate ungroup select between n left_join +#' @importFrom zoo rollmean +#' @export +classify_points <- function( + cs_pts, + pct_of_length_for_relief = 0.01 +){ + + . <- L <- L1 <- L2 <- R <- R1 <- R2 <- Z <- Z2 <- anchor <- b1 <- b2 <- cs_lengthm <- count_left <- + count_right <- cs_id <- hy_id <- in_channel_pts <- lengthm <- low_pt <- max_bottom <- mean_dist <- mid_bottom <- min_bottom <- pt_id <- relative_distance <- third <- NULL + + # type checking + if (!is.numeric(pct_of_length_for_relief)) { + stop("Invalid argument type, 'pct_of_length_for_relief' must be of type 'numeric', given type was '", + class(pct_of_length_for_relief), "'") + } + + # Make sure pct_of_length_for_relief is valid percentage value (greater than 0) + if (pct_of_length_for_relief < 0 ) { + stop("Invalid value 'pct_of_length_for_relief' of ", pct_of_length_for_relief, ", 'pct_of_length_for_relief' must be greater than or equal to 0") + } + + # # remove any columns that already exist + cs_pts <- dplyr::select(cs_pts, + !dplyr::any_of(c("class", "point_type", "bottom", "left_bank", "right_bank", "valid_banks", "has_relief")) + ) + + # required cols that will be selected from the classified_pts object and in this order + req_cols <- c("hy_id", "cs_id", "pt_id", "Z", "relative_distance", "cs_lengthm", "class", "point_type") + + # any starting columns in the original data + starting_cols <- names(cs_pts) + + # name and order of columns to select with + cols_to_select <- c(req_cols, starting_cols[!starting_cols %in% req_cols]) + + # create classifications for points + classified_pts <- + dplyr::filter(cs_pts) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + third = ceiling(n() / 3), + mean_dist = mean(diff(relative_distance)), + in_channel_pts = ceiling(cs_lengthm[1] / mean_dist), + b1 = ceiling(in_channel_pts / 2), + b2 = in_channel_pts - b1, + low_pt = min(Z[third[1]:(2*third[1] - 1)]), + class = ifelse(Z <= low_pt & dplyr::between(pt_id, third[1], (2*third[1] - 1)), + "bottom", + "bank"), + Z2 = c(Z[1], zoo::rollmean(Z, 3), Z[dplyr::n()]), + Z = ifelse(class == "bottom", Z, Z2), + min_bottom = which(class == "bottom")[1], + mid_bottom = which(class == "bottom")[ceiling(length(which(class == "bottom"))/2)], + max_bottom = which(class == "bottom")[length(which(class == "bottom"))], + L1 = pmax(1, mid_bottom - b1), + L2 = pmax(1, mid_bottom - b2), + R1 = pmin(mid_bottom + b2, n()), + R2 = pmin(mid_bottom + b1, n()), + anchor = ifelse(Z[R2] < Z[L1], 2, 1), + L = pmax(third, ifelse(anchor == 1, L1, L2)), + R = pmin(2*third[1], ifelse(anchor == 1, R1, R2)), + count_left = min_bottom - L, + count_right = R - max_bottom, + L = ifelse(count_left == 0, L - count_right, L), + R = ifelse(count_right == 0, R + count_left, R), + class = ifelse(dplyr::between(pt_id, L[1], R[1]) & class != 'bottom', "channel", class), + class = ifelse(class == 'bank' & pt_id <= L[1], "left_bank", class), + class = ifelse(class == 'bank' & pt_id >= R[1], "right_bank", class)) %>% + dplyr::ungroup() %>% + dplyr::mutate(point_type = class) %>% + dplyr::select(dplyr::any_of(cols_to_select)) + # dplyr::select(dplyr::all_of(cols_to_select)) # Stricter, requires ALL of the columns to be present or it will throw an error + # dplyr::select(hy_id, cs_id, pt_id, Z, + # relative_distance, cs_lengthm, class, point_type) # Old strict ordering, removed this to keep other columns in the input data and not lose any data for the user. + # classified_pts[cols_to_select] # Another method for selecting columns.... + + # get bank validity attributes for each hy_id/cs_id + # - Uses the count of point types per cross section and checks Z to make sure that a "bottom" point is + # in each cross section and each "bottom" point has a valid left and right bank) + bank_validity_df <- get_bank_attributes(classified_pts) + + # # Or add bank attributes + # banked_pts <- add_bank_attributes(output_pts) + + # get relief data, determine if a cross section has relief within X% percentage of the cross sections length + relief_df <- get_relief( + classified_pts, + pct_of_length_for_relief = pct_of_length_for_relief, + detailed = FALSE + ) + + # join the bank validity attributes with the relief values + validity_checks <- dplyr::left_join( + bank_validity_df, + relief_df, + by = c("hy_id", "cs_id") + ) + + # join the new validity check values to the classified points + classified_pts <- + classified_pts %>% + dplyr::left_join( + validity_checks, + by = c("hy_id", "cs_id") + ) + + # move the geometry column to the last column (if one exists) + classified_pts <- move_geometry_to_last(classified_pts) + + return(classified_pts) + +} + +# classify_points3 <- function( +# cs_pts, +# pct_of_length_for_relief = 0.01 +# ){ +# +# . <- L <- L1 <- L2 <- R <- R1 <- R2 <- Z <- Z2 <- anchor <- b1 <- b2 <- cs_lengthm <- count_left <- +# count_right <- cs_id <- hy_id <- in_channel_pts <- lengthm <- low_pt <- max_bottom <- mean_dist <- mid_bottom <- min_bottom <- pt_id <- relative_distance <- third <- NULL +# +# # cs_pts = cs_pts_adjusted +# # pct_of_length_for_relief = 0.01 +# test_cs <- +# cs_pts_adjusted %>% +# dplyr::filter(is_adjusted) %>% +# hydrofabric3D::add_tmp_id() %>% +# dplyr::filter(tmp_id == test_id) +# # dplyr::select(-bottom, -left_bank, -right_bank, -has_relief, -valid_banks, -point_type, -class) %>% +# # hydrofabric3D::classify_points() %>% +# # classify_points3() %>% +# # dplyr::mutate( +# # updated = "UPDATED - Reclassified" +# # ) +# +# # type checking +# if (!is.numeric(pct_of_length_for_relief)) { +# stop("Invalid argument type, 'pct_of_length_for_relief' must be of type 'numeric', given type was '", +# class(pct_of_length_for_relief), "'") +# } +# +# # Make sure pct_of_length_for_relief is valid percentage value (greater than 0) +# if (pct_of_length_for_relief < 0 ) { +# stop("Invalid value 'pct_of_length_for_relief' of ", pct_of_length_for_relief, ", 'pct_of_length_for_relief' must be greater than or equal to 0") +# } +# +# # # remove any columns that already exist +# cs_pts <- dplyr::select(cs_pts, +# -class, -point_type, -bottom, -left_bank, -right_bank, -valid_banks, -has_relief) +# test_cs <- dplyr::select(test_cs, +# -class, -point_type, -bottom, -left_bank, +# -right_bank, -valid_banks, -has_relief) +# +# # required cols that will be selected from the classified_pts object and in this order +# req_cols <- c("hy_id", "cs_id", "pt_id", "Z", "relative_distance", "cs_lengthm", "class", "point_type") +# +# # any starting columns in the original data +# starting_cols <- names(cs_pts) +# +# starting_cols <- names(test_cs) +# +# # name and order of columns to select with +# cols_to_select <- c(req_cols, starting_cols[!starting_cols %in% req_cols]) +# +# # create classifications for points +# classified_pts <- +# # dplyr::filter(cs_pts) %>% +# dplyr::filter(test_cs) %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::mutate( +# third = ceiling(n() / 3), +# mean_dist = mean(diff(relative_distance)), +# in_channel_pts = ceiling(cs_lengthm[1] / mean_dist), +# b1 = ceiling(in_channel_pts / 2), +# b2 = in_channel_pts - b1, +# low_pt = min(Z[third[1]:(2*third[1] - 1)]), +# class = ifelse(Z <= low_pt & dplyr::between(pt_id, third[1], (2*third[1] - 1)), +# "bottom", +# "bank"), +# Z2 = c(Z[1], zoo::rollmean(Z, 3), Z[dplyr::n()]), +# Z = ifelse(class == "bottom", Z, Z2), +# min_bottom = which(class == "bottom")[1], +# mid_bottom = which(class == "bottom")[ceiling(length(which(class == "bottom"))/2)], +# max_bottom = which(class == "bottom")[length(which(class == "bottom"))], +# L1 = pmax(1, mid_bottom - b1), +# L2 = pmax(1, mid_bottom - b2), +# R1 = pmin(mid_bottom + b2, n()), +# R2 = pmin(mid_bottom + b1, n()), +# anchor = ifelse(Z[R2] < Z[L1], 2, 1), +# L = pmax(third, ifelse(anchor == 1, L1, L2)), +# R = pmin(2*third[1], ifelse(anchor == 1, R1, R2)), +# count_left = min_bottom - L, +# count_right = R - max_bottom, +# L = ifelse(count_left == 0, L - count_right, L), +# R = ifelse(count_right == 0, R + count_left, R), +# class = ifelse(dplyr::between(pt_id, L[1], R[1]) & class != 'bottom', "channel", class), +# class = ifelse(class == 'bank' & pt_id <= L[1], "left_bank", class), +# class = ifelse(class == 'bank' & pt_id >= R[1], "right_bank", class)) %>% +# dplyr::ungroup() %>% +# dplyr::mutate(point_type = class) %>% +# dplyr::select(dplyr::any_of(cols_to_select)) +# # dplyr::select(dplyr::all_of(cols_to_select)) # Stricter, requires ALL of the columns to be present or it will throw an error +# # dplyr::select(hy_id, cs_id, pt_id, Z, +# # relative_distance, cs_lengthm, class, point_type) # Old strict ordering, removed this to keep other columns in the input data and not lose any data for the user. +# # classified_pts[cols_to_select] # Another method for selecting columns.... +# +# # get bank validity attributes for each hy_id/cs_id +# # - Uses the count of point types per cross section and checks Z to make sure that a "bottom" point is +# # in each cross section and each "bottom" point has a valid left and right bank) +# bank_validity_df <- get_bank_attributes(classified_pts) +# +# # # Or add bank attributes +# # banked_pts <- add_bank_attributes(output_pts) +# +# # get relief data, determine if a cross section has relief within X% percentage of the cross sections length +# relief_df <- get_relief( +# classified_pts, +# pct_of_length_for_relief = pct_of_length_for_relief, +# detailed = FALSE +# ) +# +# # join the bank validity attributes with the relief values +# validity_checks <- dplyr::left_join( +# bank_validity_df, +# relief_df, +# by = c("hy_id", "cs_id") +# ) +# +# # join the new validity check values to the classified points +# classified_pts <- +# classified_pts %>% +# dplyr::left_join( +# validity_checks, +# by = c("hy_id", "cs_id") +# ) +# +# # move the geometry column to the last column (if one exists) +# classified_pts <- move_geometry_to_last(classified_pts) +# +# return(classified_pts) +# +# } + +#' Classify Cross Section Points v1 (Deprecated version) +#' @param cs_pts CS points +#' @return sf object +#' @importFrom dplyr filter group_by mutate ungroup select between n +#' @importFrom zoo rollmean +classify_points2 <- function(cs_pts){ + + . <- L <- L1 <- L2 <- R <- R1 <- R2 <- Z <- Z2 <- anchor <- b1 <- b2 <- cs_lengthm <- count_left <- + count_right <- cs_id <- hy_id <- in_channel_pts <- lengthm <- low_pt <- max_bottom <- mean_dist <- mid_bottom <- min_bottom <- pt_id <- relative_distance <- third <- NULL + + dplyr::filter(cs_pts) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + third = ceiling(n() / 3), + mean_dist = mean(diff(relative_distance)), + in_channel_pts = ceiling(cs_lengthm[1] / mean_dist), + b1 = ceiling(in_channel_pts / 2), + b2 = in_channel_pts - b1, + low_pt = min(Z[third[1]:(2*third[1] - 1)]), + class = ifelse(Z <= low_pt & dplyr::between(pt_id, third[1], (2*third[1] - 1)), + "bottom", + "bank"), + Z2 = c(Z[1], zoo::rollmean(Z, 3), Z[dplyr::n()]), + Z = ifelse(class == "bottom", Z, Z2), + min_bottom = which(class == "bottom")[1], + mid_bottom = which(class == "bottom")[ceiling(length(which(class == "bottom"))/2)], + max_bottom = which(class == "bottom")[length(which(class == "bottom"))], + L1 = pmax(1, mid_bottom - b1), + L2 = pmax(1, mid_bottom - b2), + R1 = pmin(mid_bottom + b2, dplyr::n()), + R2 = pmin(mid_bottom + b1, dplyr::n()), + anchor = ifelse(Z[R2] < Z[L1], 2, 1), + L = pmax(third, ifelse(anchor == 1, L1, L2)), + R = pmin(2*third[1], ifelse(anchor == 1, R1, R2)), + count_left = min_bottom - L, + count_right = R - max_bottom, + L = ifelse(count_left == 0, L - count_right, L), + R = ifelse(count_right == 0, R + count_left, R), + class = ifelse(dplyr::between(pt_id, L[1], R[1]) & class != 'bottom', "channel", class), + class = ifelse(class == 'bank' & pt_id <= L[1], "left_bank", class), + class = ifelse(class == 'bank' & pt_id >= R[1], "right_bank", class)) %>% + dplyr::ungroup() %>% + dplyr::mutate(point_type = class) %>% + dplyr::select(hy_id, cs_id, pt_id, Z, relative_distance, cs_lengthm, class, point_type) + +} + +#' Get Points across transects with elevation values +#' @param cs character, Hydrographic LINESTRING Network file path +#' @param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +#' @param min_pts_per_cs Minimun number of points per cross section required. +#' @param dem the DEM to extract data from +#' @param scale numeric, If a transect line DEM extraction results in all equal Z values, +#' by what percent of the transect lines length (meters) should the transect line be +#' extended in both directions to try to capture representative Z values ? Default is 0.5 (50% of the transect length) +#' @return sf object +#' @importFrom dplyr mutate group_by ungroup n select everything relocate last_col bind_rows filter +#' @importFrom terra linearUnits res rast extract project vect crs +#' @importFrom sf st_line_sample st_set_geometry st_cast +#' @export +cross_section_pts_v3 = function( + cs = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5 +){ + + # check if a cross section is given, and return NULL if missing + if (is.null(cs)) { + return(NULL) + } + + # check if a file path or not + if(is.character(cs)) { + # Read in file + cs <- sf::read_sf(cs) + } + + # add points per cross sections + cs <- add_points_per_cs( + cs = cs, + points_per_cs = points_per_cs, + min_pts_per_cs = min_pts_per_cs, + dem = dem + ) + + + # Extract DEM "Z" values for each point along cross section linestrings + cs_pts <- extract_dem_values(cs = cs, dem = dem) + + # check for any flat cross sections (All Z values are equal within a given cross section) + # flat_cs <- check_z_values(pts = cs_pts, threshold = 0) + flat_cs <- check_z_values(pts = cs_pts, threshold = 0.5) + + # if there are no flatlines, return the cs_pts object + if (nrow(flat_cs) == 0) { + + cs_pts <- + cs_pts %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::relocate(geom, .after = dplyr::last_col()) + + return(cs_pts) + + } + + # subset transects (cs) to the flat cross sections in flat_cs + to_extend <- + cs %>% + dplyr::mutate( + tmp_id = paste0(hy_id, "_", cs_id) + ) %>% + dplyr::filter(tmp_id %in% unique( + dplyr::mutate(flat_cs, + tmp_id = paste0(hy_id, "_", cs_id))$tmp_id + ) + ) %>% + dplyr::select(-tmp_id) + + # dplyr::mutate(extend_by = scale * cs_lengthm) + # extend linestring geometries by a percent of linestring length + extended <- extend_by_percent(x = to_extend, pct = scale, length_col = "cs_lengthm") + + # mapview::mapview(cs, color = "dodgerblue") + + # mapview::mapview(extended, color = "red") + + # mapview::mapview(to_extend, color = "green") + # + # add cross section points to extended cross sections + extended <- add_points_per_cs( + cs = extended, + points_per_cs = points_per_cs, + min_pts_per_cs = min_pts_per_cs, + dem = dem + ) + + # extended <- add_points_per_cs(cs = extended, dem = dem, points_per_cs = NULL, min_pts_per_cs = 10) + + # extract DEM values for newly extended cross sections + extended_pts <- extract_dem_values(cs = extended, dem = dem) + + # take the below points, and put them back into "cs_pts" object + # then go back to the input "transects" ("cs") object and update the transect geometries based on the extensions done above^^ + # then resave the input transects dataset back to its original location.... + extended_pts <- + extended_pts %>% + # sf::st_drop_geometry() %>% + # dplyr::select(hy_id, cs_id, Z) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + is_same_Z = max(Z) - min(Z) <= 0 + # is_same_Z = dplyr::n_distinct(Z) == 1, + ) %>% + dplyr::ungroup() %>% + dplyr::mutate( + tmp_id = paste0(hy_id, "_", cs_id) + ) + + # separate newly extended cross sections with new Z values into groups (those that show "good" DEM values after extension are kept) + to_keep <- dplyr::filter(extended_pts, !is_same_Z) + to_drop <- dplyr::filter(extended_pts, is_same_Z) + + # filter out cross section points that have "same Z" values (remove flat Z values) + final_pts <- + cs_pts %>% + dplyr::mutate( + tmp_id = paste0(hy_id, "_", cs_id) + ) %>% + dplyr::filter( + !tmp_id %in% unique(to_drop$tmp_id) + # !tmp_id %in% unique(paste0(to_drop$hy_id, "_", to_drop$cs_id)) + ) + + # remove the old versions of the "to_keep" cross section points and + # replace them with the updated cross section points with the extended "cs_lengthm" and "Z" values + final_pts <- + final_pts %>% + dplyr::filter( + !tmp_id %in% unique(to_keep$tmp_id) + ) %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::bind_rows( + dplyr::select( + dplyr::mutate( + to_keep, + is_extended = TRUE + ), + -is_same_Z) + ) %>% + dplyr::select(-tmp_id) %>% + dplyr::relocate(geom, .after = dplyr::last_col()) + + return(final_pts) + + # tmp %>% + # ggplot2::ggplot() + + # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z,color = is_same_Z)) + + # ggplot2::facet_wrap(~cs_id) + +} + +#' Get Points across transects with elevation values +#' @param cs Hydrographic LINESTRING Network +#' @param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +#' @param min_pts_per_cs Minimun number of points per cross section required. +#' @param dem the DEM to extract data from +#' @return sf object +#' @importFrom dplyr mutate group_by ungroup n select everything +#' @importFrom terra linearUnits res rast extract project vect crs +#' @importFrom sf st_line_sample st_set_geometry st_cast +#' @export +cross_section_pts_v2 = function(cs, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt"){ + + # check if a cross section is given, and return NULL if missing + if (is.null(cs)) { + return(NULL) + } + + # IF NULL value is given to points_per_cs argument, calculate points_per_cs values + # - IF DEM has a longitude/latitude CRS (terra::linearUnits == 0): + # -- then divide the cross section length by 111139 and divide that resulting value by the minimum resolution value from the DEM (then round the result up) + # - ELSE: + # -- just divide the cross section length by the minimum resolution value from the DEM (then round the result up) + if (is.null(points_per_cs)) { + if (terra::linearUnits(terra::rast(dem)) == 0) { + points_per_cs = ceiling( + (cs$lengthm / 111139) / min(terra::res(terra::rast(dem))) + ) + } else { + points_per_cs = ceiling( + (cs$lengthm) / min(terra::res(terra::rast(dem))) + ) + } + } + + # take the max between the given minimum points per cross section and the derived points per cross section + cs$points_per_cs = pmax(min_pts_per_cs, points_per_cs) + + # function to extract Z/elevation values at a point from DEM + extract_pt_val = function(rast, pts){ + terra::extract(rast, + terra::project(terra::vect(pts), + terra::crs(rast)) + )[, 2] + } + + suppressWarnings({ + + return( + sf::st_set_geometry(cs, sf::st_line_sample(cs, cs$points_per_cs)) %>% + sf::st_cast("POINT") %>% + dplyr::mutate(Z = extract_pt_val(terra::rast(dem), .)) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + pt_id = 1:dplyr::n(), + relative_distance = seq(from = 0, to = lengthm[1], length.out = dplyr::n()) + ) %>% + dplyr::ungroup() %>% + dplyr::select(hy_id, cs_id, pt_id, Z, lengthm, relative_distance, dplyr::everything()) + ) + + }) + +} + +# #Get Points across transects with elevation values +# #@param cs Hydrographic LINESTRING Network +# #@param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +# #@param min_pts_per_cs Minimun number of points per cross section required. +# #@param dem the DEM to extract data from +# #@return sf object +# #@export +# cross_section_pts = function(cs, +# points_per_cs = NULL, +# min_pts_per_cs = 10, +# dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt"){ +# +# if(is.null(cs)){ return(NULL) } +# +# if(is.null(points_per_cs)){ +# if(linearUnits(rast(dem)) == 0){ +# points_per_cs = ceiling((cs$lengthm / 111139) / min(res(rast(dem)))) +# } else { +# points_per_cs = ceiling((cs$lengthm) / min(res(rast(dem)))) +# } +# } +# +# cs$points_per_cs = pmax(min_pts_per_cs, points_per_cs) +# +# extract_pt_val = function(rast, pts){ extract(rast, project(vect(pts), crs(rast)))[, 2] } +# +# suppressWarnings({ +# st_set_geometry(cs, st_line_sample(cs, cs$points_per_cs)) %>% +# st_cast("POINT") %>% +# mutate(Z = extract_pt_val(rast(dem), .)) %>% +# group_by(hy_id, cs_id) %>% +# mutate(pt_id = 1:n(), +# relative_distance = seq(from = 0, to = lengthm[1], length.out = n())) %>% +# ungroup() %>% +# select(hy_id, cs_id, pt_id, Z, lengthm, relative_distance, everything()) +# }) +# +# } \ No newline at end of file diff --git a/R/cs_rectify.R b/R/cs_rectify.R new file mode 100644 index 00000000..4717a6cb --- /dev/null +++ b/R/cs_rectify.R @@ -0,0 +1,1710 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +#' @title Check and fix cross section points with limited variation in Z values (without removing any flowlines) +#' @description Duplicate process as rectify_cs() but does NOT remove any cross sections, only attempts to extend transects and improve cross sections. This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (transects). +#' This function assumes the cross section points have been classified via "classify_points()" and have "has_relief" and "valid_banks" logical columns. +#' This function will look for cross section points that either have no relief or don't have valid banks, then the transect lines that generated these cross section points +#' are extended and new points are extracted along the newly extended, longer transect line. The newly extracted points are checked for relief AND valid banks and +#' are removed if they still have no relief or don't have valid banks. Any new points that became valid as a result of the extension process are added to the original dataset +#' and the rectified set of cross section points will be returned with an "is_extended" logical flag, indicating if the transect line that generated the cross section points was extended. +#' Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values. +#' @param cs_pts sf dataframe or dataframe of cross section points from cross_section_pts() followed by classify_points() +#' @param net Hydrographic LINESTRING Network +#' @param transects character, Hydrographic LINESTRING of transects along hydrographic (net) network +#' @param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +#' @param min_pts_per_cs Minimun number of points per cross section required. +#' @param dem the DEM to extract data from +#' @param scale numeric, If a transect line DEM extraction results in all equal Z values, +#' by what percent of the transect lines length (meters) should the transect line be +#' extended in both directions to try to capture representative Z values ? Default is 0.5 (50% of the transect length) +#' @param pct_of_length_for_relief numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1% of the cross sections length). +#' @param fix_ids logical, whether to reenumerate the "cs_id" column to +#' make sure cross sections are number 1 - number of total cross sections on flowline. Default is FALSE, cs_id will be kept as +#' they were in the input data and may contain gaps between cs_ids within a flowline (hy_id). +#' WARNING: Setting fix_ids = TRUE may result in input cross section points (cross_section_pts) having DIFFERENT cs_id values as the input transects (cs) +#' and the inconsistency can cause problems when trying to cross walk between the datasets in the future. +#' @param verbose logical, whether to print messages or not. Default is TRUE +#' @importFrom dplyr mutate relocate last_col select rename left_join group_by ungroup slice n bind_rows filter +#' @importFrom sf st_drop_geometry +#' @importFrom nhdplusTools rename_geometry +#' @return sf object of cross section points based on extended transects to try and improve the number of points with "valid_banks" and "has_relief" +#' @export +improve_invalid_cs = function( + cs_pts = NULL, + net = NULL, + transects = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5, + pct_of_length_for_relief = 0.01, + fix_ids = FALSE, + verbose = TRUE +) { + + # add a "tmp_id" column to easily index transects by hy_id and cs_id + transects <- hydrofabric3D::add_tmp_id(transects) + + ### ### ## ## ### ## ### ## ### ### ## ## ### ## ### ## + + if (verbose) { message("Determining points to reevaluate...") } + + # add valid_banks and has_relief columns to transects data + transects <- + transects %>% + dplyr::left_join( + dplyr::ungroup( + dplyr::slice( + dplyr::group_by( + dplyr::select(sf::st_drop_geometry(cs_pts), hy_id, cs_id, valid_banks, has_relief), + hy_id, cs_id), + 1) + ), + by = c("hy_id", "cs_id") + ) + + # if there are no transects that need rectification, return the original cs_pts early with a "is_extended" flag + if (!needs_rectification(transects)) { + + cs_pts <- + cs_pts %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::relocate(geom, .after = dplyr::last_col()) + + return(cs_pts) + } + + # flag_transects <- transects %>% + # dplyr::mutate( + # needs_extension = dplyr::case_when( + # tmp_id %in% unique(hydrofabric3D::add_tmp_id(pts_to_inspect)$tmp_id) ~ TRUE, + # TRUE ~ FALSE), + # length_to_extend = dplyr::case_when( + # needs_extension ~ (cs_lengthm * scale) / 2, + # TRUE ~ 0)) + + # 0. Split the data into valid and invalid transects + # 1. Go through invalid transects + # 2. Try to EXTEND, + # 3. and then UPDATE --> (only IF the extended transect does NOT violate any of the intersection rules) + # If ALL of the below intersection conditions are TRUE then a given extended transect line will get replace the old transect geometry + # Intersection rules: + # - Newly extended transect intersects with its flowlines AT MOST 1 time + # - Newly extended transect does NOT intersect with any of the other NEWLY EXTENDED transect lines + # - Newly extended transect does NOT intersect with any of the ORIGINAL transect lines + + # NOTE: extend_invalid_transects() returns the "transects" object with updated attributes for any + # extensions that were made (geometries, cs_lengthm, "is_extended" flag) and keeps all the rest of the remaining data in place + extended_geoms <- extend_invalid_transects( + transects_to_check = transects, + net = net, + scale = scale, + verbose = verbose + ) + + # good_to_go_transects <- dplyr::filter(extended_geoms, !is_extended) + + # Remove unextendable transects from extended_geoms + extended_transects <- dplyr::filter(extended_geoms, is_extended) + + # nrow(extended_transects) + nrow(good_to_go_transects) == nrow(transects) + + # add cross section points to extended cross sections + extended_transects <- add_points_per_cs( + cs = extended_transects, + # cs = trans_to_extend, + # cs = dplyr::slice(extended_geoms , 1:100), + points_per_cs = points_per_cs, + min_pts_per_cs = min_pts_per_cs, + dem = dem + ) + + if (verbose) { message("Extracting new DEM values..")} + + # extract DEM values for newly extended cross sections + extended_pts <- extract_dem_values(cs = extended_transects, dem = dem) + + # Drop the old valid_banks and has_relief columns + extended_pts <- dplyr::select(extended_pts, -valid_banks, -has_relief) + + # add a tmp_id for joining and filtering + # extended_pts <- add_tmp_id(extended_pts) + + if (verbose) { message("Double checking new extended cross section DEM values for flatness") } + + # reclassify the cross sections to look for any improvments in the points bank/relief validity + reclassified_pts <- hydrofabric3D::classify_points( + extended_pts, + pct_of_length_for_relief = pct_of_length_for_relief + ) + + # add tmp id for convenience + reclassified_pts <- hydrofabric3D::add_tmp_id(reclassified_pts) + + # Find "validity score" values which just represents a cross sections bank and relief validity as either (0, 1, or 2) + # Score 0 = FALSE banks & FALSE relief + # Score 1 = Either TRUE banks OR relief + # Score 2 = Both TRUE banks & TRUE relief + # ---> We get this score for the old and the new set of extended cross sections and + # then take the points in the new data that showed improvement from the original cross section. + # The cross section points that did NOT show improvment remain untouched in the original data + old_validity_scores <- hydrofabric3D::add_tmp_id(calc_validity_scores(cs_pts, "old_validity_score")) + new_validity_scores <- hydrofabric3D::add_tmp_id(calc_validity_scores(reclassified_pts, "new_validity_score")) + + # mark as "improved" for any hy_id/cs_ids that increased "validity score" after extending + check_for_improvement <- dplyr::left_join( + dplyr::select(dplyr::filter(old_validity_scores, + tmp_id %in% unique(new_validity_scores$tmp_id)), + hy_id, cs_id, old_validity_score), + dplyr::select(new_validity_scores, hy_id, cs_id, new_validity_score), + by = c("hy_id", "cs_id") + ) %>% + dplyr::mutate( + improved = dplyr::case_when( + new_validity_score > old_validity_score ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::select(hy_id, cs_id, improved) + + # List of unique hy_id/cs_ids (tmp_id) that showed improvement after extension, if valid banks or relief was addded (or both), + # then the cross section "showed improvement", and the new values will be put into the output cross section dataset + extended_ids_to_keep <- + check_for_improvement %>% + dplyr::filter(improved) %>% + get_unique_tmp_ids() + + # ids_to_add_to_good_set <- + # check_for_improvement %>% + # dplyr::filter(!improved) %>% + # get_unique_tmp_ids() + + # add a tmp_id for joining and filtering + extended_pts <- add_tmp_id(extended_pts) + + # TODO: Left off here to add back and remove old data 03/05/2024 + pts_to_keep <- dplyr::filter(extended_pts, tmp_id %in% extended_ids_to_keep) + # pts_to_keep <- dplyr::filter(extended_pts2, !tmp_id %in% ids_to_add_to_good_set) + # pts_to_move_to_good_set <- dplyr::filter(extended_pts2, tmp_id %in% ids_to_add_to_good_set) + + # Reclassify the pts_to_keep so they can be added back to the remaining "good" cross section points from the input + pts_to_keep <- hydrofabric3D::classify_points(pts_to_keep, + pct_of_length_for_relief = pct_of_length_for_relief) + + # add is_extended logical if does not exist + if (!"is_extended" %in% names(pts_to_keep)) { + pts_to_keep$is_extended = TRUE + } + + # remove the IDs of newly updated cross section points from the original data, then + # bind the new version of these points to the rest of the original data + final_pts <- + cs_pts %>% + hydrofabric3D::add_tmp_id() %>% + dplyr::filter( + !tmp_id %in% extended_ids_to_keep + ) %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::bind_rows( + hydrofabric3D::add_tmp_id(pts_to_keep) + ) %>% + dplyr::select(-tmp_id) + + # start_ids <- unique(hydrofabric3D::add_tmp_id(cs_pts)$tmp_id) + # end_ids <- unique(final_pts$tmp_id) + # + # length(unique(final_pts$tmp_id)) + # length(unique(hydrofabric3D::add_tmp_id(cs_pts)$tmp_id)) + # length(unique(final_pts$tmp_id)) == length(unique(hydrofabric3D::add_tmp_id(cs_pts)$tmp_id)) + # length(unique(hydrofabric3D::add_tmp_id(final_pts)$tmp_id)) == length(unique(hydrofabric3D::add_tmp_id(cs_pts)$tmp_id)) + + # rename geometry column to "geom" + final_pts <- nhdplusTools::rename_geometry(final_pts, "geom") + + # TODO: this should probably be removed and just kept as its own separete function and use outside of this function + # If TRUE then the cs_ids are renumbered to make sure each hy_id has cross sections + # that are numbered (1 - number of cross sections) on the hy_id + if (fix_ids) { + if (verbose) { message("Renumbering cross section IDs...") } + final_pts <- renumber_cs_ids(final_pts) + } + + # final_pts == hydrofabric3D:::renumber_cs_ids(final_pts) + + # then move the geometry column to the last column + final_pts <- move_geometry_to_last(final_pts) + # final_pts <- dplyr::relocate(final_pts, geom, .after = dplyr::last_col()) + + return(final_pts) +} + +#' @title Check and fix cross section points with limited variation in Z values (version 2 latest) +#' @description +#' This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (transects). +#' This function assumes the cross section points have been classified via "classify_points()" and have "has_relief" and "valid_banks" logical columns. +#' This function will look for cross section points that either have no relief or don't have valid banks, then the transect lines that generated these cross section points +#' are extended and new points are extracted along the newly extended, longer transect line. The newly extracted points are checked for relief AND valid banks and +#' are removed if they still have no relief or don't have valid banks. Any new points that became valid as a result of the extension process are added to the original dataset +#' and the rectified set of cross section points will be returned with an "is_extended" logical flag, indicating if the transect line that generated the cross section points was extended. +#' Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values. +#' @param cs_pts sf dataframe or dataframe of cross section points from cross_section_pts() followed by classify_points() +#' @param net Hydrographic LINESTRING Network +#' @param transects character, Hydrographic LINESTRING of transects along hydrographic (net) network +#' @param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +#' @param min_pts_per_cs Minimun number of points per cross section required. +#' @param dem the DEM to extract data from +#' @param scale numeric, If a transect line DEM extraction results in all equal Z values, +#' by what percent of the transect lines length (meters) should the transect line be +#' extended in both directions to try to capture representative Z values ? Default is 0.5 (50% of the transect length) +#' @param pct_of_length_for_relief numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1% of the cross sections length). +#' @param fix_ids logical, whether to reenumerate the "cs_id" column to +#' make sure cross sections are number 1 - number of total cross sections on flowline. Default is FALSE, cs_id will be kept as +#' they were in the input data and may contain gaps between cs_ids within a flowline (hy_id). +#' WARNING: Setting fix_ids = TRUE may result in input cross section points (cs_pts) having DIFFERENT cs_id values as the input transects (cs) +#' and the inconsistency can cause problems when trying to cross walk between the datasets in the future. +#' @param verbose logical, whether to print messages or not. Default is TRUE +#' @importFrom dplyr mutate relocate last_col select rename left_join group_by ungroup slice n bind_rows filter +#' @importFrom sf st_drop_geometry +#' @importFrom nhdplusTools rename_geometry +#' @return sf object of cs_pts with only cross sections points that have relief and have valid banks, other points that don't meet this condition are removed +#' @export +rectify_cs = function( + cs_pts = NULL, + net = NULL, + transects = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5, + pct_of_length_for_relief = 0.01, + fix_ids = FALSE, + verbose = TRUE +) { + + ### ### ### ### ### ### ### ### + ### ### ### ### ### ### ### ### + # cs_pts = classified_pts + # net = flines + # transects = transects + # points_per_cs = NULL + # min_pts_per_cs = 10 + # dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt" + # scale = 0.5 + # pct_of_length_for_relief = 0.01 + # fix_ids = FALSE + # verbose = TRUE + ### ### ### ### ### ### ### ### + ### ### ### ### ### ### ### ### + + # # starting column names + # start_cols <- names(cs_pts) + + # add a "tmp_id" column to easily index transects by hy_id and cs_id + transects <- hydrofabric3D::add_tmp_id(transects) + + ### ### ## ## ### ## ### ## ### ### ## ## ### ## ### ## + + if (verbose) { message("Determining points to reevaluate...") } + # # Check if any cross sections are "flat" within a threshold (All Z values are the same or the difference is within the threshold) + # pts_to_inspect <- pts_to_reevaluate(cs_pts = cs_pts, + # threshold = threshold, + # pct_threshold = pct_threshold) + + # filter down to cross sections that DON'T have valid banks OR DON'T have any relief + pts_to_inspect <- + cs_pts %>% + sf::st_drop_geometry() %>% + dplyr::filter(!valid_banks | !has_relief) + + # # Check if any cross sections are "flat" within a threshold (All Z values are the same or the difference is within the threshold) + # pts_to_inspect <- pts_to_reevaluate(cs_pts = cs_pts, threshold = threshold, pct_threshold = pct_threshold) + + # if there are no flatlines, return the cs_pts object + if (nrow(pts_to_inspect) == 0) { + + cs_pts <- + cs_pts %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::relocate(geom, .after = dplyr::last_col()) + + return(cs_pts) + } + + # subset transects (transects) to the flat cross sections in pts_to_inspect + trans_to_extend <- + transects %>% + dplyr::filter(tmp_id %in% unique(hydrofabric3D::add_tmp_id(pts_to_inspect)$tmp_id)) %>% + dplyr::select(-tmp_id) + + + # 1. Loop through geometries that might need to be extended, + # 2. Try to EXTEND, + # 3. and then UPDATE --> (only IF the extended transect does NOT violate any of the intersection rules) + # If ALL of the below intersection conditions are TRUE then a given extended transect line will get replace the old transect geometry + # Intersection rules: + # - Newly extended transect intersects with its flowlines AT MOST 1 time + # - Newly extended transect does NOT intersect with any of the other NEWLY EXTENDED transect lines + # - Newly extended transect does NOT intersect with any of the ORIGINAL transect lines + # extend_transects() returns the "trans_to_extend" object with updated attributes for any extensions that were made (geometries, cs_lengthm, "is_extended" flag) + extended_geoms <- extend_transects( + transects_to_extend = trans_to_extend, + transects = transects, + net = net, + scale = scale, + verbose = verbose + ) + + # Store unextendable transects for filtering out later on + # (these are transects that were flat AND could NOT be extended without violating an intersection rule) + unextendable <- dplyr::filter(extended_geoms, !is_extended) + + # Remove unextendable transects from extended_geoms + extended_geoms <- dplyr::filter(extended_geoms, is_extended) + + # system.time({ + + # add cross section points to extended cross sections + extended_geoms <- add_points_per_cs( + cs = extended_geoms, + # cs = trans_to_extend, + # cs = dplyr::slice(extended_geoms , 1:100), + points_per_cs = points_per_cs, + min_pts_per_cs = min_pts_per_cs, + dem = dem + ) + + # }) + + if (verbose) { message("Extracting new DEM values..")} + # system.time({ + + # extract DEM values for newly extended cross sections + extended_pts <- extract_dem_values(cs = extended_geoms, dem = dem) + + # }) + + # add a tmp_id for joining and filtering + extended_pts <- add_tmp_id(extended_pts) + + if (verbose) { message("Double checking new extended cross section DEM values for flatness") } + + classify_pts_again <- hydrofabric3D::classify_points( + extended_pts, + pct_of_length_for_relief = pct_of_length_for_relief + ) + + # add tmp id for convenience + classify_pts_again <- hydrofabric3D::add_tmp_id(classify_pts_again) + + # List of unique hy_id/cs_ids (tmp_id) that are STILL bad after attempting to extend and + # re-extract new cross section points from the extended transect line + # ---> ("Bad" = No relief OR not valid banks) + still_bad_ids <- + classify_pts_again %>% + dplyr::filter(!has_relief | !valid_banks) %>% + get_unique_tmp_ids() + + # TODO: Left off here to add back and remove old data 03/05/2024 + pts_to_keep <- dplyr::filter(extended_pts, !tmp_id %in% still_bad_ids) + pts_to_drop <- dplyr::filter(extended_pts, tmp_id %in% still_bad_ids) + # pts_to_keep <- dplyr::filter(extended_pts, !tmp_id %in% unique(dplyr::filter(classify_pts_again, + # !has_relief | !valid_banks)$tmp_id)) + # pts_to_drop <- dplyr::filter(extended_pts, tmp_id %in% unique(dplyr::filter(classify_pts_again, + # !has_relief | !valid_banks)$tmp_id)) + + # classify the pts_to_keep so they can be added back to the remaining "good" cross section points from the input + pts_to_keep <- hydrofabric3D::classify_points(pts_to_keep, pct_of_length_for_relief = pct_of_length_for_relief) + + # add is_extended logical if does not exist + if (!"is_extended" %in% names(pts_to_keep)) { + pts_to_keep$is_extended = TRUE + } + + # get list of unique tmp_ids for the "unextendable" dataframe, and for the "keep" and "drop" dataframes + unextendable_ids <- get_unique_tmp_ids(unextendable, x = hy_id, y = cs_id) + drop_ids <- get_unique_tmp_ids(pts_to_drop) + keep_ids <- get_unique_tmp_ids(pts_to_keep) + + # filter out cross section points that have "same Z" values (remove flat Z values) + final_pts <- + cs_pts %>% + hydrofabric3D::add_tmp_id() %>% + dplyr::filter( + !tmp_id %in% unextendable_ids + # !tmp_id %in% unique(hydrofabric3D::add_tmp_id(unextendable)$tmp_id) + # !tmp_id %in% unique(pts_to_drop$tmp_id) + ) %>% + dplyr::filter( + !tmp_id %in% drop_ids + # !tmp_id %in% unique(pts_to_drop$tmp_id) + ) + + # remove the old versions of the "pts_to_keep" cross section points and + # replace them with the updated cross section points with the extended "cs_lengthm" and "Z" values + final_pts <- + final_pts %>% + dplyr::filter( + !tmp_id %in% keep_ids + # !tmp_id %in% unique(pts_to_keep$tmp_id) + # !tmp_id %in% unique(extended_pts$tmp_id) + ) %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::bind_rows( + # pts_to_keep + hydrofabric3D::add_tmp_id(pts_to_keep) + ) %>% + dplyr::select(-tmp_id) + + # rectify_summary(cs_pts, final_pts) + + # rename geometry column to "geom" + final_pts <- nhdplusTools::rename_geometry(final_pts, "geom") + + # TODO: this should probably be removed and just kept as its own separete function and use outside of this function + # If TRUE then the cs_ids are renumbered to make sure each hy_id has cross sections + # that are numbered (1 - number of cross sections) on the hy_id + if (fix_ids) { + if (verbose) { message("Renumbering cross section IDs...") } + final_pts <- renumber_cs_ids(final_pts) + } + + # then move the geometry column to the last column + final_pts <- move_geometry_to_last(final_pts) + # final_pts <- dplyr::relocate(final_pts, geom, .after = dplyr::last_col()) + + return(final_pts) +} + +#' @title Fix IDs in a dataframe +#' +#' @description +#' This function renumbers cross section IDs in a dataframe to ensure each hy_id has cross sections +#' numbered from 1 to the total number of cross sections on the hy_id. +#' +#' @param df A dataframe containing hy_id and cs_id columns. +#' @return The input dataframe with renumbered cs_id values. +#' @importFrom dplyr select group_by slice ungroup mutate n left_join rename relocate +#' @importFrom sf st_drop_geometry +renumber_cs_ids <- function(df) { + + if (!"hy_id" %in% colnames(df) || !"cs_id" %in% colnames(df)) { + stop("The dataframe must contain 'hy_id' and 'cs_id' columns.") + } + + if (length(unique(df$hy_id)) == 0 || length(unique(df$cs_id)) == 0) { + stop("The dataframe must have non-empty 'hy_id' and 'cs_id' columns.") + } + + if (any(is.na(df$hy_id)) || any(is.na(df$cs_id))) { + stop("The 'hy_id' and 'cs_id' columns cannot have NA values.") + } + + # make a dataframe that has a new_cs_id column that has + # the cs_id renumbered to fill in any missing IDs, + # so each hy_id has cs_ids that go from 1 - number of cross sections on hy_id + # The dataframe below will be used to join the "new_cs_id" with + # the original "cs_ids" in the final_pts output data + renumbered_ids <- + df %>% + sf::st_drop_geometry() %>% + dplyr::select(hy_id, cs_id, pt_id, cs_measure) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::group_by(hy_id) %>% + dplyr::mutate( + new_cs_id = 1:dplyr::n(), + tmp_id = paste0(hy_id, "_", cs_id) + ) %>% + dplyr::ungroup() %>% + dplyr::select(new_cs_id, tmp_id) + + # Join the new cs_ids back with the final output data to replace the old cs_ids + df <- dplyr::left_join( + dplyr::mutate( + df, + tmp_id = paste0(hy_id, "_", cs_id) + ), + renumbered_ids, + by = "tmp_id" + ) %>% + dplyr::select(-cs_id, -tmp_id) %>% + dplyr::rename("cs_id" = "new_cs_id") %>% + dplyr::relocate(hy_id, cs_id) + + return(df) +} + + +#' @title Makes a summaru dataframe and print out of differences between 2 cross section points dataframes +#' @description +#' Convenience function for printing out the difference between a cross section point dataframe and +#' the resulting output of putting that dataframe through the rectify_cs() function +#' +#' @param input_points sf dataframe or dataframe of cross section points +#' @param output_points sf dataframe or dataframe of cross section points, with "is_extended" logical column +#' @param verbose logical, whether to print out summary message/ Default is TRUE +#' +#' @return dataframe +#' @importFrom dplyr select group_by arrange slice ungroup summarize count +#' @importFrom sf st_drop_geometry +#' @export +rectify_summary <- function(input_points, output_points, verbose = TRUE) { + + # drop geometries + input_points <- sf::st_drop_geometry(input_points) + output_points <- sf::st_drop_geometry(output_points) + + # change in number of hy_ids + input_number_of_hyids <- length(unique(input_points$hy_id)) + output_number_of_hyids <- length(unique(output_points$hy_id)) + number_removed_hyids <- input_number_of_hyids - output_number_of_hyids + + # number of rows + number_input_rows <- nrow(input_points) + number_output_rows <- nrow(output_points) + diff_in_row_number <- number_input_rows - number_output_rows + + change_in_rows_string <- ifelse(diff_in_row_number >= 0, + paste0(abs(diff_in_row_number), " rows were removed"), + paste0(abs(diff_in_row_number), " rows were added") + ) + + # Average points per cross section + input_pts_per_cs <- + input_points %>% + dplyr::select(hy_id, cs_id, pt_id) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::arrange(-pt_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::summarize(avg_pts_per_cs = round(mean(pt_id), 2)) %>% + .$avg_pts_per_cs + + output_pts_per_cs <- + output_points %>% + dplyr::select(hy_id, cs_id, pt_id) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::arrange(-pt_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::summarize(avg_pts_per_cs = round(mean(pt_id), 2)) %>% + .$avg_pts_per_cs + + # Extensions counts + output_extended_counts <- + output_points %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::count(is_extended) + # output_extended_counts <- + # output_points %>% + # dplyr::count(is_extended) + + is_extended_count <- output_extended_counts$n[output_extended_counts$is_extended == TRUE] + is_not_extended_count <- output_extended_counts$n[output_extended_counts$is_extended == FALSE] + + if(verbose) { + message("------ Rectification summary stats ------") + message("Change in number of 'hy_ids':") + message(paste0(" - Start number of 'hy_ids': ", input_number_of_hyids)) + message(paste0(" - End number of 'hy_ids': ", output_number_of_hyids)) + message(paste0(" - Number removed 'hy_ids': ", number_removed_hyids)) + message("Change in number of rows:") + message(paste0(" - Starting number of rows: ", number_input_rows)) + message(paste0(" - Ending number of rows: ", number_output_rows)) + message(paste0(" > ", change_in_rows_string)) + message("Average points per cross section:") + message(paste0(" - Starting average points per cross section: ", input_pts_per_cs)) + message(paste0(" - Ending average points per cross section: ", output_pts_per_cs)) + message("Extensions counts:") + message(paste0(" - Number of extended cross sections: ", is_extended_count, " / ", is_extended_count + is_not_extended_count)) + message(paste0(" - Number of non-extended cross sections: ", is_not_extended_count, " / ", is_extended_count + is_not_extended_count)) + message("-----------------------------------------") + } + + # Create dataframe + summary_df <- data.frame( + metric = c("Input number of hy_ids", "Output number of hy_ids", "Number removed hy_ids", + "Number of input rows", "Number of output rows", "Change in row number", + "Average input points per cross section", "Average output points per cross section", + "Count of extended points", "Count of non-extended points"), + value = c(input_number_of_hyids, output_number_of_hyids, number_removed_hyids, + number_input_rows, number_output_rows, change_in_rows_string, + input_pts_per_cs, output_pts_per_cs, + is_extended_count, is_not_extended_count) + ) + + return(summary_df) +} + +#' Check if there transects without valid banks or relief +#' +#' @param transects sf linestring with "valid_banks" and "has_relief" logical columns +#' +#' @return logical, TRUE if there are transects without valid banks or relief +#' @importFrom dplyr mutate case_when filter select +#' @importFrom sf st_drop_geometry +needs_rectification <- function(transects) { + + lines_to_inspect_counts <- + transects %>% + sf::st_drop_geometry() %>% + dplyr::mutate( + needs_rectification = dplyr::case_when( + !valid_banks | !has_relief ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::select(needs_rectification ) %>% + table() %>% + as.data.frame() %>% + dplyr::mutate(needs_rectification = as.logical(needs_rectification)) + + has_transects_to_rectify <- ifelse(nrow(dplyr::filter(lines_to_inspect_counts, needs_rectification )) == 0, FALSE, TRUE) + + return(has_transects_to_rectify) + +} + +#' Add a "needs_rectification" column to a sf/dataframe +#' +#' @param transects sf linestring with "valid_banks" and "has_relief" logical columns +#' +#' @return logical, TRUE if there are transects without valid banks or relief +#' @importFrom dplyr mutate case_when filter select +#' @importFrom sf st_drop_geometry +add_needs_rectification <- function(transects) { + + transects <- + transects %>% + dplyr::mutate( + needs_rectification = dplyr::case_when( + !valid_banks | !has_relief ~ TRUE, + TRUE ~ FALSE + ) + ) + + return(transects) + +} + +#' Calculate percentage of points within a set of cross section points that are near the bottom of the cross section +#' Adds the following columns: +#' is_near_bottom: state whether a point is near the bottom of the cross section (within a specified distance threshold of the bottom), +#' pts_near_bottom: count of points near the bottom of the cross section +#' pct_near_bottom: percent of points near the bottom of the cross section +#' @param cs_pts sf dataframe of cross section points (output of cross_section_pts() function) +#' @param distance_from_bottom numeric, distance threshold (in meters) to determine if a point is near the bottom of the cross section +#' @param look_only_above_bottom logical, whether to look only at points ABOVE the channel bottom as points that can be classified as "near bottom". +# Default is TRUE, meaning only points that are between Z and Z + distance_from_bottom are classified as "near bottom" +# If FALSE, then points at Z values BELOW the bottom (Z - distance_from_bottom) AND +# points at Z values ABOVE the bottom (Z + distance_from_bottom) are classified as +# "near bottom" if they are within the range BELOW OR ABOVE the bottom. +#' @param total_from_bottom_up logical, whether to use only points ABOVE bottom points as part of total points for calculating percentage of points near bottom. Default is FALSE and ALL points will be used when calculating percentage, even if a point has a Z value BELOW the bottom, but is NOT classified as a bottom point +#' @importFrom dplyr group_by mutate ungroup relocate filter summarize left_join between case_when select all_of last_col +#' @importFrom sf st_drop_geometry +#' @return sf dataframe of cross section points with the added columns described above +#' @export +pct_pts_near_bottom = function(cs_pts, + distance_from_bottom = 1, + look_only_above_bottom = TRUE, + total_from_bottom_up = FALSE +) { + + # + # cs_pts = cs_pts + # distance_from_bottom = 1 + # look_only_above_bottom = TRUE + # look_only_above_bottom = FALSE + # total_from_bottom_up = FALSE + # + + # Drop geometries to work with tabular data only + flat_check <- + cs_pts %>% + sf::st_drop_geometry() + + # classify cross section points and add back point count per cross section column + flat_check <- + flat_check %>% + # dplyr::rename(cs_widths = cs_lengthm) %>% + hydrofabric3D::classify_points() %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + points_per_cs = dplyr::n() + ) %>% + dplyr::ungroup() %>% + sf::st_drop_geometry() + # dplyr::relocate(hy_id, cs_id, pt_id, Z, class, points_per_cs) + + # # if there is no "class" column, classify the points using classify_points() + # if (!"class" %in% colnames(cs_pts)) { } + + # reorder columns + flat_check <- dplyr::relocate(flat_check, + hy_id, cs_id, pt_id, Z, class, points_per_cs) + + # get the minimum Z value of the bottom points of each cross section and add this as a column to cs_pts + bottomZ = + flat_check %>% + # sf::st_drop_geometry() %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::filter(class == "bottom") %>% + dplyr::summarize( + Z_at_bottom = min(Z) + ) %>% + dplyr::ungroup() + + # join the flat_check dataframe with the dataframe containing the Z values of the bottom depths for each cross section + bottom_pct = + flat_check %>% + dplyr::left_join( + bottomZ, + by = c("hy_id", "cs_id") + ) + + # TODO: This code could be shortened and combined with the ELSE clause, just being lazy right now + if(total_from_bottom_up) { + # When calculating the percentage, use only points that are GREATER THAN OR EQUAL to the bottom Z as part of percentage calculation. + bottom_pct <- + bottom_pct %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + lower_bound = ifelse(look_only_above_bottom, Z_at_bottom, Z_at_bottom - distance_from_bottom), + upper_bound = Z_at_bottom + distance_from_bottom, + is_near_bottom = dplyr::between( + Z, + lower_bound, + upper_bound + ), + ge_bottom = dplyr::case_when( + Z >= Z_at_bottom ~ TRUE, + TRUE ~ FALSE + ), + total_valid_pts = sum(ge_bottom), + pts_near_bottom = sum(is_near_bottom), + pct_near_bottom = pts_near_bottom/total_valid_pts, + tmp_id = paste0(hy_id, "_", cs_id, "_", pt_id) + ) %>% + dplyr::ungroup() %>% + dplyr::select(tmp_id, class, Z_at_bottom, is_near_bottom, pts_near_bottom, pct_near_bottom, lower_bound, upper_bound, total_valid_pts) + } else { + + # Given the Z value of each point, and the Z value of the bottom points ("Z_at_bottom"), + # determine if each point is near the bottom + # If the Z value for a given point is between the lower_bound and upper_bound, then the the point is determined to be "is_near_bottom" + # If look_only_above_bottom is TRUE, then the lower_bound is the Z value at the bottom points (Z_at_bottom), otherwise + # If look_only_above_bottom is FALSE, then the lower_bound is the Z value at the bottom points (Z_at_bottom) minus distance_from_bottom (Z_at_bottom - distance_from_bottom) + bottom_pct <- + bottom_pct %>% + # sf::st_drop_geometry() %>% + # dplyr::filter(hy_id == "wb-2399072", cs_id == 3) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + lower_bound = ifelse(look_only_above_bottom, Z_at_bottom, Z_at_bottom - distance_from_bottom), + upper_bound = Z_at_bottom + distance_from_bottom, + is_near_bottom = dplyr::between( + Z, + lower_bound, + upper_bound + ), + # pts_near_bottom = sum(dplyr::between(Z, Z_at_bottom - distance_from_bottom, Z_at_bottom + distance_from_bottom)), + pts_near_bottom = sum(is_near_bottom), + pct_near_bottom = pts_near_bottom/points_per_cs, + tmp_id = paste0(hy_id, "_", cs_id, "_", pt_id) + ) %>% + dplyr::ungroup() %>% + dplyr::select( + tmp_id, class, Z_at_bottom, + is_near_bottom, pts_near_bottom, pct_near_bottom, + lower_bound, upper_bound, + total_valid_pts = points_per_cs + ) + } + + # join bottom points percent table to cs_pts + cs_pts <- dplyr::left_join( + dplyr::mutate( + cs_pts, + tmp_id = paste0(hy_id, "_", cs_id, "_", pt_id) + ), + bottom_pct, + by = "tmp_id" + ) %>% + dplyr::select(-tmp_id) + + # get the sf geometryt column name + geometry_colname <- names(cs_pts)[sapply(cs_pts, function(col) any( + class(col) %in% c("sfc_POINT", "sfc", + "sfc_GEOMETRY", "sfc_MULTIPOINT"))) + ] + + # move the geometry column to the end of the dataframe + cs_pts <- + cs_pts %>% + # dplyr::relocate(hy_id, cs_id, pt_id, Z, class, Z_at_bottom, is_near_bottom, pts_near_bottom, pct_near_bottom) + # dplyr::relocate(geometry_colname, .after = dplyr::last_col()) + dplyr::relocate(dplyr::all_of(geometry_colname), .after = dplyr::last_col()) + + return(cs_pts) + +} + +#' Get a dataframe of points that should be evaluated due to their proximity (nearness in Z distance) to the bottom +#' +#' @param cs_pts dataframe/sf dataframe of cross section points (requires hy_id, cs_id, and Z values) +#' @param threshold numeric, threshold distance in meters for points to be considered "near the bottom". Default is 1 meter (i.e. check if points are within 1 meter above the bottom) +#' @param pct_threshold numeric, threshold percent of points in the cross section that are within threshold of bottom to +#' determine whether point should be considered for re evaluation. Default is 0.99 (i.e. 99% of points are near the bottom). Default is 0.99 (i.e. 99&%). +#' +#' @return dataframe with the hy_id, cs_id, pts_near_bottom (count of pts_near_bottom), and pct_near_bottom (% of points in cross section that are near bottom). +#' An empty dataframe is returned if ZERO points are classified as "near the bottom" +#' @importFrom dplyr mutate filter select group_by slice ungroup +#' @importFrom sf st_drop_geometry +#' @export +pts_to_reevaluate <- function( + cs_pts, + threshold = 1, + pct_threshold = 0.99 +) { + + # + # cs_pts = cs_pts + # threshold = 1 + # pct_threshold = 0.99 + # + + # Determine which points that are within "threshold" meters from the bottom + # (only looking at points above threshold, ignoring any points that are BELOW Z) + # So the "pct_pts_near_bottom()" function adds columns to the "cs_pts" input data that detail which points are "near" the bottom points. + # "bottom" points are classified via hydrofabric3D::classify_pts() + near_bottom <- + cs_pts %>% + pct_pts_near_bottom( + distance_from_bottom = threshold, + look_only_above_bottom = TRUE, + total_from_bottom_up = FALSE + ) + + # Determine which points should be re evaluated (by extending) because most of the points are all "near the bottom" + # Filter the "near_bottom" dataframe to only cross sections that + # have a percent of all of the cross sections points that are GREATER THAN OR EQUAL to "pct_threshold" + + # In simple words, get the cross sections that have, for example, 80% of its points that are "near the bottom" + + # Also filter cross sections that have only a SINGLE point that is NOT near the bottom: + # -----> So if a cross section has 9/10 of its points near the bottom, + # that means only a single point is NOT near the bottom and thus + # that cross section should be kept for FURTHER EVALUATION + near_bottom <- + near_bottom %>% + sf::st_drop_geometry() %>% + # to_check %>% + dplyr::mutate( + diff_pts = total_valid_pts - pts_near_bottom + ) %>% + dplyr::filter(pct_near_bottom >= pct_threshold | diff_pts == 1) %>% + dplyr::select(-diff_pts) %>% + # dplyr::filter(pct_near_bottom >= pct_threshold) %>% + # dplyr::relocate(pts_near_bottom, total_valid_pts, pct_near_bottom) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + # dplyr::select(-is_near_bottom, -Z_at_bottom, -pts_near_bottom, -pct_near_bottom, -lower_bound, -upper_bound) + # dplyr::select(hy_id, cs_id, Z_at_bottom, pts_near_bottom, pct_near_bottom, lower_bound, upper_bound) + + return(near_bottom) + +} + +#' Check and fix cross section points with limited variation in Z values (version 2 latest) +#' This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (cs). +#' The function that looks at the cross section points and identifies cross sections that are "flat" +#' (have a percent of all points in the cross section within a threshold distance from the bottom of the cross section). +#' The transect lines that generated the "flat" cross section points are then extended and new points are extracted +#' along this new longer transect line. The newly extracted points are checked for "flatness" and are removed if they are still "flat", otherwise the original dataset +#' of points is updated with the new set of point derived from an extended transect line. +#' Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values. +#' @param cs_pts Output from extract_dem_values_first +#' @param net Hydrographic LINESTRING Network +#' @param cs character, Hydrographic LINESTRING Network file path +#' @param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +#' @param min_pts_per_cs Minimun number of points per cross section required. +#' @param dem the DEM to extract data from +#' @param scale numeric, If a transect line DEM extraction results in all equal Z values, +#' by what percent of the transect lines length (meters) should the transect line be +#' extended in both directions to try to capture representative Z values ? Default is 0.5 (50% of the transect length) +#' @param threshold numeric, threshold Z value (meters) that determines if a cross section is flat. +#' A threshold = 0 means if all Z values are the same, then the cross section is considered flat. +#' A threshold value of 1 means that any cross section with Z values all within 1 meter of eachother, is considered flat. Default is 0. +#' @param pct_threshold numeric, threshold percent of points in the cross section that are within threshold of bottom to +#' determine whether point should be considered for re evaluation. Default is 0.99 (i.e. 99% of points are near the bottom) +#' @param fix_ids logical, whether to reenumerate the "cs_id" column to +#' make sure cross sections are number 1 - number of total cross sections on flowline. Default is FALSE, cs_id will be kept as +#' they were in the input data and may contain gaps between cs_ids within a flowline (hy_id). +#' WARNING: Setting fix_ids = TRUE may result in input cross section points (cs_pts) having DIFFERENT cs_id values as the input transects (cs) +#' and the inconsistency can cause problems when trying to cross walk between the datasets in the future. +#' @importFrom dplyr mutate relocate last_col select rename left_join group_by ungroup slice n bind_rows filter +#' @importFrom sf st_drop_geometry +#' @importFrom nhdplusTools rename_geometry +#' @return sf object of cs_pts with "flat" cross sections removed/updated with longer transects to capture more Z data +#' @export +rectify_flat_cs = function( + cs_pts = NULL, + net = NULL, + cs = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5, + threshold = 0, + pct_threshold = 0.99, + fix_ids = FALSE +) { + + # net = flines2 + # cs = transects2 + # cs_pts = cs_pts2 + # points_per_cs = NULL + # min_pts_per_cs = 10 + # dem = DEM_URL + # scale = 0.5 + # threshold = 1 + # pct_threshold = 0.99 + + # add a "tmp_id" column to easily index transects by hy_id and cs_id + cs <- hydrofabric3D::add_tmp_id(cs) + # cs <- dplyr::mutate(cs, + # tmp_id = paste0(hy_id, "_", cs_id) + # ) + + ### ### ## ## ### ## ### ## ### ### ## ## ### ## ### ## + message("Determining points to reevaluate...") + # logger::log_info("Determining points to reevaluate...") + + # Check if any cross sections are "flat" within a threshold (All Z values are the same or the difference is within the threshold) + flat_cs <- pts_to_reevaluate(cs_pts = cs_pts, + threshold = threshold, + pct_threshold = pct_threshold + ) + + # if there are no flatlines, return the cs_pts object + if (nrow(flat_cs) == 0) { + + cs_pts <- + cs_pts %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::relocate(geom, .after = dplyr::last_col()) + + return(cs_pts) + } + + # subset transects (cs) to the flat cross sections in flat_cs + to_extend <- + cs %>% + # dplyr::mutate(# tmp_id = paste0(hy_id, "_", cs_id)is_extended = FALSE) %>% + dplyr::filter(tmp_id %in% unique(dplyr::mutate(flat_cs, # Filter the cross sections ("cs") for any cross sections that were decided to be flat/needing reevaluation + tmp_id = paste0(hy_id, "_", cs_id))$tmp_id) + ) %>% + dplyr::select(-tmp_id) + + # 1. Loop through geometries that might need to be extended, + # 2. Try to EXTEND, + # 3. and then UPDATE --> (only IF the extended transect does NOT violate any of the intersection rules) + # If ALL of the below intersection conditions are TRUE then a given extended transect line will get replace the old transect geometry + # Intersection rules: + # - Newly extended transect intersects with its flowlines AT MOST 1 time + # - Newly extended transect does NOT intersect with any of the other NEWLY EXTENDED transect lines + # - Newly extended transect does NOT intersect with any of the ORIGINAL transect lines + # extend_transects() returns the "to_extend" object with updated attributes for any extensions that were made (geometries, cs_lengthm, "is_extended" flag) + extended_geoms <- extend_transects( + transects_to_extend = to_extend, + transects = cs, + net = net, + scale = scale + ) + + # TODO: + # # Probably can just drop any "is_extended" == FALSE because + # # these were cross sections that yield FLAT points + # # AND they CAN'T be extended according to extend_transects() + # hopeless <- dplyr::filter(extended_geoms, !is_extended) + + # Store unextendable transects for filtering out later on + # (these are transects that were flat AND could NOT be extended without violating an intersection rule) + unextendable <- dplyr::filter(extended_geoms, !is_extended) + + # Remove unextendable transects from extended_geoms + extended_geoms <- dplyr::filter(extended_geoms, is_extended) + + message("Attempted extensions: ", nrow(to_extend)) + message("- FAILED extensions: ", nrow(unextendable)) + message("- SUCCESSFUL extensions: ", nrow(extended_geoms)) + message("Adding points per cross section...") + + # add cross section points to extended cross sections + extended_geoms <- add_points_per_cs( + cs = extended_geoms, + # cs = to_extend, + # cs = dplyr::slice(extended_geoms , 1:100), + points_per_cs = points_per_cs, + min_pts_per_cs = min_pts_per_cs, + dem = dem + ) + + + message("Extracting new DEM values..") + + # extract DEM values for newly extended cross sections + extended_pts <- extract_dem_values(cs = extended_geoms, dem = dem) + + # add a tmp_id for joining and filtering + extended_pts <- add_tmp_id(extended_pts) + # extended_pts <- dplyr::mutate( + # extended_pts, + # tmp_id = paste0(hy_id, "_", cs_id) + # ) + + message("Double checking new extended cross section DEM values for flatness") + + # Check the new extended_pts cross section points for any "flat" set of points + second_flat_check <- pts_to_reevaluate( + cs_pts = extended_pts, + threshold = threshold, + pct_threshold = pct_threshold + ) + + + # add a tmp_id column to second_flat_check to filter out any set of cross section points + # that are STILL flat after extending the transect lines + second_flat_check <- add_tmp_id(second_flat_check) + # second_flat_check <- dplyr::mutate( + # second_flat_check, + # tmp_id = paste0(hy_id, "_", cs_id) + # ) + + # take the below points, and put them back into "cs_pts" object + # then go back to the input "transects" ("cs") object and update the transect geometries based on the extensions done above^^ + # then resave the input transects dataset back to its original location.... + + # separate newly extended cross sections with new Z values into groups (those that show "good" DEM values after extension are kept) + to_keep <- dplyr::filter(extended_pts, !tmp_id %in% unique(second_flat_check$tmp_id)) + to_drop <- dplyr::filter(extended_pts, tmp_id %in% unique(second_flat_check$tmp_id)) + + message("Count of extended cross sections POINTS to KEEP: ", nrow(to_keep)) + message("Count of extended cross sections POINTS to DROP: ", nrow(to_drop)) + + # filter out cross section points that have "same Z" values (remove flat Z values) + final_pts <- + cs_pts %>% + # dplyr::mutate( + # tmp_id = paste0(hy_id, "_", cs_id) + # ) %>% + add_tmp_id() %>% + dplyr::filter( + !tmp_id %in% unique( + dplyr::mutate( + unextendable, + tmp_id = paste0(hy_id, "_", cs_id) + )$tmp_id) + # !tmp_id %in% unique(to_drop$tmp_id) + ) %>% + dplyr::filter( + !tmp_id %in% unique(to_drop$tmp_id) + ) + + # remove the old versions of the "to_keep" cross section points and + # replace them with the updated cross section points with the extended "cs_lengthm" and "Z" values + final_pts <- + final_pts %>% + dplyr::filter( + !tmp_id %in% unique(to_keep$tmp_id) + # !tmp_id %in% unique(extended_pts$tmp_id) + ) %>% + dplyr::mutate( + is_extended = FALSE + ) %>% + dplyr::bind_rows( + to_keep + ) %>% + dplyr::select(-tmp_id) + + # rename geometry column to "geom" + final_pts <- nhdplusTools::rename_geometry(final_pts, "geom") + + # If TRUE then the cs_ids are renumbered to make sure each hy_id has cross sections + # that are numbered (1 - number of cross sections) on the hy_id + if (fix_ids) { + + message("Renumbering cross section IDs...") + + # make a dataframe that has a new_cs_id column that has + # the cs_id renumbered to fill in any missing IDs, + # so each hy_id has cs_ids that go from 1 - number of cross sections on hy_id + # The dataframe below will be used to join the "new_cs_id" with + # the original "cs_ids" in the final_pts output data + renumbered_ids <- + final_pts %>% + sf::st_drop_geometry() %>% + # dplyr::filter(hy_id %in% c("wb-2402800", "wb-2398282", "wb-2400351")) %>% + dplyr::select(hy_id, cs_id, pt_id, cs_measure) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::group_by(hy_id) %>% + dplyr::mutate( + new_cs_id = 1:dplyr::n(), + tmp_id = paste0(hy_id, "_", cs_id) + ) %>% + dplyr::ungroup() %>% + dplyr::select(new_cs_id, tmp_id) + + # Join the new cs_ids back with the final output data to replace the old cs_ids + final_pts <- dplyr::left_join( + dplyr::mutate( + final_pts, + tmp_id = paste0(hy_id, "_", cs_id) + ), + renumbered_ids, + by = "tmp_id" + ) %>% + dplyr::select(-cs_id, -tmp_id) %>% + dplyr::rename("cs_id" = "new_cs_id") %>% + dplyr::relocate(hy_id, cs_id) + } + + # move geom column to the last column + final_pts <- dplyr::relocate(final_pts, geom, .after = dplyr::last_col()) + + message("TOTAL # of transects EVALUATED > ", nrow(to_extend)) + message("# of transects that are INVALID after extension > ", nrow(unextendable)) + message("# of transects KEPT after extension > ", length(unique(to_keep$tmp_id))) + message("# of transects REMOVED after extension >", length(unique(to_drop$tmp_id))) + message("INVALID + KEPT + REMOVED = ", + nrow(unextendable), " + ", length(unique(to_keep$tmp_id)), " + ", length(unique(to_drop$tmp_id)), + " = ", + nrow(unextendable) + length(unique(to_keep$tmp_id)) + length(unique(to_drop$tmp_id)) + ) + message("Start # of cross section points > ", length(unique(dplyr::mutate(cs_pts, tmp_id = paste0(hy_id, '_', cs_id, '_',pt_id))$tmp_id))) + message("End # of cross section points > ", length(unique(dplyr::mutate(final_pts, tmp_id = paste0(hy_id, '_', cs_id, '_',pt_id))$tmp_id))) + message("INPUT # of unique hy_id/cs_id cross section points > ", length(unique(dplyr::mutate(cs_pts, tmp_id = paste0(hy_id, '_', cs_id))$tmp_id))) + message("OUTPUT # of unique hy_id/cs_id cross section points > ", length(unique(dplyr::mutate(final_pts, tmp_id = paste0(hy_id, '_', cs_id))$tmp_id))) + + # final_pts$is_extended %>% table() + + return(final_pts) +} + + +#Check for flat cross sections and try to update these values by extending the original cross sections and reextracting DEM values +#(Deprecated version 1) +#@param cs_pts Output from extract_dem_values_first +#@param net Hydrographic LINESTRING Network +#@param cs character, Hydrographic LINESTRING Network file path +#@param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. +#@param min_pts_per_cs Minimun number of points per cross section required. +#@param dem the DEM to extract data from +#@param scale numeric, If a transect line DEM extraction results in all equal Z values, +# by what percent of the transect lines length (meters) should the transect line be +# extended in both directions to try to capture representative Z values ? Default is 0.5 (50% of the transect length) +#@param threshold numeric, threshold Z value (meters) that determines if a cross section is flat. +#A threshold = 0 means if all Z values are the same, then the cross section is considered flat. +#A threshold value of 1 means that any cross section with Z values all within 1 meter of eachother, is considered flat. Default is 0. +#@importFrom dplyr mutate relocate last_col group_by ungroup n select everything relocate last_col bind_rows filter +#@importFrom sf st_intersection st_is st_intersects +#@importFrom nhdplusTools rename_geometry +#@return sf object of cs_pts with "flat" cross sections removed/updated with longer transects to capture more Z data +# rectify_flat_cs_v1 = function( +# cs_pts = NULL, +# net = NULL, +# cs = NULL, +# points_per_cs = NULL, +# min_pts_per_cs = 10, +# dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", +# scale = 0.5, +# threshold = 0 +# ) { +# +# ### ### ## ## ### ## ### ## +# ## ### ### ### ### #### ## +# +# # add a "tmp_id" column to easily index transects by hy_id and cs_id +# cs <- dplyr::mutate(cs, +# tmp_id = paste0(hy_id, "_", cs_id) +# ) +# +# # Check if any cross sections are "flat" within a threshold (All Z values are the same or the difference is within the threshold) +# flat_cs <- check_z_values(pts = cs_pts, threshold = threshold) +# +# # if there are no flatlines, return the cs_pts object +# if (nrow(flat_cs) == 0) { +# +# cs_pts <- +# cs_pts %>% +# dplyr::mutate( +# is_extended = FALSE +# ) %>% +# dplyr::relocate(geom, .after = dplyr::last_col()) +# +# return(cs_pts) +# } +# +# # subset transects (cs) to the flat cross sections in flat_cs +# to_extend <- +# cs %>% +# # dplyr::mutate( +# # # tmp_id = paste0(hy_id, "_", cs_id) +# # is_extended = FALSE +# # ) %>% +# dplyr::filter(tmp_id %in% unique( +# dplyr::mutate(flat_cs, +# tmp_id = paste0(hy_id, "_", cs_id))$tmp_id +# )) %>% +# dplyr::select(-tmp_id) +# # dplyr::relocate(geom, .after = dplyr::last_col()) +# +# # loop through geometries that might need to be extended, try to extend, and then update +# # the 'to_extend' values IF the extended transectr does NOT violate any intersection rules +# for(i in 1:nrow(to_extend)) { +# # message("i: ", i) +# # extend transect out by "scale" % of lines length +# extended_tran <- extend_by_percent( +# x = to_extend[i, ], +# pct = scale, +# length_col = "cs_lengthm" +# ) +# +# # filter down to the rest of the transects on the given "hy_id", EXCLUDING SELF +# neighbor_transects <- dplyr::filter(cs, +# hy_id == to_extend[i, ]$hy_id, +# cs_id != to_extend[i, ]$cs_id +# ) +# +# # # filter down to ALL OF THE OTHER TRANSECTS (EXCEPT SELF) +# # neighbor_transects <- dplyr::filter(cs, tmp_id != to_extend[i, ]$tmp_id) +# +# # Make sure that newly extended line only interesects its origin flowline at MOST 1 time +# # AND that the newly extended transect does NOT intersect with any previously computed transect lines +# +# fline_intersect <- sf::st_intersection( +# extended_tran, +# net[net$id == to_extend[i, ]$hy_id, ] +# # dplyr::filter(net, id == to_extend[i, ]$hy_id) +# ) +# +# if(nrow(fline_intersect) > 0) { +# +# # Check that newly extended cross section only interesects its origin flowline at MOST 1 time (This value will be a "MULTIPOINT" if it intersects more than once) +# if ( +# sf::st_is( +# fline_intersect, "POINT" +# ) && +# # Check that extended transect doesn't intersect with any of the NEWLY EXTENDED cross sections +# !any(sf::st_intersects( +# extended_tran, +# to_extend[-i, ], +# sparse = FALSE +# )) && +# # Check that extended transect doesn't intersect with any of the original cross sections on this "hy_id" +# !any(sf::st_intersects( +# extended_tran, +# neighbor_transects, +# sparse = FALSE +# )) +# ) { +# +# # # set is_extended to TRUE +# # extended_tran$is_extended <- TRUE +# +# # replace old transect with extended geometry and updated lengths, etc. +# to_extend[i, ] <- extended_tran +# +# } +# } +# # message("=========") +# } +# +# # # extend linestring geometries by a percent of linestring length +# # extended <- extend_by_percent(x = to_extend, pct = scale, length_col = "cs_lengthm") +# +# # add cross section points to extended cross sections +# extended <- add_points_per_cs( +# cs = to_extend, +# points_per_cs = points_per_cs, +# min_pts_per_cs = min_pts_per_cs, +# dem = dem +# ) +# +# # extract DEM values for newly extended cross sections +# extended_pts <- extract_dem_values(cs = extended, dem = dem) +# +# # take the below points, and put them back into "cs_pts" object +# # then go back to the input "transects" ("cs") object and update the transect geometries based on the extensions done above^^ +# # then resave the input transects dataset back to its original location.... +# extended_pts <- +# extended_pts %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::mutate( +# is_same_Z = max(Z) - min(Z) <= threshold +# ) %>% +# dplyr::ungroup() %>% +# dplyr::mutate( +# tmp_id = paste0(hy_id, "_", cs_id) +# ) +# +# # separate newly extended cross sections with new Z values into groups (those that show "good" DEM values after extension are kept) +# to_keep <- dplyr::filter(extended_pts, !is_same_Z) +# to_drop <- dplyr::filter(extended_pts, is_same_Z) +# +# # filter out cross section points that have "same Z" values (remove flat Z values) +# final_pts <- +# cs_pts %>% +# dplyr::mutate( +# tmp_id = paste0(hy_id, "_", cs_id) +# ) %>% +# dplyr::filter( +# !tmp_id %in% unique(to_drop$tmp_id) +# ) +# +# # remove the old versions of the "to_keep" cross section points and +# # replace them with the updated cross section points with the extended "cs_lengthm" and "Z" values +# final_pts <- +# final_pts %>% +# dplyr::filter( +# !tmp_id %in% unique(to_keep$tmp_id) +# ) %>% +# dplyr::mutate( +# is_extended = FALSE +# ) %>% +# dplyr::bind_rows( +# dplyr::select( +# dplyr::mutate( +# to_keep, +# is_extended = TRUE +# ), +# -is_same_Z) +# ) %>% +# dplyr::select(-tmp_id) +# +# # rename geometry column to "geom" +# final_pts <- nhdplusTools::rename_geometry(final_pts, "geom") +# +# # move geom column to the last column +# final_pts <- dplyr::relocate(final_pts, geom, .after = dplyr::last_col()) +# +# # final_pts$is_extended %>% table() +# +# return(final_pts) +# } + +#Check for any Z values that are all equal or within a given threshold value +#@param pts sf points dataframe +#@param threshold numeric, default is 1 meter +#@importFrom dplyr select group_by mutate filter slice ungroup +#@importFrom sf st_drop_geometry st_line_sample st_cast +#@return dataframe with hy_id, cs_id, Z, and is_same_Z value columns +# check_z_values <- function(pts, threshold = 1) { +# +# # check for any flat cross sections (All Z values are equal within a given cross section) +# flat_pts <- +# pts %>% +# sf::st_drop_geometry() %>% +# dplyr::select(hy_id, cs_id, Z) %>% +# # dplyr::filter(hy_id != "wb-2959") %>% +# # dplyr::filter(!hy_id %in% c("wb-2959", "wb-2960", "wb-4131", "wb-4364", "wb-4365", "wb-4770")) %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::mutate( +# is_same_Z = max(Z) - min(Z) <= threshold +# # is_same_Z = as.integer(dplyr::n_distinct(Z) == 1) +# ) %>% +# dplyr::filter(is_same_Z) %>% +# # dplyr::filter(is_same_Z == 1) %>% +# dplyr::slice(1) %>% +# dplyr::ungroup() +# +# return(flat_pts) +# } + + +#Calculate percentage of points within a set of cross section points that are near the bottom of the cross section +#Adds the following columns: +#is_near_bottom: state whether a point is near the bottom of the cross section (within a specified distance threshold of the bottom), +#pts_near_bottom: count of points near the bottom of the cross section +#pct_near_bottom: percent of points near the bottom of the cross section +#@param cs_pts sf dataframe of cross section points (output of cross_section_pts() function) +#@param distance_from_bottom numeric, distance threshold (in meters) to determine if a point is near the bottom of the cross section +#@param look_only_above_bottom logical, whether to look only at points ABOVE the channel bottom as points that can be classified as "near bottom". +# Default is TRUE, meaning only points that are between Z and Z + distance_from_bottom are classified as "near bottom" +# If FALSE, then points at Z values BELOW the bottom (Z - distance_from_bottom) AND +# points at Z values ABOVE the bottom (Z + distance_from_bottom) are classified as +# "near bottom" if they are within the range BELOW OR ABOVE the bottom. +#@param total_from_bottom_up logical, whether to use only points ABOVE bottom points as part of total points for calculating percentage of points near bottom. Default is FALSE and ALL points will be used when calculating percentage, even if a point has a Z value BELOW the bottom, but is NOT classified as a bottom point +#@importFrom dplyr group_by mutate ungroup relocate filter summarize left_join between case_when select all_of last_col +#@importFrom sf st_drop_geometry +#@return sf dataframe of cross section points with the added columns described above +#@export +# pct_pts_near_bottom = function(cs_pts, +# distance_from_bottom = 1, +# look_only_above_bottom = TRUE, +# total_from_bottom_up = FALSE +# ) { +# +# # +# # cs_pts = cs_pts +# # distance_from_bottom = 1 +# # look_only_above_bottom = TRUE +# # look_only_above_bottom = FALSE +# # total_from_bottom_up = FALSE +# # +# +# # Drop geometries to work with tabular data only +# flat_check <- +# cs_pts %>% +# sf::st_drop_geometry() +# +# # classify cross section points and add back point count per cross section column +# flat_check <- +# flat_check %>% +# # dplyr::rename(cs_widths = cs_lengthm) %>% +# hydrofabric3D::classify_points() %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::mutate( +# points_per_cs = dplyr::n() +# ) %>% +# dplyr::ungroup() %>% +# sf::st_drop_geometry() +# # dplyr::relocate(hy_id, cs_id, pt_id, Z, class, points_per_cs) +# +# # # if there is no "class" column, classify the points using classify_points() +# # if (!"class" %in% colnames(cs_pts)) { } +# +# # reorder columns +# flat_check <- dplyr::relocate(flat_check, +# hy_id, cs_id, pt_id, Z, class, points_per_cs) +# +# # get the minimum Z value of the bottom points of each cross section and add this as a column to cs_pts +# bottomZ = +# flat_check %>% +# # sf::st_drop_geometry() %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::filter(class == "bottom") %>% +# dplyr::summarize( +# Z_at_bottom = min(Z) +# ) %>% +# dplyr::ungroup() +# +# # join the flat_check dataframe with the dataframe containing the Z values of the bottom depths for each cross section +# bottom_pct = +# flat_check %>% +# dplyr::left_join( +# bottomZ, +# by = c("hy_id", "cs_id") +# ) +# +# # TODO: This code could be shortened and combined with the ELSE clause, just being lazy right now +# if(total_from_bottom_up) { +# # When calculating the percentage, use only points that are GREATER THAN OR EQUAL to the bottom Z as part of percentage calculation. +# bottom_pct <- +# bottom_pct %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::mutate( +# lower_bound = ifelse(look_only_above_bottom, Z_at_bottom, Z_at_bottom - distance_from_bottom), +# upper_bound = Z_at_bottom + distance_from_bottom, +# is_near_bottom = dplyr::between( +# Z, +# lower_bound, +# upper_bound +# ), +# ge_bottom = dplyr::case_when( +# Z >= Z_at_bottom ~ TRUE, +# TRUE ~ FALSE +# ), +# total_valid_pts = sum(ge_bottom), +# pts_near_bottom = sum(is_near_bottom), +# pct_near_bottom = pts_near_bottom/total_valid_pts, +# tmp_id = paste0(hy_id, "_", cs_id, "_", pt_id) +# ) %>% +# dplyr::ungroup() %>% +# dplyr::select(tmp_id, class, Z_at_bottom, is_near_bottom, pts_near_bottom, pct_near_bottom, lower_bound, upper_bound, total_valid_pts) +# } else { +# +# # Given the Z value of each point, and the Z value of the bottom points ("Z_at_bottom"), +# # determine if each point is near the bottom +# # If the Z value for a given point is between the lower_bound and upper_bound, then the the point is determined to be "is_near_bottom" +# # If look_only_above_bottom is TRUE, then the lower_bound is the Z value at the bottom points (Z_at_bottom), otherwise +# # If look_only_above_bottom is FALSE, then the lower_bound is the Z value at the bottom points (Z_at_bottom) minus distance_from_bottom (Z_at_bottom - distance_from_bottom) +# bottom_pct <- +# bottom_pct %>% +# # sf::st_drop_geometry() %>% +# # dplyr::filter(hy_id == "wb-2399072", cs_id == 3) %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::mutate( +# lower_bound = ifelse(look_only_above_bottom, Z_at_bottom, Z_at_bottom - distance_from_bottom), +# upper_bound = Z_at_bottom + distance_from_bottom, +# is_near_bottom = dplyr::between( +# Z, +# lower_bound, +# upper_bound +# ), +# # pts_near_bottom = sum(dplyr::between(Z, Z_at_bottom - distance_from_bottom, Z_at_bottom + distance_from_bottom)), +# pts_near_bottom = sum(is_near_bottom), +# pct_near_bottom = pts_near_bottom/points_per_cs, +# tmp_id = paste0(hy_id, "_", cs_id, "_", pt_id) +# ) %>% +# dplyr::ungroup() %>% +# dplyr::select( +# tmp_id, class, Z_at_bottom, +# is_near_bottom, pts_near_bottom, pct_near_bottom, +# lower_bound, upper_bound, +# total_valid_pts = points_per_cs +# ) +# } +# +# # join bottom points percent table to cs_pts +# cs_pts <- dplyr::left_join( +# dplyr::mutate( +# cs_pts, +# tmp_id = paste0(hy_id, "_", cs_id, "_", pt_id) +# ), +# bottom_pct, +# by = "tmp_id" +# ) %>% +# dplyr::select(-tmp_id) +# +# # get the sf geometryt column name +# geometry_colname <- names(cs_pts)[sapply(cs_pts, function(col) any( +# class(col) %in% c("sfc_POINT", "sfc", +# "sfc_GEOMETRY", "sfc_MULTIPOINT"))) +# ] +# +# # move the geometry column to the end of the dataframe +# cs_pts <- +# cs_pts %>% +# # dplyr::relocate(hy_id, cs_id, pt_id, Z, class, Z_at_bottom, is_near_bottom, pts_near_bottom, pct_near_bottom) +# # dplyr::relocate(geometry_colname, .after = dplyr::last_col()) +# dplyr::relocate(dplyr::all_of(geometry_colname), .after = dplyr::last_col()) +# +# return(cs_pts) +# +# } + +#Get a dataframe of points that should be evaluated due to their proximity (nearness in Z distance) to the bottom +#@param cs_pts dataframe/sf dataframe of cross section points (requires hy_id, cs_id, and Z values) +#@param threshold numeric, threshold distance in meters for points to be considered "near the bottom". Default is 1 meter (i.e. check if points are within 1 meter above the bottom) +#@param pct_threshold numeric, threshold percent of points in the cross section that are within threshold of bottom to +#determine whether point should be considered for re evaluation. Default is 0.99 (i.e. 99% of points are near the bottom). Default is 0.99 (i.e. 99&%). +#@return dataframe with the hy_id, cs_id, pts_near_bottom (count of pts_near_bottom), and pct_near_bottom (% of points in cross section that are near bottom). +#An empty dataframe is returned if ZERO points are classified as "near the bottom" +#@importFrom dplyr mutate filter select group_by slice ungroup +#@importFrom sf st_drop_geometry +#@export +# pts_to_reevaluate <- function( +# cs_pts, +# threshold = 1, +# pct_threshold = 0.99 +# ) { +# +# # +# # cs_pts = cs_pts +# # threshold = 1 +# # pct_threshold = 0.99 +# # +# +# # Determine which points that are within "threshold" meters from the bottom +# # (only looking at points above threshold, ignoring any points that are BELOW Z) +# # So the "pct_pts_near_bottom()" function adds columns to the "cs_pts" input data that detail which points are "near" the bottom points. +# # "bottom" points are classified via hydrofabric3D::classify_pts() +# near_bottom <- +# cs_pts %>% +# pct_pts_near_bottom( +# distance_from_bottom = threshold, +# look_only_above_bottom = TRUE, +# total_from_bottom_up = FALSE +# ) +# +# # Determine which points should be re evaluated (by extending) because most of the points are all "near the bottom" +# # Filter the "near_bottom" dataframe to only cross sections that +# # have a percent of all of the cross sections points that are GREATER THAN OR EQUAL to "pct_threshold" +# +# # In simple words, get the cross sections that have, for example, 80% of its points that are "near the bottom" +# +# # Also filter cross sections that have only a SINGLE point that is NOT near the bottom: +# # -----> So if a cross section has 9/10 of its points near the bottom, +# # that means only a single point is NOT near the bottom and thus +# # that cross section should be kept for FURTHER EVALUATION +# near_bottom <- +# near_bottom %>% +# sf::st_drop_geometry() %>% +# # to_check %>% +# dplyr::mutate( +# diff_pts = total_valid_pts - pts_near_bottom +# ) %>% +# dplyr::filter(pct_near_bottom >= pct_threshold | diff_pts == 1) %>% +# dplyr::select(-diff_pts) %>% +# # dplyr::filter(pct_near_bottom >= pct_threshold) %>% +# # dplyr::relocate(pts_near_bottom, total_valid_pts, pct_near_bottom) %>% +# dplyr::group_by(hy_id, cs_id) %>% +# dplyr::slice(1) %>% +# dplyr::ungroup() +# # dplyr::select(-is_near_bottom, -Z_at_bottom, -pts_near_bottom, -pct_near_bottom, -lower_bound, -upper_bound) +# # dplyr::select(hy_id, cs_id, Z_at_bottom, pts_near_bottom, pct_near_bottom, lower_bound, upper_bound) +# +# return(near_bottom) +# +# } \ No newline at end of file diff --git a/R/cs_visualization.R b/R/cs_visualization.R new file mode 100644 index 00000000..19aff106 --- /dev/null +++ b/R/cs_visualization.R @@ -0,0 +1,105 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +#' Plots an X-Y scatter plot of cross section points +#' @param cs_pts data.frame of cross section points with columns hy_id, cs_id and columns for X and Y axises (i.e. "pt_id", "Z") +#' @param x character name of column in cs_pts to use for X axis +#' @param y character name of column in cs_pts to use for Y axis +#' @param color character name of column in cs_pts to color points on plot +#' @param grid logical, if TRUE then use facet_grid, otherwise use facet_wrap. Default is FALSE (uses facet_wrap) +#' +#' @return ggplot2 object +#' @importFrom ggplot2 ggplot geom_point aes facet_grid facet_wrap +#' @importFrom dplyr sym +#' @export +plot_cs_pts <- function(cs_pts, + x = "pt_id", + y = "Z", + color = NULL, + grid = FALSE +) { + + ###### ###### ###### ###### + # x = "pt_id" + # y = "Z" + # color = "cs_source" + # color = 2 + # color = NULL + # grid = FALSE + # cs_pts = cs_pts + ###### ###### ###### ###### + + cs_plot <- + # cs_pts %>% + cs_pts %>% + ggplot2::ggplot() + + # ggplot2::geom_point(ggplot2::aes(x = pt_id, y = Z)) + ggplot2::geom_point( + ggplot2::aes( + x = !!dplyr::sym(x), + y = !!dplyr::sym(y), + color = !!ifelse(is.character(color), dplyr::sym(color), TRUE) + ) + ) + # tidyselect::all_of("pt_id") + + # if grid == TRUE, then use facet_grid, otherwise use facet wrap + if (grid) { + + cs_plot <- + cs_plot + + ggplot2::facet_grid(hy_id~cs_id, scales = "free_y") + + } else { + + cs_plot <- + cs_plot + + ggplot2::facet_wrap(hy_id~cs_id, scales = "free_y") + } + + return(cs_plot) + +} \ No newline at end of file diff --git a/R/fema_utils.R b/R/fema_utils.R new file mode 100644 index 00000000..a2490292 --- /dev/null +++ b/R/fema_utils.R @@ -0,0 +1,2310 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm", "polygon_index" + ) +) + +#' Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +#' WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons +#' @param transect_lines Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons) +#' @param polygons set of sf polygons that transect lines should be exteneded +#' @param flowlines set of Sf linestrings +#' @param crosswalk_id character, flowline ID that matches flowlines with transect lines. This crosswalk_id must appear are a column in both flowlines and transect_lines. +#' @param intersect_group_id character, name of a column in flowlines that should be used to group each transect with 1 or more flowlines. +#' That is, when transects are checked to make sure they don't intersect +#' other transects or other flowlines, this group ID will distinguise which flowlines a transect should be checked against. +#' The intersect_group_id must appear as a column in both flowlines and transect_lines dataframes +#' @param max_extension_distance numeric, maximum distance (meters) to extend a transect line +#' in either direction to try and intersect one of the "polygons". Default is 3000m +#' @return sf linestring, with extended transect lines +#' @importFrom rmapshaper ms_simplify +#' @importFrom geos as_geos_geometry geos_intersects_matrix geos_simplify_preserve_topology geos_within_matrix geos_empty geos_point_start geos_point_end +#' @importFrom sf st_as_sf st_cast st_segmentize st_length st_drop_geometry st_geometry +#' @importFrom dplyr mutate case_when select left_join relocate n any_of +#' @importFrom lwgeom st_linesubstring +#' @importFrom wk wk_crs +#' @importFrom nhdplusTools rename_geometry +#' @importFrom vctrs vec_c +#' @export +extend_transects_to_polygons <- function(transect_lines, + polygons, + flowlines, + crosswalk_id, + intersect_group_id = NULL, + max_extension_distance = 3000 + ) { + # ---------------------------------------------------------- + # library(sf) + # library(dplyr) + # # library(lwgeom) + # # library(wk) + # # library(vctrs) + # library(geos) + # # library(rmapshaper) + # + # polygons <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/FEMA_BY_VPU/VPU_02/fema_vpu_02_output.gpkg") + # transect_lines <- sf::read_sf("/Users/anguswatters/Desktop/test_transects_02.gpkg") + # flowlines <- sf::read_sf("/Users/anguswatters/Desktop/test_flines_02.gpkg") + # crosswalk_id = "hy_id" + # intersect_group_id = "mainstem" + # max_extension_distance = 3000 + # + # # mapview::npts(polygons) + # + # polygons <- rmapshaper::ms_simplify(polygons, keep_shapes = T, keep = 0.01, sys = TRUE, sys_mem = 16) + + # mapview::npts(polygons) + + # ---------------------------------------------------------------------------------- + + # transect_lines = transects + # + # polygons = fema + # flowlines = dplyr::rename(flines, hy_id = id) + # # flowlines + # crosswalk_id = "hy_id" + # intersect_group_id = "mainstem" + # max_extension_distance = 3000 + # transect_lines <- + # transect_lines %>% + # dplyr::left_join( + # dplyr::select(sf::st_drop_geometry(flowlines), + # dplyr::any_of(crosswalk_id), + # dplyr::any_of(intersect_group_id) + # ), + # by = c(crosswalk_id) + # ) + # ---------------------------------------------------------- + + + if(!crosswalk_id %in% names(flowlines)) { + stop("crosswalk_id '", crosswalk_id, "' is not a column in 'flowlines' input,\n", + "Please provide a valid crosswalk_id that crosswalks 'flowlines' to 'transect_lines'") + } + + if(!crosswalk_id %in% names(transect_lines)) { + stop("crosswalk_id '", crosswalk_id, "' is not a column in 'transect_lines' input,\n", + "Please provide a valid crosswalk_id that crosswalks the 'transect_lines' to 'flowlines'") + } + + if(!intersect_group_id %in% names(flowlines)) { + stop("intersect_group_id '", intersect_group_id, "' is not a column in 'flowlines' input,\n", + "Please provide a valid intersect_group_id that associates each transect line with 1 or more flowlines in 'flowlines'" + ) + } + + if(!intersect_group_id %in% names(transect_lines)) { + stop("intersect_group_id '", intersect_group_id, "' is not a column in 'transect_lines' input,\n", + "Please provide a valid intersect_group_id that associates each transect line with 1 or more flowlines in 'flowlines'" + ) + } + + transect_lines <- nhdplusTools::rename_geometry(transect_lines, "geometry") + flowlines <- nhdplusTools::rename_geometry(flowlines, "geometry") + + # if(!is.null(intersect_group_id)) { + # if(!intersect_group_id %in% names(flowlines)) { + # stop("Invalid 'intersect_group_id' value, '", intersect_group_id, "' is not a column in 'flowlines'.\n", + # "Provide a valid 'intersect_group_id' value representing a column in 'flowlines' that should be used to ", + # "compare neighboring flowlines and transects for proper intersection logic") + # } + # # TODO: if the intersect_group_id column is not attached to the transects, then join it on + # if(!intersect_group_id %in% names(transect_lines)) { + # transect_lines <- + # transect_lines %>% + # dplyr::left_join( + # dplyr::select(sf::st_drop_geometry(flowlines),id, dplyr::any_of(intersect_group_id)), + # by = c("hy_id" = "id") + # ) + # } + # } + + # TODO: this should be a function argument OR removed, shouldn't probably forcibly and silently simplify the input polygons without user knowing.. + # keep 10% of the original points for speed + # polygons <- rmapshaper::ms_simplify(polygons, keep_shapes = F, keep = 0.10) + + # polygons + transects_geos <- geos::as_geos_geometry(transect_lines) + polygons_geos <- geos::as_geos_geometry(polygons) + + # polygons_geos %>% + # geos::geos_type() %>% + # unique() + + transects_polygons_matrix <- geos::geos_intersects_matrix(transects_geos, polygons_geos) + polygons_transects_matrix <- geos::geos_intersects_matrix(polygons_geos, transects_geos) + + # subset the transects and polygons to only those with intersections + intersect_transects <- transect_lines[lengths(transects_polygons_matrix) != 0, ] + intersect_polygons <- polygons_geos[lengths(polygons_transects_matrix) != 0] + + # # Convert our intersecting polygons to LINESTRINGS b/c we DON'T NEED polygons to calculate extension distances from our transect lines + # # This can be done with just linestrings (not sure if this is actually more performent but I'm pretty sure it is....) + # intersect_lines <- + # intersect_polygons %>% + # # geos::geos_make_valid() %>% + # sf::st_as_sf() %>% + # sf::st_cast("MULTILINESTRING") %>% + # geos::as_geos_geometry() %>% + # geos::geos_simplify_preserve_topology(250) + # # geos::geos_simplify(250) + + # # mapview::mapview(sf::st_as_sf(no_simple_intersect_lines[1]), color="gold") + + # mapview::mapview(sf::st_as_sf(no_simple_intersect_lines[2]), color= "green") + + # # mapview::mapview(sf::st_as_sf(no_simple_intersect_lines[3]), color = "gold") + + # # mapview::mapview(sf::st_as_sf(intersect_lines[1]), color="green") + + + # use half of the shortest transect line as the segmentation length for all transects (ensures all transects will have a midpoint...?) + # TODO: Double check this logic. + min_segmentation <- min(intersect_transects$cs_lengthm %/% 2) + + # # make each transect line have way more segments so we can take a left and right half of each transect line + # segmented_trans <- sf::st_segmentize(intersect_transects, min_segmentation) + + # Seperate the transect lines into LEFT and RIGHT halves + # We do this so we can check if a side of a transect is ENTIRELY WITHIN a polygon. + # If the half is entirely within a polygon, + left_trans <- + # segmented_trans %>% + sf::st_segmentize(intersect_transects, min_segmentation) %>% + lwgeom::st_linesubstring(0, 0.50) %>% + dplyr::mutate( + partition = "left", + partition_lengthm = as.numeric(sf::st_length(geometry)) + ) %>% + # hydrofabric3D::add_tmp_id() %>% + hydrofabric3D::add_tmp_id(x = get(crosswalk_id), y = cs_id) %>% + dplyr::select(tmp_id, + # hy_id, + dplyr::any_of(crosswalk_id), + cs_source, cs_id, cs_measure, + cs_lengthm, + # is_extended, + partition, partition_lengthm, geometry) + + # Find the distances from the right side of transect lines + right_trans <- + # segmented_trans %>% + sf::st_segmentize(intersect_transects, min_segmentation) %>% + lwgeom::st_linesubstring(0.50, 1) %>% + dplyr::mutate( + partition = "right", + partition_lengthm = as.numeric(sf::st_length(geometry)) + ) %>% + # hydrofabric3D::add_tmp_id() %>% + hydrofabric3D::add_tmp_id(x = get(crosswalk_id), y = cs_id) %>% + dplyr::select(tmp_id, + # hy_id, + dplyr::any_of(crosswalk_id), + cs_source, + cs_id, cs_measure, + cs_lengthm, + # is_extended, + partition, partition_lengthm, geometry) + + # convert the transect geometries to geos types + # get the fema polygon indices for the transect halves that are completely within a fema polygon + # add the fema polygons index as a column to the transect dataframes + left_trans_geos <- geos::as_geos_geometry(left_trans) + right_trans_geos <- geos::as_geos_geometry(right_trans) + + left_within_matrix <- geos::geos_within_matrix(left_trans_geos, intersect_polygons) + right_within_matrix <- geos::geos_within_matrix(right_trans_geos, intersect_polygons) + + left_within_vect <- lapply(left_within_matrix, function(i) { if(length(i) > 0) { c(i) } else { c(NA) } }) + right_within_vect <- lapply(right_within_matrix, function(i) { if(length(i) > 0) { c(i) } else { c(NA) } }) + + # add the fema polygon indexes as columns + left_trans$left_fema_index <- left_within_vect + right_trans$right_fema_index <- right_within_vect + + # add boolean columns whether the transect is fully within the FEMA polygons + left_trans <- + left_trans %>% + dplyr::mutate( + left_is_within_fema = dplyr::case_when( + !is.na(left_fema_index) ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::select(tmp_id, + # hy_id, + dplyr::any_of(crosswalk_id), + cs_source, cs_id, cs_measure, + cs_lengthm, + partition, + partition_lengthm, + left_fema_index, + left_is_within_fema, + geometry + ) + + right_trans <- + right_trans %>% + dplyr::mutate( + right_is_within_fema = dplyr::case_when( + !is.na(right_fema_index) ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::select(tmp_id, + # hy_id, + dplyr::any_of(crosswalk_id), + cs_source, cs_id, cs_measure, + cs_lengthm, + partition, + partition_lengthm, + right_fema_index, + right_is_within_fema, + geometry + ) + + # Convert our intersecting polygons to LINESTRINGS b/c we DON'T NEED polygons to calculate extension distances from our transect lines + # This can be done with just linestrings (not sure if this is actually more performent but I'm pretty sure it is....) + intersect_polygons <- + intersect_polygons %>% + # geos::geos_make_valid() %>% + sf::st_as_sf() %>% + sf::st_cast("MULTILINESTRING") %>% + geos::as_geos_geometry() %>% + geos::geos_simplify_preserve_topology(250) + # geos::geos_simplify(250) + + message("Generating left side distances....") + + # profvis::profvis({ + + left_distances <- calc_extension_distances2( + geos_geoms = left_trans_geos, + ids = left_trans$tmp_id, + lines_to_cut = intersect_polygons, + lines_to_cut_indices = left_trans$left_fema_index, + direction = "head", + max_extension_distance = max_extension_distance + ) + + # }) + + message("Generating right side distances...") + + right_distances <- calc_extension_distances2( + geos_geoms = right_trans_geos, + ids = right_trans$tmp_id, + lines_to_cut = intersect_polygons, + lines_to_cut_indices = right_trans$right_fema_index, + direction = "tail", + max_extension_distance = max_extension_distance + ) + + left_trans$left_distance <- left_distances + right_trans$right_distance <- right_distances + + # TODO: this way the EXTENDED transects get returned instead of the DISTANCES TO EXTEND + # TODO: Somepoint, this is probably the better way, it would mean 1-2 less extension calculations + # TODO: on the other hand, the line extension is NOT very compute or memory intensive so + # message("Generating left side extensions...") + # left_trans_geos <- get_lines_extended_to_geoms( + # geos_geoms = left_trans_geos, + # ids = left_trans$tmp_id, + # lines_to_cut = intersect_lines, + # lines_to_cut_indices = left_trans$left_fema_index, + # direction = "head", + # max_extension_distance = max_extension_distance + # ) + # + # message("Generating right side extensions...") + # right_trans_geos <- get_lines_extended_to_geoms( + # geos_geoms = right_trans_geos, + # ids = right_trans$tmp_id, + # lines_to_cut = intersect_lines, + # lines_to_cut_indices = right_trans$right_fema_index, + # direction = "tail", + # max_extension_distance = max_extension_distance + # ) + + # distance to extend LEFT and/or RIGHT for each hy_id/cs_id + extensions_by_id <- dplyr::left_join( + sf::st_drop_geometry( + dplyr::select(left_trans, + # hy_id, + dplyr::any_of(crosswalk_id), + cs_id, + left_distance) + ), + sf::st_drop_geometry( + dplyr::select(right_trans, + # hy_id, + dplyr::any_of(crosswalk_id), + cs_id, + right_distance) + ), + by = c(crosswalk_id, "cs_id") + ) + + # TODO: Add left/right extension distancces to transect data + # TODO: this can ultimately just be the "transects" variable, dont need to make new "transects_with_distances" variable + transect_lines <- + transect_lines %>% + dplyr::left_join( + extensions_by_id, + by = c(crosswalk_id, "cs_id") + ) %>% + dplyr::mutate( + left_distance = dplyr::case_when( + is.na(left_distance) ~ 0, + TRUE ~ left_distance + ), + right_distance = dplyr::case_when( + is.na(right_distance) ~ 0, + TRUE ~ right_distance + ) + ) %>% + # hydrofabric3D::add_tmp_id() + hydrofabric3D::add_tmp_id(x = get(crosswalk_id), y = cs_id) + + # rm(fema, polygons, left_trans_geos, right_trans_geos) + # gc() + + # format(object.size(flowlines), 'auto') + # profvis::profvis({ + + # # TODO: if an intersect group id is given, then pull those columns as vectors to use for intersection checks in loop + # if(!is.null(intersect_group_id)) { + # fline_group_id_array <- flowlines[[intersect_group_id]] + # transect_group_id_array <- transect_lines[[intersect_group_id]] + # } + + fline_id_array <- flowlines[[crosswalk_id]] + # fline_id_array <- flowlines$id + + # TODO: next time, change this function to ONLY process transects that have ANY extension distance, right now we iterate through ALL transects, + # TODO: and 'next' the ones with the no extension distance so doesn't really matter much but + + # Convert the net object into a geos_geometry + flowlines_geos <- geos::as_geos_geometry(flowlines) + + transect_crosswalk_id_array <- transect_lines[[crosswalk_id]] + # transect_crosswalk_id_array <- transect_lines$hy_id + transect_cs_id_array <- transect_lines$cs_id + + # Intersect grouping IDs + fline_group_id_array <- flowlines[[intersect_group_id]] + transect_group_id_array <- transect_lines[[intersect_group_id]] + + # transect_geoms <- geos::as_geos_geometry(transect_lines$geometry) + + left_distances <- transect_lines$left_distance + right_distances <- transect_lines$right_distance + + # # preallocate vector that stores the extension. distances + # new_transects <- vctrs::vec_c(rep(geos::geos_empty(), length(transect_crosswalk_id_array))) + + left_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + right_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + both_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + + updated_left_distances <- rep(0, length(transect_crosswalk_id_array)) + updated_right_distances <- rep(0, length(transect_crosswalk_id_array)) + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(transect_crosswalk_id_array) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + number_of_skips = 0 + + for (i in seq_along(transect_crosswalk_id_array)) { + + # Check if the iteration is a multiple of 100 + if (message_interval != 0 && i %% message_interval == 0) { + percent_done <- round(i/total, 2) * 100 + message(i, " > ", percent_done, "% ") + message("Number of skips: ", number_of_skips) + } + + # get the current transect, hy_id, cs_id, flowline, and extension distances + current_trans <- transects_geos[i] + + current_hy_id <- transect_crosswalk_id_array[i] + current_cs_id <- transect_cs_id_array[i] + + # current_intersect_group_id <- transect_group_id_array[i] + + # TODO: might need this in case I do the is_valid_transect() check on just the single flowline + # current_fline <- flowlines_geos[fline_id_array == current_hy_id] + + # TODO: these are the rest of the transects for this flowline + # neighbor_transects <- transects_geos[transect_crosswalk_id_array == current_hy_id & transect_cs_id_array != current_cs_id] + + # mapview::mapview(sf::st_as_sf(transects_geos[transect_crosswalk_id_array == current_hy_id & transect_cs_id_array != current_cs_id]), color = "red") + + # mapview::mapview(sf::st_as_sf(current_trans), color = "green") + + left_distance_to_extend <- left_distances[i] + right_distance_to_extend <- right_distances[i] + + no_extension_required <- (left_distance_to_extend == 0 && right_distance_to_extend == 0) + # no_extension_required <- is.na(left_distance_to_extend) && is.na(right_distance_to_extend) + # message("Transect tmp_id: ", curr_tmp_id, " - (", i, ")") + + if(no_extension_required) { + # message("Skipping -left/right extension are both 0") + number_of_skips = number_of_skips + 1 + + next + } + + # message("Extending transect line left and right") + # extend the lines + left_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + left_distance_to_extend, "head") + right_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + right_distance_to_extend, "tail") + + # initial check to make sure the extended versions of the transects are valid + # mapview::mapview(sf::st_as_sf(flowlines_geos[fline_group_id_array == transect_group_id_array[i]])) + + # mapview::mapview(sf::st_as_sf(transects_geos[transect_group_id_array == transect_group_id_array[i]]), color = "red") + + # mapview::mapview(sf::st_as_sf(current_trans)) + + # TODO: version 1 + # # CHECKS WHOLE NETWORK OF FLOWLINES + # use_left_extension <- is_valid_transect_line(left_extended_trans, transects_geos, flowlines_geos) + # use_right_extension <- is_valid_transect_line(right_extended_trans, transects_geos, flowlines_geos) + + # TODO version 2: + # ONLY CHECKING FOR INTERSECTIONS ON CURRENT FLOWLINE NOT WHOLE NETWORK + + + # if (!is.null(intersect_group_id)) { + use_left_extension <- is_valid_transect_line( + left_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + # transects_geos, + # flowlines_geos + ) + + # } else { + # use_left_extension <- is_valid_transect_line(left_extended_trans, + # transects_geos[transect_crosswalk_id_array == current_hy_id], + # flowlines_geos[fline_id_array == current_hy_id]) + # } + + # if (!is.null(intersect_group_id)) { + + use_right_extension <- is_valid_transect_line( + right_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + ) + + # } else { + # + # use_right_extension <- is_valid_transect_line( + # right_extended_trans, + # transects_geos[transect_crosswalk_id_array == current_hy_id], + # flowlines_geos[fline_id_array == current_hy_id] + # # transects_geos, + # # flowlines_geos + # ) + # } + # use_both_extensions <- use_left_extension && use_right_extension + + used_half_of_left <- FALSE + used_half_of_right <- FALSE + + # TODO: Probably should precompute this division BEFORE the loop... + half_left_distance <- ifelse(left_distance_to_extend > 0, left_distance_to_extend %/% 2, 0) + half_right_distance <- ifelse(right_distance_to_extend > 0, right_distance_to_extend %/% 2, 0) + + # if we CAN'T use the original LEFT extension distance, + # we try HALF the distance (or some distane less than we extended by in the first place) + if (!use_left_extension) { + + # half_left_distance <- ifelse(left_distance_to_extend > 0, left_distance_to_extend %/% 2, 0) + left_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + half_left_distance, "head") + # TODO: verison 1 + # use_left_extension <- is_valid_transect_line(left_extended_trans, transects_geos, flowlines_geos) + + # TODO version 2: + # ONLY CHECKING FOR INTERSECTIONS ON CURRENT FLOWLINE NOT WHOLE NETWORK + # if (!is.null(intersect_group_id)) { + use_left_extension <- is_valid_transect_line( + left_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + # transects_geos, + # flowlines_geos + ) + # } else { + # use_left_extension <- is_valid_transect_line(left_extended_trans, + # transects_geos[transect_crosswalk_id_array == current_hy_id], + # flowlines_geos[fline_id_array == current_hy_id]) + # } + used_half_of_left <- ifelse(use_left_extension, TRUE, FALSE) + } + + # if we CAN'T use the original RIGHT extension distance, + # we try HALF the distance (or some distance less than we extended by in the first place) + if (!use_right_extension) { + + # half_right_distance <- ifelse(right_distance_to_extend > 0, right_distance_to_extend %/% 2, 0) + right_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + half_right_distance, "tail") + + # TODO: version 1 + # use_right_extension <- is_valid_transect_line(right_extended_trans, transects_geos, flowlines_geos) + + # TODO version 3 + # if (!is.null(intersect_group_id)) { + + use_right_extension <- is_valid_transect_line( + right_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + ) + + # } else { + + # use_right_extension <- is_valid_transect_line( + # right_extended_trans, + # transects_geos[transect_crosswalk_id_array == current_hy_id], + # flowlines_geos[fline_id_array == current_hy_id] + # transects_geos, + # flowlines_geos + # ) + # } + + used_half_of_right <- ifelse(use_right_extension, TRUE, FALSE) + + # mapview::mapview(sf::st_as_sf(current_trans), color = "red") + + # mapview::mapview(sf::st_as_sf(left_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(right_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(left_extended_trans2), color = "dodgerblue") + + # mapview::mapview(sf::st_as_sf(right_extended_trans2), color = "dodgerblue") + + } + + use_both_extensions <- use_left_extension && use_right_extension + + # # message("Checking left and right intersections with flowline...") + + # # mapview::mapview(sf::st_as_sf(merged_trans), color = "green") + + # # mapview::mapview(sf::st_as_sf(left_start), col.region = "red") + + # # mapview::mapview(sf::st_as_sf(left_end), col.region = "red") + + # # mapview::mapview(sf::st_as_sf(right_start), col.region = "dodgerblue") + + # # mapview::mapview(sf::st_as_sf(right_end), col.region = "dodgerblue") + + # Get the start and end of both extended tranects + left_start <- geos::geos_point_start(left_extended_trans) + left_end <- geos::geos_point_end(left_extended_trans) + right_start <- geos::geos_point_start(right_extended_trans) + right_end <- geos::geos_point_end(right_extended_trans) + + # } + # Extend in BOTH directions + if(use_both_extensions) { + # message("Extend direction: BOTH") + start <- left_start + end <- right_end + + # extend ONLY the left side + } else if(use_left_extension && !use_right_extension) { + # message("Extend direction: LEFT") + start <- left_start + end <- left_end + + # Extend ONLY the right side + } else if(!use_left_extension && use_right_extension) { + # message("Extend direction: RIGHT") + start <- right_start + end <- right_end + + # DO NOT extend either direction + } else { + # message("No extension") + # TODO: Really dont need to do anything + # TODO: in this scenario because we just use the original transect line + start <- left_end + end <- right_start + } + + line_crs <- wk::wk_crs(current_trans) + updated_trans <- make_line_from_start_and_end_pts(start, end, line_crs) + + # mapview::mapview(touched_flowlines, color = "dodgerblue") + + # mapview::mapview(sf::st_as_sf(current_trans), color = "red") + + # mapview::mapview(sf::st_as_sf(left_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(right_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(updated_trans), color = "yellow") + + if(use_left_extension) { + left_extended_flag[i] <- TRUE + } + + if(use_right_extension) { + right_extended_flag[i] <- TRUE + } + + if(use_both_extensions) { + both_extended_flag[i] <- TRUE + } + + if(used_half_of_left) { + updated_left_distances[i] <- half_left_distance + } + if(used_half_of_right) { + updated_right_distances[i] <- half_right_distance + } + + # new_transects[i] <- updated_trans + transects_geos[i] <- updated_trans + + } + + # }) + # transects2 <- transects + # dplyr::mutate( + # new_cs_lengthm = as.numeric(sf::st_length(geom)) + # ) %>% + # dplyr::relocate(hy_id, cs_id, cs_lengthm, new_cs_lengthm) + # mapview::mapview(sf::st_as_sf(transects_geos), color = "red") + # transect_lines[lengths(sf::st_intersects(transect_lines)) == 1, ] %>% + # dplyr::group_by(hy_id) + + # Update the "transects_to_extend" with new geos geometries ("geos_list") + sf::st_geometry(transect_lines) <- sf::st_geometry(sf::st_as_sf(transects_geos)) + + transect_lines$left_is_extended <- left_extended_flag + transect_lines$right_is_extended <- right_extended_flag + + # remove self intersecting transects or not + transect_lines <- + transect_lines[lengths(sf::st_intersects(transect_lines)) == 1, ] %>% + dplyr::group_by(dplyr::across(dplyr::any_of(crosswalk_id))) %>% + # dplyr::group_by(hy_id) + dplyr::mutate(cs_id = 1:dplyr::n()) %>% + dplyr::ungroup() + + # remove transects that intersect multiple flowlines + transect_lines <- + transect_lines[lengths(sf::st_intersects(transect_lines, flowlines)) == 1, ] %>% + dplyr::group_by(dplyr::across(dplyr::any_of(crosswalk_id))) %>% + # dplyr::group_by(hy_id) + dplyr::mutate(cs_id = 1:dplyr::n()) %>% + dplyr::ungroup() + + transect_lines <- + transect_lines %>% + dplyr::mutate( + cs_lengthm = as.numeric(sf::st_length(geometry)) + ) %>% + dplyr::relocate(dplyr::any_of(crosswalk_id), cs_id, cs_lengthm) + + transect_lines <- move_geometry_to_last(transect_lines) + + return(transect_lines) + +} + +#' Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +#' +#' @param geos_geoms list of geos_geometrys +#' @param ids character vector +#' @param lines_to_cut geos_linestrings +#' @param lines_to_cut_indices numeric vector +#' @param direction character, either "head", "tail" or "both" +#' @param max_extension_distance numeric +#' +#' @return numeric vector, distance to extend each geos_geoms +#' @importFrom vctrs vec_c +calc_extension_distances <- function(geos_geoms, ids, lines_to_cut, lines_to_cut_indices, direction = "head", max_extension_distance = 2500) { + + if (!direction %in% c("head", "tail")) { + stop("Invalid 'direction' value, must be one of 'head' or 'tail'") + } + + # Precompute flags and a distance vector for extending + is_within_polygon_flags <- sapply(lines_to_cut_indices, function(i) { any(!is.na(i)) }) + distance_range <- 1:max_extension_distance + + # preallocate vector that stores the extension. distances + extension_dists <- vctrs::vec_c(rep(0, length(ids))) + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(ids) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + + # extension_dists <- vector(mode = "numeric", length = nrow(trans_data)) + for (i in seq_along(ids)) { + + # log percent complete + if (message_interval != 0 && i %% message_interval == 0) { + # get the percent complete + percent_done <- round(i/total, 2) * 100 + message(i, " > ", percent_done, "% ") + } + + curr_id <- ids[i] + is_within_polygon <- is_within_polygon_flags[i] + # is_within_polygon <- any(!is.na(lines_to_cut_indices[[i]])) + # polygon_index <- lines_to_cut_indices[[i]] + + # message("Transect: '", curr_id, "' - (", i, ")") + + if (is_within_polygon) { + # message("- Side of transect intersects with FEMA") + # message("\t > FEMA index: ", polygon_index) + # polygon_index <- lines_to_cut_indices[[i]] + # curr_geom <- geos_geoms[[i]] + + index_vect <- unlist(lines_to_cut_indices[[i]]) + # index_vect <- unlist(polygon_index) + # index_vect <- sort(unlist(polygon_index)) + + distance_to_extend <- geos_bs_distance( + distances = distance_range, + line = geos_geoms[[i]], + geoms_to_cut = lines_to_cut[index_vect], + direction = direction + ) + + extension_dists[i] <- distance_to_extend + } + + } + + return(extension_dists) +} + +#' Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +#' VERSION 2 +#' @param geos_geoms list of geos_geometrys +#' @param ids character vector +#' @param lines_to_cut geos_linestrings +#' @param lines_to_cut_indices numeric vector +#' @param direction character, either "head", "tail" or "both" +#' @param max_extension_distance numeric +#' +#' @return numeric vector, distance to extend each geos_geoms +#' @importFrom vctrs vec_c +calc_extension_distances2 <- function( + geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500 +) { + + if (!direction %in% c("head", "tail")) { + stop("Invalid 'direction' value, must be one of 'head' or 'tail'") + } + + # ----------------------------------------------------- + # geos_geoms = geos::as_geos_geometry(left_partition) + # ids = left_partition$tmp_id + # + # # mapview::mapview(left_partition[1:4, ]$geom, color = "green") + + # # mapview::mapview( + # # sf::st_as_sf(mls[unique(unlist(left_partition[1:4, ]$polygon_index))]), color = "red" + # # ) + # + # lines_to_cut = mls + # lines_to_cut_indices = left_partition$polygon_index + # + # direction = "head" + # max_extension_distance = 3000 + # ----------------------------------------------------- + + distance_range <- 1:max_extension_distance + + # preallocate vector that stores the extension. distances + extension_dists <- vctrs::vec_c(rep(0, length(ids))) + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(ids) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + + for (i in seq_along(ids)) { + + # log percent complete + if (message_interval != 0 && i %% message_interval == 0) { + # get the percent complete + percent_done <- round(i/total, 2) * 100 + message(i, " > ", percent_done, "% ") + } + + index_vect <- unlist(lines_to_cut_indices[[i]]) + + distance_to_extend <- geos_bs_distance( + distances = distance_range, + line = geos_geoms[[i]], + geoms_to_cut = lines_to_cut[index_vect], + direction = direction + ) + + extension_dists[i] <- distance_to_extend + + } + + return(extension_dists) +} + +#' Given 2 geos_geometry point geometries, create a line between the 2 points +#' +#' @param start geos_geoemtry, point +#' @param end geos_geoemtry, point +#' @param line_crs crs +#' @importFrom geos geos_y geos_x geos_make_linestring +#' @return geos_geometry linestring +make_line_from_start_and_end_pts <- function(start, end, line_crs) { + + # Y_start <- geos::geos_y(start) + # X_start <- geos::geos_x(start) + # Y_end <- geos::geos_y(end) + # X_end <- geos::geos_x(end) + # + # # make the new transect line from the start and points + # geos_ls <- geos::geos_make_linestring(x = c(X_start, X_end), + # y = c(Y_start, Y_end), + # crs = line_crs) + # return(geos_ls) + + # make the new transect line from the start and points + return( + geos::geos_make_linestring( + x = c(geos::geos_x(start), geos::geos_x(end)), + y = c(geos::geos_y(start), geos::geos_y(end)), + crs = line_crs + ) + ) + +} + +#' Check if an updated transect line is valid relative to the other transects and flowlines in the network +#' The 'transect_to_check' should be 'used' (i.e. function returns TRUE) if +#' the 'transect_to_check' does NOT interesect any other transects ('transect_lines') AND it only intersects a single flowline ONCE. +#' If the 'transect_to_check' intersects ANY other transects OR intersects a flowline more +#' than once (OR more than one flowline in the network) then the function returns FALSE. +#' @param transect_to_check geos_geometry, linestring +#' @param trans geos_geometry, linestring +#' @param flines geos_geometry, linestring +#' +#' @return TRUE if the extension should be used, FALSE if it shouldn't be used +#' @importFrom geos geos_intersection geos_type geos_intersects +is_valid_transect_line <- function(transect_to_check, trans, flines) { + + # ### ## ## ## ## ## ## ## ## ## + # transect_to_check <- right_extended_trans + # trans <- transects_geos[transect_crosswalk_id_array == current_hy_id & transect_cs_id_array != current_cs_id] + # flines <- flowlines_geos[fline_id_array == current_hy_id] + + # transect_to_check <- right_extended_trans + # trans <- transects_geos[transect_group_id_array == transect_group_id_array[i]] + # flines <- flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + + # ### ## ## ## ## ## ## ## ## ## + + # Define conditions to decide which version of the transect to use + + # 1. Use transect with extension in BOTH directions + # 2. Use transect with LEFT extension only + # 3. Use transect with RIGHT extension only + + # Check that the extended transect lines only intersect a single flowline in the network only ONCE + intersects_with_flowlines <- geos::geos_intersection( + transect_to_check, + flines + ) + + intersects_flowline_only_once <- sum(geos::geos_type(intersects_with_flowlines) == "point") == 1 && + sum(geos::geos_type(intersects_with_flowlines) == "multipoint") == 0 + + # NOTE: return early if if the transects does NOT intersect the flowline ONLY once + # little optimization, avoids extra geos_intersects() calls + if (!intersects_flowline_only_once) { + return(FALSE) + } + + # check that the extended transect line does NOT intersect other transect lines (other than SELF) + intersects_other_transects <- lengths(geos::geos_intersects_matrix(transect_to_check, trans)) > 1 + # intersects_other_transects <- sum(geos::geos_intersects(transect_to_check, trans)) > 1 + + # TRUE == Only one flowline is intersected a single time AND no other transect lines are intersected + use_transect <- intersects_flowline_only_once && !intersects_other_transects + + return(use_transect) +} + +#' Get transects that intersect with the polygons +#' @param transect_lines Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons) +#' @param polygons set of sf polygons that transect lines should be exteneded +#' @return sf linestring, with extended transect lines +#' @importFrom geos as_geos_geometry geos_intersects_matrix +#' @export +subset_transects_in_polygons <- function(transect_lines, polygons) { + + transects_polygons_matrix <- geos::geos_intersects_matrix(geos::as_geos_geometry(transect_lines), geos::as_geos_geometry(polygons)) + + # return(transect_lines[lengths(transects_polygons_matrix) != 0, ]) + return(transect_lines[lengths(transects_polygons_matrix) != 0, ]) + +} + +#' Get polygons that intersect with the transects +#' @param transect_lines Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons) +#' @param polygons set of sf polygons that transect lines should be exteneded +#' @return sf polygon dataframe +#' @importFrom geos as_geos_geometry geos_intersects_matrix +#' @export +subset_polygons_in_transects <- function(transect_lines, polygons) { + + # TODO: this should be a function argument OR removed, shouldn't probably forcibly and silently simplify the input polygons without user knowing.. + # keep 10% of the original points for speed + # polygons <- rmapshaper::ms_simplify(polygons, keep_shapes = T, keep = 0.01) + + # polygons_transects_matrix <- geos::geos_intersects_matrix(polygons_geos, transects_geos) + polygons_transects_matrix <- geos::geos_intersects_matrix(geos::as_geos_geometry(polygons), geos::as_geos_geometry(transect_lines)) + + # return(polygons_geos[lengths(polygons_transects_matrix) != 0]) + return(polygons[lengths(polygons_transects_matrix) != 0, ]) + +} + +sf_polygons_to_geos_multilinestrings <- function(polygons, tolerance = 250) { + + return(polygons %>% + geos::as_geos_geometry() %>% + geos::geos_node() %>% + geos::geos_simplify_preserve_topology(tolerance)) +} + +# Helper function for cleaning up transects and adding some meta data after going through partition_transects_for_extension +wrangle_paritioned_transects <- function(partition, + dir = "left", + crosswalk_id = "hy_id" +) { + + partition <- + partition %>% + dplyr::mutate( + partition = dir, + partition_lengthm = as.numeric(sf::st_length(.)) + ) %>% + hydrofabric3D::add_tmp_id(x = get(crosswalk_id), y = cs_id) %>% + dplyr::relocate(tmp_id, + dplyr::any_of(crosswalk_id), + # cs_source, + cs_id + # cs_measure, + # cs_lengthm, + # is_extended, + # partition, partition_lengthm, geometry + ) + # dplyr::select(tmp_id, dplyr::any_of(crosswalk_id), cs_source, cs_id, cs_measure, cs_lengthm, + # partition, partition_lengthm, geometry) + + return(partition) +} + +# From a set of transects and a set of polygons, subset the transects based on whether their start / end point is fully within a polygon +# This function will return the points transect lines that need to be extended in a given direction +# i.e. When dir = "left" then the returned transects have their starting points entirely within a polygon +partition_transects_for_extension <- function(transects, polygons_subset, crosswalk_id = "hy_id", dir = "left") { + + # POINT START = LEFT + # POINT END = RIGHT + + # get the function needed for a given direction, a transects starting point is the "left" and the ending point is the right + dir_function <- ifelse(dir == "left", geos::geos_point_start, geos::geos_point_end) + + # determine transects whose starting/end points are within a polygon + is_within_matrix <- geos::geos_within_matrix(dir_function(transects), polygons_subset) + + is_within_vect <- lapply(is_within_matrix, function(i) { if(length(i) > 0) { c(i) } else { c(NA) } }) + + transects$polygon_index <- is_within_vect + + # return only the transects whose start / end point are within a polygon + return(dplyr::filter(transects, !is.na(polygon_index))) + +} + +#' Get the left and right extension distances for a set of transects out to a set of polygons +#' +#' @param transects sf linestring dataframe +#' @param polygons sf polygon dataframe +#' @param crosswalk_id character +#' @param max_extension_distance numeric +#' +#' @return data.frame or tibble +#' @export +get_extensions_by_id <- function(transects, polygons, crosswalk_id, max_extension_distance) { + + left_partition <- partition_transects_for_extension( + transects, + polygons, + dir = "left" + ) %>% + wrangle_paritioned_transects( + dir = "left", + crosswalk_id = crosswalk_id + ) + + right_partition <- partition_transects_for_extension( + transects, + polygons, + dir = "right" + ) %>% + wrangle_paritioned_transects( + dir = "right", + crosswalk_id = crosswalk_id + ) + + # Convert the polygon to a MULTILINESTRING geometry for checking extension distances + mls <- sf_polygons_to_geos_multilinestrings(polygons, 200) + + message("Generating left side distances....") + left_distances <- calc_extension_distances2( + geos_geoms = geos::as_geos_geometry(left_partition), + ids = left_partition$tmp_id, + lines_to_cut = mls, + lines_to_cut_indices = left_partition$polygon_index, + direction = "head", + max_extension_distance = max_extension_distance + ) + + message("Generating right side distances...") + right_distances <- calc_extension_distances2( + geos_geoms = geos::as_geos_geometry(right_partition), + ids = right_partition$tmp_id, + lines_to_cut = mls, + lines_to_cut_indices = right_partition$polygon_index, + direction = "tail", + max_extension_distance = max_extension_distance + ) + + left_partition$left_distance <- left_distances + right_partition$right_distance <- right_distances + + # Distance to extend LEFT and/or RIGHT for each hy_id/cs_id + extensions_by_id <- dplyr::left_join( + sf::st_drop_geometry( + dplyr::select(left_partition, + dplyr::any_of(crosswalk_id), + cs_id, + left_distance + ) + ), + sf::st_drop_geometry( + dplyr::select(right_partition, + dplyr::any_of(crosswalk_id), + cs_id, + right_distance + ) + ), + by = c(crosswalk_id, "cs_id") + ) + + return(extensions_by_id) +} + +#' Decide the start and end points for the final transect line given two extended versions of the same transect +#' Requires two logicals indicating what to do with the extensions (these are decided by checking for intersections with the rest of the network) +#' Internal helper function +#' @param left_extension geos_geometry linestring +#' @param right_extension geos_geometry linestring +#' @param use_left logical, do we use the left extension +#' @param use_right logical, do we use the right extension +#' @importFrom geos geos_point_start geos_point_end +#' @return geos_geometry points, the start and end point of the final extension line +#' @export +pick_extension_pts <- function( + left_extension, + right_extension, + use_left, + use_right +) { + + use_both <- use_left && use_right + + # Get the start and end of both extended tranects + left_start <- geos::geos_point_start(left_extension) + left_end <- geos::geos_point_end(left_extension) + right_start <- geos::geos_point_start(right_extension) + right_end <- geos::geos_point_end(right_extension) + + # Extend in BOTH directions + if(use_both) { + # message("Extend direction: BOTH") + start <- left_start + end <- right_end + + # extend ONLY the left side + } else if(use_left && !use_right) { + # message("Extend direction: LEFT") + start <- left_start + end <- left_end + + # Extend ONLY the right side + } else if(!use_left && use_right) { + # message("Extend direction: RIGHT") + start <- right_start + end <- right_end + + # DO NOT extend either direction + } else { + # message("No extension") + # TODO: Really dont need to do anything + # TODO: in this scenario because we just use the original transect line + start <- left_end + end <- right_start + } + + return( c(start, end) ) + +} + +#' Given a set of transect lines, a flowline network, extend the transect lines out given distances from the left and right +#' Flowlines are required to ensure valid transect intersection relationship is maintained +#' +#' @param transects sf dataframe of linestrings, requires crosswalk_id, cs_id, grouping_id columns and numeric 'left_distance' and 'right_distance' columns +#' @param flowlines sf dataframe of linestrings +#' @param crosswalk_id character, column name that connects features in transects to flowlines +#' @param cs_id character, column name that uniquely identifies transects within a flowline +#' @param grouping_id character, column name in both transects and flowlines that denotes which flowlines are grouped with which transects. +#' @importFrom utils str +#' @importFrom geos as_geos_geometry +#' @importFrom wk wk_crs +#' @importFrom sf st_geometry st_as_sf st_length +#' @importFrom nhdplusTools rename_geometry +#' @importFrom dplyr mutate relocate any_of +#' @return transects sf dataframe with extended transect geometries, left and right distance columns, and flags indicating if the transect was extended in the left and/or right directions +#' @export +extend_transects_by_distances <- function( + transects, + flowlines, + crosswalk_id, + cs_id = "cs_id", + grouping_id = "mainstem" +) { + + # --------------------------------------- + # transects <- transect_lines2 + # flowlines <- sf::read_sf("/Users/anguswatters/Desktop/test_flines_06.gpkg") + # crosswalk_id = "hy_id" + # cs_id = "cs_id" + # grouping_id = 'mainstem' + # transects = transect_lines + # flowlines = flowlines + # crosswalk_id = crosswalk_id + # cs_id = "cs_id" + # grouping_id = grouping_id + + # --------------------------------------- + + # ---------------------------------------------------------------------------------- + # ----------- Input checking ------ + # ---------------------------------------------------------------------------------- + if(!crosswalk_id %in% names(flowlines)) { + stop("crosswalk_id '", crosswalk_id, "' is not a column in 'flowlines' input,\n", + "Please provide a valid 'crosswalk_id' that crosswalks 'flowlines' to 'transects'") + } + + if(!crosswalk_id %in% names(transects)) { + stop("crosswalk_id '", crosswalk_id, "' is not a column in 'transects' input,\n", + "Please provide a valid 'crosswalk_id' that crosswalks the 'transects' to 'flowlines'") + } + + if(!cs_id %in% names(transects)) { + stop("cs_id '", cs_id, "' is not a column in 'transects' input,\n", + "Please provide a valid 'cs_id' column name from 'transects'.\n", + "The 'cs_id' should uniquely identify each transect lines within a flowline.\n", + "(ID for each transect within the crosswalk_id)") + } + + if(!grouping_id %in% names(flowlines)) { + stop("grouping_id '", grouping_id, "' is not a column in 'flowlines' input,\n", + "Please provide a valid 'grouping_id' that associates each transect line with 1 or more flowlines in 'flowlines'" + ) + } + + if(!grouping_id %in% names(transects)) { + stop("grouping_id '", grouping_id, "' is not a column in 'transect_lines' input,\n", + "Please provide a valid 'grouping_id' that associates each transect line with 1 or more flowlines in 'flowlines'" + ) + } + + if(!'left_distance' %in% names(transects)) { + stop("transect_lines is missing a numeric 'left_distance' column.\n", + "A numeric 'left_distance' column must be present to indicate the distance to extend each transect in the left direction." + ) + } + + if(!'right_distance' %in% names(transects)) { + stop("transect_lines is missing a numeric 'right_distance' column.\n", + "A numeric 'right_distance' column must be present to indicate the distance to extend each transect in the right direction." + ) + } + + fline_id_array <- flowlines[[crosswalk_id]] + # fline_id_array <- flowlines$id + + # TODO: next time, change this function to ONLY process transects that have ANY extension distance, right now we iterate through ALL transects, + # TODO: and 'next' the ones with the no extension distance so doesn't really matter much but + + # Convert the net object into a geos_geometry + flowlines_geos <- geos::as_geos_geometry(flowlines) + transects_geos <- geos::as_geos_geometry(transects) + + # stash the CRS of the transects to use when making the new extended transect lines + line_crs <- wk::wk_crs(transects) + + transect_crosswalk_id_array <- transects[[crosswalk_id]] + # transect_crosswalk_id_array <- transect_lines$hy_id + + transect_cs_id_array <- transects[[cs_id]] + # transect_cs_id_array <- transects$cs_id + + # Intersect grouping IDs + fline_group_id_array <- flowlines[[grouping_id]] + transect_group_id_array <- transects[[grouping_id]] + + # distance vectors + left_distances <- transects$left_distance + right_distances <- transects$right_distance + + # # preallocate vector that stores the extension. distances + # new_transects <- vctrs::vec_c(rep(geos::geos_empty(), length(transect_crosswalk_id_array))) + + # preallocate vectors for storing if transect was extended and from which directions + left_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + right_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + # both_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + + # updated_left_distances <- rep(0, length(transect_crosswalk_id_array)) + # updated_right_distances <- rep(0, length(transect_crosswalk_id_array)) + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(transect_crosswalk_id_array) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + number_of_skips <- 0 + + + # profvis::profvis({ + + for (i in seq_along(transect_crosswalk_id_array)) { + + # Check if the iteration is a multiple of 100 + if (message_interval != 0 && i %% message_interval == 0) { + percent_done <- round(i/total, 2) * 100 + message(i, " > ", percent_done, "% ") + message("Number of skips: ", number_of_skips) + } + + # get the current transect, hy_id, cs_id, flowline, and extension distances + current_trans <- transects_geos[i] + + current_hy_id <- transect_crosswalk_id_array[i] + current_cs_id <- transect_cs_id_array[i] + + # distances to try extending + left_distance_to_extend <- left_distances[i] + right_distance_to_extend <- right_distances[i] + + # skip the iteration if no extension required + no_extension_required <- (left_distance_to_extend == 0 && right_distance_to_extend == 0) + + # TODO: use this if we switch from using 0s to NAs + # no_extension_required <- (is.na(left_distance_to_extend) && is.na(right_distance_to_extend)) + + # current_intersect_group_id <- transect_group_id_array[i] + + # TODO: might need this in case I do the is_valid_transect() check on just the single flowline + # current_fline <- flowlines_geos[fline_id_array == current_hy_id] + + # TODO: these are the rest of the transects for this flowline + # neighbor_transects <- transects_geos[transect_crosswalk_id_array == current_hy_id & transect_cs_id_array != current_cs_id] + + # mapview::mapview(sf::st_as_sf(transects_geos[transect_crosswalk_id_array == current_hy_id & transect_cs_id_array != current_cs_id]), color = "red") + + # mapview::mapview(sf::st_as_sf(current_trans), color = "green") + + # Skip the iteration if NO extension distance in either direction + if(no_extension_required) { + # message("Skipping -left/right extension are both 0") + number_of_skips = number_of_skips + 1 + + next + } + + # message("Extending transect line left and right") + + # extend the transects by the prescribed distances + left_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + left_distance_to_extend, "head") + right_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + right_distance_to_extend, "tail") + + # initial check to make sure the extended versions of the transects are valid + # mapview::mapview(sf::st_as_sf(flowlines_geos[fline_group_id_array == transect_group_id_array[i]])) + + # mapview::mapview(sf::st_as_sf(transects_geos[transect_group_id_array == transect_group_id_array[i]]), color = "red") + + # mapview::mapview(sf::st_as_sf(left_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(right_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(current_trans), color = "red") + + # TODO version 2: + # ONLY CHECKING FOR INTERSECTIONS ON CURRENT FLOWLINE NOT WHOLE NETWORK + use_left_extension <- is_valid_transect_line( + left_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + ) + + use_right_extension <- is_valid_transect_line( + right_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + ) + + used_half_of_left <- FALSE + used_half_of_right <- FALSE + + # TODO: Probably should precompute this division BEFORE the loop... + half_left_distance <- ifelse(left_distance_to_extend > 0, left_distance_to_extend %/% 2, 0) + half_right_distance <- ifelse(right_distance_to_extend > 0, right_distance_to_extend %/% 2, 0) + + # if we CAN'T use the original LEFT extension distance, + # we try HALF the distance (or some distane less than we extended by in the first place) + if (!use_left_extension) { + + # half_left_distance <- ifelse(left_distance_to_extend > 0, left_distance_to_extend %/% 2, 0) + left_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + half_left_distance, "head") + # TODO version 2: + # ONLY CHECKING FOR INTERSECTIONS ON CURRENT FLOWLINE NOT WHOLE NETWORK + # if (!is.null(intersect_group_id)) { + use_left_extension <- is_valid_transect_line( + left_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + ) + + used_half_of_left <- ifelse(use_left_extension, TRUE, FALSE) + } + + # if we CAN'T use the original RIGHT extension distance, + # we try HALF the distance (or some distance less than we extended by in the first place) + if (!use_right_extension) { + + # half_right_distance <- ifelse(right_distance_to_extend > 0, right_distance_to_extend %/% 2, 0) + right_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + half_right_distance, "tail") + + use_right_extension <- is_valid_transect_line( + right_extended_trans, + transects_geos[transect_group_id_array == transect_group_id_array[i]], + flowlines_geos[fline_group_id_array == transect_group_id_array[i]] + ) + + used_half_of_right <- ifelse(use_right_extension, TRUE, FALSE) + + } + + # get the start and end point of the new line + extension_pts <- pick_extension_pts( + left_extended_trans, + right_extended_trans, + use_left_extension, + use_right_extension + ) + + # single geos_geometry points + start <- extension_pts[1] + end <- extension_pts[2] + + # create the new transect line + updated_trans <- make_line_from_start_and_end_pts(start, end, line_crs) + + # TODO: in case the above code is making a copy, below should NOT ( i dont think creating start/end is a copy but just a pointer to the data) + # updated_trans <- make_line_from_start_and_end_pts(extension_pts[1], extension_pts[2], line_crs) + + # flag if left extension happened + if(use_left_extension) { + left_extended_flag[i] <- TRUE + } + + # flag if right extension happened + if(use_right_extension) { + right_extended_flag[i] <- TRUE + } + + # update the left extension distance if half the original distance was used + if (used_half_of_left) { + left_distances[i] <- half_left_distance + # updated_left_distances[i] <- half_left_distance + } + + # update the right extension distance if half the original distance was used + if (used_half_of_right) { + right_distances[i] <- half_right_distance + # updated_right_distances[i] <- half_right_distance + } + + # last step is to replace the original transect with the updated transect (extended) + transects_geos[i] <- updated_trans + + } + + # }) + + # Update the "transects_to_extend" with new geos geometries ("geos_list") + sf::st_geometry(transects) <- sf::st_geometry(sf::st_as_sf(transects_geos)) + + # replace the distance values so that any transects that were extended HALFWAY will be accounted for + transects$left_distance <- left_distances + transects$right_distance <- right_distances + + # Flags indicating if extensions happened or not (probably can just be dropped) + transects$left_is_extended <- left_extended_flag + transects$right_is_extended <- right_extended_flag + + message("==========================") + message("Structure of transects object ^^^^^^^", utils::str(transects)) + message("==========================") + + transects <- nhdplusTools::rename_geometry(transects, "geometry") + + message("Structure of transects object AFTER RENAME ^^^^^^^", utils::str(transects)) + message("==========================") + + transects <- + transects %>% + dplyr::mutate( + cs_lengthm = as.numeric(sf::st_length(.)) + ) %>% + dplyr::relocate( + dplyr::any_of(c(crosswalk_id, cs_id)), + # dplyr::any_of(crosswalk_id), + # dplyr::any_of(cs_id), + cs_lengthm + ) + + transects <- move_geometry_to_last(transects) + + return(transects) + +} + +#' Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +#' WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons (VERSION 2) +#' @param transect_lines Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons) +#' @param polygons set of sf polygons that transect lines should be exteneded +#' @param flowlines set of Sf linestrings +#' @param crosswalk_id character, flowline ID that matches flowlines with transect lines. This crosswalk_id must appear are a column in both flowlines and transect_lines. +#' @param grouping_id character, name of a column in flowlines that should be used to group each transect with 1 or more flowlines. +#' That is, when transects are checked to make sure they don't intersect +#' other transects or other flowlines, this group ID will distinguise which flowlines a transect should be checked against. +#' The intersect_group_id must appear as a column in both flowlines and transect_lines dataframes +#' @param max_extension_distance numeric, maximum distance (meters) to extend a transect line +#' in either direction to try and intersect one of the "polygons". Default is 3000m +#' @return sf linestring, with extended transect lines +#' @importFrom rmapshaper ms_simplify +#' @importFrom geos as_geos_geometry geos_intersects_matrix geos_simplify_preserve_topology geos_within_matrix geos_empty geos_point_start geos_point_end +#' @importFrom sf st_as_sf st_cast st_segmentize st_length st_drop_geometry st_geometry +#' @importFrom dplyr mutate case_when select left_join relocate n any_of +#' @importFrom lwgeom st_linesubstring +#' @importFrom wk wk_crs +#' @importFrom nhdplusTools rename_geometry +#' @importFrom vctrs vec_c +#' @export +extend_transects_to_polygons2 <- function( + transect_lines, + polygons, + flowlines, + crosswalk_id = 'hy_id', + grouping_id = 'mainstem', + max_extension_distance = 3000 +) { + # # ---------------------------------------------------------- + # library(sf) + # library(dplyr) + # library(geos) + # library(profvis) + # + # # polygons <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/FEMA_BY_VPU/VPU_02/fema_vpu_02_output.gpkg") + # # transect_lines <- sf::read_sf("/Users/anguswatters/Desktop/test_transects_02.gpkg") + # # flowlines <- sf::read_sf("/Users/anguswatters/Desktop/test_flines_02.gpkg") + # polygons <- sf::read_sf("/Users/anguswatters/Desktop/lynker-spatial/FEMA_BY_VPU/VPU_06/fema_vpu_06_output.gpkg") + # transect_lines <- sf::read_sf("/Users/anguswatters/Desktop/test_transects_06.gpkg") + # flowlines <- sf::read_sf("/Users/anguswatters/Desktop/test_flines_06.gpkg") + # # + # crosswalk_id = "hy_id" + # grouping_id = "mainstem" + # max_extension_distance = 3000 + # # # # + # # # # mapview::npts(polygons, by_feature = T) %>% sort(decreasing = T) %>% .[1:100] + # # # + # polygons <- rmapshaper::ms_simplify(polygons, keep_shapes = T, keep = 0.02, sys = TRUE, sys_mem = 16) + # # mapview::mapview(polygons, col.regions = "white", color = "green") + + # # mapview::mapview(polygons2, col.regions = "white", color = "red") + # # mapview::npts(polygons, by_feature = T) %>% sort(decreasing = T) %>% .[1:100] + # # mapview::npts(polygons) + + # ---------------------------------------------------------------------------------- + # ----------- Input checking ------ + # ---------------------------------------------------------------------------------- + if(!crosswalk_id %in% names(flowlines)) { + stop("crosswalk_id '", crosswalk_id, "' is not a column in 'flowlines' input,\n", + "Please provide a valid 'crosswalk_id' that crosswalks 'flowlines' to 'transect_lines'") + } + + if(!crosswalk_id %in% names(transect_lines)) { + stop("crosswalk_id '", crosswalk_id, "' is not a column in 'transect_lines' input,\n", + "Please provide a valid 'crosswalk_id' that crosswalks the 'transect_lines' to 'flowlines'") + } + + if(!grouping_id %in% names(flowlines)) { + stop("grouping_id '", grouping_id, "' is not a column in 'flowlines' input,\n", + "Please provide a valid 'grouping_id' that associates each transect line with 1 or more flowlines in 'flowlines'" + ) + } + + if(!grouping_id %in% names(transect_lines)) { + stop("grouping_id '", grouping_id, "' is not a column in 'transect_lines' input,\n", + "Please provide a valid 'grouping_id' that associates each transect line with 1 or more flowlines in 'flowlines'" + ) + } + # ---------------------------------------------------------------------------------- + + + # get only the relevent polygons/transects + transect_subset <- subset_transects_in_polygons(transect_lines, polygons) + polygons_subset <- subset_polygons_in_transects(transect_lines, polygons) + + + # get a dataframe that tells you how far to extend each line in either direction + extensions_by_id <- get_extensions_by_id(transect_subset, polygons_subset, crosswalk_id, max_extension_distance) + + # TODO: Add left/right extension distancces to transect data + # TODO: this can ultimately just be the "transects" variable, dont need to make new "transects_with_distances" variable + transect_lines <- + transect_lines %>% + dplyr::left_join( + extensions_by_id, + by = c(crosswalk_id, "cs_id") + ) %>% + # TODO: I think i want to keep the NAs and NOT fill w/ 0 + dplyr::mutate( + left_distance = dplyr::case_when( + is.na(left_distance) ~ 0, + TRUE ~ left_distance + ), + right_distance = dplyr::case_when( + is.na(right_distance) ~ 0, + TRUE ~ right_distance + ) + ) %>% + # hydrofabric3D::add_tmp_id() + hydrofabric3D::add_tmp_id(x = get(crosswalk_id), y = cs_id) + + # system.time({ + transect_lines <- extend_transects_by_distances( + transects = transect_lines, + flowlines = flowlines, + crosswalk_id = crosswalk_id, + cs_id = "cs_id", + grouping_id = grouping_id + ) + # }) + + # remove transects that intersect with OTHER TRANSECTS + transect_lines <- + transect_lines[lengths(sf::st_intersects(transect_lines)) == 1, ] %>% + dplyr::group_by(dplyr::across(dplyr::any_of(crosswalk_id))) %>% + # dplyr::group_by(hy_id) + dplyr::mutate(cs_id = 1:dplyr::n()) %>% + dplyr::ungroup() + + # remove transects that intersect multiple flowlines + transect_lines <- + transect_lines[lengths(sf::st_intersects(transect_lines, flowlines)) == 1, ] %>% + dplyr::group_by(dplyr::across(dplyr::any_of(crosswalk_id))) %>% + # dplyr::group_by(hy_id) + dplyr::mutate(cs_id = 1:dplyr::n()) %>% + dplyr::ungroup() + + return(transect_lines) + # +} + + +#' Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +#' +#' @param geos_geoms list of geos_geometrys +#' @param ids character vector +#' @param lines_to_cut geos_linestrings +#' @param lines_to_cut_indices numeric vector +#' @param direction character, either "head", "tail" or "both" +#' @param max_extension_distance numeric +#' @param verbose logical, whether to print messages or not. Default is FALSE +#' +#' @return geos_geometry vector of extended linestrings where extension was needed/possible, return vector is same length as number of input 'ids' +#' @importFrom vctrs vec_c +#' @importFrom geos geos_empty +get_lines_extended_to_geoms <- function(geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500, + verbose = FALSE + ) { + + if (!direction %in% c("head", "tail")) { + stop("Invalid 'direction' value, must be one of 'head' or 'tail'") + } + + # # preallocate vector that stores the extended geos linestrings + extended_lines_vect <- vctrs::vec_c(rep(geos::geos_empty(), length(ids))) + + # Precompute flags and a distance vector for extending + is_within_polygon_flags <- sapply(lines_to_cut_indices, function(i) { any(!is.na(i)) }) + distance_range <- 1:max_extension_distance + + if(verbose) { + message("Geoms length: ", length(geos_geoms), "\n", + "IDS length: ", length(ids), "\n", + "lines to cut length: ", length(lines_to_cut_indices) + ) + } + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(ids) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + + # extension_dists <- vector(mode = "numeric", length = nrow(trans_data)) + for (i in seq_along(ids)) { + + # log percent complete + if (message_interval != 0 && i %% message_interval == 0) { + # get the percent complete + percent_done <- round(i/total, 2) * 100 + message(i, " > ", percent_done, "% ") + } + + curr_id <- ids[i] + is_within_polygon <- is_within_polygon_flags[i] + # is_within_polygon <- any(!is.na(lines_to_cut_indices[[i]])) + + polygon_index <- lines_to_cut_indices[[i]] + # message("transect: '", curr_id, "' - (", i, ")") + # message("in polygon? ", is_within_polygon) + + if (is_within_polygon) { + # message("Extending linestring within polygons...") + # curr_geom <- geos_geoms[[i]] + + # # TODO: not sure why i did this sort step... probably not needed + # index_vect <- unlist(polygon_index) + # index_vect <- sort(unlist(polygon_index)) + + extended_line <- geos_bs_extend_to_geom( + distances = distance_range, + line = geos_geoms[[i]], + geoms_to_cut = lines_to_cut[unlist(polygon_index)], + direction = direction + ) + + extended_lines_vect[i] <- extended_line + } else { + extended_lines_vect[i] <- geos_geoms[[i]] + } + + } + + # mapview::mapview(sf::st_as_sf(extended_lines_vect), color = 'green') + + # mapview::mapview(sf::st_as_sf(geos_geoms), color = 'red') + + return(extended_lines_vect) +} + +#' Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +#' Version of get_lines_extended_to_geoms() but only iterates through the IDs/geometries that are predetermined to be WITHIN A POLYGON +#' @param geos_geoms list of geos_geometrys +#' @param ids character vector +#' @param lines_to_cut geos_linestrings +#' @param lines_to_cut_indices numeric vector +#' @param direction character, either "head", "tail" or "both" +#' @param max_extension_distance numeric +#' @param verbose logical, whether to print messages or not. Default is FALSE +#' @return geos_geometry vector of extended linestrings for the geometries within the lines to cut +#' @importFrom vctrs vec_c +#' @importFrom geos geos_empty +get_lines_extended_to_geoms_subset <- function(geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500, + verbose = FALSE + ) { + + if (!direction %in% c("head", "tail")) { + stop("Invalid 'direction' value, must be one of 'head' or 'tail'") + } + + # Precompute flags and a distance vector for extending + is_within_polygon_flags <- sapply(lines_to_cut_indices, function(i) { any(!is.na(i)) }) + distance_range <- 1:max_extension_distance + + geos_geoms_subset <- geos_geoms[is_within_polygon_flags] + ids_subset <- ids[is_within_polygon_flags] + lines_to_cut_indices_subset <- lines_to_cut_indices[is_within_polygon_flags] + extended_lines_vect <- vctrs::vec_c(rep(geos::geos_empty(), length(ids_subset))) + + if (verbose) { + message("Geoms length: ", length(geos_geoms_subset), "\n", + "IDS length: ", length(ids_subset), "\n", + "lines to cut length: ", length(lines_to_cut_indices_subset) + ) + } + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(ids_subset) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + + for (i in seq_along(ids_subset)) { + + # log percent complete + if (message_interval != 0 && i %% message_interval == 0) { + # get the percent complete + percent_done <- round(i/total, 2) * 100 + message(i, " > ", percent_done, "% ") + } + + polygon_index <- lines_to_cut_indices_subset[[i]] + + extended_line <- geos_bs_extend_to_geom( + distances = distance_range, + line = geos_geoms[[i]], + geoms_to_cut = lines_to_cut[unlist(polygon_index)], + direction = direction + ) + + extended_lines_vect[i] <- extended_line + } + + # mapview::mapview(sf::st_as_sf(extended_lines_vect), color = 'green') + + # mapview::mapview(sf::st_as_sf(geos_geoms), color = 'red') + + return(extended_lines_vect) +} + + + +#' Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +#' WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons +#' DEPRECATED at this point, will delete on next version +#' @param transect_lines Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons) +#' @param polygons set of sf polygons that transect lines should be exteneded +#' @param flines set of Sf linestrings +#' @param max_extension_distance numeric, maximum distance (meters) to extend a transect line in either direction to try and intersect one of the "polygons" +#' +#' @return sf linestring, with extended transect lines +#' @importFrom rmapshaper ms_simplify +#' @importFrom geos as_geos_geometry geos_intersects_matrix geos_simplify_preserve_topology geos_within_matrix geos_empty geos_point_start geos_point_end +#' @importFrom sf st_as_sf st_cast st_segmentize st_length st_drop_geometry st_geometry +#' @importFrom dplyr mutate case_when select left_join relocate +#' @importFrom lwgeom st_linesubstring +#' @importFrom wk wk_crs +#' @importFrom vctrs vec_c +#' @export +get_transect_extension_distances_to_polygons <- function(transect_lines, polygons, flines, max_extension_distance) { + + # TODO: this should be a function argument OR removed, shouldn't probably forcibly and silently simplify the input polygons without user knowing.. + # keep 10% of the original points for speed + # polygons <- rmapshaper::ms_simplify(polygons, keep_shapes = F, keep = 0.10) + + # polygons + transects_geos <- geos::as_geos_geometry(transect_lines) + polygons_geos <- geos::as_geos_geometry(polygons) + + # geos::geos_union( polygons_geos, polygons_geos) %>% length() + # polygons_geos %>% length() + # polygons + # polygons_geos + transects_polygons_matrix <- geos::geos_intersects_matrix(transects_geos, polygons_geos) + polygons_transects_matrix <- geos::geos_intersects_matrix(polygons_geos, transects_geos) + + # subset the transects and polygons to only those with intersections + intersect_transects <- transect_lines[lengths(transects_polygons_matrix) != 0, ] + intersect_polygons <- polygons_geos[lengths(polygons_transects_matrix) != 0] + + # Convert our intersecting polygons to LINESTRINGS b/c we DON'T NEED polygons to calculate extension distances from our transect lines + # This can be done with just linestrings (not sure if this is actually more performent but I'm pretty sure it is....) + intersect_lines <- + intersect_polygons %>% + # geos::geos_make_valid() %>% + sf::st_as_sf() %>% + # sf::st_union() %>% + # rmapshaper::ms_explode() %>% + # sf::st_as_sf() %>% + # dplyr::mutate(fema_id = 1:dplyr::n()) %>% + # dplyr::select(fema_id, geom = x) %>% + sf::st_cast("MULTILINESTRING") %>% + geos::as_geos_geometry() %>% + geos::geos_simplify_preserve_topology(25) + + # use half of the shortest transect line as the segmentation length for all transects (ensures all transects will have a midpoint...?) + # TODO: Double check this logic. + min_segmentation <- min(intersect_transects$cs_lengthm %/% 2) + + # which.min(intersect_transects$cs_lengthm %/% 2) + + # make each transect line have way more segments so we can take a left and right half of each transect line + segmented_trans <- sf::st_segmentize(intersect_transects, min_segmentation) + + # mapview::mapview(left_trans, col.regions = "dodgerblue") + + # mapview::mapview(intersect_transects, color = "red") + + # mapview::mapview(intersect_transects[42, ], color = "yellow") + + # mapview::mapview(right_trans, color = "dodgerblue") + + # mapview::mapview(left_trans, color = "green") + + # Seperate the transect lines into LEFT and RIGHT halves + # We do this so we can check if a side of a transect is ENTIRELY WITHIN a polygon. + # If the half is entirely within a polygon, + left_trans <- + segmented_trans %>% + lwgeom::st_linesubstring(0, 0.50) %>% + dplyr::mutate( + partition = "left", + partition_lengthm = as.numeric(sf::st_length(geom)) + ) %>% + hydrofabric3D::add_tmp_id() %>% + dplyr::select(tmp_id, hy_id, cs_source, cs_id, cs_measure, + cs_lengthm, + # is_extended, + partition, partition_lengthm, geom) + + # Find the distances from the right side of transect lines + right_trans <- + segmented_trans %>% + lwgeom::st_linesubstring(0.50, 1) %>% + dplyr::mutate( + partition = "right", + partition_lengthm = as.numeric(sf::st_length(geom)) + ) %>% + hydrofabric3D::add_tmp_id() %>% + dplyr::select(tmp_id, hy_id, cs_source, cs_id, cs_measure, + cs_lengthm, + # is_extended, + partition, partition_lengthm, geom) + + # convert the transect geometries to geos types + # get the fema polygon indices for the transect halves that are completely within a fema polygon + # add the fema polygons index as a column to the transect dataframes + left_trans_geos <- geos::as_geos_geometry(left_trans) + right_trans_geos <- geos::as_geos_geometry(right_trans) + + left_within_matrix <- geos::geos_within_matrix(left_trans_geos, intersect_polygons) + right_within_matrix <- geos::geos_within_matrix(right_trans_geos, intersect_polygons) + + left_within_vect <- lapply(left_within_matrix, function(i) { if(length(i) > 0) { c(i) } else { c(NA) } }) + right_within_vect <- lapply(right_within_matrix, function(i) { if(length(i) > 0) { c(i) } else { c(NA) } }) + + # add the fema polygon indexes as columns + left_trans$left_fema_index <- left_within_vect + right_trans$right_fema_index <- right_within_vect + + # add boolean columns whether the transect is fully within the FEMA polygons + left_trans <- + left_trans %>% + dplyr::mutate( + left_is_within_fema = dplyr::case_when( + !is.na(left_fema_index) ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::select(tmp_id, hy_id, cs_source, cs_id, cs_measure, + cs_lengthm, + # is_extended, + partition, partition_lengthm, + left_fema_index, left_is_within_fema, + geom + ) + + right_trans <- + right_trans %>% + dplyr::mutate( + right_is_within_fema = dplyr::case_when( + !is.na(right_fema_index) ~ TRUE, + TRUE ~ FALSE + ) + ) %>% + dplyr::select(tmp_id, hy_id, cs_source, cs_id, cs_measure, + cs_lengthm, + # is_extended, + partition, partition_lengthm, + right_fema_index, right_is_within_fema, + geom + ) + + # max_extension_distance = 3000 + # which(transects_with_distances$hy_id == "wb-1003839") + # left_trans[which(left_trans$hy_id == "wb-1003839"), ]$cs_lengthm + # right_trans[which(left_trans$hy_id == "wb-1003839"), ]$cs_lengthm + # which(right_trans$hy_id == "wb-1003839") + + message("Calculating left side extension distances...") + + left_distances <- calc_extension_distances( + geos_geoms = left_trans_geos, + ids = left_trans$tmp_id, + lines_to_cut = intersect_lines, + lines_to_cut_indices = left_trans$left_fema_index, + direction = "head", + max_extension_distance = max_extension_distance + ) + + message("Calculating right side extension distances...") + + right_distances <- calc_extension_distances( + geos_geoms = right_trans_geos, + ids = right_trans$tmp_id, + lines_to_cut = intersect_lines, + lines_to_cut_indices = right_trans$right_fema_index, + direction = "tail", + max_extension_distance = max_extension_distance + ) + + left_trans$left_distance <- left_distances + right_trans$right_distance <- right_distances + + # distance to extend LEFT and/or RIGHT for each hy_id/cs_id + extensions_by_id <- dplyr::left_join( + sf::st_drop_geometry( + dplyr::select(left_trans, + hy_id, cs_id, left_distance) + ), + sf::st_drop_geometry( + dplyr::select(right_trans, + hy_id, cs_id, + right_distance) + ), + by = c("hy_id", "cs_id") + ) + + # TODO: Add left/right extension distancces to transect data + # TODO: this can ultimately just be the "transect_lines" variable, dont need to make new "transects_with_distances" variable + transect_lines <- + transect_lines %>% + dplyr::left_join( + extensions_by_id, + by = c("hy_id", "cs_id") + ) %>% + dplyr::mutate( + left_distance = dplyr::case_when( + is.na(left_distance) ~ 0, + TRUE ~ left_distance + ), + right_distance = dplyr::case_when( + is.na(right_distance) ~ 0, + TRUE ~ right_distance + ) + # left_distance = dplyr::case_when( + # left_distance == 0 ~ NA, + # TRUE ~ left_distance + # ), + # right_distance = dplyr::case_when( + # right_distance == 0 ~ NA, + # TRUE ~ right_distance + # ) + ) %>% + hydrofabric3D::add_tmp_id() + + # left_extended_flag[1:20] + # right_extended_flag[1:20] + # both_extended_flag[1:20] + # + # range_vect <- 1:500 + # + # fema_uids <- unique(c(unlist(fema_index_df[range_vect, ]$left_fema_index), unlist(fema_index_df[range_vect, ]$right_fema_index))) + # fema_uids <- fema_uids[!is.na(fema_uids)] + # fema_uids + # foi <- sf::st_as_sf(intersect_polygons[fema_uids]) %>% dplyr::mutate( + # fema_id = fema_uids + # ) + # # ooi <- sf::st_as_sf() + # # toi <- sf::st_as_sf(new_transects[1:20]) + # toi <- sf::st_as_sf(transect_geoms[range_vect]) + # toi + # og_trans <- transects_with_distances[range_vect, ] + # mapview::mapview(foi, col.regions = "dodgerblue") + + # mapview::mapview(toi, color = "red") + + # mapview::mapview(og_trans, color = "green") + + fline_id_array <- flines$id + + # Convert the net object into a geos_geometry + flines_geos <- geos::as_geos_geometry(flines) + + transect_crosswalk_id_array <- transect_lines$hy_id + transect_cs_id_array <- transect_lines$cs_id + + # transect_geoms <- geos::as_geos_geometry(transect_lines$geom) + + left_distances <- transect_lines$left_distance + right_distances <- transect_lines$right_distance + + # # preallocate vector that stores the extension. distances + # new_transects <- vctrs::vec_c(rep(geos::geos_empty(), length(transect_crosswalk_id_array))) + + left_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + right_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + both_extended_flag <- rep(FALSE, length(transect_crosswalk_id_array)) + + + updated_left_distances <- rep(0, length(transect_crosswalk_id_array)) + updated_right_distances <- rep(0, length(transect_crosswalk_id_array)) + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(transect_crosswalk_id_array) + + # output a message every ~10% intervals + message_interval <- total %/% 20 + number_of_skips = 0 + + for (i in seq_along(transect_crosswalk_id_array)) { + + # Check if the iteration is a multiple of 100 + if (message_interval != 0 && i %% message_interval == 0) { + + # get the percent complete + percent_done <- round(i/total, 2) * 100 + + # Print the message every "message_interval" + # if(verbose) { + message(i, " > ", percent_done, "% ") + message("Number of skips: ", number_of_skips) + # } + # message("Iteration ", i, " / ", length(extended_trans), + # " - (", percent_done, "%) ") + + } + # which(transects_with_distances$hy_id == "wb-1003839") + # i = 9587 + # get the current transect, hy_id, cs_id, flowline, and extension distances + current_trans <- transects_geos[i] + + current_hy_id <- transect_crosswalk_id_array[i] + current_cs_id <- transect_cs_id_array[i] + + current_fline <- flines_geos[fline_id_array == current_hy_id] + + left_distance_to_extend <- left_distances[i] + right_distance_to_extend <- right_distances[i] + + no_extension_required <- (left_distance_to_extend == 0 && right_distance_to_extend == 0) + # no_extension_required <- is.na(left_distance_to_extend) && is.na(right_distance_to_extend) + # message("Transect tmp_id: ", curr_tmp_id, " - (", i, ")") + + if(no_extension_required) { + # message("Skipping -left/right extension are both 0") + number_of_skips = number_of_skips + 1 + + next + } + + # message("Extending transect line left and right") + # extend the lines + left_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + left_distance_to_extend, "head") + right_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + right_distance_to_extend, "tail") + + # initial check to make sure the extended versions of the transects are valid + use_left_extension <- is_valid_transect_line(left_extended_trans, transects_geos, flines_geos) + use_right_extension <- is_valid_transect_line(right_extended_trans, transects_geos, flines_geos) + # use_both_extensions <- use_left_extension && use_right_extension + + used_half_of_left <- FALSE + used_half_of_right <- FALSE + + # TODO: Probably should precompute this division BEFORE the loop... + half_left_distance <- ifelse(left_distance_to_extend > 0, left_distance_to_extend %/% 2, 0) + half_right_distance <- ifelse(right_distance_to_extend > 0, right_distance_to_extend %/% 2, 0) + + # if we CAN'T use the original LEFT extension distance, + # we try HALF the distance (or some distane less than we extended by in the first place) + if (!use_left_extension) { + + # half_left_distance <- ifelse(left_distance_to_extend > 0, left_distance_to_extend %/% 2, 0) + left_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + half_left_distance, "head") + use_left_extension <- is_valid_transect_line(left_extended_trans, transects_geos, flines_geos) + + used_half_of_left <- ifelse(use_left_extension, TRUE, FALSE) + } + + # if we CAN'T use the original RIGHT extension distance, + # we try HALF the distance (or some distance less than we extended by in the first place) + if (!use_right_extension) { + + # half_right_distance <- ifelse(right_distance_to_extend > 0, right_distance_to_extend %/% 2, 0) + right_extended_trans <- hydrofabric3D::geos_extend_line(current_trans, + half_right_distance, "tail") + use_right_extension <- is_valid_transect_line(right_extended_trans, transects_geos, flines_geos) + + used_half_of_right <- ifelse(use_right_extension, TRUE, FALSE) + + # mapview::mapview(sf::st_as_sf(current_trans), color = "red") + + # mapview::mapview(sf::st_as_sf(left_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(right_extended_trans), color = "green") + + # mapview::mapview(sf::st_as_sf(left_extended_trans2), color = "dodgerblue") + + # mapview::mapview(sf::st_as_sf(right_extended_trans2), color = "dodgerblue") + + } + + use_both_extensions <- use_left_extension && use_right_extension + + # Get the start and end of both extended tranects + left_start <- geos::geos_point_start(left_extended_trans) + left_end <- geos::geos_point_end(left_extended_trans) + right_start <- geos::geos_point_start(right_extended_trans) + right_end <- geos::geos_point_end(right_extended_trans) + + # } + # Extend in BOTH directions + if(use_both_extensions) { + # message("Extend direction: BOTH") + start <- left_start + end <- right_end + + # extend ONLY the left side + } else if(use_left_extension && !use_right_extension) { + # message("Extend direction: LEFT") + start <- left_start + end <- left_end + + # Extend ONLY the right side + } else if(!use_left_extension && use_right_extension) { + # message("Extend direction: RIGHT") + start <- right_start + end <- right_end + + # DO NOT extend either direction + } else { + # message("No extension") + # TODO: Really dont need to do anything + # TODO: in this scenario because we just use the original transect line + start <- left_end + end <- right_start + } + + # trans_needs_extension <- use_left_extension || use_right_extension + + # if(trans_needs_extension) { + + line_crs <- wk::wk_crs(current_trans) + updated_trans <- make_line_from_start_and_end_pts(start, end, line_crs) + + if(use_left_extension) { + left_extended_flag[i] <- TRUE + } + + if(use_right_extension) { + right_extended_flag[i] <- TRUE + } + + if(use_both_extensions) { + both_extended_flag[i] <- TRUE + } + + if(used_half_of_left) { + updated_left_distances[i] <- half_left_distance + } + if(used_half_of_right) { + updated_right_distances[i] <- half_right_distance + } + + # new_transects[i] <- updated_trans + transects_geos[i] <- updated_trans + + } + + # transect_lines2 <- transect_lines + # dplyr::mutate( + # new_cs_lengthm = as.numeric(sf::st_length(geom)) + # ) %>% + # dplyr::relocate(hy_id, cs_id, cs_lengthm, new_cs_lengthm) + + + # Update the "transect_lines" with new geos geometries ("geos_list") + sf::st_geometry(transect_lines) <- sf::st_geometry(sf::st_as_sf(transects_geos)) + + transect_lines <- + transect_lines %>% + dplyr::mutate( + new_cs_lengthm = as.numeric(sf::st_length(geom)) + ) %>% + dplyr::relocate(hy_id, cs_id, cs_lengthm, new_cs_lengthm) + + transect_lines$left_is_extended <- left_extended_flag + transect_lines$right_is_extended <- right_extended_flag + + return(transect_lines) + +} + + diff --git a/R/fix_transects.R b/R/fix_transects.R index 14584389..4756e23e 100644 --- a/R/fix_transects.R +++ b/R/fix_transects.R @@ -1,3 +1,49 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + # ********************************* # ------------- LATEST ------------ # ********************************* @@ -121,7 +167,7 @@ fix_braid_transects <- function( ###### BRAID LENGTH CHECKING # braid_sizes <- braid_lengths(braids, keep_geom = TRUE) # hist(braid_sizes$braid_length) - + if (!is.null(braid_threshold)) { # remove braids that have a total flowline length greater than braid_threshold @@ -231,15 +277,15 @@ fix_braid_transects <- function( # get the component ID of current COMID comp_id <- braids$component_id[braids$comid == com] - + # other geometries to cut across with transects others <- get_geoms_to_cut( - x = braids, - id = com, - braid_id = braid_of_interest, - component = comp_id, - method = method - ) + x = braids, + id = com, + braid_id = braid_of_interest, + component = comp_id, + method = method + ) # get information on extension distance and position of cross section extend_maps <- geos_augment_transect( @@ -281,13 +327,13 @@ fix_braid_transects <- function( # geos::as_geos_geometry(dplyr::filter(xs[-i,], changed)) ) ) - # !any( - # lengths( - # sf::st_intersects(sf::st_as_sf(res_geom), - # dplyr::filter(xs[-i,], changed) - # ) - # ) > 0) - { + # !any( + # lengths( + # sf::st_intersects(sf::st_as_sf(res_geom), + # dplyr::filter(xs[-i,], changed) + # ) + # ) > 0) + { # update geometry with new, extended cross section xs$geometry[i] <- res_geom @@ -317,16 +363,16 @@ fix_braid_transects <- function( # mapview::mapview(transect_lines, color = "green") + # mapview::mapview(braids, color = "dodgerblue") + other_xs # mapview::mapview(tmp, color = "green") - + # # keep only the transects that were changed/extended # xs <- dplyr::filter(xs, changed) # check intersection of keeps and NOT BRAID # indices of div_xs transects that now intersect with the updated/extended 'xs' transects net_intersects <- geos::geos_intersects_any( - xs$geometry, - not_braids$geometry - ) + xs$geometry, + not_braids$geometry + ) # remove updated cross sections that intersect with the NOT BRAIDED flowlines if(any(net_intersects)) { @@ -355,15 +401,15 @@ fix_braid_transects <- function( # intersections between updated inner cross sections ("xs") and the remaining inner cross sections that were NOT changed ("unchanged_inners") inner_intersects <- geos::geos_intersects_any( - unchanged_inners$geometry, - xs$geometry - ) + unchanged_inners$geometry, + xs$geometry + ) # add back into "xs" the unchanged inner transects that do NOT intersect with our updated/extended inner transect lines xs <- dplyr::bind_rows( - xs, - unchanged_inners[!inner_intersects, ] - ) + xs, + unchanged_inners[!inner_intersects, ] + ) # # # # keep ALL "inner" transects, both the ones that were extended ("changed" == TRUE) and not changed inners @@ -374,9 +420,9 @@ fix_braid_transects <- function( # indices of other_xs transects that now intersect with the updated/extended 'xs' transects. # All the cross section lines in "xs" are now "inner" lines that were extended other_intersects <- geos::geos_intersects_any( - other_xs$geometry, - xs$geometry - ) + other_xs$geometry, + xs$geometry + ) # other_intersects <- sf::st_intersects(xs, other_xs) # unlist(sf::st_intersects(xs, other_xs)) @@ -394,15 +440,15 @@ fix_braid_transects <- function( # if there are still other (non "inner") transects, do extension processing if (nrow(other_xs) == 0) { - + # bind together final updated transect lines out <- dplyr::select(xs, - # -braid_id, -head_cuts, -tail_cuts - -is_multibraid, - # -has_mainstem, - -changed, - -head_distance, -tail_distance, - ) + # -braid_id, -head_cuts, -tail_cuts + -is_multibraid, + # -has_mainstem, + -changed, + -head_distance, -tail_distance, + ) # # bind together final updated transect lines # out <- dplyr::select(xs, -braid_id, @@ -412,7 +458,7 @@ fix_braid_transects <- function( } else { # message("===== ", nrow(other_xs) ," 'other_xs' transect lines =====") - + # loop through the remaining transects that were NOT "inner" lines, and do extensions for (i in 1:nrow(other_xs)) { @@ -455,11 +501,11 @@ fix_braid_transects <- function( # geos::as_geos_geometry(res_geom) )) & !any(geos::geos_intersects_any( - other_xs[-i, ], - res_geom - # geos::as_geos_geometry(other_xs[-i, ]), - # geos::as_geos_geometry(res_geom) - )) + other_xs[-i, ], + res_geom + # geos::as_geos_geometry(other_xs[-i, ]), + # geos::as_geos_geometry(res_geom) + )) ) { # # # message stating that replacement was made @@ -476,7 +522,7 @@ fix_braid_transects <- function( # keep only the transects that were changed/extended other_xs <- dplyr::filter(other_xs, changed) - + # # # keep only the transects that were changed/extended # other_drop <- dplyr::filter(other_xs, !changed) @@ -504,36 +550,36 @@ fix_braid_transects <- function( # drop all of the transects that are on braids, and replace them with the updated/extended transect lines in "out" transect_lines <- dplyr::bind_rows( - # from original transect_lines, remove all of the cross sections on braids, - dplyr::select( - dplyr::filter( - dplyr::mutate(transect_lines, - tmp_id = paste0(hy_id, "_", cs_id) - ), - !tmp_id %in% all_xs - ), - -tmp_id - ), - # updated braid cross sections - sf::st_as_sf(out) - # out - ) + # from original transect_lines, remove all of the cross sections on braids, + dplyr::select( + dplyr::filter( + dplyr::mutate(transect_lines, + tmp_id = paste0(hy_id, "_", cs_id) + ), + !tmp_id %in% all_xs + ), + -tmp_id + ), + # updated braid cross sections + sf::st_as_sf(out) + # out + ) # if rm_intersects == TRUE, then remove transects that interesect with other parts of the network if(rm_intersects) { # bind braids and not_braids back together to reform original "net" but with added "braid_id" column net <- sf::st_as_sf( - dplyr::bind_rows(braids, not_braids) - ) + dplyr::bind_rows(braids, not_braids) + ) # if final transect_lines has an NA for the braid_id column it means that it was part of the non braided (untouched) transect_lines, # set braid_id to "no_braid" in those cases, otherwise keep braid_id as is transect_lines$braid_id <- ifelse( - is.na(transect_lines$braid_id), - "no_braid", - transect_lines$braid_id - ) + is.na(transect_lines$braid_id), + "no_braid", + transect_lines$braid_id + ) # if one of the transect lines interesects MORE than 1 line in net AND it also has a braid_id == "no_braid", then remove it from output transect_lines <- transect_lines[!(lengths(sf::st_intersects(transect_lines, net)) > 1 & transect_lines$braid_id == "no_braid"), ] @@ -542,7 +588,7 @@ fix_braid_transects <- function( # select and reorder columns back to original starting positions transect_lines <- transect_lines[starting_names] - + # mapview::mapview(braids, color = "gold") + # mapview::mapview(not_braids, color = "dodgerblue") + # mapview::mapview(transect_lines, color = "gold") @@ -572,7 +618,7 @@ fix_braid_transects <- function( # #@importFrom geos as_geos_geometry geos_intersects_any # #@importFrom fastmap fastmap # fix_braid_transects2 <- function( -# net, + # net, # transect_lines, # terminal_id = NULL, # braid_threshold = NULL @@ -1097,7 +1143,7 @@ get_geoms_to_cut <- function(x, braid_id = NULL, component = NULL, method = "comid" - ) { +) { # stop the function if an invalid "method" argument is given if(!method %in% c("comid", "component", "neighbor")) { @@ -1435,21 +1481,21 @@ geos_extend_transects <- function( #' @importFrom geos as_geos_geometry #' @importFrom fastmap fastmap geos_augment_transect <- function( - cs_line, - cs_width, - bf_width, - id, - geoms_to_cut, - geom_ids, - max_distance = NULL, - by = NULL, - carry_geom = TRUE - ) { + cs_line, + cs_width, + bf_width, + id, + geoms_to_cut, + geom_ids, + max_distance = NULL, + by = NULL, + carry_geom = TRUE +) { # max distance from transect of interest and rest of braid flowlines # TODO (need a better method of determing max possible extension of flowline) # max_dist <- as.numeric(max(sf::st_distance(geoms_to_cut, x))) - + # # cs_line <- geos::as_geos_geometry(cross_section$geometry) # # # extract values from cross_section dataframe @@ -1554,35 +1600,35 @@ geos_augment_transect <- function( # if as_df is FALSE, return the line data hashmaps as a list of length 2, # first list element is the head extension data and the second is the tail extension data + + # if NOT AN INNER LINE, postpone processesing + if(position != "inner") { - # if NOT AN INNER LINE, postpone processesing - if(position != "inner") { - - # set "position" values for these geometries - head_map$set("position", position) - tail_map$set("position", position) - - } else { # if LINE IS A INNER LINE, GET READY TO EXTEND - - # set "position" values for these geometries - head_map$set("position", position) - tail_map$set("position", position) - - } + # set "position" values for these geometries + head_map$set("position", position) + tail_map$set("position", position) - # if carry geom is FALSE, remove geometry linestrings from maps before returning - if(!carry_geom) { - head_map$remove("line") - tail_map$remove("line") - } + } else { # if LINE IS A INNER LINE, GET READY TO EXTEND - return( - list( - head = head_map, - tail = tail_map - ) + # set "position" values for these geometries + head_map$set("position", position) + tail_map$set("position", position) + + } + + # if carry geom is FALSE, remove geometry linestrings from maps before returning + if(!carry_geom) { + head_map$remove("line") + tail_map$remove("line") + } + + return( + list( + head = head_map, + tail = tail_map ) - + ) + # # update "relative_position" column in cross_section to reflect the position of the cross section flowline within the braid value # cross_section$relative_position <- position # @@ -1868,7 +1914,8 @@ geos_bs_distance <- function( # if ANY of the geometries in geoms_to_cut are intersected by the new extended line if( - any(geos::geos_intersects(geoms_to_cut, new_line)) + any(lengths(geos::geos_intersects_matrix(new_line, geoms_to_cut)) > 0) + # any(geos::geos_intersects(geoms_to_cut, new_line)) ) { # then DECREMENT RIGHT pointer (DECREASE DISTANCE VALUE) to the midpoint - 1 @@ -1947,6 +1994,97 @@ geos_bs_distance <- function( # # return(L) # } +#' Perform Binary search on sorted distance vector to extend a linestring (transect line) out minimum distance to another linestring geometry +#' This is a variation of the geos_bs_distance() function but this function actually returns the extended linestring instead of the distance TO EXTEND +#' @param distances numeric vector sorted in ascending order +#' @param line geos_geometry, linestring to extend out to the point that it crosses the first geometry in "geoms_to_cut" +#' @param geoms_to_cut geos_geometry, geometries to extend "line" out and cut, when line is extending out and intersects with "geoms_to_cut", algo stops and returns the index of the distance array +#' @param direction character, either "head" or "tail", indicating which end of the line to extend out. +#' +#' @noRd +#' @keywords internal +#' @return extended 'line' geos linestring +#' @importFrom geos geos_intersects geos_empty geos_is_empty +geos_bs_extend_to_geom <- function(distances, line, geoms_to_cut, direction = "head") { + + + # distances = 1:max_extension_distance + # line = curr_geom + # geoms_to_cut = lines_to_cut[index_vect] + # direction = direction + + # Left and right pointers (start and end of distances vector) + L = 1 + R = length(distances) + + + new_line <- geos::geos_empty() + + # While left pointer (L) is less than or equal to the right pointer (R), run binary search. + # Each iteration: + # - the midpoint value gets calculated (M) + # - M is the index of the 'distances' vector that we will use as the distance value to extend 'line' + # - if the new extended line ('new_line') intersects with 'geoms_to_cut', then we decrease the distance value (DECREMENT RIGHT POINTER to the MIDPOINT - 1), + # - if NOT we increase the distance value (INCREMENT LEFT POINTER to the MIDPOINT + 1) + while(L <= R) { + + # calculate midpoint between left and right pointers + M = (L + R) %/% 2 + + if(M == 0 | M == length(distances)) { + # message("EARLY STOPPING bc M = ", M, " (reached start or end bounds of distance vector)") + # return(L) + + # TODO: if the the new_line value is still an empty geos geometry, return the original line + if(geos::geos_is_empty(new_line)) { + # message("Empty geos geometry after extending, returning original line") + return(line) + } + + # message("RETURNING extended line line... ") + return(new_line) + } + + # extend line out to midpoint of distances vector + new_line <- geos_extend_line(line, distances[M], dir = direction) + # new_line_sf <- st_extend_line(sf::st_as_sf(line), distances[M], end = direction) + + # check if any of the other braid linestrings get intersected by the extended line: + # IF: Any interesection occurs, DECREMENT right pointer and search for a SMALLER distance value + # ELSE: no intersection yet, so INCREMENT left pointer and search for a LARGER distance value + + # if ANY of the geometries in geoms_to_cut are intersected by the new extended line + if( + any(geos::geos_intersects(geoms_to_cut, new_line)) + ) { + + # then DECREMENT RIGHT pointer (DECREASE DISTANCE VALUE) to the midpoint - 1 + R = M - 1 + + # otherwise IF NO intersections occur: + } else { + + # then INCREMENT LEFT pointer (INCREASE DISTANCE VALUE) to the midpoint + 1 + L = M + 1 + + } + # message("=======================") + } + + # new_line + # mapview::mapview(sf::st_as_sf(new_line), color = "green") + + # mapview::mapview(sf::st_as_sf(line), color = "red") + + # mapview::mapview(sf::st_as_sf(geoms_to_cut), color = "dodgerblue") + + # TODO: if the the new_line value is still an empty geos geometry, return the original line + if(geos::geos_is_empty(new_line)) { + message("Empty geos geometry after extending, returning original line") + return(line) + } + + return(new_line) +} + #' Find the direction of the endpoints of a linestring (v2) #' Internal function used in geos_extend_line() function to identify the the direction of each of the ends of a linestring @@ -2016,19 +2154,18 @@ geos_linestring_dir <- function(line) { #' @param distance numeric value in meters or a vector of length 2 if 'end = "both"' where # the first value in the vector will extend that tail by that value and the second value extends the head by that value c(tail, head). # If a single value is given when end = "both", the value is recycled and used to extend both ends -#' @param end character, determines whether to extend the linestring from the 'tail', 'head' or 'both' ends +#' @param dir character, determines whether to extend the linestring from the 'tail', 'head' or 'both' ends #' @param with_crs logical, whether a CRS should be prescribed to extended output geos_geometry linestring #' -#' @noRd -#' @keywords internal #' @return geos_geometry linestring extended by 'distance' from either the 'head', 'tail' or 'both' ends of the original linestring #' @importFrom geos as_geos_geometry geos_make_linestring #' @importFrom wk wk_coords wk_crs +#' @export geos_extend_line <- function(line, distance, dir = "both", with_crs = TRUE - ) { +) { # line <- xs[1, ] # if NOT a geos_geometry class, coerce @@ -2139,7 +2276,7 @@ braid_thresholder <- function(x, new_braid_ids = "no_braid", verbose = TRUE ) { - + # input check for input 'x' if(is.null(x)) { stop("missing 'x' input argument") @@ -2206,20 +2343,20 @@ braid_thresholder <- function(x, # add the "too big braid COMIDs" back to original "not_braids" data # and set these comids braid_ids to "no_braid" and is_multibraid = FALSE originals <- dplyr::bind_rows( - originals, - # dplyr::select( - dplyr::mutate( - dplyr::filter( - x, !comid %in% to_keep - ), - braid_id = new_braid_ids, - # braid_id = "no_braid", - # braid_id = "thresholded", - is_multibraid = FALSE - ) - # -has_mainstem - # ) - ) + originals, + # dplyr::select( + dplyr::mutate( + dplyr::filter( + x, !comid %in% to_keep + ), + braid_id = new_braid_ids, + # braid_id = "no_braid", + # braid_id = "thresholded", + is_multibraid = FALSE + ) + # -has_mainstem + # ) + ) new_orig_nrows <- nrow(originals) @@ -2229,12 +2366,12 @@ braid_thresholder <- function(x, # # Drop "braid_id" IDs values that were removed via threshold length value updated_braid_ids <- strsplit(x$braid_id, ", ") updated_braid_ids <- lapply(updated_braid_ids, function(vec) - paste0( - vec[(!vec %in% drop_braids)], - collapse = ", " - ) - ) - + paste0( + vec[(!vec %in% drop_braids)], + collapse = ", " + ) + ) + # replace old "braid_id" with updated thresholded "braid_id" x$braid_id <- unlist(updated_braid_ids) @@ -2369,7 +2506,7 @@ braid_thresholder <- function(x, braid_lengths <- function(x, keep_geom = FALSE, multibraid = FALSE - ) { +) { # input check for input 'x' if(is.null(x)) { @@ -2394,7 +2531,7 @@ braid_lengths <- function(x, dplyr::arrange(-braid_length) } else { - + # lengths of multibraids (groups of braids) xlengths <- x %>% @@ -2517,7 +2654,7 @@ comids_in_braid_ids <- function(x, braids_to_match, braid_ids) { ### "other" geometries are being selected and thus transect lines are attempting to cut across # make_geoms_to_cut_plot <- function( -# shp, + # shp, # x, # id = NULL, # braid_id = NULL, @@ -2648,7 +2785,7 @@ plot_braid_geoms_to_cut <- function( keep_plots = FALSE, save_path = NULL ) { - + ### TEST DATA INPUTS # net = net2 # transect_lines = transects @@ -2661,35 +2798,35 @@ plot_braid_geoms_to_cut <- function( # braid_threshold = NULL # braid_threshold = 25000 ### - + # names that transect_lines starts out with to use at the end starting_names <- names(transect_lines) - + # set geometry name of network to "geometry" net <- nhdplusTools::rename_geometry(net, "geometry") - + # keep track of the original CRS of the inputs to retransform return start_crs1 <- sf::st_crs(net, parameters = T)$epsg start_crs2 <- sf::st_crs(transect_lines, parameters = T)$epsg - + message("Start CRS: ", start_crs1) - + # check if net CRS is 5070, if not, transform it to 5070 if(start_crs1 != 5070) { # if(sf::st_crs(net, parameters = T)$epsg != 5070) { message("Transforming CRS to EPSG: 5070") net <- sf::st_transform(net, 5070) } - + # check if net CRS is 5070, if not, transform it to 5070 if(start_crs2 != 5070) { # if(sf::st_crs(net, parameters = T)$epsg != 5070) { message("Transforming CRS to EPSG: 5070") transect_lines <- sf::st_transform(transect_lines, 5070) } - + message("Identifying braids...") - + braids <- find_braids( network = net, terminal_id = terminal_id, @@ -2698,43 +2835,43 @@ plot_braid_geoms_to_cut <- function( version = version, verbose = FALSE ) - + if(all(braids$braid_id == "no_braid")) { - + message("No braids identified, returning original transects") - + # transform CRS back to input CRS if(start_crs2 != 5070) { message("Transforming CRS back to EPSG: ", start_crs2) transect_lines <- sf::st_transform(transect_lines, start_crs2) } - + return(transect_lines) } - + message("Fixing braid transects...") - + # not braided flowlines not_braids <- dplyr::filter(braids, braid_id == "no_braid") # not_braids <- braids[!braids$comid %in% only_braids$comid, ] - + # trim down network to just the braided parts, and add a comid count to separate out multibraids braids <- braids %>% dplyr::filter(braid_id != "no_braid") %>% dplyr::group_by(braid_id) %>% dplyr::ungroup() - - + + # temporary braid_threshold variable of "drop_max" will use all of the braids EXCEPT the max length braid (minus 1 meter) if(!is.null(braid_threshold) && braid_threshold == "drop_max") { - + braid_threshold <- max(braid_lengths(braids)$braid_length) - 1 - + } - + if (!is.null(braid_threshold)) { - + # remove braids that have a total flowline length greater than braid_threshold braids <- braid_thresholder( x = braids, @@ -2742,16 +2879,16 @@ plot_braid_geoms_to_cut <- function( threshold = braid_threshold, verbose = TRUE ) - + # reassign braids and not_braids datasets to the updated values in 'braids' list (REASSIGNMENT ORDER MATTERS HERE) not_braids <- braids$not_braids braids <- braids$braids - + } - + # add connected component "component_id" column braids <- find_connected_components(braids) - + # join cross sections w/ braid flowlines xs <- transect_lines %>% @@ -2769,77 +2906,77 @@ plot_braid_geoms_to_cut <- function( dplyr::mutate(has_mainstem = any(divergence == 0)) %>% dplyr::ungroup() %>% dplyr::arrange(-totdasqkm) - + # keep track of all original crossections all_xs <- paste0(xs$hy_id, "_", xs$cs_id) - + # column to store the relative position within the braid of the flowline we're on xs$relative_position <- NA - + # flag determining whether transect should/has been replaced xs$changed <- FALSE - + # flag determining whether transect is to be processed in a future step after middle flowlines are processed xs$pending <- TRUE - + # flag determining whether transect is to be processed in a future step after middle flowlines are processed xs$pending <- TRUE - + # empty columns to store number of head/tail intersections xs$head_cuts <- NA xs$tail_cuts <- NA - + # empty columns to store distance needed to extend from head/tail of line xs$head_distance <- NA xs$tail_distance <- NA - + # data.table::data.table(xs)[1, ] - + # check if any transects exist, if not, just return the original transects if (nrow(xs) == 0) { - + # message("===== NO 'xs' transect lines =====") # message("===== returning original data =====") message("No transect lines intersect with braided flowlines, returning original transect lines") return(transect_lines) - + } else { message( "Fixing ", nrow(xs) , " transect lines intersecting with braided flowlines lines") } - + # keep track of seen component_ids seen <- fastmap::fastmap() - + # Loop through every single cross section and determine: # 1. its relative position # 2. how far to extend the line # 3. in what order should transects be extended, # 4. in what direction to extend the transect - + # list to store plots plot_list <- list() - + # system.time({ for(i in 1:nrow(xs)) { # message("i: ", i, "/", nrow(xs)) - - + + # 1 = braid2_components # 2 = braid_components # 3 = braid2_comids # 4 = braid2_neighs # 5 = braid_comids # 6 = braid_neighs - + # comid of transect line com <- xs$hy_id[i] - + # braid ID of interest bid <- xs$braid_id[i] - + # get the component ID of current COMID comp_id <- braids$component_id[braids$comid == com] - + # make a plot for each unique component ID that comes up if(!seen$has(comp_id)) { # save_path = "/Users/anguswatters/Desktop/test_geoms_to_cut_plot.png" @@ -2857,28 +2994,28 @@ plot_braid_geoms_to_cut <- function( # comp_id, # ".png") ) - + message("--> Adding ", comp_id, " to seen hashmap...") - + # add component ID to hashmap seen$set(comp_id, TRUE) - + message("Length of seen hashmap: ", seen$size()) } - + if(keep_plots) { - + plot_list[[i]] <- geoms_to_cut_plot - + } } - + if(keep_plots) { plot_list <- Filter(function(x) !is.null(x), plot_list) - + return(plot_list) } - + } # ********************************************* @@ -2895,7 +3032,7 @@ plot_braid_geoms_to_cut <- function( # #@keywords internal # #@return logical, TRUE if line is within the threshold value, FALSE otherwise # within_threshold <- function( -# base_distance, + # base_distance, # head_distance = 0, # tail_distance = 0, # threshold = NULL @@ -3229,7 +3366,7 @@ plot_braid_geoms_to_cut <- function( # #@keywords internal # #@return fastmap::fastmap() with details on line extension, or a geos_geometry of the extended line # geos_extend_out2 <- function( -# x, + # x, # line, # distances, # geoms_to_cut, @@ -3413,7 +3550,7 @@ plot_braid_geoms_to_cut <- function( # #@keywords internal # #@return geos_geometry, extended by specified distance # geos_extend_transects2 <- function( -# starter_line, + # starter_line, # head_distance = 0, # tail_distance = 0, # extra_distance = 0 @@ -3475,7 +3612,7 @@ plot_braid_geoms_to_cut <- function( # #@keywords internal # #@return index of 'distance' vector, representing the minimum extension distance for a line to intersect nearby geometries # geos_bs_distance2 <- function( -# distances, + # distances, # line, # geoms_to_cut, # direction = "head" diff --git a/R/transects.R b/R/transects.R index 7f1c222d..166589a2 100644 --- a/R/transects.R +++ b/R/transects.R @@ -1,3 +1,49 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + #' Generate a Perpendicular Linestring of a Given Width #' @param edge LINESRTING #' @param width Length of Perpendicular LINESTRING @@ -29,7 +75,7 @@ cut_transect = function(edge, width){ ) ), wk::wk_crs(edge) - ) + ) ) } @@ -56,16 +102,20 @@ get_transects <- function(line, bf_width, n) { # create evenly spaced linestring geometries along line of interest edges <- geos::as_geos_geometry( - wk::wk_linestring( - vertices[c(1, rep(seq_along(vertices)[-c(1, length(vertices))], each = 2), length(vertices))], - feature_id = rep(seq_len(length(vertices) - 1), each = 2) - ) - ) + wk::wk_linestring( + vertices[c(1, + rep( + seq_along(vertices)[-c(1, length(vertices))], each = 2 + ), + length(vertices))], + feature_id = rep(seq_len(length(vertices) - 1), each = 2) + ) + ) # # get the cumulative length of edges along flowline edge_lengths <- cumsum( - geos::geos_length(edges) - ) + geos::geos_length(edges) + ) # total length of linestring total_length <- edge_lengths[length(edge_lengths)] @@ -91,14 +141,14 @@ get_transects <- function(line, bf_width, n) { } else { # extract edges at intervals of 'n' edges <- edges[as.integer( - seq.int(1, length(edges), length.out = min(n, length(edges))) - ) - ] + seq.int(1, length(edges), length.out = min(n, length(edges))) + ) + ] # extract edge lengths at intervals of 'n' (same interval/indices of above edges indexing) edge_lengths <- edge_lengths[as.integer( - seq.int(1, length(edge_lengths), length.out = min(n, length(edge_lengths))) - ) - ] + seq.int(1, length(edge_lengths), length.out = min(n, length(edge_lengths))) + ) + ] } } @@ -111,10 +161,10 @@ get_transects <- function(line, bf_width, n) { measures <- vctrs::vec_c() for(i in 1:length(edges)){ - + # message("TRANSECT: ", i) tran = cut_transect(edges[i], bf_width[i]) - + # # # measure of edge meas <- edge_lengths[i] @@ -138,7 +188,7 @@ get_transects <- function(line, bf_width, n) { # extract only edge lengths of remaining transect lines only valid edge lengths measures <- measures[is_valid[-1]] # edge_lengths <- edge_lengths[is_valid[-1]] - + # # calculate cs_measure value edge_measure <- (measures/total_length) * 100 # edge_lengths <- (edge_lengths/total_length) * 100 @@ -150,7 +200,7 @@ get_transects <- function(line, bf_width, n) { transects$ds_distance <- measures transects$cs_measure <- edge_measure # transects$cs_measure <- edge_lengths - + return(transects) # return(list( # transects = transects, @@ -257,8 +307,8 @@ get_cs_sinuosity <- function( #' #' @param net Hydrographic LINESTRING Network #' @param id Unique Identifier in net -#' @param cs_widths Bankfull Widths (length of cross sections for each net element) -#' @param num Number of transects per Net element +#' @param cs_widths numeric, Bankfull Widths (length of cross sections for each net element) +#' @param num numeric, Number of transects per Net element #' @param smooth logical, whether to smooth linestring geometries or not. Default is TRUE. #' @param densify numeric, how many times more points should be added to linestrings. Default is 2. #' @param rm_self_intersect logical, whether to remove self intersecting transect linestrings @@ -273,7 +323,7 @@ get_cs_sinuosity <- function( #' @param add logical indicating whether to add original 'net' data to the outputted transect lines. Default is FALSE. #' #' @return sf object -#' @importFrom dplyr group_by mutate ungroup n left_join all_of +#' @importFrom dplyr group_by mutate ungroup n left_join all_of rename #' @importFrom sf st_crs st_transform st_intersects st_length st_drop_geometry st_as_sf #' @importFrom smoothr smooth densify #' @importFrom geos as_geos_geometry @@ -296,6 +346,23 @@ cut_cross_sections <- function( add = FALSE ) { + # validate all inputs are valid, throws an error if they are not + validate_cut_cross_section_inputs(net = net, + id = id, + cs_widths = cs_widths, + num = num, + smooth = smooth, + densify = densify, + rm_self_intersect = rm_self_intersect, + fix_braids = fix_braids, + terminal_id = terminal_id, + braid_threshold = braid_threshold, + version = version, + braid_method = braid_method, + precision = precision, + add = add + ) + # keep track of the CRS of the input to retransform return start_crs <- sf::st_crs(net, parameters = T)$epsg @@ -305,21 +372,21 @@ cut_cross_sections <- function( net <- sf::st_transform(net, 5070) } + # Densify network flowlines, adds more points to each linestring + if(!is.null(densify)){ + message("Densifying") + net <- smoothr::densify(net, densify) + } + # smooth out flowlines if(smooth){ message("Smoothing") # net = smoothr::smooth(net, "ksmooth") - net = smoothr::smooth(net, "spline") - } - - # Densify network flowlines, adds more points to each linestring - if(!is.null(densify)){ - message("Densifying") - net = smoothr::densify(net, densify) + net <- smoothr::smooth(net, "spline") } # list to store transect outputs - ll <- list() + transects <- list() # if there is a missing number of cross section widths given relative to the number of rows in net, fill in the missing values if (length(cs_widths) != nrow(net)) { @@ -331,16 +398,16 @@ cut_cross_sections <- function( } message("Cutting") - + # iterate through each linestring in "net" and generate transect lines along each line for (j in 1:nrow(net)) { # logger::log_info("{j} / {nrow(net)}") # cut transect lines at each 'edge' generated along our line of interest trans <- get_transects( - line = geos::as_geos_geometry(net$geometry[j]), - bf_width = cs_widths[j], - n = num[j] - ) + line = geos::as_geos_geometry(net$geometry[j]), + bf_width = cs_widths[j], + n = num[j] + ) # if 0 transects can be formed, skip the iteration if(nrow(trans) == 0) { @@ -353,27 +420,27 @@ cut_cross_sections <- function( trans$cs_widths <- cs_widths[j] # insert 'trans' sf dataframe into list - ll[[j]] <- trans + transects[[j]] <- trans # # cut transect lines at each 'edge' generated along our line of interest - # ll[[j]] <- get_transects( + # transects[[j]] <- get_transects( # line = geos::as_geos_geometry(net$geometry[j]), # bf_width = cs_widths[j], # n = num[j] # ) } - + # # get length of each dataframe to assign "hy_id" back with cross sections - # ids_length <- sapply(ll, nrow) - # # # ids_length <- lengths(ll) + # ids_length <- sapply(transects, nrow) + # # # ids_length <- lengths(transects) - # crs_list <- lapply(ll, function(i) { is.na(sf::st_crs(i)$epsg) } ) + # crs_list <- lapply(transects, function(i) { is.na(sf::st_crs(i)$epsg) } ) # bind list of sf dataframes of transects back together - ll <- dplyr::bind_rows(ll) - # ll <- sf::st_as_sf(Reduce(c, ll))] + transects <- dplyr::bind_rows(transects) + # transects <- sf::st_as_sf(Reduce(c, transects))] - if(nrow(ll) == 0){ + if(nrow(transects) == 0){ return(NULL) } @@ -381,25 +448,25 @@ cut_cross_sections <- function( # # add id column if provided as an input # if (!is.null(id)) { - # ll$hy_id = rep(net[[id]], times = ids_length) + # transects$hy_id = rep(net[[id]], times = ids_length) # } else { - # ll$hy_id = rep(1:nrow(net), times = ids_length) + # transects$hy_id = rep(1:nrow(net), times = ids_length) # } # # # add back cross sections width column - # ll$cs_widths = rep(cs_widths, times = ids_length) - + # transects$cs_widths = rep(cs_widths, times = ids_length) + # remove self intersecting transects or not if(rm_self_intersect){ - ll <- - ll[lengths(sf::st_intersects(ll)) == 1, ] %>% + transects <- + transects[lengths(sf::st_intersects(transects)) == 1, ] %>% dplyr::group_by(hy_id) %>% dplyr::mutate(cs_id = 1:dplyr::n()) %>% dplyr::ungroup() %>% dplyr::mutate(lengthm = as.numeric(sf::st_length(.))) } else { - ll <- - ll %>% + transects <- + transects %>% dplyr::group_by(hy_id) %>% dplyr::mutate(cs_id = 1:dplyr::n()) %>% dplyr::ungroup() %>% @@ -408,9 +475,9 @@ cut_cross_sections <- function( # if original columns of data should be added to transects dataset if(add) { - ll <- + transects <- dplyr::left_join( - ll, + transects, sf::st_drop_geometry(net), by = c("hy_id" = id) # by = c("hy_id" = "comid") @@ -425,9 +492,9 @@ cut_cross_sections <- function( # "- Braid grouping method: ", braid_method # )) - ll <- fix_braid_transects( + transects <- fix_braid_transects( net = net, - transect_lines = ll, + transect_lines = transects, terminal_id = terminal_id, braid_threshold = braid_threshold, version = version, @@ -435,183 +502,682 @@ cut_cross_sections <- function( precision = precision, rm_intersects = rm_self_intersect ) - } + # remove any transect lines that intersect with any flowlines more than 1 time + transects <- transects[lengths(sf::st_intersects(transects, net)) == 1, ] + # rename "id" column to hy_id if "hy_id" is not already present if(!"hy_id" %in% names(net)) { net <- dplyr::rename(net, hy_id = dplyr::all_of(id)) } - - # calculate sinuosity and add it as a column to the cross sections - ll <- get_cs_sinuosity( - lines = net, - cross_sections = ll, - add = TRUE - ) + # calculate sinuosity and add it as a column to the cross sections + transects <- get_cs_sinuosity( + lines = net, + cross_sections = transects, + add = TRUE + ) # transform CRS back to input CRS if(start_crs != 5070) { # message("Transforming CRS back to EPSG: ", start_crs) - ll <- sf::st_transform(ll, start_crs) + transects <- sf::st_transform(transects, start_crs) } - return(ll) + # rename the cs_widths column to cs_lengthm + transects <- dplyr::rename(transects, "cs_lengthm" = cs_widths) + + # select all relevent columns and set output columns order + transects <- + transects %>% + dplyr::select( + dplyr::any_of(c("hy_id", + "cs_id", + "cs_lengthm", + # "cs_widths", + "cs_measure", + "ds_distance", + "lengthm", + "sinuosity", + "geometry" + )) + ) + + return(transects) } -#' Get Points across transects with elevation values -#' @param cs Hydrographic LINESTRING Network -#' @param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. -#' @param min_pts_per_cs Minimun number of points per cross section required. -#' @param dem the DEM to extract data from -#' @return sf object -#' @importFrom dplyr mutate group_by ungroup n select everything -#' @importFrom terra linearUnits res rast extract project vect crs -#' @importFrom sf st_line_sample st_set_geometry st_cast +#' @title Extend an sf linestring dataframe by a percent of the lines length +#' +#' @param x linestring sf dataframe +#' @param pct numeric, percent of line to extend linestring by in both directions +#' @param length_col character, name of the column in "x" that has the length of the linestring (meters) +#' @importFrom dplyr group_by mutate ungroup rename +#' @importFrom sf st_length st_geometry st_drop_geometry st_as_sf st_crs +#' @importFrom nhdplusTools rename_geometry +#' @return sf dataframe with extended linestring geometries +extend_by_percent <- function( + x, + pct = 0.5, + length_col = NULL +) { + + # rename the geometry to "geom" + x <- nhdplusTools::rename_geometry(x, "geom") + + # length_col is NULL then set it to "cs_lengthm" + if(is.null(length_col)) { + length_col = "cs_lengthm" + } + + # if the length_col string is not a column in the x, + # then create a column based on the length of the linestring using "length_col" as name of column + if (!length_col %in% names(x)) { + + # add a "length_col" column of the length of each linestring in meters + x[length_col] <- as.numeric(sf::st_length(sf::st_geometry(x))) + # x <- dplyr::mutate(x, length_col = as.numeric(sf::st_length(.))) + } + + # extend linestrings by pct * length of line + extended_df <- + x %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + extended_geom = geos_extend_line( + geom, + distance = ( + ((pct)*(!!dplyr::sym(length_col))) / 2 + ), + # distance = (pct)*(!!dplyr::sym(length_col)), + dir = "both" + ) + ) %>% + dplyr::ungroup() + + # drop original geometry column + extended_df <- sf::st_drop_geometry(extended_df) + + # set the extended geometry as the new geometry + extended_df$extended_geom <- sf::st_geometry(sf::st_as_sf(extended_df$extended_geom)) + + # make extended_df an sf object + extended_df <- sf::st_as_sf( + extended_df, + crs = sf::st_crs(x) + ) + + # rename "extended_geom" col to "geom" + extended_df <- dplyr::rename(extended_df, "geom" = "extended_geom") + + # recalculate length of linestring and update length_col value + extended_df[[length_col]] <- as.numeric(sf::st_length(extended_df$geom)) + + return(extended_df) + +} + +#' @title Extend an sf linestring dataframe by a specified lengths vector +#' +#' @param x linestring sf dataframe +#' @param length_vector numeric, vector of length 'x' representing the number of meters to extend 'x' from both directions (i.e. 10 means the linestring will be extended 10m from both ends of the line) +#' @param length_col character, name of the column in "x" that has the length of the linestring (meters) +#' @importFrom dplyr group_by mutate ungroup rename +#' @importFrom sf st_length st_geometry st_drop_geometry st_as_sf st_crs +#' @importFrom nhdplusTools rename_geometry +#' @return sf dataframe with extended linestring geometries +extend_by_length <- function( + x, + length_vector, + length_col = NULL +) { + + # rename the geometry to "geom" + x <- nhdplusTools::rename_geometry(x, "geom") + + # length_col is NULL then set it to "cs_lengthm" + if(is.null(length_col)) { + length_col = "cs_lengthm" + } + + # if the length_col string is not a column in the x, + # then create a column based on the length of the linestring using "length_col" as name of column + if (!length_col %in% names(x)) { + + # add a "length_col" column of the length of each linestring in meters + x[length_col] <- as.numeric(sf::st_length(sf::st_geometry(x))) + # x <- dplyr::mutate(x, length_col = as.numeric(sf::st_length(.))) + } + + # TODO: this needs a check to make sure a column with this name does NOT already exist + # add length vector col to extended lines out by in next step + x$length_vector_col <- length_vector + + # extend linestrings by pct * length of line + extended_df <- + x %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + extended_geom = geos_extend_line( + geom, + distance = length_vector_col, + # distance = (pct)*(!!dplyr::sym(length_col)), + dir = "both" + ) + ) %>% + dplyr::ungroup() + + # drop original geometry column + extended_df <- sf::st_drop_geometry(extended_df) + + # set the extended geometry as the new geometry + extended_df$extended_geom <- sf::st_geometry(sf::st_as_sf(extended_df$extended_geom)) + + # make extended_df an sf object + extended_df <- sf::st_as_sf( + extended_df, + crs = sf::st_crs(x) + ) + + # rename "extended_geom" col to "geom" + extended_df <- dplyr::rename(extended_df, "geom" = "extended_geom") + + # recalculate length of linestring and update length_col value + extended_df[[length_col]] <- as.numeric(sf::st_length(extended_df$geom)) + + # drop the added length_vector_col + extended_df <- dplyr::select( + extended_df, + -length_vector_col + ) + + return(extended_df) + +} + +#' @title Extend a set of transects by a percentage +#' +#' @param transects_to_extend sf linestrings, set of transects that should be extended (subset of 'transects'). Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters) +#' @param transects sf linestrings, set of all transects in the network. Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters) +#' @param net sf linestrings, flowline network that transects were generated from, requires "id" column (where "id" equals the "hy_id" columns in 'transects_to_extend' and 'transects' ) +#' @param scale numeric, percentage of current transect line length to extend transects in transects_to_extend by. Default is 0.5 (50% of the transect length) +#' @param verbose logical, whether to print messages or not. Default is TRUE +#' @return sf linestring dataframe containing the updates transects_to_extend (with a flag denoting if the geometry was extended by "scale" % or not) +#' @importFrom geos as_geos_geometry geos_intersection geos_type geos_intersects +#' @importFrom sf st_geometry st_as_sf #' @export -cross_section_pts = function(cs, - points_per_cs = NULL, - min_pts_per_cs = 10, - dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt"){ +extend_transects <- function( + transects_to_extend, + transects, + net, + scale = 0.5, + verbose = TRUE +) { - # check if a cross section is given, and return NULL if missing - if (is.null(cs)) { - return(NULL) - } + # Create an "is_extended" flag to identify which transects were extended and updated + transects_to_extend$is_extended <- FALSE - # IF NULL value is given to points_per_cs argument, calculate points_per_cs values - # - IF DEM has a longitude/latitude CRS (terra::linearUnits == 0): - # -- then divide the cross section length by 111139 and divide that resulting value by the minimum resolution value from the DEM (then round the result up) - # - ELSE: - # -- just divide the cross section length by the minimum resolution value from the DEM (then round the result up) - if (is.null(points_per_cs)) { - if (terra::linearUnits(terra::rast(dem)) == 0) { - points_per_cs = ceiling( - (cs$lengthm / 111139) / min(terra::res(terra::rast(dem))) - ) - } else { - points_per_cs = ceiling( - (cs$lengthm) / min(terra::res(terra::rast(dem))) - ) + if(verbose) { message(paste0("Extending ", nrow(transects_to_extend), " transects by ", scale * 100, "%...")) } + + # Extend the transects by a scale % value + extended_trans <- extend_by_percent(transects_to_extend, scale, "cs_lengthm") + + # Store the identifying information to use in for loop to subset data using IDs + fline_id_array <- net$id + hy_id_array <- extended_trans$hy_id + cs_id_array <- extended_trans$cs_id + + # Convert extended transects to geos + extended_trans <- geos::as_geos_geometry(extended_trans) + + # Convert the net object into a geos_geometry + geos_net <- geos::as_geos_geometry(net) + + # if(verbose) { message(paste0("Iterating through extended geometries and checking validity...")) } + + # Convert the original transect lines to geos_geometries and when + # a valid extension comes up in the below for loop, replace the old geometry with the newly extended one + geos_list <- geos::as_geos_geometry(transects_to_extend$geom) + + # Preallocate vectors to store the "is_extended" flag and the new lengths after extensions: + # - if an extension is VALID (checked in the loop below), then + # set the "is_extended" flag to TRUE and update the cross section length + # to use the new extended length + extended_flag <- rep(FALSE, length(extended_trans)) + length_list <- transects_to_extend$cs_lengthm + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(extended_trans) + + # output a message every ~10% intervals + message_interval <- total %/% 10 + + # loop through geometries that might need to be extended, try to extend, and then update + # the 'to_extend' values IF the extended transectr does NOT violate any intersection rules + for (i in 1:length(extended_trans)) { + + # Check if the iteration is a multiple of 100 + if (i %% message_interval == 0) { + + # get the percent complete + percent_done <- round(i/total, 2) * 100 + + # Print the message every "message_interval" + if(verbose) { message(" > ", percent_done, "% ") } + } + + # Get the current transect, hy_id, cs_id + current_trans <- extended_trans[i] + current_hy_id <- hy_id_array[i] + current_cs_id <- cs_id_array[i] + + # use the hy_id from the current transect line to index the + # full network of flowlines to get the specific flowline for this transect (geos_geometry) + current_fline <- geos_net[fline_id_array == current_hy_id] + + # # filter down to the rest of the transects on the given "hy_id", EXCLUDING SELF + # neighbor_transects <- geos::as_geos_geometry(dplyr::filter(transects, + # hy_id == current_hy_id, cs_id != current_cs_id)) + + # Get all of the other transects on this flowline using "hy_id" and "cs_id" (EXCLUDING SELF) + neighbor_transects <- geos::as_geos_geometry( + transects[transects$hy_id == current_hy_id & transects$cs_id != current_cs_id, ] + ) + + # Make sure that newly extended transect line only intersects its origin flowline at MOST 1 time + # AND that the newly extended transect does NOT intersect with any previously computed transect lines + fline_intersect <- geos::geos_intersection( + current_trans, + current_fline + ) + + # If all of these conditions are TRUE then the currently extended transect will get inserted into "to_extend" + # - Newly extended transect intersects with its flowlines AT MOST 1 time + # - Newly extended transect does NOT intersect with any of the other NEWLY EXTENDED transect lines + # - Newly extended transect does NOT intersect with any of the ORIGINAL transect lines + if ( + # Check that newly extended cross section only intersects its origin flowline at MOST 1 time + # (This value will be a "MULTIPOINT" if it intersects more than once and will evaluate to FALSE) + geos::geos_type(fline_intersect) == "point" && + # Check that extended transect doesn't intersect with any of the NEWLY EXTENDED cross sections + !any(geos::geos_intersects(current_trans, extended_trans[-i])) && + # Check that extended transect doesn't intersect with any of the original cross sections on this "hy_id" + !any(geos::geos_intersects(current_trans, neighbor_transects)) + ) { + + # message("Extending transect: ", i) + + # get the current cross section list + current_length <- length_list[i] + # current_length <- transects_to_extend$cs_lengthm[i] + + # # Calculate the updated cross section length to align with the newly extended cross section for this row + updated_cs_length <- (current_length * scale) + current_length + # updated_cs_length <- (output_row$cs_lengthm * scale) + output_row$cs_lengthm + + # copy the current cross section length + length_list[i] <- updated_cs_length + # length_list <- vctrs::vec_c(length_list, updated_cs_length) + + # Update the transect geometry with the newly extended transect + geos_list[i] <- current_trans + # geos_list <- vctrs::vec_c(geos_list, current_trans) + # transects_to_extend$geom[i] <- sf::st_geometry(sf::st_as_sf(current_trans)) + + # Set the extended flag to TRUE for this transect + extended_flag[i] <- TRUE + # extended_flag <- vctrs::vec_c(extended_flag, TRUE) + + } } - # take the max between the given minimum points per cross section and the derived points per cross section - cs$points_per_cs = pmax(min_pts_per_cs, points_per_cs) + if(verbose) { message(paste0("Complete!")) } + + # Update the "transects_to_extend" with new geos geometries ("geos_list") + sf::st_geometry(transects_to_extend) <- sf::st_geometry(sf::st_as_sf(geos_list)) + + transects_to_extend$is_extended <- extended_flag + transects_to_extend$cs_lengthm <- length_list + + return(transects_to_extend) +} + +#' @title Extend a set of transects by a percentage +#' +#' @param transects_to_extend sf linestrings, set of all transects in the network. Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters), +#' @param length_vector numeric, vector of length 'x' representing the number of meters to extend 'x' from both directions (i.e. 10 means the linestring will be extended 10m from both ends of the line) +#' @param net sf linestrings, flowline network that transects were generated from, requires "id" column (where "id" equals the "hy_id" columns in 'transects_to_extend' and 'transects' ) +#' @param verbose logical, whether to print messages or not. Default is TRUE +#' @return sf linestring dataframe containing the updates transects_to_extend (with a flag denoting if the geometry was extended by "scale" % or not) +#' @importFrom geos as_geos_geometry geos_intersection geos_type geos_intersects +#' @importFrom sf st_geometry st_as_sf st_length +#' @export +extend_transects_by_length <- function( + transects_to_extend, + length_vector, + net, + verbose = TRUE +) { + + # Create an "is_extended" flag to identify which transects were extended and updated + transects_to_extend$is_extended <- FALSE + + if(verbose) { message(paste0("Extending ", nrow(transects_to_extend), " transects...")) } + + # Extend the transects by a scale % value + extended_trans <- extend_by_length(transects_to_extend, length_vector, "cs_lengthm") + + # Store the identifying information to use in for loop to subset data using IDs + fline_id_array <- net$id + hy_id_array <- extended_trans$hy_id + cs_id_array <- extended_trans$cs_id + + # to_extend2 <- dplyr::slice(to_extend, 1:10) + # extended_trans2 <- extend_by_percent(to_extend2, scale, "cs_lengthm") + # geos_trans <- geos::as_geos_geometry(extended_trans2) - # function to extract Z/elevation values at a point from DEM - extract_pt_val = function(rast, pts){ - terra::extract(rast, - terra::project(terra::vect(pts), - terra::crs(rast)) - )[, 2] + # if(verbose) { message(paste0("Converting sf geometries to geos geometries...")) } + + # Convert extended transects to geos + extended_trans <- geos::as_geos_geometry(extended_trans) + + # Convert the net object into a geos_geometry + geos_net <- geos::as_geos_geometry(net) + + # if(verbose) { message(paste0("Iterating through extended geometries and checking validity...")) } + + # Convert the original transect lines to geos_geometries and when + # a valid extension comes up in the below for loop, replace the old geometry with the newly extended one + geos_list <- geos::as_geos_geometry(transects_to_extend$geom) + + # Preallocate vectors to store the "is_extended" flag and the new lengths after extensions: + # - if an extension is VALID (checked in the loop below), then + # set the "is_extended" flag to TRUE and update the cross section length + # to use the new extended length + extended_flag <- rep(FALSE, length(extended_trans)) + # length_list <- transects_to_extend$cs_lengthm + + # length(geos_net) + # length(fline_id_array) + # length(hy_id_array) + + # geos_list <- geos::geos_empty(rep("linestring", length(extended_trans))) + # geos_list <- extended_trans + # extended_flag <- vctrs::vec_c() + # length_list <- vctrs::vec_c() + + # number of geometries that will be iterated over, keeping this variable to reference in message block + total <- length(extended_trans) + + # output a message every ~10% intervals + message_interval <- total %/% 10 + + # loop through geometries that might need to be extended, try to extend, and then update + # the 'to_extend' values IF the extended transectr does NOT violate any intersection rules + for (i in 1:length(extended_trans)) { + + # Check if the iteration is a multiple of 100 + if (i %% message_interval == 0) { + + # get the percent complete + percent_done <- round(i/total, 2) * 100 + + # Print the message every "message_interval" + if(verbose) { message(" > ", percent_done, "% ") } + # message("Iteration ", i, " / ", length(extended_trans), + # " - (", percent_done, "%) ") + } - suppressWarnings({ + # Get the current transect, hy_id, cs_id + current_trans <- extended_trans[i] + current_hy_id <- hy_id_array[i] + current_cs_id <- cs_id_array[i] - return( - sf::st_set_geometry(cs, sf::st_line_sample(cs, cs$points_per_cs)) %>% - sf::st_cast("POINT") %>% - dplyr::mutate(Z = extract_pt_val(terra::rast(dem), .)) %>% - dplyr::group_by(hy_id, cs_id) %>% - dplyr::mutate( - pt_id = 1:dplyr::n(), - relative_distance = seq(from = 0, to = lengthm[1], length.out = dplyr::n()) - ) %>% - dplyr::ungroup() %>% - dplyr::select(hy_id, cs_id, pt_id, Z, lengthm, relative_distance, dplyr::everything()) - ) + # use the hy_id from the current transect line to index the + # full network of flowlines to get the specific flowline for this transect (geos_geometry) + current_fline <- geos_net[fline_id_array == current_hy_id] - }) + # # filter down to the rest of the transects on the given "hy_id", EXCLUDING SELF + # neighbor_transects <- geos::as_geos_geometry(dplyr::filter(transects, + # hy_id == current_hy_id, cs_id != current_cs_id)) + + # Get all of the other transects on this flowline using "hy_id" and "cs_id" (EXCLUDING SELF) + neighbor_transects <- geos::as_geos_geometry( + transects[transects$hy_id == current_hy_id & transects$cs_id != current_cs_id, ] + ) + + # Make sure that newly extended transect line only intersects its origin flowline at MOST 1 time + # AND that the newly extended transect does NOT intersect with any previously computed transect lines + fline_intersect <- geos::geos_intersection( + current_trans, + current_fline + ) + + # If all of these conditions are TRUE then the currently extended transect will get inserted into "to_extend" + # - Newly extended transect intersects with its flowlines AT MOST 1 time + # - Newly extended transect does NOT intersect with any of the other NEWLY EXTENDED transect lines + # - Newly extended transect does NOT intersect with any of the ORIGINAL transect lines + if ( + # Check that newly extended cross section only intersects its origin flowline at MOST 1 time + # (This value will be a "MULTIPOINT" if it intersects more than once and will evaluate to FALSE) + geos::geos_type(fline_intersect) == "point" && + # Check that extended transect doesn't intersect with any of the NEWLY EXTENDED cross sections + !any(geos::geos_intersects(current_trans, extended_trans[-i])) && + # Check that extended transect doesn't intersect with any of the original cross sections on this "hy_id" + !any(geos::geos_intersects(current_trans, neighbor_transects)) + ) { + + # Update the transect geometry with the newly extended transect + geos_list[i] <- current_trans + # geos_list <- vctrs::vec_c(geos_list, current_trans) + # transects_to_extend$geom[i] <- sf::st_geometry(sf::st_as_sf(current_trans)) + + # Set the extended flag to TRUE for this transect + extended_flag[i] <- TRUE + # extended_flag <- vctrs::vec_c(extended_flag, TRUE) + + } + } + + if(verbose) { message(paste0("Complete!")) } + + # Update the "transects_to_extend" with new geos geometries ("geos_list") + sf::st_geometry(transects_to_extend) <- sf::st_geometry(sf::st_as_sf(geos_list)) + + transects_to_extend$is_extended <- extended_flag + transects_to_extend$cs_lengthm <- as.numeric(sf::st_length(transects_to_extend)) + # transects_to_extend$cs_lengthm <- length_list + + # transects_to_extend$geom[1] %>% sf::st_length() + # geos::geos_length(geos_list[1]) + return(transects_to_extend) } -# #Get Points across transects with elevation values -# #@param cs Hydrographic LINESTRING Network -# #@param points_per_cs the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected. -# #@param min_pts_per_cs Minimun number of points per cross section required. -# #@param dem the DEM to extract data from -# #@return sf object -# #@export -# cross_section_pts = function(cs, -# points_per_cs = NULL, -# min_pts_per_cs = 10, -# dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt"){ -# -# if(is.null(cs)){ return(NULL) } -# -# if(is.null(points_per_cs)){ -# if(linearUnits(rast(dem)) == 0){ -# points_per_cs = ceiling((cs$lengthm / 111139) / min(res(rast(dem)))) -# } else { -# points_per_cs = ceiling((cs$lengthm) / min(res(rast(dem)))) -# } -# } -# -# cs$points_per_cs = pmax(min_pts_per_cs, points_per_cs) -# -# extract_pt_val = function(rast, pts){ extract(rast, project(vect(pts), crs(rast)))[, 2] } -# -# suppressWarnings({ -# st_set_geometry(cs, st_line_sample(cs, cs$points_per_cs)) %>% -# st_cast("POINT") %>% -# mutate(Z = extract_pt_val(rast(dem), .)) %>% -# group_by(hy_id, cs_id) %>% -# mutate(pt_id = 1:n(), -# relative_distance = seq(from = 0, to = lengthm[1], length.out = n())) %>% -# ungroup() %>% -# select(hy_id, cs_id, pt_id, Z, lengthm, relative_distance, everything()) -# }) -# -# } -#' Classify Cross Section Points -#' @param cs_pts CS points -#' @return sf object +#' @title Extend a set of transects by a percentage based on banks and relief +#' Given a set of transect lines with valid_banks and has_relief columns (derived from DEM extracted cross section points), extend any transects +#' by a percentage of the transects length if the transect does NOT have valid banks (valid_banks == FALSE) OR it does NOT have relief (has_relief == FALSE). +#' @param transects_to_check sf linestrings, set of all transects in the network. Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters), "valid_banks", and "has_relief" +#' @param net sf linestrings, flowline network that transects were generated from, requires "id" column (where "id" equals the "hy_id" columns in 'transects_to_check' and 'transects' ) +#' @param scale numeric, percentage of current transect line length to extend transects in transects_to_extend by. Default is 0.5 (50% of the transect length) +#' @param verbose logical, whether to show a progress bar and progress messages or not. Default is TRUE. +#' @return sf linestring dataframe containing the the original transects with extensions performed on transects without valid_banks OR has_relief (a "is_extended" flag denotes if the geometry was extended by "scale" % or not) +#' @importFrom geos as_geos_geometry geos_intersection geos_type geos_intersects +#' @importFrom sf st_geometry st_as_sf +#' @importFrom dplyr filter bind_rows #' @export -classify_points = function(cs_pts){ +extend_invalid_transects <- function( + transects_to_check, + net, + scale = 0.5, + verbose = TRUE +) { + + # Create an "is_extended" flag to identify which transects were extended and updated + transects_to_check$is_extended <- FALSE + + # split input transects into invalid and valid sets (valid == has valid banks AND has relief) + invalid_transects <- dplyr::filter(transects_to_check, !valid_banks | !has_relief) + valid_transects <- dplyr::filter(transects_to_check, valid_banks & has_relief) + + # keep track of any transects that having missing values in either valid_banks/has_relief columns, + # these get added back to the updated data at the end + missing_bank_or_relief_data <- + transects_to_check %>% + dplyr::filter(is.na(valid_banks) | is.na(has_relief)) + + # TODO: Probably remove this + count_check <- nrow(valid_transects) + nrow(invalid_transects) == nrow(transects_to_check) + # count_check <- nrow(valid_transects) + nrow(invalid_transects) == nrow(transects_to_check) - nrow(missing_bank_or_relief_data) + + if(!count_check) { + warning(paste0(nrow(missing_bank_or_relief_data), " transects have NA values in either 'valid_banks' or 'has_relief' columns")) + # warning(paste0("Different number of transects after splitting data by 'valid_banks' and 'has_relief' columns, ", nrow(missing_bank_or_relief_data), " transects have NA values in either 'valid_banks' or 'has_relief' columns")) + # stop("Mismatch in number of points after splitting data by the 'valid_banks' and 'has_relief' columns, likely a missing value in either 'valid_banks' or 'has_relief' columns") + } + + if(verbose) { message(paste0("Extending ", nrow(invalid_transects), " transects without valid banks or relief by ", scale * 100, "%...")) } + + # Extend the transects by a scale % value + extended_trans <- extend_by_percent(invalid_transects, scale, "cs_lengthm") + + # Store the identifying information to use in for loop to subset data using IDs + fline_id_array <- net$id + hy_id_array <- extended_trans$hy_id + cs_id_array <- extended_trans$cs_id + + # Convert extended transects to geos + extended_trans <- geos::as_geos_geometry(extended_trans) + + # Convert the net object into a geos_geometry + geos_net <- geos::as_geos_geometry(net) + + # if(verbose) { message(paste0("Iterating through extended geometries and checking validity...")) } + + # Convert the original transect lines to geos_geometries and when + # a valid extension comes up in the below for loop, replace the old geometry with the newly extended one + geos_list <- geos::as_geos_geometry(invalid_transects$geom) + + # Preallocate vectors to store the "is_extended" flag and the new lengths after extensions: + # - if an extension is VALID (checked in the loop below), then + # set the "is_extended" flag to TRUE and update the cross section length + # to use the new extended length + extended_flag <- rep(FALSE, length(extended_trans)) + length_list <- invalid_transects$cs_lengthm + + make_progress <- make_progress_bar(verbose, length(extended_trans)) - . <- L <- L1 <- L2 <- R <- R1 <- R2 <- Z <- Z2 <- anchor <- b1 <- b2 <- cs_widths <- count_left <- - count_right <- cs_id <- hy_id <- in_channel_pts <- lengthm <- low_pt <- max_bottom <- mean_dist <- mid_bottom <- min_bottom <- pt_id <- relative_distance <- third <- NULL + # loop through geometries that might need to be extended, try to extend, and then update + # the 'to_extend' values IF the extended transectr does NOT violate any intersection rules + for (i in 1:length(extended_trans)) { + + # Get the current transect, hy_id, cs_id + current_trans <- extended_trans[i] + current_hy_id <- hy_id_array[i] + current_cs_id <- cs_id_array[i] + + # use the hy_id from the current transect line to index the + # full network of flowlines to get the specific flowline for this transect (geos_geometry) + current_fline <- geos_net[fline_id_array == current_hy_id] + + # # filter down to the rest of the transects on the given "hy_id", EXCLUDING SELF + # neighbor_transects <- geos::as_geos_geometry(dplyr::filter(transects, + # hy_id == current_hy_id, cs_id != current_cs_id)) + + # Get all of the other transects on this flowline using "hy_id" and "cs_id" (EXCLUDING SELF) + neighbor_transects <- geos::as_geos_geometry( + transects_to_check[transects_to_check$hy_id == current_hy_id & transects_to_check$cs_id != current_cs_id, ] + ) + + # Make sure that newly extended transect line only intersects its origin flowline at MOST 1 time + # AND that the newly extended transect does NOT intersect with any previously computed transect lines + fline_intersect <- geos::geos_intersection( + current_trans, + current_fline + ) + + # If all of these conditions are TRUE then the currently extended transect will get inserted into "to_extend" + # - Newly extended transect intersects with its flowlines AT MOST 1 time + # - Newly extended transect does NOT intersect with any of the other NEWLY EXTENDED transect lines + # - Newly extended transect does NOT intersect with any of the ORIGINAL transect lines + if ( + # Check that newly extended cross section only intersects its origin flowline at MOST 1 time + # (This value will be a "MULTIPOINT" if it intersects more than once and will evaluate to FALSE) + geos::geos_type(fline_intersect) == "point" && + # Check that extended transect doesn't intersect with any of the NEWLY EXTENDED cross sections + !any(geos::geos_intersects(current_trans, extended_trans[-i])) && + # Check that extended transect doesn't intersect with any of the original cross sections on this "hy_id" + !any(geos::geos_intersects(current_trans, neighbor_transects)) + ) { + + # message("Extending transect: ", i) + + # get the current cross section list + current_length <- length_list[i] + # current_length <- invalid_transects$cs_lengthm[i] + + # # Calculate the updated cross section length to align with the newly extended cross section for this row + updated_cs_length <- (current_length * scale) + current_length + # updated_cs_length <- (output_row$cs_lengthm * scale) + output_row$cs_lengthm + + # copy the current cross section length + length_list[i] <- updated_cs_length + # length_list <- vctrs::vec_c(length_list, updated_cs_length) + + # Update the transect geometry with the newly extended transect + geos_list[i] <- current_trans + # geos_list <- vctrs::vec_c(geos_list, current_trans) - filter(cs_pts) %>% - group_by(hy_id, cs_id) %>% - mutate(third = ceiling(n() / 3), - mean_dist = mean(diff(relative_distance)), - in_channel_pts = ceiling(cs_widths[1] / mean_dist), - b1 = ceiling(in_channel_pts / 2), - b2 = in_channel_pts - b1, - low_pt = min(Z[third[1]:(2*third[1] - 1)]), - class = ifelse(Z <= low_pt & between(pt_id, third[1], (2*third[1] - 1)), - "bottom", - "bank"), - Z2 = c(Z[1], zoo::rollmean(Z, 3), Z[n()]), - Z = ifelse(class == "bottom", Z, Z2), - min_bottom = which(class == "bottom")[1], - mid_bottom = which(class == "bottom")[ceiling(length(which(class == "bottom"))/2)], - max_bottom = which(class == "bottom")[length(which(class == "bottom"))], - L1 = pmax(1, mid_bottom - b1), - L2 = pmax(1, mid_bottom - b2), - R1 = pmin(mid_bottom + b2, n()), - R2 = pmin(mid_bottom + b1, n()), - anchor = ifelse(Z[R2] < Z[L1], 2, 1), - L = pmax(third, ifelse(anchor == 1, L1, L2)), - R = pmin(2*third[1], ifelse(anchor == 1, R1, R2)), - count_left = min_bottom - L, - count_right = R - max_bottom, - L = ifelse(count_left == 0, L - count_right, L), - R = ifelse(count_right == 0, R + count_left, R), - class = ifelse(between(pt_id, L[1], R[1]) & class != 'bottom', "channel", class), - class = ifelse(class == 'bank' & pt_id <= L[1], "left_bank", class), - class = ifelse(class == 'bank' & pt_id >= R[1], "right_bank", class)) %>% - ungroup() %>% - select(hy_id, cs_id, pt_id, Z, relative_distance, cs_widths, class) + # Set the extended flag to TRUE for this transect + extended_flag[i] <- TRUE + # extended_flag <- vctrs::vec_c(extended_flag, TRUE) + + } + + make_progress() + } + + if(verbose) { message(paste0("Complete!")) } + + # Update the "invalid_transects" with new geos geometries ("geos_list") + sf::st_geometry(invalid_transects) <- sf::st_geometry(sf::st_as_sf(geos_list)) + + # update the "is_extended" flag and the cross section lengths to reflect any extensions + invalid_transects$is_extended <- extended_flag + invalid_transects$cs_lengthm <- length_list + + # Combine the valid_transects with the UPDATED invalid_transects (updated by attempting extension) to get the final output dataset + extended_transects <- dplyr::bind_rows( + valid_transects, + invalid_transects + ) + # add back any transects that were missing banks/relief values + extended_transects <- dplyr::bind_rows( + extended_transects, + dplyr::select(missing_bank_or_relief_data, + dplyr::any_of(names(extended_transects))) + ) + + # check to make sure all unique hy_id/cs_id in the INPUT are in the OUTPUT, + # and raise an error if they're are missing hy_id/cs_ids + input_uids <- unique(hydrofabric3D::add_tmp_id(transects_to_check)$tmp_id) + output_uids <- unique(hydrofabric3D::add_tmp_id(extended_transects)$tmp_id) + + has_all_uids <- all(output_uids %in% input_uids) + + # throw an error if NOT all hy_id/cs_ids are the same in the input and output data + if(!has_all_uids) { + stop("Missing unique hy_id/cs_id from input transects in the output transects") + } + + return(extended_transects) } - # #Generate Multiple cross section along a linestring # #@param edges data.frame of LINESTRINGs (pieces of line) # #@param line original line element diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 00000000..92f6b093 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,1117 @@ +utils::globalVariables( + c(".", "hy_id", "cs_id", "pt_id", "Z", "middle_index", "point_type", "minZ", + "maxZ", "minZ_bottom", "maxZ_left_bank", "maxZ_right_bank", "valid_left_bank", + "valid_right_bank", "bottom", "left_bank", "right_bank", "valid_banks", + "relative_distance", "cs_lengthm", "default_middle", "has_relief", + "max_relief", "braid_id", "geometry", + + "comid", "fromnode", "tonode", + "tocomid", "divergence", "cycle_id", "node", "braid_vector", "totdasqkm", + "changed", "relative_position", "head_distance", "tail_distance", + "component_id", "cs_measure", "ds_distance", "along_channel", "euclid_dist", + "sinuosity", "points_per_cs", "Z_at_bottom", "lower_bound", "upper_bound", + "ge_bottom", "is_near_bottom", "pts_near_bottom", "total_valid_pts", + "pct_near_bottom", + "member_braids", "braid_members", "diff_pts", "is_extended", + "new_cs_id", "split_braid_ids", + + "braid_length", + "id", + "lengthm", + "check_z_values", + "geom", + "is_same_Z", + "is_multibraid", + "channel", "unique_count", + "left_bank_count", "right_bank_count", "channel_count", "bottom_count", + "terminalID", + "tmp_id", + "make_geoms_to_cut_plot", + "Y", "improved", "length_vector_col", "median", "min_ch", "new_validity_score", + "old_validity_score", "transects", "validity_score", "x", + "A", "DEPTH", "DINGMAN_R", "TW", "X", "X_end", "X_start", "Y_end", "Y_start", + "ahg_a", "ahg_index", "ahg_x", "ahg_y", + "bottom_end", "bottom_length", "bottom_midpoint", + "bottom_start", "cs_partition", "distance_interval", "fixed_TW", + "has_new_DEPTH", "has_new_TW", "ind", "is_dem_point", "left_max", + "left_start", "max_right_position", "new_DEPTH", "new_TW", "next_X_is_missing", "next_Y_is_missing", + "parabola", "partition", "prev_X_is_missing", + "prev_Y_is_missing", "right_start", "right_start_max", "start_or_end", "start_pt_id", + "cs_source", + "partition_lengthm", "left_fema_index", "right_fema_index", + "left_is_within_fema", "right_is_within_fema", "left_distance", "right_distance", + "new_cs_lengthm" + ) +) + +#' @title Function to add a new "tmp_id" column to a dataframe from 2 other columns +#' @description +#' Internal convenience function for creating a tmp_id column from 2 other columns in a dataframe. +#' Default is to use hy_id and cs_id columns to create a tmp_id = _. +#' @param df dataframe with x and y as columns +#' @param x The name of the column in df to make up the first part of the added tmp_id column (tmp_id = x_y). Default is hy_id. +#' @param y The name of the column in df to make up the second part of the added tmp_id column (tmp_id = x_y). Default is cs_id. +#' +#' @return The input dataframe with the "tmp_id" column added. +#' +#' @importFrom dplyr mutate +#' @export +add_tmp_id <- function(df, x = hy_id, y = cs_id) { + # # Create the "tmp_id" column by concatenating values from "x" and "y" + # df <- dplyr::mutate(df, tmp_id = paste0({{x}}, "_", {{y}})) + + # first try to add the tmp_id as if 'x' and 'y' are characters + # if that fails, then use 'x' and 'y' as tidyselectors in dplyr::mutate() + tryCatch({ + + tmp_ids = paste0(df[[x]], "_", df[[y]]) + df$tmp_id = tmp_ids + + return(df) + + }, error = function(e) { }) + + # if columns are NOT characters, then try with tidyselectors... + df <- dplyr::mutate(df, + tmp_id = paste0({{x}}, "_", {{y}})) # Create the "tmp_id" column by concatenating values from "x" and "y" + + return(df) +} + +#' @title Get a list of unique tmp_ids in a dataframe +#' @description +#' Dataframe can have "tmp_id" column already or the columns can be specified with 'x' and 'y' arguments +#' +#' @param df dataframe with x and y as columns, with an optional "tmp_id" column, otherwise a tmp_id will be created from x_y +#' @param x The name of the column in df to make up the first part of the added tmp_id column (tmp_id = x_y). Default is hy_id. +#' @param y The name of the column in df to make up the second part of the added tmp_id column (tmp_id = x_y). Default is cs_id. +#' +#' @return character vector of unique "tmp_id" values in the given dataframe +#' +#' @export +get_unique_tmp_ids <- function(df, x = hy_id, y = cs_id) { + + # if no tmp_id exists, add one + if (!"tmp_id" %in% names(df)) { + # message("No 'tmp_id' found, adding 'tmp_id' from 'x' and 'y' columns") + df <- + df %>% + hydrofabric3D::add_tmp_id(x = {{x}}, y = {{y}}) + } + + # get the unique tmp_ids + unique_tmp_ids <- unique(df$tmp_id) + + return(unique_tmp_ids) + +} + +#' @title Move Geometry Column to the last column position +#' @description +#' Internal utility function for taking a dataframe or an sf dataframe, checks for the existence of a geometry type column, and +#' if it exists, moves it to the last column. If no geometry column exists, it returns the input dataframe as is. +#' @param df A dataframe or an sf dataframe. +#' @return Returns the input dataframe with the geometry column moved to the last position if it exists. Otherwise, returns the input dataframe as is. +#' @importFrom dplyr relocate all_of last_col +#' @examples +#' \dontrun{ +#' # Create a dataframe +#' df <- data.frame(x = c(1, 2, 3), y = c(4, 5, 6)) +#' # Add a geometry column (sf dataframe) +#' df_sf <- sf::st_sf(df, geometry = sf::st_sfc(sf::st_point(c(1, 2, 3)))) +#' # move column +#' df_sf <- dplyr::relocate(df_sf, x, geometry, y) +#' df_sf # geometry column should be move to the middle column +#' # Move geometry column to last position +#' df_sf_moved <- move_geometry_to_last(df_sf) +#' df_sf_moved # geometry column should be move the end column +#' } +move_geometry_to_last <- function(df) { + # Check if any of the columns in the dataframe are geometry types + check_for_geom <- sapply(df, function(col) { + any(class(col) %in% c("sfc", "sfc_GEOMETRY", + "sfc_POINT", "sfc_MULTIPOINT", + "sfc_LINESTRING", "sfc_MULTILINESTRING", + "sfc_POLYGON", "sfc_MULTIPOLYGON" + )) + }) + + # If there is a geometry type column, move it to the last position + if (any(check_for_geom)) { + geometry_colname <- names(df)[check_for_geom] + + # move geometry column to the end + df <- + df %>% + dplyr::relocate(dplyr::all_of(geometry_colname), .after = dplyr::last_col()) + } + + return(df) +} + +# TODO: probably delete this function given you can just use dplyr::select().... + +#' Remove specified columns from a dataframe if they exist. +#' +#' @param df A dataframe. +#' @param columns_to_remove character vector specifying the names of columns to be removed. +#' @return dataframe with specified columns removed if they exist. +remove_cols_from_df <- function(df, columns_to_remove) { + + existing_columns <- intersect(columns_to_remove, colnames(df)) + + # If columns exist, remove them + if (length(existing_columns) > 0) { + df <- df[, !colnames(df) %in% existing_columns, drop = FALSE] + } + + return(df) +} + +#' @title Get the count of each point type in a set of cross section points +#' @description get_point_type_counts() will create a dataframe providing the counts of every point_type for each hy_id/cs_id in a set of classified cross section points (output of classify_pts()) +#' @param classified_pts dataframe or sf dataframe, cross section points with a "hy_id", and "cs_id" columns as well asa 'point_type' column containing the values: "bottom", "left_bank", "right_bank", and "channel" +#' @return dataframe or sf dataframe with hy_id, cs_id, and _count columns for each point_type +#' @importFrom sf st_drop_geometry +#' @importFrom dplyr group_by count ungroup summarize filter n_distinct select slice left_join relocate all_of last_col +#' @importFrom tidyr pivot_wider pivot_longer +#' @export +get_point_type_counts <- function(classified_pts) { + + # classified_pts <- cs_pts %>% hydrofabric3D::classify_points() + # add = F + # classified_pts = classified_pts2 + # add = TRUE + + # type checking + if (!any(class(classified_pts) %in% c("sf", "tbl_df", "tbl", "data.frame"))) { + stop("Invalid argument type, 'classified_pts' must be of type 'sf', 'tbl_df', 'tbl' or 'data.frame', given type was '", + class(classified_pts), "'") + } + + # create a copy of the input dataset, add a tmp_id column + stage_df <- + classified_pts %>% + sf::st_drop_geometry() %>% + hydrofabric3D::add_tmp_id() + + # # create a reference dataframe with all possible combinations of tmp_id and point_type + # reference_df <- expand.grid( + # tmp_id = unique(stage_df$tmp_id), + # point_type = unique(stage_df$point_type) + # ) + + # get a count of the point_types in each hy_id/cs_id group (i.e. each cross section) + point_type_counts <- + stage_df %>% + dplyr::group_by(tmp_id, point_type) %>% + dplyr::count() %>% + dplyr::ungroup() %>% + dplyr::mutate( + # add levels to the point_type column so if a given point_type + # is NOT in the cross seciton points, then it will be added with NAs in the subsequent pivot_wider + point_type = factor(point_type, levels = c("left_bank", "bottom", "right_bank", "channel")) + ) + + # pivot data wider to get implicit missing groups with NA values + point_type_counts <- + point_type_counts %>% + tidyr::pivot_wider( + names_from = point_type, + values_from = n, + names_expand = TRUE + ) + + point_type_counts <- + point_type_counts %>% + tidyr::pivot_longer( + cols = c(bottom, channel, right_bank, left_bank), + names_to = "point_type", + values_to = "n" + ) %>% + dplyr::mutate(n = ifelse(is.na(n), 0, n)) + + # # Join the count of point types in each group with the reference_df to + # # get rows of NA values for any group that is missing a specific point_type + # point_type_counts <- + # point_type_counts %>% + # dplyr::right_join(reference_df, by = c("tmp_id", "point_type")) + + # # For any cross section group that does NOT contain a point type, + # # the point type will be NA and here we replace those NAs with 0 + # point_type_counts$n[is.na(point_type_counts$n)] <- 0 + + # # make sure that all tmp_id groups have all 4 point types + check_counts <- + point_type_counts %>% + dplyr::group_by(tmp_id) %>% + dplyr::summarize(unique_count = dplyr::n_distinct(point_type)) %>% + dplyr::filter(unique_count == 4) + + # if the number of distinct points types in each cross section is not 4, raise an error + if (length(unique(stage_df$tmp_id)) != nrow(check_counts)) { + stop("Error validating each hy_id/cs_id cross section contains exactly 4 distinct values in the 'point_type' column") + } + + # get the hy_id, cs_id for each tmp_id to cross walk back to just using hy_id/cs_id + stage_df <- + stage_df %>% + dplyr::select(tmp_id, hy_id, cs_id) %>% + dplyr::group_by(tmp_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + + # convert the column of point types to be a column for each point type that + # has the point type count for each hy_id/cs_id (cross section) + point_type_counts <- + point_type_counts %>% + tidyr::pivot_wider(names_from = point_type, + names_glue = "{point_type}_count", + values_from = n) %>% + dplyr::left_join( + stage_df, + by = "tmp_id" + ) %>% + dplyr::select(hy_id, cs_id, left_bank_count, right_bank_count, channel_count, bottom_count) + + # point_type_counts %>% + # dplyr::arrange(-right_bank_count) + + return(point_type_counts) + +} + +#' @title Add the count of each point type as a column to a dataframe of section points +#' @description add_point_type_counts() will add columns to the input dataframe with the counts of every point_type for each hy_id/cs_id in the input dataframe of classified cross section points (output of classify_pts()) +#' @param classified_pts dataframe or sf dataframe, cross section points with a "hy_id", and "cs_id" columns as well as a 'point_type' column containing the values: "bottom", "left_bank", "right_bank", and "channel" +#' @return dataframe or sf dataframe with "_count" columns added +#' @importFrom sf st_drop_geometry +#' @importFrom dplyr group_by count ungroup summarize filter n_distinct select slice left_join relocate all_of last_col +#' @importFrom tidyr pivot_wider pivot_longer +#' @export +add_point_type_counts <- function(classified_pts) { + + # classified_pts <- cs_pts %>% hydrofabric3D::classify_points() + # add = F + # classified_pts = classified_pts2 + # add = TRUE + + # type checking + if (!any(class(classified_pts) %in% c("sf", "tbl_df", "tbl", "data.frame"))) { + stop("Invalid argument type, 'classified_pts' must be of type 'sf', 'tbl_df', 'tbl' or 'data.frame', given type was '", + class(classified_pts), "'") + } + + # create a copy of the input dataset, add a tmp_id column + stage_df <- + classified_pts %>% + sf::st_drop_geometry() %>% + hydrofabric3D::add_tmp_id() + + # # create a reference dataframe with all possible combinations of tmp_id and point_type + # reference_df <- expand.grid( + # tmp_id = unique(stage_df$tmp_id), + # point_type = unique(stage_df$point_type) + # ) + + # get a count of the point_types in each hy_id/cs_id group (i.e. each cross section) + point_type_counts <- + stage_df %>% + dplyr::group_by(tmp_id, point_type) %>% + dplyr::count() %>% + dplyr::ungroup() %>% + dplyr::mutate( + # add levels to the point_type column so if a given point_type + # is NOT in the cross seciton points, then it will be added with NAs in the subsequent pivot_wider + point_type = factor(point_type, levels = c("left_bank", "bottom", "right_bank", "channel")) + ) + + # pivot data wider to get implicit missing groups with NA values + point_type_counts <- + point_type_counts %>% + tidyr::pivot_wider( + names_from = point_type, + values_from = n, + names_expand = TRUE + ) + + point_type_counts <- + point_type_counts %>% + tidyr::pivot_longer( + cols = c(bottom, channel, right_bank, left_bank), + names_to = "point_type", + values_to = "n" + ) %>% + dplyr::mutate(n = ifelse(is.na(n), 0, n)) + + # # Join the count of point types in each group with the reference_df to + # # get rows of NA values for any group that is missing a specific point_type + # point_type_counts <- + # point_type_counts %>% + # dplyr::right_join(reference_df, by = c("tmp_id", "point_type")) + + # # For any cross section group that does NOT contain a point type, + # # the point type will be NA and here we replace those NAs with 0 + # point_type_counts$n[is.na(point_type_counts$n)] <- 0 + + # # make sure that all tmp_id groups have all 4 point types + check_counts <- + point_type_counts %>% + dplyr::group_by(tmp_id) %>% + dplyr::summarize(unique_count = dplyr::n_distinct(point_type)) %>% + dplyr::filter(unique_count == 4) + + # if the number of distinct points types in each cross section is not 4, raise an error + if (length(unique(stage_df$tmp_id)) != nrow(check_counts)) { + stop("Error validating each hy_id/cs_id cross section contains exactly 4 distinct values in the 'point_type' column") + } + + # get the hy_id, cs_id for each tmp_id to cross walk back to just using hy_id/cs_id + stage_df <- + stage_df %>% + dplyr::select(tmp_id, hy_id, cs_id) %>% + dplyr::group_by(tmp_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + + # convert the column of point types to be a column for each point type that + # has the point type count for each hy_id/cs_id (cross section) + point_type_counts <- + point_type_counts %>% + tidyr::pivot_wider(names_from = point_type, + names_glue = "{point_type}_count", + values_from = n) %>% + dplyr::left_join( + stage_df, + by = "tmp_id" + ) %>% + dplyr::select(hy_id, cs_id, left_bank_count, right_bank_count, channel_count, bottom_count) + + # Join the point type counts to the original dataframe + classified_pts <- + classified_pts %>% + dplyr::left_join( + point_type_counts, + by = c("hy_id", "cs_id") + ) + + # check if any of the columns in 'classified_pts' are geometry types and move them to the end column if they do exist + classified_pts <- move_geometry_to_last(classified_pts) + + return(classified_pts) +} + +#' @title Adds attributes about the banks of each cross section in a dataframe of cross section points +#' Function adds "bottom", "left_bank", "right_bank" columns that are +#' the Z values of the "lowest" bottom point, and the "highest" left and right bank Z values, respectively. If there are +#' And also a "valid_banks" column is added that is TRUE if the hy_id/cs_id set of cross section point has at least 1 bottom point with +#' at least 1 left bank point AND 1 right bank point that are above the lowest "bottom" point. +#' @param classified_pts sf or dataframe of points with "hy_id", "cs_id", and "point_type" columns. Output of hydrofabric3D::classify_pts() +#' @return sf or dataframe with added "bottom", "left_bank", "right_bank", and "valid_banks" columns +#' @importFrom dplyr mutate case_when filter select group_by summarise ungroup left_join +#' @importFrom tidyr pivot_wider +add_bank_attributes <- function( + classified_pts +) { + + # classified_pts <- output_pts + + # type checking, throw an error if not "sf", "tbl_df", "tbl", or "data.frame" + if (!any(class(classified_pts) %in% c("sf", "tbl_df", "tbl", "data.frame"))) { + stop("Invalid argument type, 'classified_pts' must be of type 'sf', 'tbl_df', 'tbl' or 'data.frame', given type was '", + class(classified_pts), "'") + } + + # Add columns with the counts of point types + classified_pts <- hydrofabric3D::add_point_type_counts(classified_pts) + + # TODO: Need to add code that will just set aside the geometries and add them back to the final output dataset + # For now we will just drop geometries as safety precaution (as to not summarize() on a massive number of sf geometries) + classified_pts <- sf::st_drop_geometry(classified_pts) + + # Add a valid_count column which is TRUE + # if a hy_id/cs_id has a bottom point AND atleast 1 left and right bank + classified_pts <- + classified_pts %>% + dplyr::mutate( + valid_count = dplyr::case_when( + (bottom_count > 0 & + left_bank_count > 0 & + right_bank_count > 0) ~ TRUE, + TRUE ~ FALSE + ) + ) + + # Add minimum bottom Z, max left and right bank Z, and + # flags noting if the left/right banks are "valid" (i.e. max left/right bank values are greater than the bottom Z) + bank_validity <- + classified_pts %>% + dplyr::filter(point_type %in% c("bottom", "left_bank", "right_bank")) %>% + # dplyr::filter(point_type %in% c("left_bank", "right_bank")) %>% + dplyr::select(hy_id, cs_id, pt_id, Z, point_type) %>% + dplyr::group_by(hy_id, cs_id, point_type) %>% + dplyr::summarise( + minZ = min(Z, na.rm = TRUE), + maxZ = max(Z, na.rm = TRUE) + ) %>% + dplyr::ungroup() %>% + tidyr::pivot_wider( + names_from = point_type, + values_from = c(minZ, maxZ) + ) %>% + dplyr::select(hy_id, cs_id, + bottom = minZ_bottom, + left_bank = maxZ_left_bank, + right_bank = maxZ_right_bank + ) + + # Get logical values of the bank validity on both sides + bank_validity <- + bank_validity %>% + dplyr::mutate( + # bottom = ifelse(is.na(bottom), 0, bottom), # Old way was to set the NA left/bank/bottom Z values to 0 but i think this could lead to problems with small number of edge cases + # right_bank = ifelse(is.na(right_bank), 0, right_bank), + # left_bank = ifelse(is.na(left_bank), 0, left_bank), + valid_left_bank = dplyr::case_when( + (left_bank > bottom) & (!is.na(left_bank)) ~ TRUE, # Old method used: left_bank > bottom ~ TRUE, + TRUE ~ FALSE + ), + valid_right_bank = dplyr::case_when( + (right_bank > bottom) & (!is.na(right_bank)) ~ TRUE, # Old method used: right_bank > bottom ~ TRUE, + TRUE ~ FALSE + ), + valid_banks = valid_left_bank & valid_right_bank + ) + # tidyr::pivot_longer(cols = c(right_bank, left_bank), + # names_to = "point_type", values_to = "max_Z_at_banks") %>% + # dplyr::mutate(max_Z_at_banks = ifelse(is.na(max_Z_at_banks), 0, max_Z_at_banks)) + + # Add the following columns to the final output data: + # bottom - numeric, max depth (depth of lowest "bottom" point) + # left_bank - numeric, min depth of left bank (depth of the highest "left_bank" point). If no left_bank points exist, value is 0. + # right_bank - numeric, min depth of right bank (depth of the highest "right_bank" point). If no right_bank points exist, value is 0. + # valid_banks - logical, TRUE if the hy_id/cs_id has a bottom point with atleast 1 leftbank point AND 1 rightbank point that are above the lowest "bottom" point + classified_pts <- + classified_pts %>% + dplyr::left_join( + dplyr::select(bank_validity, + hy_id, cs_id, + bottom, left_bank, right_bank, + valid_left_bank, valid_right_bank, valid_banks + ), + by = c("hy_id", "cs_id") + ) + # %>% + # dplyr::mutate(valid_banks2 = valid_left_bank & valid_right_bank) + + # # return simple dataset if add is FALSE + # if(!add) { + # # subset to just hy_id/cs_id and added bank attributes to + # # return a dataframe with unique hy_id/cs_ids for each row + # bank_validity %>% + # sf::st_drop_geometry() %>% # drop sf geometry as a safety precaution to make sure returned data is a dataframe + # dplyr::select(hy_id, cs_id, + # bottom, left_bank, right_bank, + # valid_banks) + # + # return(bank_validity) + # + # } + + # select specific rows and returns + classified_pts <- + classified_pts %>% + dplyr::select(hy_id, cs_id, pt_id, Z, + relative_distance, cs_lengthm, + class, point_type, + bottom, left_bank, right_bank, valid_banks) + + # check if any of the columns in 'classified_pts' are geometry types and move them to the end column if they do exist + classified_pts <- move_geometry_to_last(classified_pts) + + return(classified_pts) + +} + +#' @title Get attributes about the banks of each cross section in a dataframe of cross section points +#' Given a set of cross section points with point_type column, return a dataframe of the unique hy_id/cs_ids with the following calculated columns: +#' "bottom", "left_bank", "right_bank" columns which are the Z values of the "lowest" bottom point, and the "highest" left and right bank Z values, respectively. +#' And a "valid_banks" column indicating whether the hy_id/cs_id set of cross section point has at least a signle bottom point with +#' at least 1 left bank point AND 1 right bank point that are above the lowest "bottom" point. +#' @param classified_pts sf or dataframe of points with "hy_id", "cs_id", and "point_type" columns. Output of hydrofabric3D::classify_pts() +#' @return dataframe with each row being a unique hy_id/cs_id with "bottom", "left_bank", "right_bank", and "valid_banks" values for each hy_id/cs_id. +#' @importFrom dplyr mutate case_when filter select group_by summarise ungroup left_join +#' @importFrom tidyr pivot_wider +get_bank_attributes <- function( + classified_pts +) { + + # classified_pts <- output_pts + # classified_pts + # classified_pts <- classified_pts2 + + # type checking, throw an error if not "sf", "tbl_df", "tbl", or "data.frame" + if (!any(class(classified_pts) %in% c("sf", "tbl_df", "tbl", "data.frame"))) { + stop("Invalid argument type, 'classified_pts' must be of type 'sf', 'tbl_df', 'tbl' or 'data.frame', given type was '", + class(classified_pts), "'") + } + + # Add columns with the counts of point types + classified_pts <- hydrofabric3D::add_point_type_counts(classified_pts) + + # TODO: Need to add code that will just set aside the geometries and add them back to the final output dataset + # For now we will just drop geometries as safety precaution (as to not summarize() on a massive number of sf geometries) + classified_pts <- sf::st_drop_geometry(classified_pts) + + # Add a valid_count column which is TRUE + # if a hy_id/cs_id has a bottom point AND atleast 1 left and right bank + classified_pts <- + classified_pts %>% + # sf::st_drop_geometry() %>% # drop sf geometry as a safety precaution to make sure returned data is a dataframe + dplyr::mutate( + valid_count = dplyr::case_when( + (bottom_count > 0 & + left_bank_count > 0 & + right_bank_count > 0) ~ TRUE, + TRUE ~ FALSE + ) + ) + + # Add minimum bottom Z, max left and right bank Z, and + # flags noting if the left/right banks are "valid" (i.e. max left/right bank values are greater than the bottom Z) + bank_validity <- + classified_pts %>% + # classified_pts2 %>% + # sf::st_drop_geometry() %>% # drop sf geometry as a safety precaution to make sure returned data is a dataframe + dplyr::filter(point_type %in% c("bottom", "left_bank", "right_bank")) %>% + # dplyr::filter(point_type %in% c("left_bank", "right_bank")) %>% + dplyr::select(hy_id, cs_id, pt_id, Z, point_type) %>% + dplyr::group_by(hy_id, cs_id, point_type) %>% + dplyr::summarise( + minZ = min(Z, na.rm = TRUE), + maxZ = max(Z, na.rm = TRUE) + ) %>% + dplyr::ungroup() %>% + tidyr::pivot_wider( + names_from = point_type, + values_from = c(minZ, maxZ) + ) %>% + dplyr::select(hy_id, cs_id, + bottom = minZ_bottom, + left_bank = maxZ_left_bank, + right_bank = maxZ_right_bank + ) + + bank_validity <- + bank_validity %>% + dplyr::mutate( + # bottom = ifelse(is.na(bottom), 0, bottom), # Old way was to set the NA left/bank/bottom Z values to 0 but i think this could lead to problems with small number of edge cases + # right_bank = ifelse(is.na(right_bank), 0, right_bank), + # left_bank = ifelse(is.na(left_bank), 0, left_bank), + valid_left_bank = dplyr::case_when( + (left_bank > bottom) & (!is.na(left_bank)) ~ TRUE, # Old method used: left_bank > bottom ~ TRUE, + TRUE ~ FALSE + ), + valid_right_bank = dplyr::case_when( + (right_bank > bottom) & (!is.na(right_bank)) ~ TRUE, # Old method used: right_bank > bottom ~ TRUE, + TRUE ~ FALSE + ), + valid_banks = valid_left_bank & valid_right_bank + ) + # tidyr::pivot_longer(cols = c(right_bank, left_bank), + # names_to = "point_type", values_to = "max_Z_at_banks") %>% + # dplyr::mutate(max_Z_at_banks = ifelse(is.na(max_Z_at_banks), 0, max_Z_at_banks)) + + # Add the following columns to the final output data: + # bottom - numeric, max depth (depth of lowest "bottom" point) + # left_bank - numeric, min depth of left bank (depth of the highest "left_bank" point). If no left_bank points exist, value is 0. + # right_bank - numeric, min depth of right bank (depth of the highest "right_bank" point). If no right_bank points exist, value is 0. + # valid_banks - logical, TRUE if the hy_id/cs_id has a bottom point with atleast 1 leftbank point AND 1 rightbank point that are above the lowest "bottom" point + + # subset to just hy_id/cs_id and added bank attributes to + # return a dataframe with unique hy_id/cs_ids for each row + bank_validity <- + bank_validity %>% + dplyr::select(hy_id, cs_id, + bottom, left_bank, right_bank, + valid_banks) + + return(bank_validity) + +} + +#' @title Add relief attributes to a dataframe of cross sections points +#' Given a set of cross section points (derived from hydrofabric3D::cross_section_pts() and hydrofabric3D::classify_points()) add a "has_relief" logical +#' value to data. The "has_relief" value is indicating whether a cross section "has relief". +#' Relief is determined by checking each set of cross section points have a left OR right bank that +#' has a depth difference from the bottom that isgreater than or equal to a percentage of the cross section length (e.g. Assuming a 'pct_of_length_for_relief' of 0.01 (1%) of a 100m cross section would have a relief depth threshold of 1m) +#' @param classified_pts sf or dataframe of points with "hy_id", "cs_id", "cs_lengthm", and "point_type" columns. Output of hydrofabric3D::classify_points() +#' @param pct_of_length_for_relief numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1% of the cross sections length). +#' @return sf or dataframe with added "has_relief" columns or a dataframe of dataframe of unique hy_id/cs_id and "has_relief" +#' @importFrom dplyr select group_by slice ungroup mutate filter summarise left_join case_when all_of relocate last_col +#' @importFrom tidyr pivot_wider +#' @export +add_relief <- function( + classified_pts, + pct_of_length_for_relief = 0.01 +) { + + # 34 * as.numeric("2.3") + # classified_pts = output_pts + # pct_of_length_for_relief = 0.01 + # classified_pts <- output_pts + # pct_of_length_for_relief = 0.01 + + # type checking + if (!any(class(classified_pts) %in% c("sf", "tbl_df", "tbl", "data.frame"))) { + stop("Invalid argument type, 'classified_pts' must be of type 'sf', 'tbl_df', 'tbl' or 'data.frame', given type was '", + class(classified_pts), "'") + } + + # type checking + if (!is.numeric(pct_of_length_for_relief)) { + stop("Invalid argument type, 'pct_of_length_for_relief' must be of type 'numeric', given type was '", + class(pct_of_length_for_relief), "'") + } + + # Make sure pct_of_length_for_relief is valid percentage value (greater than 0) + if (pct_of_length_for_relief < 0 ) { + stop("Invalid value 'pct_of_length_for_relief' of ", pct_of_length_for_relief, ", 'pct_of_length_for_relief' must be greater than or equal to 0") + } + + # TODO: Need to add code that will just set aside the geometries and add them back to the final output dataset + # For now we will just drop geometries as safety precaution (as to not summarize() on a massive number of sf geometries) + classified_pts <- sf::st_drop_geometry(classified_pts) + + # store the cross section lengths and calculate the depth threshold as a percent of the cross sections length + cs_lengths <- + classified_pts %>% + dplyr::select(hy_id, cs_id, cs_lengthm) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::mutate( + depth_threshold = round(cs_lengthm * pct_of_length_for_relief, 3) # maybe use floor() here + ) + + # get the minimum bottom point and maximum left and right bank points + relief <- + classified_pts %>% + # dplyr::filter(point_type %in% c("left_bank", "right_bank")) %>% + dplyr::filter(point_type %in% c("bottom", "left_bank", "right_bank")) %>% + dplyr::select(hy_id, cs_id, pt_id, Z, point_type) %>% + dplyr::group_by(hy_id, cs_id, point_type) %>% + dplyr::summarise( + minZ = min(Z, na.rm = TRUE), + maxZ = max(Z, na.rm = TRUE) + ) %>% + dplyr::ungroup() %>% + tidyr::pivot_wider( + names_from = point_type, + values_from = c(minZ, maxZ) + ) %>% + dplyr::select(hy_id, cs_id, + bottom = minZ_bottom, + left_bank = maxZ_left_bank, + right_bank = maxZ_right_bank + ) + + # join lengths and depth threshold back with relief table and + # calculate if the max difference between left/right bank vs bottom is + # greater than or equal to the depth threshold + relief <- + relief %>% + dplyr::left_join( + cs_lengths, + by = c("hy_id", "cs_id") + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + depth_diff = max(c(round(right_bank - bottom, 3), + round(left_bank - bottom, 3)), + na.rm = TRUE) # TODO: removing NAs might not be the right call, + # removing them might set has_relief to TRUE and + # says "there IS relief but no valid banks" + ) %>% + dplyr::ungroup() %>% + dplyr::mutate( + has_relief = dplyr::case_when( + depth_diff >= depth_threshold ~ TRUE, + TRUE ~ FALSE + ) + ) + + # add the new point type columns to the original dataframe + # Join the point type counts to the original dataframe + classified_pts <- + classified_pts %>% + dplyr::left_join( + dplyr::select(relief, + hy_id, cs_id, has_relief), + by = c("hy_id", "cs_id") + ) + + # check if any of the columns in 'classified_pts' are geometry types and move them to the end column if they do exist + classified_pts <- move_geometry_to_last(classified_pts) + + return(classified_pts) + +} + +#' @title Get relief attributes from a dataframe of cross sections points +#' Generate a dataframe from a set of classified cross section points indicating whether a cross section "has relief". +#' Relief is determined by checking each set of cross section points have a left OR right bank that has a depth difference from the bottom that is +#' greater than or equal to a percentage of the cross section length (e.g. Assuming a 'pct_of_length_for_relief' of 0.01 (1%) of a 100m cross section would have a relief depth threshold of 1m) +#' @param classified_pts sf or dataframe of points with "hy_id", "cs_id", "cs_lengthm", and "point_type" columns. Output of hydrofabric3D::classify_pts() +#' @param pct_of_length_for_relief numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1% of the cross sections length). +#' @param detailed logical, whether to return only a the "has_relief" column or +#' include all derived relief based columns such as "max_relief" and the "pct_of_length_for_relief" used. Default is FALSE and returns a dataframe with only "hy_id", "cs_id", and "has_relief". +#' @return dataframe with each row being a unique hy_id/cs_id with a "has_relief" value for each hy_id/cs_id. If detailed = TRUE, then the output dataframe will include the following additional columns: "cs_lengthm", "max_relief", "pct_of_length_for_relief". +#' @importFrom dplyr select group_by slice ungroup mutate filter summarise left_join case_when all_of relocate last_col +#' @importFrom tidyr pivot_wider +#' @export +get_relief <- function( + classified_pts, + pct_of_length_for_relief = 0.01, + detailed = FALSE +) { + + # classified_pts + # pct_of_length_for_relief = pct_of_length_for_relief + # detailed = FALSE + + # classified_pts = output_pts + # pct_of_length_for_relief = 0.01 + + # type checking + if (!any(class(classified_pts) %in% c("sf", "tbl_df", "tbl", "data.frame"))) { + stop("Invalid argument type, 'classified_pts' must be of type 'sf', 'tbl_df', 'tbl' or 'data.frame', given type was '", class(classified_pts), "'") + } + + # type checking + if (!is.numeric(pct_of_length_for_relief)) { + stop("Invalid argument type, 'pct_of_length_for_relief' must be of type 'numeric', given type was '", class(pct_of_length_for_relief), "'") + } + + # type checking + if (!is.logical(detailed)) { + stop("Invalid argument type, 'detailed' must be of type 'logical', given type was '", class(detailed), "'") + } + + # drop geometries as safety precaution + classified_pts <- sf::st_drop_geometry(classified_pts) + + # store the cross section lengths and calculate the depth threshold as a percent of the cross sections length + cs_lengths <- + classified_pts %>% + # classified_pts2 %>% + dplyr::select(hy_id, cs_id, cs_lengthm) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::mutate( + depth_threshold = round(cs_lengthm * pct_of_length_for_relief, 3) # maybe use floor() here + ) + + # get the minimum bottom point and maximum left and right bank points + relief <- + classified_pts %>% + # dplyr::filter(point_type %in% c("left_bank", "right_bank")) %>% + dplyr::filter(point_type %in% c("bottom", "left_bank", "right_bank")) %>% + dplyr::select(hy_id, cs_id, pt_id, Z, point_type) %>% + dplyr::group_by(hy_id, cs_id, point_type) %>% + dplyr::summarise( + minZ = min(Z, na.rm = TRUE), + maxZ = max(Z, na.rm = TRUE) + ) %>% + dplyr::ungroup() %>% + tidyr::pivot_wider( + names_from = point_type, + values_from = c(minZ, maxZ) + ) %>% + dplyr::select(hy_id, cs_id, + bottom = minZ_bottom, + left_bank = maxZ_left_bank, + right_bank = maxZ_right_bank + ) + + # join lengths and depth threshold back with relief table and + # calculate if the max difference between left/right bank vs bottom is + # greater than or equal to the depth threshold + relief <- + relief %>% + dplyr::left_join( + cs_lengths, + by = c("hy_id", "cs_id") + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + max_relief = max(c(round(right_bank - bottom, 3), + round(left_bank - bottom, 3)), + na.rm = TRUE) # TODO: removing NAs might not be the right call, removing them might set has_relief to TRUE and says "there IS relief but no valid banks" + ) %>% + dplyr::ungroup() %>% + dplyr::mutate( + has_relief = dplyr::case_when( + max_relief >= depth_threshold ~ TRUE, + TRUE ~ FALSE + ), + pct_of_length_for_relief = pct_of_length_for_relief + ) + + # if detailed set of data is specified, return the relief dataframe with additional columns + if(detailed) { + relief <- + relief %>% + dplyr::select(hy_id, cs_id, cs_lengthm, has_relief, max_relief, pct_of_length_for_relief) + + return(relief) + + } + + # return dataframe with just hy_id/cs_id, and has_relief + relief <- + relief %>% + dplyr::select(hy_id, cs_id, has_relief) + + return(relief) +} + +#' Validate Inputs for cut_cross_sections Function +#' +#' This function validates the inputs for the cut_cross_sections function to ensure they meet the required criteria. +#' +#' @param net An sf object representing the hydrographic network. +#' @param id A unique identifier column in the network data. +#' @param cs_widths Bankfull widths (length of cross sections) for each network element. +#' @param num Number of transects per network element. +#' @param smooth Logical, whether to smooth linestring geometries or not. +#' @param densify Numeric, the factor by which to densify the linestrings. +#' @param rm_self_intersect Logical, whether to remove self-intersecting transect linestrings. +#' @param fix_braids Logical, whether to fix braided transect lines or not. +#' @param terminal_id Character, column name containing a unique identifier delineating separate networks in the 'net' dataset. +#' @param braid_threshold Numeric, the total length of all flowlines in a braid below which fix_braid_transects should operate. +#' @param version Integer, version number of braid algorithm to use, either 1 or 2. Default is 2. +#' @param braid_method Character, the method to determine the geometries to cut. Options are "comid", "component", or "neighbor". Default is "comid". +#' @param precision Numeric, the number of meters to approximate final cross-section linestring length. +#' @param add Logical, indicating whether to add original 'net' data to the outputted transect lines. +#' @return NULL if inputs are valid; otherwise, an error is thrown. +#' @keywords internal +validate_cut_cross_section_inputs <- function(net, + id, + cs_widths, + num, + smooth, + densify, + rm_self_intersect, + fix_braids, + terminal_id, + braid_threshold , + version, + braid_method, + precision, + add +) { + + # Check if 'net' is an sf object + if (!inherits(net, "sf")) { + stop("'net' must be an sf object.") + } + + # Check if 'id' is NOT a character or if its NULL + if (!is.character(id) || is.null(id)) { + # if (is.null(id) || !is.character(id)) { + stop("'id' must be a character vector") + } + + # Check if 'cs_widths' is numeric or a numeric vector + if (!is.numeric(cs_widths)) { + stop("'cs_widths' must be a numeric") + } + + # # Check if 'cs_widths' is numeric or a numeric vector + # if (!is.numeric(cs_widths) && !is.null(cs_widths)) { + # stop("'cs_widths' must be numeric or NULL.") + # } + + # Check if 'num' is numeric or a numeric vector + if (!is.numeric(num)) { + stop("'num' must be numeric") + } + + # # Check if 'num' is numeric or a numeric vector + # if (!is.numeric(num) && !is.null(num)) { + # stop("'num' must be numeric or NULL.") + # } + + # Check if 'densify' is numeric or NULL + if (!is.numeric(densify) && !is.null(densify)) { + stop("'densify' must be numeric or NULL.") + } + + # Check if 'smooth' is a logical value + if (!is.logical(smooth)) { + stop("'smooth' must be a logical value.") + } + + # Check if 'rm_self_intersect' is a logical value + if (!is.logical(rm_self_intersect)) { + stop("'rm_self_intersect' must be a logical value.") + } + + # Check if 'fix_braids' is a logical value + if (!is.logical(fix_braids)) { + stop("'fix_braids' must be a logical value.") + } + + # Check if 'terminal_id' is NOT a character and its NOT NULL + if (!is.character(terminal_id) && !is.null(terminal_id)) { + # if (is.null(id) || !is.character(id)) { + stop("'terminal_id' must be a character vector or NULL") + } + + # Check if 'braid_threshold' is numeric or NULL + if (!is.null(braid_threshold) && !is.numeric(braid_threshold)) { + stop("'braid_threshold' must be numeric or NULL.") + } + + # Check if 'version' is an integer and either 1 or 2 + if (!is.numeric(version) || !(version %in% c(1, 2))) { + stop("'version' must be an integer, either 1 or 2.") + } + + # Check if 'braid_method' is one of the valid options + valid_methods <- c("comid", "component", "neighbor") + if (!braid_method %in% valid_methods) { + stop("'braid_method' must be one of 'comid', 'component', or 'neighbor'.") + } + + # Check if 'precision' is numeric and greater than 0 + if (!is.numeric(precision) || precision <= 0) { + stop("'precision' must be a numeric value greater than 0.") + } + + # Check if 'add' is a logical value + if (!is.logical(add)) { + stop("'add' must be a logical value.") + } + + return(NULL) +} + +#' Calculate the length between the leftmost and rightmost bottom point in each cross section +#' +#' @param cross_section_pts dataframe, or sf dataframe of cross section points +#' @importFrom dplyr select mutate case_when group_by lag ungroup filter summarise left_join +#' @return summarized dataframe of input cross_section_pts dataframe with a bottom_length value for each hy_id/cs_id +#' @export +get_cs_bottom_length <- function(cross_section_pts) { + + # get the distance between cross section pts in each cross section, + # this will be used as a default for bottom length in case bottom length is 0 + interval_distances <- + cross_section_pts %>% + dplyr::select(hy_id, cs_id, pt_id, relative_distance) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + distance_interval = relative_distance - dplyr::lag(relative_distance) + ) %>% + dplyr::summarise( + distance_interval = ceiling(mean(distance_interval, na.rm = TRUE)) # TODO: round up to make sure we are not underestimating + # the interval, we're going to use this value to + # derive a new Top width for each cross section if + # the cross section length is less than the prescribed top width + ) %>% + dplyr::ungroup() + + # get the distance from the first and last bottom points, substittue any bottom lengths == 0 + # with the interval between points distance + bottom_lengths <- + cross_section_pts %>% + dplyr::filter(point_type == "bottom") %>% + dplyr::select(hy_id, cs_id, pt_id, relative_distance) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::summarise( + bottom_start = min(relative_distance, na.rm = TRUE), + bottom_end = max(relative_distance, na.rm = TRUE) + ) %>% + dplyr::left_join( + interval_distances, + by = c("hy_id", "cs_id") + ) %>% + dplyr::group_by(hy_id, cs_id) %>% + dplyr::mutate( + bottom_length = bottom_end - bottom_start + ) %>% + dplyr::ungroup() %>% + dplyr::mutate( + bottom_length = dplyr::case_when( + floor(bottom_length) == 0 ~ distance_interval, + TRUE ~ bottom_length + ) + ) %>% + dplyr::select(hy_id, cs_id, bottom_length) + + return(bottom_lengths) + +} + +#' Calculates a validity score column based on valid_banks and has_relief columns in a set of cross section points +#' +#' @param cs_to_validate dataframe +#' @param validity_col_name name of the output validity score column +#' @importFrom sf st_drop_geometry +#' @importFrom dplyr group_by slice ungroup mutate select +#' @return dataframe with added validity_score column +calc_validity_scores <- function(cs_to_validate, validity_col_name = "validity_score") { + + scores <- + cs_to_validate %>% + sf::st_drop_geometry() %>% + hydrofabric3D::add_tmp_id() %>% + dplyr::group_by(tmp_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() %>% + dplyr::mutate( + validity_score = valid_banks + has_relief + ) %>% + dplyr::select(hy_id, cs_id, valid_banks, has_relief, validity_score) + + names(scores) <- c("hy_id", "cs_id", "valid_banks", "has_relief", validity_col_name) + + return(scores) + +} + +#' Make a progress bar and return an "make_progress()" function to update the progress bar. +#' Credit to the exactextractr team: https://github.com/isciences/exactextractr/blob/5fd17dcf02717332b125345aea586304f668cf12/R/exact_extract_helpers.R#L361 +#' @param progress logical, whether to make a progress bar or not (FALSE) +#' @param n numeric, total number of iterations +#' @importFrom utils txtProgressBar +#' @return make_progress function, when called will increment the progress bar text +#' @export +#' +#' @examples +#' progress=TRUE +#' x = 1:500000 +#' make_progress <- make_progress_bar(progress, length(x)) +#' for (i in 1:length(x)) { +#' make_progress() +#' } +make_progress_bar <- function(progress, n) { + if (progress && n > 1) { + pb <- utils::txtProgressBar(min = 0, max = n, initial=0, style=3) + make_progress <- function() { + i <- 1 + utils::getTxtProgressBar(pb) + utils::setTxtProgressBar(pb, i) + if (i == n) { + close(pb) + } + } + } else { + make_progress <- function() {} + } + + return(make_progress) +} + diff --git a/hydrofabric3D.Rproj b/hydrofabric3D.Rproj index 8d82f1f3..21a4da08 100644 --- a/hydrofabric3D.Rproj +++ b/hydrofabric3D.Rproj @@ -1,17 +1,17 @@ -Version: 1.0 - -RestoreWorkspace: Default -SaveWorkspace: Default -AlwaysSaveHistory: Default - -EnableCodeIndexing: Yes -UseSpacesForTab: Yes -NumSpacesForTab: 2 -Encoding: UTF-8 - -RnwWeave: Sweave -LaTeX: pdfLaTeX - -BuildType: Package -PackageUseDevtools: Yes -PackageInstallArgs: --no-multiarch --with-keep.source +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source diff --git a/man/.DS_Store b/man/.DS_Store deleted file mode 100644 index d33bdb08..00000000 Binary files a/man/.DS_Store and /dev/null differ diff --git a/man/add_angle_at_point_type.Rd b/man/add_angle_at_point_type.Rd new file mode 100644 index 00000000..8dec87a0 --- /dev/null +++ b/man/add_angle_at_point_type.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_eval.R +\name{add_angle_at_point_type} +\alias{add_angle_at_point_type} +\title{Add the degree angle between the middle index of a specific point type and the maximum XY points to the left and right of the given middle index +Uses Law of Cosines to determine angle from a given point given a set of 3 points that can form a triangle the rest of the cross section points in each hy_id, cs_id} +\usage{ +add_angle_at_point_type( + cross_section_pts, + angle_at = "bottom", + default_col_name = TRUE +) +} +\arguments{ +\item{cross_section_pts}{cross section points dataframe with a "point_type" column and "hy_id", "cs_id" columns} + +\item{angle_at}{character, which point type to get the degree angle for. Must be one of "left_bank", "bottom", "right_bank", or "channel". Default is "bottom"} + +\item{default_col_name}{logical, whether the output column should be named "angle_at" or +if the new column should take the "point_type" string and use. Default is TRUE and adds a column named "angle_at"} +} +\value{ +dataframe, the cross_section_pts dataframe with an added "angle_at" column +} +\description{ +Add the degree angle between the middle index of a specific point type and the maximum XY points to the left and right of the given middle index +Uses Law of Cosines to determine angle from a given point given a set of 3 points that can form a triangle the rest of the cross section points in each hy_id, cs_id +} diff --git a/man/add_bank_attributes.Rd b/man/add_bank_attributes.Rd new file mode 100644 index 00000000..743d5561 --- /dev/null +++ b/man/add_bank_attributes.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{add_bank_attributes} +\alias{add_bank_attributes} +\title{Adds attributes about the banks of each cross section in a dataframe of cross section points +Function adds "bottom", "left_bank", "right_bank" columns that are +the Z values of the "lowest" bottom point, and the "highest" left and right bank Z values, respectively. If there are +And also a "valid_banks" column is added that is TRUE if the hy_id/cs_id set of cross section point has at least 1 bottom point with +at least 1 left bank point AND 1 right bank point that are above the lowest "bottom" point.} +\usage{ +add_bank_attributes(classified_pts) +} +\arguments{ +\item{classified_pts}{sf or dataframe of points with "hy_id", "cs_id", and "point_type" columns. Output of hydrofabric3D::classify_pts()} +} +\value{ +sf or dataframe with added "bottom", "left_bank", "right_bank", and "valid_banks" columns +} +\description{ +Adds attributes about the banks of each cross section in a dataframe of cross section points +Function adds "bottom", "left_bank", "right_bank" columns that are +the Z values of the "lowest" bottom point, and the "highest" left and right bank Z values, respectively. If there are +And also a "valid_banks" column is added that is TRUE if the hy_id/cs_id set of cross section point has at least 1 bottom point with +at least 1 left bank point AND 1 right bank point that are above the lowest "bottom" point. +} diff --git a/man/add_cs_bathymetry.Rd b/man/add_cs_bathymetry.Rd new file mode 100644 index 00000000..b65befff --- /dev/null +++ b/man/add_cs_bathymetry.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ahg_estimates.R +\name{add_cs_bathymetry} +\alias{add_cs_bathymetry} +\title{Given provide inchannel widths and depths to a set of cross section points and derive estimated shapes} +\usage{ +add_cs_bathymetry(cross_section_pts = NULL) +} +\arguments{ +\item{cross_section_pts}{dataframe or sf dataframe. Default is NULL} +} +\value{ +dataframe or sf dataframe with AHG estimated points injected into the input cross section points +} +\description{ +Still in early development phases +} diff --git a/man/add_middle_index_by_point_type.Rd b/man/add_middle_index_by_point_type.Rd new file mode 100644 index 00000000..9d64eb0c --- /dev/null +++ b/man/add_middle_index_by_point_type.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_eval.R +\name{add_middle_index_by_point_type} +\alias{add_middle_index_by_point_type} +\title{Add a "middle_index" column denoting the middle index of a specific point_type +The middle index is relative to the rest of the cross section points in each hy_id, cs_id} +\usage{ +add_middle_index_by_point_type( + cross_section_pts, + point_type = "bottom", + default_col_name = TRUE +) +} +\arguments{ +\item{cross_section_pts}{cross section points dataframe with a "point_type" column and "hy_id", "cs_id" columns} + +\item{point_type}{character, which point type to get the middle index for. Must be one of "left_bank", "bottom", "right_bank", or "channel". Default is "bottom"} + +\item{default_col_name}{logical, whether the output column should be named "middle_index" or if +the new column should take the point_type string and use that in the column name (i.e. "left_bank_middle_index" instead of "middle_index"). +Default is TRUE and adds a column named "middle_index"} +} +\value{ +dataframe of the input cross_section_pts with an added middle index column +} +\description{ +Add a "middle_index" column denoting the middle index of a specific point_type +The middle index is relative to the rest of the cross section points in each hy_id, cs_id +} diff --git a/man/add_needs_rectification.Rd b/man/add_needs_rectification.Rd new file mode 100644 index 00000000..01069962 --- /dev/null +++ b/man/add_needs_rectification.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{add_needs_rectification} +\alias{add_needs_rectification} +\title{Add a "needs_rectification" column to a sf/dataframe} +\usage{ +add_needs_rectification(transects) +} +\arguments{ +\item{transects}{sf linestring with "valid_banks" and "has_relief" logical columns} +} +\value{ +logical, TRUE if there are transects without valid banks or relief +} +\description{ +Add a "needs_rectification" column to a sf/dataframe +} diff --git a/man/add_point_type_counts.Rd b/man/add_point_type_counts.Rd new file mode 100644 index 00000000..44ce4a92 --- /dev/null +++ b/man/add_point_type_counts.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{add_point_type_counts} +\alias{add_point_type_counts} +\title{Add the count of each point type as a column to a dataframe of section points} +\usage{ +add_point_type_counts(classified_pts) +} +\arguments{ +\item{classified_pts}{dataframe or sf dataframe, cross section points with a "hy_id", and "cs_id" columns as well as a 'point_type' column containing the values: "bottom", "left_bank", "right_bank", and "channel"} +} +\value{ +dataframe or sf dataframe with "_count" columns added +} +\description{ +add_point_type_counts() will add columns to the input dataframe with the counts of every point_type for each hy_id/cs_id in the input dataframe of classified cross section points (output of classify_pts()) +} diff --git a/man/add_points_per_cs.Rd b/man/add_points_per_cs.Rd new file mode 100644 index 00000000..b82bfd54 --- /dev/null +++ b/man/add_points_per_cs.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_pts.R +\name{add_points_per_cs} +\alias{add_points_per_cs} +\title{Add a points per cross section column to an sf dataframe of linestrings given a DEM and min points value} +\usage{ +add_points_per_cs( + cs, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = + "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt" +) +} +\arguments{ +\item{cs}{An sf dataframe representing cross-sections (linestrings). With a required cs_lengthm column (length of cross section in meters)} + +\item{points_per_cs}{numeric, number of points per cross section. Default is NULL} + +\item{min_pts_per_cs}{An optional minimum points value per cross section. If not provided,} + +\item{dem}{A SpatRaster object representing the Digital Elevation Model (DEM) or a character string referencing a remote resource. +the function calculates it based on the length of cross-sections and the resolution of the DEM.} +} +\value{ +An updated sf dataframe with the 'points_per_cs' column added. +} +\description{ +This function calculates and adds a column called 'points_per_cs' to an sf dataframe +representing cross-sections (linestrings) based on a provided DEM and a minimum points +value per cross section. +} diff --git a/man/add_relief.Rd b/man/add_relief.Rd new file mode 100644 index 00000000..6f3dff29 --- /dev/null +++ b/man/add_relief.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{add_relief} +\alias{add_relief} +\title{Add relief attributes to a dataframe of cross sections points +Given a set of cross section points (derived from hydrofabric3D::cross_section_pts() and hydrofabric3D::classify_points()) add a "has_relief" logical +value to data. The "has_relief" value is indicating whether a cross section "has relief". +Relief is determined by checking each set of cross section points have a left OR right bank that +has a depth difference from the bottom that isgreater than or equal to a percentage of the cross section length (e.g. Assuming a 'pct_of_length_for_relief' of 0.01 (1\%) of a 100m cross section would have a relief depth threshold of 1m)} +\usage{ +add_relief(classified_pts, pct_of_length_for_relief = 0.01) +} +\arguments{ +\item{classified_pts}{sf or dataframe of points with "hy_id", "cs_id", "cs_lengthm", and "point_type" columns. Output of hydrofabric3D::classify_points()} + +\item{pct_of_length_for_relief}{numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1\% of the cross sections length).} +} +\value{ +sf or dataframe with added "has_relief" columns or a dataframe of dataframe of unique hy_id/cs_id and "has_relief" +} +\description{ +Add relief attributes to a dataframe of cross sections points +Given a set of cross section points (derived from hydrofabric3D::cross_section_pts() and hydrofabric3D::classify_points()) add a "has_relief" logical +value to data. The "has_relief" value is indicating whether a cross section "has relief". +Relief is determined by checking each set of cross section points have a left OR right bank that +has a depth difference from the bottom that isgreater than or equal to a percentage of the cross section length (e.g. Assuming a 'pct_of_length_for_relief' of 0.01 (1\%) of a 100m cross section would have a relief depth threshold of 1m) +} diff --git a/man/add_tmp_id.Rd b/man/add_tmp_id.Rd new file mode 100644 index 00000000..4cc62717 --- /dev/null +++ b/man/add_tmp_id.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{add_tmp_id} +\alias{add_tmp_id} +\title{Function to add a new "tmp_id" column to a dataframe from 2 other columns} +\usage{ +add_tmp_id(df, x = hy_id, y = cs_id) +} +\arguments{ +\item{df}{dataframe with x and y as columns} + +\item{x}{The name of the column in df to make up the first part of the added tmp_id column (tmp_id = x_y). Default is hy_id.} + +\item{y}{The name of the column in df to make up the second part of the added tmp_id column (tmp_id = x_y). Default is cs_id.} +} +\value{ +The input dataframe with the "tmp_id" column added. +} +\description{ +Internal convenience function for creating a tmp_id column from 2 other columns in a dataframe. +Default is to use hy_id and cs_id columns to create a tmp_id = _. +} diff --git a/man/align_banks_and_bottoms.Rd b/man/align_banks_and_bottoms.Rd new file mode 100644 index 00000000..5a71d61b --- /dev/null +++ b/man/align_banks_and_bottoms.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_banks_and_bottoms.R +\name{align_banks_and_bottoms} +\alias{align_banks_and_bottoms} +\title{Align banks and smooth bottoms of cross section points} +\usage{ +align_banks_and_bottoms(cs_pts) +} +\arguments{ +\item{cs_pts}{dataframe or sf dataframe of classified cross section points (output of classify_points())} +} +\value{ +sf dataframe of cross section points with aligned banks and smoothed bottoms +} +\description{ +Ensures the bottom of each cross section is lower then or equal to that one upstream. +To do this, we traverse down the network making sure this condition is met, and, +in cases where it isn't, we will lower the in channel portion of the cross section to make it true. +} diff --git a/man/angle_at_index.Rd b/man/angle_at_index.Rd new file mode 100644 index 00000000..d5c36a70 --- /dev/null +++ b/man/angle_at_index.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_eval.R +\name{angle_at_index} +\alias{angle_at_index} +\title{Function to calculate the angle using the Law of Cosines at a given index of X, Y, points} +\usage{ +angle_at_index(x, y, middle_index = NULL) +} +\arguments{ +\item{x}{numeric vector of size n} + +\item{y}{numeric vector of size n} + +\item{middle_index}{numeric value, indicating middle index X, Y point to calculate the angle at (can be obtained from add_middle_index_by_point_type())} +} +\value{ +numeric angle in degrees between the middle_index point and the maximum Y value XY points to the left and right of middle_index point +} +\description{ +Function to calculate the angle using the Law of Cosines at a given index of X, Y, points +} diff --git a/man/calc_extension_distances.Rd b/man/calc_extension_distances.Rd new file mode 100644 index 00000000..d38b85b3 --- /dev/null +++ b/man/calc_extension_distances.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{calc_extension_distances} +\alias{calc_extension_distances} +\title{Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within} +\usage{ +calc_extension_distances( + geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500 +) +} +\arguments{ +\item{geos_geoms}{list of geos_geometrys} + +\item{ids}{character vector} + +\item{lines_to_cut}{geos_linestrings} + +\item{lines_to_cut_indices}{numeric vector} + +\item{direction}{character, either "head", "tail" or "both"} + +\item{max_extension_distance}{numeric} +} +\value{ +numeric vector, distance to extend each geos_geoms +} +\description{ +Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +} diff --git a/man/calc_extension_distances2.Rd b/man/calc_extension_distances2.Rd new file mode 100644 index 00000000..cc45e8f1 --- /dev/null +++ b/man/calc_extension_distances2.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{calc_extension_distances2} +\alias{calc_extension_distances2} +\title{Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +VERSION 2} +\usage{ +calc_extension_distances2( + geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500 +) +} +\arguments{ +\item{geos_geoms}{list of geos_geometrys} + +\item{ids}{character vector} + +\item{lines_to_cut}{geos_linestrings} + +\item{lines_to_cut_indices}{numeric vector} + +\item{direction}{character, either "head", "tail" or "both"} + +\item{max_extension_distance}{numeric} +} +\value{ +numeric vector, distance to extend each geos_geoms +} +\description{ +Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +VERSION 2 +} diff --git a/man/calc_validity_scores.Rd b/man/calc_validity_scores.Rd new file mode 100644 index 00000000..1ee0355d --- /dev/null +++ b/man/calc_validity_scores.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{calc_validity_scores} +\alias{calc_validity_scores} +\title{Calculates a validity score column based on valid_banks and has_relief columns in a set of cross section points} +\usage{ +calc_validity_scores(cs_to_validate, validity_col_name = "validity_score") +} +\arguments{ +\item{cs_to_validate}{dataframe} + +\item{validity_col_name}{name of the output validity score column} +} +\value{ +dataframe with added validity_score column +} +\description{ +Calculates a validity score column based on valid_banks and has_relief columns in a set of cross section points +} diff --git a/man/classify_points.Rd b/man/classify_points.Rd index 7fc00766..ef780038 100644 --- a/man/classify_points.Rd +++ b/man/classify_points.Rd @@ -1,13 +1,18 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transects.R +% Please edit documentation in R/cs_pts.R \name{classify_points} \alias{classify_points} \title{Classify Cross Section Points} \usage{ -classify_points(cs_pts) +classify_points(cs_pts, pct_of_length_for_relief = 0.01) } \arguments{ -\item{cs_pts}{CS points} +\item{cs_pts}{CS points, output of hydrofabric3D::cross_section_pts()} + +\item{pct_of_length_for_relief}{numeric, percent of cross section length (cs_lengthm) to use as the +threshold depth for classifying whether a cross section has "relief". If a cross section has at least X\% of its length in depth, +then it is classified as "having relief" (i.e. has_relief = TRUE). Value must be non negative number (greater than or equal to 0). +Default is 0.01 (1\% of the cross sections length).} } \value{ sf object diff --git a/man/classify_points2.Rd b/man/classify_points2.Rd new file mode 100644 index 00000000..1dec33fd --- /dev/null +++ b/man/classify_points2.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_pts.R +\name{classify_points2} +\alias{classify_points2} +\title{Classify Cross Section Points v1 (Deprecated version)} +\usage{ +classify_points2(cs_pts) +} +\arguments{ +\item{cs_pts}{CS points} +} +\value{ +sf object +} +\description{ +Classify Cross Section Points v1 (Deprecated version) +} diff --git a/man/cross_section_pts.Rd b/man/cross_section_pts.Rd index afa5c442..a10309aa 100644 --- a/man/cross_section_pts.Rd +++ b/man/cross_section_pts.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/transects.R +% Please edit documentation in R/cs_pts.R \name{cross_section_pts} \alias{cross_section_pts} \title{Get Points across transects with elevation values} \usage{ cross_section_pts( - cs, + cs = NULL, points_per_cs = NULL, min_pts_per_cs = 10, dem = @@ -13,16 +13,16 @@ cross_section_pts( ) } \arguments{ -\item{cs}{Hydrographic LINESTRING Network} +\item{cs}{character, Hydrographic LINESTRING Network file path} -\item{points_per_cs}{the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected.} +\item{points_per_cs}{the desired number of points per CS. If NULL, then approximately 1 per grid cell resultion of DEM is selected.} -\item{min_pts_per_cs}{Minimun number of points per cross section required.} +\item{min_pts_per_cs}{Minimum number of points per cross section required.} \item{dem}{the DEM to extract data from} } \value{ -sf object +sf object cross section points along the 'cs' linestring geometries } \description{ Get Points across transects with elevation values diff --git a/man/cross_section_pts_v2.Rd b/man/cross_section_pts_v2.Rd new file mode 100644 index 00000000..22ad75f7 --- /dev/null +++ b/man/cross_section_pts_v2.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_pts.R +\name{cross_section_pts_v2} +\alias{cross_section_pts_v2} +\title{Get Points across transects with elevation values} +\usage{ +cross_section_pts_v2( + cs, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = + "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt" +) +} +\arguments{ +\item{cs}{Hydrographic LINESTRING Network} + +\item{points_per_cs}{the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected.} + +\item{min_pts_per_cs}{Minimun number of points per cross section required.} + +\item{dem}{the DEM to extract data from} +} +\value{ +sf object +} +\description{ +Get Points across transects with elevation values +} diff --git a/man/cross_section_pts_v3.Rd b/man/cross_section_pts_v3.Rd new file mode 100644 index 00000000..7788dffe --- /dev/null +++ b/man/cross_section_pts_v3.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_pts.R +\name{cross_section_pts_v3} +\alias{cross_section_pts_v3} +\title{Get Points across transects with elevation values} +\usage{ +cross_section_pts_v3( + cs = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = + "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5 +) +} +\arguments{ +\item{cs}{character, Hydrographic LINESTRING Network file path} + +\item{points_per_cs}{the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected.} + +\item{min_pts_per_cs}{Minimun number of points per cross section required.} + +\item{dem}{the DEM to extract data from} + +\item{scale}{numeric, If a transect line DEM extraction results in all equal Z values, +by what percent of the transect lines length (meters) should the transect line be +extended in both directions to try to capture representative Z values ? Default is 0.5 (50\% of the transect length)} +} +\value{ +sf object +} +\description{ +Get Points across transects with elevation values +} diff --git a/man/cut_cross_sections.Rd b/man/cut_cross_sections.Rd index 40d56d2a..a7e090db 100644 --- a/man/cut_cross_sections.Rd +++ b/man/cut_cross_sections.Rd @@ -26,9 +26,9 @@ cut_cross_sections( \item{id}{Unique Identifier in net} -\item{cs_widths}{Bankfull Widths (length of cross sections for each net element)} +\item{cs_widths}{numeric, Bankfull Widths (length of cross sections for each net element)} -\item{num}{Number of transects per Net element} +\item{num}{numeric, Number of transects per Net element} \item{smooth}{logical, whether to smooth linestring geometries or not. Default is TRUE.} diff --git a/man/extend_by_length.Rd b/man/extend_by_length.Rd new file mode 100644 index 00000000..8c3c9119 --- /dev/null +++ b/man/extend_by_length.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transects.R +\name{extend_by_length} +\alias{extend_by_length} +\title{Extend an sf linestring dataframe by a specified lengths vector} +\usage{ +extend_by_length(x, length_vector, length_col = NULL) +} +\arguments{ +\item{x}{linestring sf dataframe} + +\item{length_vector}{numeric, vector of length 'x' representing the number of meters to extend 'x' from both directions (i.e. 10 means the linestring will be extended 10m from both ends of the line)} + +\item{length_col}{character, name of the column in "x" that has the length of the linestring (meters)} +} +\value{ +sf dataframe with extended linestring geometries +} +\description{ +Extend an sf linestring dataframe by a specified lengths vector +} diff --git a/man/extend_by_percent.Rd b/man/extend_by_percent.Rd new file mode 100644 index 00000000..f400a09a --- /dev/null +++ b/man/extend_by_percent.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transects.R +\name{extend_by_percent} +\alias{extend_by_percent} +\title{Extend an sf linestring dataframe by a percent of the lines length} +\usage{ +extend_by_percent(x, pct = 0.5, length_col = NULL) +} +\arguments{ +\item{x}{linestring sf dataframe} + +\item{pct}{numeric, percent of line to extend linestring by in both directions} + +\item{length_col}{character, name of the column in "x" that has the length of the linestring (meters)} +} +\value{ +sf dataframe with extended linestring geometries +} +\description{ +Extend an sf linestring dataframe by a percent of the lines length +} diff --git a/man/extend_invalid_transects.Rd b/man/extend_invalid_transects.Rd new file mode 100644 index 00000000..52386a93 --- /dev/null +++ b/man/extend_invalid_transects.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transects.R +\name{extend_invalid_transects} +\alias{extend_invalid_transects} +\title{Extend a set of transects by a percentage based on banks and relief +Given a set of transect lines with valid_banks and has_relief columns (derived from DEM extracted cross section points), extend any transects +by a percentage of the transects length if the transect does NOT have valid banks (valid_banks == FALSE) OR it does NOT have relief (has_relief == FALSE).} +\usage{ +extend_invalid_transects(transects_to_check, net, scale = 0.5, verbose = TRUE) +} +\arguments{ +\item{transects_to_check}{sf linestrings, set of all transects in the network. Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters), "valid_banks", and "has_relief"} + +\item{net}{sf linestrings, flowline network that transects were generated from, requires "id" column (where "id" equals the "hy_id" columns in 'transects_to_check' and 'transects' )} + +\item{scale}{numeric, percentage of current transect line length to extend transects in transects_to_extend by. Default is 0.5 (50\% of the transect length)} + +\item{verbose}{logical, whether to show a progress bar and progress messages or not. Default is TRUE.} +} +\value{ +sf linestring dataframe containing the the original transects with extensions performed on transects without valid_banks OR has_relief (a "is_extended" flag denotes if the geometry was extended by "scale" \% or not) +} +\description{ +Extend a set of transects by a percentage based on banks and relief +Given a set of transect lines with valid_banks and has_relief columns (derived from DEM extracted cross section points), extend any transects +by a percentage of the transects length if the transect does NOT have valid banks (valid_banks == FALSE) OR it does NOT have relief (has_relief == FALSE). +} diff --git a/man/extend_transects.Rd b/man/extend_transects.Rd new file mode 100644 index 00000000..a3506a43 --- /dev/null +++ b/man/extend_transects.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transects.R +\name{extend_transects} +\alias{extend_transects} +\title{Extend a set of transects by a percentage} +\usage{ +extend_transects( + transects_to_extend, + transects, + net, + scale = 0.5, + verbose = TRUE +) +} +\arguments{ +\item{transects_to_extend}{sf linestrings, set of transects that should be extended (subset of 'transects'). Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters)} + +\item{transects}{sf linestrings, set of all transects in the network. Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters)} + +\item{net}{sf linestrings, flowline network that transects were generated from, requires "id" column (where "id" equals the "hy_id" columns in 'transects_to_extend' and 'transects' )} + +\item{scale}{numeric, percentage of current transect line length to extend transects in transects_to_extend by. Default is 0.5 (50\% of the transect length)} + +\item{verbose}{logical, whether to print messages or not. Default is TRUE} +} +\value{ +sf linestring dataframe containing the updates transects_to_extend (with a flag denoting if the geometry was extended by "scale" \% or not) +} +\description{ +Extend a set of transects by a percentage +} diff --git a/man/extend_transects_by_distances.Rd b/man/extend_transects_by_distances.Rd new file mode 100644 index 00000000..738b241c --- /dev/null +++ b/man/extend_transects_by_distances.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{extend_transects_by_distances} +\alias{extend_transects_by_distances} +\title{Given a set of transect lines, a flowline network, extend the transect lines out given distances from the left and right +Flowlines are required to ensure valid transect intersection relationship is maintained} +\usage{ +extend_transects_by_distances( + transects, + flowlines, + crosswalk_id, + cs_id = "cs_id", + grouping_id = "mainstem" +) +} +\arguments{ +\item{transects}{sf dataframe of linestrings, requires crosswalk_id, cs_id, grouping_id columns and numeric 'left_distance' and 'right_distance' columns} + +\item{flowlines}{sf dataframe of linestrings} + +\item{crosswalk_id}{character, column name that connects features in transects to flowlines} + +\item{cs_id}{character, column name that uniquely identifies transects within a flowline} + +\item{grouping_id}{character, column name in both transects and flowlines that denotes which flowlines are grouped with which transects.} +} +\value{ +transects sf dataframe with extended transect geometries, left and right distance columns, and flags indicating if the transect was extended in the left and/or right directions +} +\description{ +Given a set of transect lines, a flowline network, extend the transect lines out given distances from the left and right +Flowlines are required to ensure valid transect intersection relationship is maintained +} diff --git a/man/extend_transects_by_length.Rd b/man/extend_transects_by_length.Rd new file mode 100644 index 00000000..a51dcf4e --- /dev/null +++ b/man/extend_transects_by_length.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transects.R +\name{extend_transects_by_length} +\alias{extend_transects_by_length} +\title{Extend a set of transects by a percentage} +\usage{ +extend_transects_by_length( + transects_to_extend, + length_vector, + net, + verbose = TRUE +) +} +\arguments{ +\item{transects_to_extend}{sf linestrings, set of all transects in the network. Requires the following columns: "hy_id", "cs_id", "cs_lengthm" (length of geometry in meters),} + +\item{length_vector}{numeric, vector of length 'x' representing the number of meters to extend 'x' from both directions (i.e. 10 means the linestring will be extended 10m from both ends of the line)} + +\item{net}{sf linestrings, flowline network that transects were generated from, requires "id" column (where "id" equals the "hy_id" columns in 'transects_to_extend' and 'transects' )} + +\item{verbose}{logical, whether to print messages or not. Default is TRUE} +} +\value{ +sf linestring dataframe containing the updates transects_to_extend (with a flag denoting if the geometry was extended by "scale" \% or not) +} +\description{ +Extend a set of transects by a percentage +} diff --git a/man/extend_transects_to_polygons.Rd b/man/extend_transects_to_polygons.Rd new file mode 100644 index 00000000..a71c0574 --- /dev/null +++ b/man/extend_transects_to_polygons.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{extend_transects_to_polygons} +\alias{extend_transects_to_polygons} +\title{Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons} +\usage{ +extend_transects_to_polygons( + transect_lines, + polygons, + flowlines, + crosswalk_id, + intersect_group_id = NULL, + max_extension_distance = 3000 +) +} +\arguments{ +\item{transect_lines}{Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons)} + +\item{polygons}{set of sf polygons that transect lines should be exteneded} + +\item{flowlines}{set of Sf linestrings} + +\item{crosswalk_id}{character, flowline ID that matches flowlines with transect lines. This crosswalk_id must appear are a column in both flowlines and transect_lines.} + +\item{intersect_group_id}{character, name of a column in flowlines that should be used to group each transect with 1 or more flowlines. +That is, when transects are checked to make sure they don't intersect +other transects or other flowlines, this group ID will distinguise which flowlines a transect should be checked against. +The intersect_group_id must appear as a column in both flowlines and transect_lines dataframes} + +\item{max_extension_distance}{numeric, maximum distance (meters) to extend a transect line +in either direction to try and intersect one of the "polygons". Default is 3000m} +} +\value{ +sf linestring, with extended transect lines +} +\description{ +Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons +} diff --git a/man/extend_transects_to_polygons2.Rd b/man/extend_transects_to_polygons2.Rd new file mode 100644 index 00000000..369fb7d7 --- /dev/null +++ b/man/extend_transects_to_polygons2.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{extend_transects_to_polygons2} +\alias{extend_transects_to_polygons2} +\title{Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons (VERSION 2)} +\usage{ +extend_transects_to_polygons2( + transect_lines, + polygons, + flowlines, + crosswalk_id = "hy_id", + grouping_id = "mainstem", + max_extension_distance = 3000 +) +} +\arguments{ +\item{transect_lines}{Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons)} + +\item{polygons}{set of sf polygons that transect lines should be exteneded} + +\item{flowlines}{set of Sf linestrings} + +\item{crosswalk_id}{character, flowline ID that matches flowlines with transect lines. This crosswalk_id must appear are a column in both flowlines and transect_lines.} + +\item{grouping_id}{character, name of a column in flowlines that should be used to group each transect with 1 or more flowlines. +That is, when transects are checked to make sure they don't intersect +other transects or other flowlines, this group ID will distinguise which flowlines a transect should be checked against. +The intersect_group_id must appear as a column in both flowlines and transect_lines dataframes} + +\item{max_extension_distance}{numeric, maximum distance (meters) to extend a transect line +in either direction to try and intersect one of the "polygons". Default is 3000m} +} +\value{ +sf linestring, with extended transect lines +} +\description{ +Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons (VERSION 2) +} diff --git a/man/extract_dem_values.Rd b/man/extract_dem_values.Rd new file mode 100644 index 00000000..00e9f7ee --- /dev/null +++ b/man/extract_dem_values.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_pts.R +\name{extract_dem_values} +\alias{extract_dem_values} +\title{Given a set of linestrings, extract DEM values at points along the linestring} +\usage{ +extract_dem_values(cs, dem) +} +\arguments{ +\item{cs}{cross section sf object} + +\item{dem}{SpatRaster DEM or character pointing to remote DEM resource} +} +\value{ +sf dataframe with Z values extracted from DEM +} +\description{ +Given a set of linestrings, extract DEM values at points along the linestring +} diff --git a/man/fill_missing_ahg_coords.Rd b/man/fill_missing_ahg_coords.Rd new file mode 100644 index 00000000..e74b693c --- /dev/null +++ b/man/fill_missing_ahg_coords.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ahg_estimates.R +\name{fill_missing_ahg_coords} +\alias{fill_missing_ahg_coords} +\title{Generate X/Y coordinates between a set of known points within a cross section +Used after inserting AHG estimated parabolas in between DEM cross sections points} +\usage{ +fill_missing_ahg_coords(cross_section_pts) +} +\arguments{ +\item{cross_section_pts}{cross section points dataframe with missing X/Y coordinates between sets of known X/Y coordinates} +} +\value{ +dataframe, input dataframe with X/Y coordinates filled in for missing hy_id/cs_id X/Y values +} +\description{ +Generate X/Y coordinates between a set of known points within a cross section +Used after inserting AHG estimated parabolas in between DEM cross sections points +} diff --git a/man/fix_oversized_topwidths.Rd b/man/fix_oversized_topwidths.Rd new file mode 100644 index 00000000..fe1d3775 --- /dev/null +++ b/man/fix_oversized_topwidths.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ahg_estimates.R +\name{fix_oversized_topwidths} +\alias{fix_oversized_topwidths} +\title{Check that all cross sections points have a prescribed top width less than the total cross section length} +\usage{ +fix_oversized_topwidths(cross_section_pts = NULL) +} +\arguments{ +\item{cross_section_pts}{dataframe or sf dataframe with "hy_id", "cs_id", "pt_id", "Z", "relative_distance", "cs_lengthm", "class", "point_type", "TW", "DEPTH", "DINGMAN_R"} +} +\value{ +cross_section_pts dataframe with updated "top_width" and "depth" column values +} +\description{ +If a set of cross section points has a top width length that is longer than the cross sections length, then a new top width and Y max (depth) value +are given so that the estimated shape is able to properly fit into the cross sections. +The cross sections length (meters) minus 1 meter is used as the new top width and +the new Y max (depth) value is derived from the original ratio between the prescribed top width and Y max +} diff --git a/man/geos_extend_line.Rd b/man/geos_extend_line.Rd new file mode 100644 index 00000000..c72ce2ba --- /dev/null +++ b/man/geos_extend_line.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fix_transects.R +\name{geos_extend_line} +\alias{geos_extend_line} +\title{Extend a geos_geometry linestring from, one or both ends, by a given distance (meters)} +\usage{ +geos_extend_line(line, distance, dir = "both", with_crs = TRUE) +} +\arguments{ +\item{line}{sf linestring or geos_geometry linestring to extend} + +\item{distance}{numeric value in meters or a vector of length 2 if 'end = "both"' where} + +\item{dir}{character, determines whether to extend the linestring from the 'tail', 'head' or 'both' ends} + +\item{with_crs}{logical, whether a CRS should be prescribed to extended output geos_geometry linestring} +} +\value{ +geos_geometry linestring extended by 'distance' from either the 'head', 'tail' or 'both' ends of the original linestring +} +\description{ +Extend a geos_geometry linestring from, one or both ends, by a given distance (meters) +} diff --git a/man/get_ahg_parabolas.Rd b/man/get_ahg_parabolas.Rd new file mode 100644 index 00000000..e12afb3a --- /dev/null +++ b/man/get_ahg_parabolas.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ahg_estimates.R +\name{get_ahg_parabolas} +\alias{get_ahg_parabolas} +\title{Get the AHG estimated parabolas for each hy_id/cs_id cross section given a set of cross section points} +\usage{ +get_ahg_parabolas(cross_section_pts = NULL) +} +\arguments{ +\item{cross_section_pts}{dataframe or sf dataframe with "hy_id", "cs_id", "bottom" columns and +specififed "top_width", "depth", "dingman_r" columns (see top_width, depth, and dingman_r arguments)} +} +\value{ +dataframe with a set of AHG points for each hy_id/cs_id in the input data, with AHG estimated X, Y, A point values that form a parabola +} +\description{ +Get the AHG estimated parabolas for each hy_id/cs_id cross section given a set of cross section points +} diff --git a/man/get_bank_attributes.Rd b/man/get_bank_attributes.Rd new file mode 100644 index 00000000..2e5eebe5 --- /dev/null +++ b/man/get_bank_attributes.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_bank_attributes} +\alias{get_bank_attributes} +\title{Get attributes about the banks of each cross section in a dataframe of cross section points +Given a set of cross section points with point_type column, return a dataframe of the unique hy_id/cs_ids with the following calculated columns: +"bottom", "left_bank", "right_bank" columns which are the Z values of the "lowest" bottom point, and the "highest" left and right bank Z values, respectively. +And a "valid_banks" column indicating whether the hy_id/cs_id set of cross section point has at least a signle bottom point with +at least 1 left bank point AND 1 right bank point that are above the lowest "bottom" point.} +\usage{ +get_bank_attributes(classified_pts) +} +\arguments{ +\item{classified_pts}{sf or dataframe of points with "hy_id", "cs_id", and "point_type" columns. Output of hydrofabric3D::classify_pts()} +} +\value{ +dataframe with each row being a unique hy_id/cs_id with "bottom", "left_bank", "right_bank", and "valid_banks" values for each hy_id/cs_id. +} +\description{ +Get attributes about the banks of each cross section in a dataframe of cross section points +Given a set of cross section points with point_type column, return a dataframe of the unique hy_id/cs_ids with the following calculated columns: +"bottom", "left_bank", "right_bank" columns which are the Z values of the "lowest" bottom point, and the "highest" left and right bank Z values, respectively. +And a "valid_banks" column indicating whether the hy_id/cs_id set of cross section point has at least a signle bottom point with +at least 1 left bank point AND 1 right bank point that are above the lowest "bottom" point. +} diff --git a/man/get_coords_around_parabola.Rd b/man/get_coords_around_parabola.Rd new file mode 100644 index 00000000..d5c00531 --- /dev/null +++ b/man/get_coords_around_parabola.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ahg_estimates.R +\name{get_coords_around_parabola} +\alias{get_coords_around_parabola} +\title{Get the coordinates surrounding a set of missing AHG X/Y coordinates.} +\usage{ +get_coords_around_parabola(cross_section_pts) +} +\arguments{ +\item{cross_section_pts}{dataframe with cross section points, (required cols, "hy_id", "cs_id", "X", "Y", "is_dem_point")} +} +\value{ +dataframe with each hy_id/cs_id cross section containing a value for X_start, X_end, Y_start, Y_end, representing the points surrounding the AHG inserted points +} +\description{ +Get the coordinates surrounding a set of missing AHG X/Y coordinates. +} diff --git a/man/get_cs_bottom_length.Rd b/man/get_cs_bottom_length.Rd new file mode 100644 index 00000000..44e861ca --- /dev/null +++ b/man/get_cs_bottom_length.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_cs_bottom_length} +\alias{get_cs_bottom_length} +\title{Calculate the length between the leftmost and rightmost bottom point in each cross section} +\usage{ +get_cs_bottom_length(cross_section_pts) +} +\arguments{ +\item{cross_section_pts}{dataframe, or sf dataframe of cross section points} +} +\value{ +summarized dataframe of input cross_section_pts dataframe with a bottom_length value for each hy_id/cs_id +} +\description{ +Calculate the length between the leftmost and rightmost bottom point in each cross section +} diff --git a/man/get_extensions_by_id.Rd b/man/get_extensions_by_id.Rd new file mode 100644 index 00000000..5b31ea27 --- /dev/null +++ b/man/get_extensions_by_id.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{get_extensions_by_id} +\alias{get_extensions_by_id} +\title{Get the left and right extension distances for a set of transects out to a set of polygons} +\usage{ +get_extensions_by_id(transects, polygons, crosswalk_id, max_extension_distance) +} +\arguments{ +\item{transects}{sf linestring dataframe} + +\item{polygons}{sf polygon dataframe} + +\item{crosswalk_id}{character} + +\item{max_extension_distance}{numeric} +} +\value{ +data.frame or tibble +} +\description{ +Get the left and right extension distances for a set of transects out to a set of polygons +} diff --git a/man/get_lines_extended_to_geoms.Rd b/man/get_lines_extended_to_geoms.Rd new file mode 100644 index 00000000..1bdad75c --- /dev/null +++ b/man/get_lines_extended_to_geoms.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{get_lines_extended_to_geoms} +\alias{get_lines_extended_to_geoms} +\title{Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within} +\usage{ +get_lines_extended_to_geoms( + geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500, + verbose = FALSE +) +} +\arguments{ +\item{geos_geoms}{list of geos_geometrys} + +\item{ids}{character vector} + +\item{lines_to_cut}{geos_linestrings} + +\item{lines_to_cut_indices}{numeric vector} + +\item{direction}{character, either "head", "tail" or "both"} + +\item{max_extension_distance}{numeric} + +\item{verbose}{logical, whether to print messages or not. Default is FALSE} +} +\value{ +geos_geometry vector of extended linestrings where extension was needed/possible, return vector is same length as number of input 'ids' +} +\description{ +Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +} diff --git a/man/get_lines_extended_to_geoms_subset.Rd b/man/get_lines_extended_to_geoms_subset.Rd new file mode 100644 index 00000000..1644c5e4 --- /dev/null +++ b/man/get_lines_extended_to_geoms_subset.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{get_lines_extended_to_geoms_subset} +\alias{get_lines_extended_to_geoms_subset} +\title{Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +Version of get_lines_extended_to_geoms() but only iterates through the IDs/geometries that are predetermined to be WITHIN A POLYGON} +\usage{ +get_lines_extended_to_geoms_subset( + geos_geoms, + ids, + lines_to_cut, + lines_to_cut_indices, + direction = "head", + max_extension_distance = 2500, + verbose = FALSE +) +} +\arguments{ +\item{geos_geoms}{list of geos_geometrys} + +\item{ids}{character vector} + +\item{lines_to_cut}{geos_linestrings} + +\item{lines_to_cut_indices}{numeric vector} + +\item{direction}{character, either "head", "tail" or "both"} + +\item{max_extension_distance}{numeric} + +\item{verbose}{logical, whether to print messages or not. Default is FALSE} +} +\value{ +geos_geometry vector of extended linestrings for the geometries within the lines to cut +} +\description{ +Calculate the minimum distance a line would need to extend to reach the boundary of the polygon/line that the input geometries are entirely within +Version of get_lines_extended_to_geoms() but only iterates through the IDs/geometries that are predetermined to be WITHIN A POLYGON +} diff --git a/man/get_point_type_counts.Rd b/man/get_point_type_counts.Rd new file mode 100644 index 00000000..1236f50e --- /dev/null +++ b/man/get_point_type_counts.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_point_type_counts} +\alias{get_point_type_counts} +\title{Get the count of each point type in a set of cross section points} +\usage{ +get_point_type_counts(classified_pts) +} +\arguments{ +\item{classified_pts}{dataframe or sf dataframe, cross section points with a "hy_id", and "cs_id" columns as well asa 'point_type' column containing the values: "bottom", "left_bank", "right_bank", and "channel"} +} +\value{ +dataframe or sf dataframe with hy_id, cs_id, and _count columns for each point_type +} +\description{ +get_point_type_counts() will create a dataframe providing the counts of every point_type for each hy_id/cs_id in a set of classified cross section points (output of classify_pts()) +} diff --git a/man/get_relief.Rd b/man/get_relief.Rd new file mode 100644 index 00000000..139d318a --- /dev/null +++ b/man/get_relief.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_relief} +\alias{get_relief} +\title{Get relief attributes from a dataframe of cross sections points +Generate a dataframe from a set of classified cross section points indicating whether a cross section "has relief". +Relief is determined by checking each set of cross section points have a left OR right bank that has a depth difference from the bottom that is +greater than or equal to a percentage of the cross section length (e.g. Assuming a 'pct_of_length_for_relief' of 0.01 (1\%) of a 100m cross section would have a relief depth threshold of 1m)} +\usage{ +get_relief(classified_pts, pct_of_length_for_relief = 0.01, detailed = FALSE) +} +\arguments{ +\item{classified_pts}{sf or dataframe of points with "hy_id", "cs_id", "cs_lengthm", and "point_type" columns. Output of hydrofabric3D::classify_pts()} + +\item{pct_of_length_for_relief}{numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1\% of the cross sections length).} + +\item{detailed}{logical, whether to return only a the "has_relief" column or +include all derived relief based columns such as "max_relief" and the "pct_of_length_for_relief" used. Default is FALSE and returns a dataframe with only "hy_id", "cs_id", and "has_relief".} +} +\value{ +dataframe with each row being a unique hy_id/cs_id with a "has_relief" value for each hy_id/cs_id. If detailed = TRUE, then the output dataframe will include the following additional columns: "cs_lengthm", "max_relief", "pct_of_length_for_relief". +} +\description{ +Get relief attributes from a dataframe of cross sections points +Generate a dataframe from a set of classified cross section points indicating whether a cross section "has relief". +Relief is determined by checking each set of cross section points have a left OR right bank that has a depth difference from the bottom that is +greater than or equal to a percentage of the cross section length (e.g. Assuming a 'pct_of_length_for_relief' of 0.01 (1\%) of a 100m cross section would have a relief depth threshold of 1m) +} diff --git a/man/get_transect_extension_distances_to_polygons.Rd b/man/get_transect_extension_distances_to_polygons.Rd new file mode 100644 index 00000000..2fa08f79 --- /dev/null +++ b/man/get_transect_extension_distances_to_polygons.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{get_transect_extension_distances_to_polygons} +\alias{get_transect_extension_distances_to_polygons} +\title{Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons +DEPRECATED at this point, will delete on next version} +\usage{ +get_transect_extension_distances_to_polygons( + transect_lines, + polygons, + flines, + max_extension_distance +) +} +\arguments{ +\item{transect_lines}{Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons)} + +\item{polygons}{set of sf polygons that transect lines should be exteneded} + +\item{flines}{set of Sf linestrings} + +\item{max_extension_distance}{numeric, maximum distance (meters) to extend a transect line in either direction to try and intersect one of the "polygons"} +} +\value{ +sf linestring, with extended transect lines +} +\description{ +Give a set of transecct linestrings and poylgons and get the minimum distance to extend each transect line (from both directions, to try and reach the edge of a "polygons") +WIP/internal function for extending transect lines out to FEMA 100 year flood plain polygons +DEPRECATED at this point, will delete on next version +} diff --git a/man/get_unique_tmp_ids.Rd b/man/get_unique_tmp_ids.Rd new file mode 100644 index 00000000..66cf5c5a --- /dev/null +++ b/man/get_unique_tmp_ids.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_unique_tmp_ids} +\alias{get_unique_tmp_ids} +\title{Get a list of unique tmp_ids in a dataframe} +\usage{ +get_unique_tmp_ids(df, x = hy_id, y = cs_id) +} +\arguments{ +\item{df}{dataframe with x and y as columns, with an optional "tmp_id" column, otherwise a tmp_id will be created from x_y} + +\item{x}{The name of the column in df to make up the first part of the added tmp_id column (tmp_id = x_y). Default is hy_id.} + +\item{y}{The name of the column in df to make up the second part of the added tmp_id column (tmp_id = x_y). Default is cs_id.} +} +\value{ +character vector of unique "tmp_id" values in the given dataframe +} +\description{ +Dataframe can have "tmp_id" column already or the columns can be specified with 'x' and 'y' arguments +} diff --git a/man/improve_invalid_cs.Rd b/man/improve_invalid_cs.Rd new file mode 100644 index 00000000..fe95afac --- /dev/null +++ b/man/improve_invalid_cs.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{improve_invalid_cs} +\alias{improve_invalid_cs} +\title{Check and fix cross section points with limited variation in Z values (without removing any flowlines)} +\usage{ +improve_invalid_cs( + cs_pts = NULL, + net = NULL, + transects = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = + "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5, + pct_of_length_for_relief = 0.01, + fix_ids = FALSE, + verbose = TRUE +) +} +\arguments{ +\item{cs_pts}{sf dataframe or dataframe of cross section points from cross_section_pts() followed by classify_points()} + +\item{net}{Hydrographic LINESTRING Network} + +\item{transects}{character, Hydrographic LINESTRING of transects along hydrographic (net) network} + +\item{points_per_cs}{the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected.} + +\item{min_pts_per_cs}{Minimun number of points per cross section required.} + +\item{dem}{the DEM to extract data from} + +\item{scale}{numeric, If a transect line DEM extraction results in all equal Z values, +by what percent of the transect lines length (meters) should the transect line be +extended in both directions to try to capture representative Z values ? Default is 0.5 (50\% of the transect length)} + +\item{pct_of_length_for_relief}{numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1\% of the cross sections length).} + +\item{fix_ids}{logical, whether to reenumerate the "cs_id" column to +make sure cross sections are number 1 - number of total cross sections on flowline. Default is FALSE, cs_id will be kept as +they were in the input data and may contain gaps between cs_ids within a flowline (hy_id). +WARNING: Setting fix_ids = TRUE may result in input cross section points (cross_section_pts) having DIFFERENT cs_id values as the input transects (cs) +and the inconsistency can cause problems when trying to cross walk between the datasets in the future.} + +\item{verbose}{logical, whether to print messages or not. Default is TRUE} +} +\value{ +sf object of cross section points based on extended transects to try and improve the number of points with "valid_banks" and "has_relief" +} +\description{ +Duplicate process as rectify_cs() but does NOT remove any cross sections, only attempts to extend transects and improve cross sections. This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (transects). +This function assumes the cross section points have been classified via "classify_points()" and have "has_relief" and "valid_banks" logical columns. +This function will look for cross section points that either have no relief or don't have valid banks, then the transect lines that generated these cross section points +are extended and new points are extracted along the newly extended, longer transect line. The newly extracted points are checked for relief AND valid banks and +are removed if they still have no relief or don't have valid banks. Any new points that became valid as a result of the extension process are added to the original dataset +and the rectified set of cross section points will be returned with an "is_extended" logical flag, indicating if the transect line that generated the cross section points was extended. +Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values. +} diff --git a/man/is_valid_transect_line.Rd b/man/is_valid_transect_line.Rd new file mode 100644 index 00000000..f9c35796 --- /dev/null +++ b/man/is_valid_transect_line.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{is_valid_transect_line} +\alias{is_valid_transect_line} +\title{Check if an updated transect line is valid relative to the other transects and flowlines in the network +The 'transect_to_check' should be 'used' (i.e. function returns TRUE) if +the 'transect_to_check' does NOT interesect any other transects ('transect_lines') AND it only intersects a single flowline ONCE. +If the 'transect_to_check' intersects ANY other transects OR intersects a flowline more +than once (OR more than one flowline in the network) then the function returns FALSE.} +\usage{ +is_valid_transect_line(transect_to_check, trans, flines) +} +\arguments{ +\item{transect_to_check}{geos_geometry, linestring} + +\item{trans}{geos_geometry, linestring} + +\item{flines}{geos_geometry, linestring} +} +\value{ +TRUE if the extension should be used, FALSE if it shouldn't be used +} +\description{ +Check if an updated transect line is valid relative to the other transects and flowlines in the network +The 'transect_to_check' should be 'used' (i.e. function returns TRUE) if +the 'transect_to_check' does NOT interesect any other transects ('transect_lines') AND it only intersects a single flowline ONCE. +If the 'transect_to_check' intersects ANY other transects OR intersects a flowline more +than once (OR more than one flowline in the network) then the function returns FALSE. +} diff --git a/man/make_line_from_start_and_end_pts.Rd b/man/make_line_from_start_and_end_pts.Rd new file mode 100644 index 00000000..01927d91 --- /dev/null +++ b/man/make_line_from_start_and_end_pts.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{make_line_from_start_and_end_pts} +\alias{make_line_from_start_and_end_pts} +\title{Given 2 geos_geometry point geometries, create a line between the 2 points} +\usage{ +make_line_from_start_and_end_pts(start, end, line_crs) +} +\arguments{ +\item{start}{geos_geoemtry, point} + +\item{end}{geos_geoemtry, point} + +\item{line_crs}{crs} +} +\value{ +geos_geometry linestring +} +\description{ +Given 2 geos_geometry point geometries, create a line between the 2 points +} diff --git a/man/make_progress_bar.Rd b/man/make_progress_bar.Rd new file mode 100644 index 00000000..85662f95 --- /dev/null +++ b/man/make_progress_bar.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{make_progress_bar} +\alias{make_progress_bar} +\title{Make a progress bar and return an "make_progress()" function to update the progress bar. +Credit to the exactextractr team: https://github.com/isciences/exactextractr/blob/5fd17dcf02717332b125345aea586304f668cf12/R/exact_extract_helpers.R#L361} +\usage{ +make_progress_bar(progress, n) +} +\arguments{ +\item{progress}{logical, whether to make a progress bar or not (FALSE)} + +\item{n}{numeric, total number of iterations} +} +\value{ +make_progress function, when called will increment the progress bar text +} +\description{ +Make a progress bar and return an "make_progress()" function to update the progress bar. +Credit to the exactextractr team: https://github.com/isciences/exactextractr/blob/5fd17dcf02717332b125345aea586304f668cf12/R/exact_extract_helpers.R#L361 +} +\examples{ +progress=TRUE +x = 1:500000 +make_progress <- make_progress_bar(progress, length(x)) +for (i in 1:length(x)) { + make_progress() +} +} diff --git a/man/move_geometry_to_last.Rd b/man/move_geometry_to_last.Rd new file mode 100644 index 00000000..911c4456 --- /dev/null +++ b/man/move_geometry_to_last.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{move_geometry_to_last} +\alias{move_geometry_to_last} +\title{Move Geometry Column to the last column position} +\usage{ +move_geometry_to_last(df) +} +\arguments{ +\item{df}{A dataframe or an sf dataframe.} +} +\value{ +Returns the input dataframe with the geometry column moved to the last position if it exists. Otherwise, returns the input dataframe as is. +} +\description{ +Internal utility function for taking a dataframe or an sf dataframe, checks for the existence of a geometry type column, and +if it exists, moves it to the last column. If no geometry column exists, it returns the input dataframe as is. +} +\examples{ +\dontrun{ +# Create a dataframe +df <- data.frame(x = c(1, 2, 3), y = c(4, 5, 6)) +# Add a geometry column (sf dataframe) +df_sf <- sf::st_sf(df, geometry = sf::st_sfc(sf::st_point(c(1, 2, 3)))) +# move column +df_sf <- dplyr::relocate(df_sf, x, geometry, y) +df_sf # geometry column should be move to the middle column +# Move geometry column to last position +df_sf_moved <- move_geometry_to_last(df_sf) +df_sf_moved # geometry column should be move the end column +} +} diff --git a/man/needs_rectification.Rd b/man/needs_rectification.Rd new file mode 100644 index 00000000..3a56755b --- /dev/null +++ b/man/needs_rectification.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{needs_rectification} +\alias{needs_rectification} +\title{Check if there transects without valid banks or relief} +\usage{ +needs_rectification(transects) +} +\arguments{ +\item{transects}{sf linestring with "valid_banks" and "has_relief" logical columns} +} +\value{ +logical, TRUE if there are transects without valid banks or relief +} +\description{ +Check if there transects without valid banks or relief +} diff --git a/man/pct_pts_near_bottom.Rd b/man/pct_pts_near_bottom.Rd new file mode 100644 index 00000000..36e455d2 --- /dev/null +++ b/man/pct_pts_near_bottom.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{pct_pts_near_bottom} +\alias{pct_pts_near_bottom} +\title{Calculate percentage of points within a set of cross section points that are near the bottom of the cross section +Adds the following columns: +is_near_bottom: state whether a point is near the bottom of the cross section (within a specified distance threshold of the bottom), +pts_near_bottom: count of points near the bottom of the cross section +pct_near_bottom: percent of points near the bottom of the cross section} +\usage{ +pct_pts_near_bottom( + cs_pts, + distance_from_bottom = 1, + look_only_above_bottom = TRUE, + total_from_bottom_up = FALSE +) +} +\arguments{ +\item{cs_pts}{sf dataframe of cross section points (output of cross_section_pts() function)} + +\item{distance_from_bottom}{numeric, distance threshold (in meters) to determine if a point is near the bottom of the cross section} + +\item{look_only_above_bottom}{logical, whether to look only at points ABOVE the channel bottom as points that can be classified as "near bottom".} + +\item{total_from_bottom_up}{logical, whether to use only points ABOVE bottom points as part of total points for calculating percentage of points near bottom. Default is FALSE and ALL points will be used when calculating percentage, even if a point has a Z value BELOW the bottom, but is NOT classified as a bottom point} +} +\value{ +sf dataframe of cross section points with the added columns described above +} +\description{ +Calculate percentage of points within a set of cross section points that are near the bottom of the cross section +Adds the following columns: +is_near_bottom: state whether a point is near the bottom of the cross section (within a specified distance threshold of the bottom), +pts_near_bottom: count of points near the bottom of the cross section +pct_near_bottom: percent of points near the bottom of the cross section +} diff --git a/man/pick_extension_pts.Rd b/man/pick_extension_pts.Rd new file mode 100644 index 00000000..8c99aedd --- /dev/null +++ b/man/pick_extension_pts.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{pick_extension_pts} +\alias{pick_extension_pts} +\title{Decide the start and end points for the final transect line given two extended versions of the same transect +Requires two logicals indicating what to do with the extensions (these are decided by checking for intersections with the rest of the network) +Internal helper function} +\usage{ +pick_extension_pts(left_extension, right_extension, use_left, use_right) +} +\arguments{ +\item{left_extension}{geos_geometry linestring} + +\item{right_extension}{geos_geometry linestring} + +\item{use_left}{logical, do we use the left extension} + +\item{use_right}{logical, do we use the right extension} +} +\value{ +geos_geometry points, the start and end point of the final extension line +} +\description{ +Decide the start and end points for the final transect line given two extended versions of the same transect +Requires two logicals indicating what to do with the extensions (these are decided by checking for intersections with the rest of the network) +Internal helper function +} diff --git a/man/plot_cs_pts.Rd b/man/plot_cs_pts.Rd new file mode 100644 index 00000000..863f34cb --- /dev/null +++ b/man/plot_cs_pts.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_visualization.R +\name{plot_cs_pts} +\alias{plot_cs_pts} +\title{Plots an X-Y scatter plot of cross section points} +\usage{ +plot_cs_pts(cs_pts, x = "pt_id", y = "Z", color = NULL, grid = FALSE) +} +\arguments{ +\item{cs_pts}{data.frame of cross section points with columns hy_id, cs_id and columns for X and Y axises (i.e. "pt_id", "Z")} + +\item{x}{character name of column in cs_pts to use for X axis} + +\item{y}{character name of column in cs_pts to use for Y axis} + +\item{color}{character name of column in cs_pts to color points on plot} + +\item{grid}{logical, if TRUE then use facet_grid, otherwise use facet_wrap. Default is FALSE (uses facet_wrap)} +} +\value{ +ggplot2 object +} +\description{ +Plots an X-Y scatter plot of cross section points +} diff --git a/man/pts_to_reevaluate.Rd b/man/pts_to_reevaluate.Rd new file mode 100644 index 00000000..73cb2f27 --- /dev/null +++ b/man/pts_to_reevaluate.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{pts_to_reevaluate} +\alias{pts_to_reevaluate} +\title{Get a dataframe of points that should be evaluated due to their proximity (nearness in Z distance) to the bottom} +\usage{ +pts_to_reevaluate(cs_pts, threshold = 1, pct_threshold = 0.99) +} +\arguments{ +\item{cs_pts}{dataframe/sf dataframe of cross section points (requires hy_id, cs_id, and Z values)} + +\item{threshold}{numeric, threshold distance in meters for points to be considered "near the bottom". Default is 1 meter (i.e. check if points are within 1 meter above the bottom)} + +\item{pct_threshold}{numeric, threshold percent of points in the cross section that are within threshold of bottom to +determine whether point should be considered for re evaluation. Default is 0.99 (i.e. 99\% of points are near the bottom). Default is 0.99 (i.e. 99&\%).} +} +\value{ +dataframe with the hy_id, cs_id, pts_near_bottom (count of pts_near_bottom), and pct_near_bottom (\% of points in cross section that are near bottom). +An empty dataframe is returned if ZERO points are classified as "near the bottom" +} +\description{ +Get a dataframe of points that should be evaluated due to their proximity (nearness in Z distance) to the bottom +} diff --git a/man/rectify_cs.Rd b/man/rectify_cs.Rd new file mode 100644 index 00000000..bd8d710f --- /dev/null +++ b/man/rectify_cs.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{rectify_cs} +\alias{rectify_cs} +\title{Check and fix cross section points with limited variation in Z values (version 2 latest)} +\usage{ +rectify_cs( + cs_pts = NULL, + net = NULL, + transects = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = + "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5, + pct_of_length_for_relief = 0.01, + fix_ids = FALSE, + verbose = TRUE +) +} +\arguments{ +\item{cs_pts}{sf dataframe or dataframe of cross section points from cross_section_pts() followed by classify_points()} + +\item{net}{Hydrographic LINESTRING Network} + +\item{transects}{character, Hydrographic LINESTRING of transects along hydrographic (net) network} + +\item{points_per_cs}{the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected.} + +\item{min_pts_per_cs}{Minimun number of points per cross section required.} + +\item{dem}{the DEM to extract data from} + +\item{scale}{numeric, If a transect line DEM extraction results in all equal Z values, +by what percent of the transect lines length (meters) should the transect line be +extended in both directions to try to capture representative Z values ? Default is 0.5 (50\% of the transect length)} + +\item{pct_of_length_for_relief}{numeric, percent of cs_lengthm to use as the threshold depth for classifying whether a cross section has "relief". Default is 0.01 (1\% of the cross sections length).} + +\item{fix_ids}{logical, whether to reenumerate the "cs_id" column to +make sure cross sections are number 1 - number of total cross sections on flowline. Default is FALSE, cs_id will be kept as +they were in the input data and may contain gaps between cs_ids within a flowline (hy_id). +WARNING: Setting fix_ids = TRUE may result in input cross section points (cs_pts) having DIFFERENT cs_id values as the input transects (cs) +and the inconsistency can cause problems when trying to cross walk between the datasets in the future.} + +\item{verbose}{logical, whether to print messages or not. Default is TRUE} +} +\value{ +sf object of cs_pts with only cross sections points that have relief and have valid banks, other points that don't meet this condition are removed +} +\description{ +This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (transects). +This function assumes the cross section points have been classified via "classify_points()" and have "has_relief" and "valid_banks" logical columns. +This function will look for cross section points that either have no relief or don't have valid banks, then the transect lines that generated these cross section points +are extended and new points are extracted along the newly extended, longer transect line. The newly extracted points are checked for relief AND valid banks and +are removed if they still have no relief or don't have valid banks. Any new points that became valid as a result of the extension process are added to the original dataset +and the rectified set of cross section points will be returned with an "is_extended" logical flag, indicating if the transect line that generated the cross section points was extended. +Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values. +} diff --git a/man/rectify_flat_cs.Rd b/man/rectify_flat_cs.Rd new file mode 100644 index 00000000..25e05ba2 --- /dev/null +++ b/man/rectify_flat_cs.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{rectify_flat_cs} +\alias{rectify_flat_cs} +\title{Check and fix cross section points with limited variation in Z values (version 2 latest) +This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (cs). +The function that looks at the cross section points and identifies cross sections that are "flat" +(have a percent of all points in the cross section within a threshold distance from the bottom of the cross section). +The transect lines that generated the "flat" cross section points are then extended and new points are extracted +along this new longer transect line. The newly extracted points are checked for "flatness" and are removed if they are still "flat", otherwise the original dataset +of points is updated with the new set of point derived from an extended transect line. +Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values.} +\usage{ +rectify_flat_cs( + cs_pts = NULL, + net = NULL, + cs = NULL, + points_per_cs = NULL, + min_pts_per_cs = 10, + dem = + "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt", + scale = 0.5, + threshold = 0, + pct_threshold = 0.99, + fix_ids = FALSE +) +} +\arguments{ +\item{cs_pts}{Output from extract_dem_values_first} + +\item{net}{Hydrographic LINESTRING Network} + +\item{cs}{character, Hydrographic LINESTRING Network file path} + +\item{points_per_cs}{the desired number of points per CS. If NULL, then approximently 1 per grid cell resultion of DEM is selected.} + +\item{min_pts_per_cs}{Minimun number of points per cross section required.} + +\item{dem}{the DEM to extract data from} + +\item{scale}{numeric, If a transect line DEM extraction results in all equal Z values, +by what percent of the transect lines length (meters) should the transect line be +extended in both directions to try to capture representative Z values ? Default is 0.5 (50\% of the transect length)} + +\item{threshold}{numeric, threshold Z value (meters) that determines if a cross section is flat. +A threshold = 0 means if all Z values are the same, then the cross section is considered flat. +A threshold value of 1 means that any cross section with Z values all within 1 meter of eachother, is considered flat. Default is 0.} + +\item{pct_threshold}{numeric, threshold percent of points in the cross section that are within threshold of bottom to +determine whether point should be considered for re evaluation. Default is 0.99 (i.e. 99\% of points are near the bottom)} + +\item{fix_ids}{logical, whether to reenumerate the "cs_id" column to +make sure cross sections are number 1 - number of total cross sections on flowline. Default is FALSE, cs_id will be kept as +they were in the input data and may contain gaps between cs_ids within a flowline (hy_id). +WARNING: Setting fix_ids = TRUE may result in input cross section points (cs_pts) having DIFFERENT cs_id values as the input transects (cs) +and the inconsistency can cause problems when trying to cross walk between the datasets in the future.} +} +\value{ +sf object of cs_pts with "flat" cross sections removed/updated with longer transects to capture more Z data +} +\description{ +Check and fix cross section points with limited variation in Z values (version 2 latest) +This function takes in a set of cross section points (cs_pts), a flowline network (net) and a set of transects lines for that flowline network (cs). +The function that looks at the cross section points and identifies cross sections that are "flat" +(have a percent of all points in the cross section within a threshold distance from the bottom of the cross section). +The transect lines that generated the "flat" cross section points are then extended and new points are extracted +along this new longer transect line. The newly extracted points are checked for "flatness" and are removed if they are still "flat", otherwise the original dataset +of points is updated with the new set of point derived from an extended transect line. +Improved function for rectifying cross section points with flat Z values by extending transect lines and reevaluating the new DEM values. +} diff --git a/man/rectify_summary.Rd b/man/rectify_summary.Rd new file mode 100644 index 00000000..9fc39524 --- /dev/null +++ b/man/rectify_summary.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{rectify_summary} +\alias{rectify_summary} +\title{Makes a summaru dataframe and print out of differences between 2 cross section points dataframes} +\usage{ +rectify_summary(input_points, output_points, verbose = TRUE) +} +\arguments{ +\item{input_points}{sf dataframe or dataframe of cross section points} + +\item{output_points}{sf dataframe or dataframe of cross section points, with "is_extended" logical column} + +\item{verbose}{logical, whether to print out summary message/ Default is TRUE} +} +\value{ +dataframe +} +\description{ +Convenience function for printing out the difference between a cross section point dataframe and +the resulting output of putting that dataframe through the rectify_cs() function +} diff --git a/man/remove_cols_from_df.Rd b/man/remove_cols_from_df.Rd new file mode 100644 index 00000000..c969138e --- /dev/null +++ b/man/remove_cols_from_df.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{remove_cols_from_df} +\alias{remove_cols_from_df} +\title{Remove specified columns from a dataframe if they exist.} +\usage{ +remove_cols_from_df(df, columns_to_remove) +} +\arguments{ +\item{df}{A dataframe.} + +\item{columns_to_remove}{character vector specifying the names of columns to be removed.} +} +\value{ +dataframe with specified columns removed if they exist. +} +\description{ +Remove specified columns from a dataframe if they exist. +} diff --git a/man/renumber_cs_ids.Rd b/man/renumber_cs_ids.Rd new file mode 100644 index 00000000..5acb4f38 --- /dev/null +++ b/man/renumber_cs_ids.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cs_rectify.R +\name{renumber_cs_ids} +\alias{renumber_cs_ids} +\title{Fix IDs in a dataframe} +\usage{ +renumber_cs_ids(df) +} +\arguments{ +\item{df}{A dataframe containing hy_id and cs_id columns.} +} +\value{ +The input dataframe with renumbered cs_id values. +} +\description{ +This function renumbers cross section IDs in a dataframe to ensure each hy_id has cross sections +numbered from 1 to the total number of cross sections on the hy_id. +} diff --git a/man/subset_polygons_in_transects.Rd b/man/subset_polygons_in_transects.Rd new file mode 100644 index 00000000..381cba3f --- /dev/null +++ b/man/subset_polygons_in_transects.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{subset_polygons_in_transects} +\alias{subset_polygons_in_transects} +\title{Get polygons that intersect with the transects} +\usage{ +subset_polygons_in_transects(transect_lines, polygons) +} +\arguments{ +\item{transect_lines}{Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons)} + +\item{polygons}{set of sf polygons that transect lines should be exteneded} +} +\value{ +sf polygon dataframe +} +\description{ +Get polygons that intersect with the transects +} diff --git a/man/subset_transects_in_polygons.Rd b/man/subset_transects_in_polygons.Rd new file mode 100644 index 00000000..0f5549ca --- /dev/null +++ b/man/subset_transects_in_polygons.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fema_utils.R +\name{subset_transects_in_polygons} +\alias{subset_transects_in_polygons} +\title{Get transects that intersect with the polygons} +\usage{ +subset_transects_in_polygons(transect_lines, polygons) +} +\arguments{ +\item{transect_lines}{Set of Sf linestrigns to extend (only if the transect lines are ENTIRELLY within a polygons)} + +\item{polygons}{set of sf polygons that transect lines should be exteneded} +} +\value{ +sf linestring, with extended transect lines +} +\description{ +Get transects that intersect with the polygons +} diff --git a/man/validate_cut_cross_section_inputs.Rd b/man/validate_cut_cross_section_inputs.Rd new file mode 100644 index 00000000..3d2c472e --- /dev/null +++ b/man/validate_cut_cross_section_inputs.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{validate_cut_cross_section_inputs} +\alias{validate_cut_cross_section_inputs} +\title{Validate Inputs for cut_cross_sections Function} +\usage{ +validate_cut_cross_section_inputs( + net, + id, + cs_widths, + num, + smooth, + densify, + rm_self_intersect, + fix_braids, + terminal_id, + braid_threshold, + version, + braid_method, + precision, + add +) +} +\arguments{ +\item{net}{An sf object representing the hydrographic network.} + +\item{id}{A unique identifier column in the network data.} + +\item{cs_widths}{Bankfull widths (length of cross sections) for each network element.} + +\item{num}{Number of transects per network element.} + +\item{smooth}{Logical, whether to smooth linestring geometries or not.} + +\item{densify}{Numeric, the factor by which to densify the linestrings.} + +\item{rm_self_intersect}{Logical, whether to remove self-intersecting transect linestrings.} + +\item{fix_braids}{Logical, whether to fix braided transect lines or not.} + +\item{terminal_id}{Character, column name containing a unique identifier delineating separate networks in the 'net' dataset.} + +\item{braid_threshold}{Numeric, the total length of all flowlines in a braid below which fix_braid_transects should operate.} + +\item{version}{Integer, version number of braid algorithm to use, either 1 or 2. Default is 2.} + +\item{braid_method}{Character, the method to determine the geometries to cut. Options are "comid", "component", or "neighbor". Default is "comid".} + +\item{precision}{Numeric, the number of meters to approximate final cross-section linestring length.} + +\item{add}{Logical, indicating whether to add original 'net' data to the outputted transect lines.} +} +\value{ +NULL if inputs are valid; otherwise, an error is thrown. +} +\description{ +This function validates the inputs for the cut_cross_sections function to ensure they meet the required criteria. +} +\keyword{internal} diff --git a/runners/.DS_Store b/runners/.DS_Store deleted file mode 100644 index 17b6f9a1..00000000 Binary files a/runners/.DS_Store and /dev/null differ diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 00000000..1950f692 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(hydrofabric3D) + +testthat::test_check("hydrofabric3D") diff --git a/tests/testthat/test-add-points-per-cs.R b/tests/testthat/test-add-points-per-cs.R new file mode 100644 index 00000000..51826092 --- /dev/null +++ b/tests/testthat/test-add-points-per-cs.R @@ -0,0 +1,74 @@ + + +library(testthat) +library(dplyr) +library(sf) +# library(hydrofabric3D) + +# ------------------------------------------------------------------- +# ---- hydrofabric3D::add_points_per_cs() ---- +# ------------------------------------------------------------------- + +# create test data (hy_id = "wb-1004970" from nextgen flowlines) +coords <- matrix(c(968520.8, 1381795, 968471.3, 1381851, 968420.6, 1381874, + 968418.1, 1381897, 968436.2, 1381961, 968426.9, 1382022, + 968412.6, 1382036, 968211.2, 1382114, 968197.2, 1382148, + 968172.4, 1382166, 968029.8, 1382217, 967972.7, 1382319, + 967936.7, 1382369, 967835.1, 1382461, 967831.7, 1382514, + 967836.6, 1382538, 967764.9, 1382589, 967741.8, 1382615, + 967695.0, 1382625, 967639.9, 1382619, 967108.0, 1382436, + 967072.6, 1382434, 967038.1, 1382448, 966982.6, 1382491, + 966947.4, 1382534, 966945.7, 1382549, 966932.3, 1382555, + 966886.3, 1382694, 966876.6, 1382781, 966930.3, 1382957, + 966926.8, 1382988, 966873.1, 1383015, 966851.8, 1383046, + 966807.0, 1383062, 966779.4, 1383172), + ncol = 2, byrow = TRUE) + +# create linestring and Sf dataframe +linestring_geom <- sf::st_linestring(as.matrix(coords)) +flowline <- sf::st_as_sf( + data.frame(hy_id = "wb-1004970", + tot_drainage_areasqkm = 3.90825, + geom = sf::st_geometry(linestring_geom)), + crs = 5070 +) + +# lengthkm and bankful width (power law equation using total draineage area (sq. km)) +flowline <- + flowline %>% + dplyr::mutate( + lengthkm = as.numeric(sf::st_length(geometry))/1000, + bf_width = exp(0.700 + 0.365* log(tot_drainage_areasqkm)) + ) %>% + dplyr::select( + hy_id, + lengthkm, + tot_drainage_areasqkm, + bf_width, + geometry + ) + +testthat::test_that("cut 10 transects along single flowline, then add cross section points column, NULL points, and 10 min", { + + dem = "/vsicurl/https://prd-tnm.s3.amazonaws.com/StagedProducts/Elevation/13/TIFF/USGS_Seamless_DEM_13.vrt" + # + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = "hy_id", + cs_widths = pmax(50, flowline$bf_width * 11), # cross section width of each "id" linestring ("hy_id") + num = 10, # number of cross sections per "id" linestring ("hy_id") + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + + # # # add points per cross sections + # testthat::expect_error(hydrofabric3D:::add_points_per_cs( + # cs = transects, + # points_per_cs = NULL, + # min_pts_per_cs = 10, + # dem = dem + # )) + +}) \ No newline at end of file diff --git a/tests/testthat/test-cut-cross-sections.R b/tests/testthat/test-cut-cross-sections.R new file mode 100644 index 00000000..4583756f --- /dev/null +++ b/tests/testthat/test-cut-cross-sections.R @@ -0,0 +1,259 @@ +library(testthat) +library(dplyr) +library(sf) +# library(hydrofabric3D) + +# ------------------------------------------------------------------- +# ---- hydrofabric::cut_cross_sections() ---- +# ------------------------------------------------------------------- +# create test data (hy_id = "wb-1004970" from nextgen flowlines) +coords <- matrix(c(968520.8, 1381795, 968471.3, 1381851, 968420.6, 1381874, + 968418.1, 1381897, 968436.2, 1381961, 968426.9, 1382022, + 968412.6, 1382036, 968211.2, 1382114, 968197.2, 1382148, + 968172.4, 1382166, 968029.8, 1382217, 967972.7, 1382319, + 967936.7, 1382369, 967835.1, 1382461, 967831.7, 1382514, + 967836.6, 1382538, 967764.9, 1382589, 967741.8, 1382615, + 967695.0, 1382625, 967639.9, 1382619, 967108.0, 1382436, + 967072.6, 1382434, 967038.1, 1382448, 966982.6, 1382491, + 966947.4, 1382534, 966945.7, 1382549, 966932.3, 1382555, + 966886.3, 1382694, 966876.6, 1382781, 966930.3, 1382957, + 966926.8, 1382988, 966873.1, 1383015, 966851.8, 1383046, + 966807.0, 1383062, 966779.4, 1383172), + ncol = 2, byrow = TRUE) + +# create linestring and Sf dataframe +linestring_geom <- sf::st_linestring(as.matrix(coords)) +flowline <- sf::st_as_sf( + data.frame(hy_id = "wb-1004970", + tot_drainage_areasqkm = 3.90825, + geom = sf::st_geometry(linestring_geom)), + crs = 5070 + ) + +# lengthkm and bankful width (power law equation using total draineage area (sq. km)) +flowline <- + flowline %>% + dplyr::mutate( + lengthkm = as.numeric(sf::st_length(geometry))/1000, + bf_width = exp(0.700 + 0.365* log(tot_drainage_areasqkm)) + ) %>% + dplyr::select( + hy_id, + lengthkm, + tot_drainage_areasqkm, + bf_width, + geometry + ) + +testthat::test_that("cut 10 transects along single flowline & remove intersects (power law bankful widths, smooth, densify 3)", { + + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = "hy_id", + cs_widths = pmax(50, flowline$bf_width * 11), # cross section width of each "id" linestring ("hy_id") + num = 10, # number of cross sections per "id" linestring ("hy_id") + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + + # plot(transects$geometry) + # plot(flowline, add = T) + + # test that the number of rows is right and all cs IDs are present + testthat::expect_equal(nrow(transects), 10) + testthat::expect_equal(transects$cs_id, c(1:10)) + # test correct column names + testthat::expect_equal(names(transects), c("hy_id","cs_id","cs_lengthm", "cs_measure", "ds_distance", "lengthm", "sinuosity","geometry")) + + # Expect cs_lengthm and lengthm are within 2 units of expected value # TODO: might not want to check for equivalency with floating point numbers... + testthat::expect_true(dplyr::between(transects$cs_lengthm[1], 50-2, 50+2)) + testthat::expect_true(dplyr::between(transects$lengthm[1], 50-2, 50+2)) + # testthat::expect_equal(as.character(transects$cs_lengthm)[1], "50") + + testthat::expect_lte(max(transects$cs_measure), 100) + testthat::expect_gte(min(transects$cs_measure), 0) +}) + +testthat::test_that("cut 20 transects along single flowline & remove intersects (power law bankful widths, smooth, densify 3)", { + + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = "hy_id", + cs_widths = pmax(50, flowline$bf_width * 11), # cross section width of each "id" linestring ("hy_id") + num = 20, # number of cross sections per "id" linestring ("hy_id") + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + + # transects + # plot(flowline$geometry[1]) + # plot(transects$geometry, add = T) + + # test that the number of rows is right and all cs IDs are present + testthat::expect_equal(nrow(transects), 20) + testthat::expect_equal(transects$cs_id, c(1:20)) + + # test correct column names + testthat::expect_equal(names(transects), c("hy_id","cs_id","cs_lengthm", "cs_measure", "ds_distance", "lengthm", "sinuosity","geometry")) + + # Expect cs_lengthm and lengthm are within 2 units of expected value # TODO: might not want to check for equivalency with floating point numbers... + testthat::expect_true(dplyr::between(transects$cs_lengthm[1], 50-2, 50+2)) + testthat::expect_true(dplyr::between(transects$lengthm[1], 50-2, 50+2)) + testthat::expect_true(all(dplyr::between(transects$cs_lengthm, 50-2, 50+2))) + testthat::expect_true(all(dplyr::between(transects$cs_lengthm, 50-2, 50+2))) + + # expect cs_measure values to be between 0-100 + testthat::expect_lte(max(transects$cs_measure), 100) + testthat::expect_gte(min(transects$cs_measure), 0) + + +}) + +testthat::test_that("cut 100 transects along single flowline & remove intersects (power law bankful widths, smooth, densify 3)", { + + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = "hy_id", + cs_widths = 100, # cross section width of each "id" linestring ("hy_id") + num = 100, # number of cross sections per "id" linestring ("hy_id") + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + + transects + plot(flowline$geometry[1]) + plot(transects$geometry, add = T) + + # test that the number of rows is right and all cs IDs are present + testthat::expect_equal(nrow(transects), 69) + testthat::expect_equal(transects$cs_id, c(1:69)) + + # test correct column names + testthat::expect_equal(names(transects), c("hy_id","cs_id","cs_lengthm", "cs_measure", "ds_distance", "lengthm", "sinuosity","geometry")) + + # Expect cs_lengthm and lengthm are within 2 units of expected value # TODO: might not want to check for equivalency with floating point numbers... + testthat::expect_true(dplyr::between(transects$cs_lengthm[1], 100-2, 100+2)) + testthat::expect_true(dplyr::between(transects$lengthm[1], 100-2, 100+2)) + testthat::expect_true(all(dplyr::between(transects$cs_lengthm, 100-2, 100+2))) + testthat::expect_true(all(dplyr::between(transects$cs_lengthm, 100-2, 100+2))) + # testthat::expect_equal(as.character(transects$cs_lengthm)[1], "50") + + # expect cs_measure values to be between 0-100 + testthat::expect_lte(max(transects$cs_measure), 100) + testthat::expect_gte(min(transects$cs_measure), 0) + + +}) + +testthat::test_that("huge cs_lengthm with remove intersections)", { + + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = "hy_id", + cs_widths = 2500, # cross section width of each "id" linestring ("hy_id") + num = 50, # number of cross sections per "id" linestring ("hy_id") + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + + transects + plot(flowline$geometry[1]) + plot(transects$geometry, add = T) + + # test that the number of rows is right and all cs IDs are present + testthat::expect_equal(nrow(transects), 9) + testthat::expect_equal(transects$cs_id, c(1:9)) + + # test correct column names + testthat::expect_equal(names(transects), c("hy_id","cs_id","cs_lengthm", "cs_measure", "ds_distance", "lengthm", "sinuosity","geometry")) + + # Expect cs_lengthm and lengthm are within 2 units of expected value # TODO: might not want to check for equivalency with floating point numbers... + testthat::expect_true(dplyr::between(transects$cs_lengthm[1], 2500-2, 2500+2)) + testthat::expect_true(dplyr::between(transects$lengthm[1], 2500-2, 2500+2)) + testthat::expect_true(all(dplyr::between(transects$cs_lengthm, 2500-2, 2500+2))) + testthat::expect_true(all(dplyr::between(transects$cs_lengthm, 2500-2, 2500+2))) + + # expect cs_measure values to be between 0-100 + testthat::expect_lte(max(transects$cs_measure), 100) + testthat::expect_gte(min(transects$cs_measure), 0) + + +}) + +testthat::test_that("error on invalid num argument)", { + + testthat::expect_error( + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = "hy_id", + cs_widths = 50, + num = "bad inputs", + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + )) +}) + +testthat::test_that("error on invalid net argument)", { + + testthat::expect_error( + transects <- hydrofabric3D::cut_cross_sections( + net = data.frame(), + id = "hy_id", + cs_widths = 50, + num = 10, + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + ) +}) + +testthat::test_that("error on invalid net argument)", { + + testthat::expect_error( + transects <- hydrofabric3D::cut_cross_sections( + net = flowline, + id = NULL, + cs_widths = 50, + num = 10, + smooth = TRUE, # smooth lines + densify = 3, # densify linestring points + rm_self_intersect = TRUE, # remove self intersecting transects + fix_braids = FALSE + ) + ) +}) + +# testthat::test_that("cut 20 transects along single flowline & remove intersects (power law bankful widths, smooth, densify 3)", { +# +# transects <- hydrofabric3D::cut_cross_sections( +# net = flowline, +# id = "hy_id", +# cs_widths = pmax(50, flowline$bf_width * 11), # cross section width of each "id" linestring ("hy_id") +# num = 100, # number of cross sections per "id" linestring ("hy_id") +# smooth = TRUE, # smooth lines +# densify = 3, # densify linestring points +# rm_self_intersect = TRUE, # remove self intersecting transects +# fix_braids = FALSE +# ) +# +# transects +# plot(flowline$geometry[1]) +# plot(transects$geometry, add = T) +# +# testthat::expect_equal(nrow(transects), 17) +# # testthat::expect_equal(names(transects), c("hy_id","cs_id","cs_widths", "cs_measure", "ds_distance", "lengthm", "sinuosity","geometry")) +# testthat::expect_equal(as.numeric(sf::st_length( transects$geometry)), rep(50, 17)) +# +# }) diff --git a/tests/testthat/test-cut-transects.R b/tests/testthat/test-cut-transects.R new file mode 100644 index 00000000..214538dd --- /dev/null +++ b/tests/testthat/test-cut-transects.R @@ -0,0 +1,20 @@ +library(testthat) +library(sf) +library(geos) + +testthat::test_that("cut_transect creates perpendicular line of given width", { + + line <- geos::as_geos_geometry(sf::st_linestring(matrix(c(0, 1, 2, 3, 4, 5, 6, 7), ncol = 2, byrow = TRUE))) + + # Test for a line with width 0.1 + transect <- hydrofabric3D::cut_transect(line, width = 0.1) + + # plot(transect, col = "green", add = F) + # plot(line, col = "red", add = T) + + testthat::expect_s3_class(transect, "geos_geometry") + testthat::expect_equal(length(transect), 1) + testthat::expect_equal(sf::st_crs(transect), sf::st_crs(line)) + testthat::expect_equal(sf::st_crs(transect)$epsg, as.character(NA)) + +}) diff --git a/tests/testthat/test-get-transects.R b/tests/testthat/test-get-transects.R new file mode 100644 index 00000000..b471d452 --- /dev/null +++ b/tests/testthat/test-get-transects.R @@ -0,0 +1,33 @@ +library(testthat) +library(sf) +library(geos) + +testthat::test_that("get_transects creates multiple cross sections", { + line <- sf::st_geometry(sf::st_linestring(matrix(c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9 ,10, 11, 12, 13, 14, 15, 16, 17), ncol = 2, byrow = TRUE))) + line <- sf::st_as_sf(line) + line$hy_id = "my_hy_id" + line <- dplyr::rename(line, "geometry" = "x") + + # Test for 2 evenly spaced transects with a bankfull width of 3 + transects <- hydrofabric3D::get_transects(line, bf_width = 3, n = 2) + # plot(line$geometry) + # plot(transects$geometry, add = T) + + testthat::expect_s3_class(transects, "sf") + testthat::expect_equal(nrow(transects), 2) + testthat::expect_equal(as.integer( transects$cs_measure[1]), 24) + testthat::expect_equal(as.integer( transects$cs_measure[2]), 87) + + # Test for a single transect at the midpoint + transects_single <- hydrofabric3D::get_transects(line, bf_width = 3, n = 1) + + # plot(line$geometry) + # plot(transects_single$geometry, add = T) + + testthat::expect_s3_class(transects_single, "sf") + testthat::expect_equal(nrow(transects_single), 1) + testthat::expect_equal(as.integer(transects_single$cs_measure), 49) + testthat::expect_equal(ceiling(transects_single$cs_measure[1]), 50) + + +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 00000000..e0e215a8 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,118 @@ +library(testthat) +library(dplyr) +# library(hydrofabric3D) + +# ------------------------------------------------------------------- +# ---- hydrofabric::add_tmp_id() ---- +# ------------------------------------------------------------------- + +# Create a sample dataframe for testing +df <- data.frame( + hy_id = c("a", "b", "c"), + cs_id = c("x", "y", "z") +) + +testthat::test_that("Adding tmp_id column with default columns", { + result <- add_tmp_id(df) + testthat::expect_equal(names(result), c("hy_id", "cs_id", "tmp_id")) + testthat::expect_equal(result$tmp_id, c("a_x", "b_y", "c_z")) + +}) + +testthat::test_that("Adding tmp_id column with specified columns", { + result <- add_tmp_id(df, "hy_id", "cs_id") + testthat::expect_equal(names(result), c("hy_id", "cs_id", "tmp_id")) + testthat::expect_equal(result$tmp_id, c("a_x", "b_y", "c_z")) + +}) + +testthat::test_that("Adding tmp_id column with specified columns in reverse order", { + result <- add_tmp_id(df, "cs_id", "hy_id") + testthat::expect_equal(names(result), c("hy_id", "cs_id", "tmp_id")) + testthat::expect_equal(result$tmp_id, c("x_a", "y_b", "z_c")) +}) + +testthat::test_that("Adding tmp_id column with specified columns with no quotes (tidy select)", { + result <- add_tmp_id(df, hy_id, cs_id) + testthat::expect_equal(names(result), c("hy_id", "cs_id", "tmp_id")) + testthat::expect_equal(result$tmp_id, c("a_x", "b_y", "c_z")) + +}) + +testthat::test_that("Adding tmp_id column with non-character columns", { + df_numeric <- data.frame( + hy_id = c(1, 2, 3), + cs_id = c(10, 20, 30) + ) + result <- add_tmp_id(df_numeric) + testthat::expect_equal(names(result), c("hy_id", "cs_id", "tmp_id")) + testthat::expect_equal(result$tmp_id, c("1_10", "2_20", "3_30")) +}) + +# ------------------------------------------------------------------- +# ---- hydrofabric::get_point_type_counts() ---- +# ------------------------------------------------------------------- + +hy_id <- c("A", "A", "A", "A", + "B", "B", "B", "B", "B", + "C", "C", "C", + "D", "D", "D", "D", "D", + "E", "E", "E", "E", "E", "E" + ) +cs_id <- c(1, 1, 1, 1, + 1, 1, 1, 1, 1, + 1, 1, 1, + 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1 + ) +point_type <- c("left_bank", "channel", "bottom", "right_bank", # A + "left_bank", "channel", "channel", "bottom", "channel", # B + "left_bank", "bottom", "right_bank", # C + "left_bank", "channel", "bottom", "bottom", "right_bank", # D + "left_bank", "channel", "bottom", "bottom", "channel", "right_bank" # E + ) + +classified_pts <- data.frame(hy_id, cs_id, point_type) + +testthat::test_that("Adding point type counts with default arguments", { + + # result <- get_point_type_counts(classified_pts) + result <- hydrofabric3D::get_point_type_counts(classified_pts) + + testthat::expect_equal(names(result), c("hy_id", "cs_id", "left_bank_count", "right_bank_count", "channel_count", "bottom_count")) + testthat::expect_equal(unique(result$hy_id), c("A", "B", "C", "D", "E")) + + testthat::expect_equal(result[result$hy_id == "A", ]$left_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "A", ]$right_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "A", ]$channel_count, 1) + testthat::expect_equal(result[result$hy_id == "A", ]$bottom_count, 1) + + testthat::expect_equal(result[result$hy_id == "B", ]$left_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "B", ]$right_bank_count, 0) + testthat::expect_equal(result[result$hy_id == "B", ]$channel_count, 3) + testthat::expect_equal(result[result$hy_id == "B", ]$bottom_count, 1) + + testthat::expect_equal(result[result$hy_id == "C", ]$left_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "C", ]$right_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "C", ]$channel_count, 0) + testthat::expect_equal(result[result$hy_id == "C", ]$bottom_count, 1) + + testthat::expect_equal(result[result$hy_id == "D", ]$left_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "D", ]$right_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "D", ]$channel_count, 1) + testthat::expect_equal(result[result$hy_id == "D", ]$bottom_count, 2) + + testthat::expect_equal(result[result$hy_id == "E", ]$left_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "E", ]$right_bank_count, 1) + testthat::expect_equal(result[result$hy_id == "E", ]$channel_count, 2) + testthat::expect_equal(result[result$hy_id == "E", ]$bottom_count, 2) + + # result[result$hy_id == "E", ]$left_bank_count + # # testthat::expect_equal(result[result$hy_id == "E", ]$right_bank_count, c(0, 0, 0, 0 ) + # # result[result$hy_id == "E", ]$channel_count + # # result[result$hy_id == "E", ]$bottom_count + # testthat::expect_equal(result$left_bank_count, c(1, 1, 1, 2, 1)) + # testthat::expect_equal(result$right_bank_count, c(1, 0, 1, 1, 1)) + # testthat::expect_equal(result$channel_count, c(1, 3, 0, 2, 2)) + # testthat::expect_equal(result$bottom_count, c(1, 1, 1, 2, 2)) +}) \ No newline at end of file diff --git a/tests/testthat/test-validate-cut-cross-sections.R b/tests/testthat/test-validate-cut-cross-sections.R new file mode 100644 index 00000000..837f24f8 --- /dev/null +++ b/tests/testthat/test-validate-cut-cross-sections.R @@ -0,0 +1,373 @@ +library(testthat) +library(dplyr) +library(sf) +# library(hydrofabric3D) + +# ------------------------------------------------------------------- +# ---- hydrofabric3D:::validate_cut_cross_section_inputs() ---- +# ------------------------------------------------------------------- +# create test data (hy_id = "wb-1004970" from nextgen flowlines) +coords <- matrix(c(968520.8, 1381795, 968471.3, 1381851, 968420.6, 1381874, + 968418.1, 1381897, 968436.2, 1381961, 968426.9, 1382022, + 968412.6, 1382036, 968211.2, 1382114, 968197.2, 1382148, + 968172.4, 1382166, 968029.8, 1382217, 967972.7, 1382319, + 967936.7, 1382369, 967835.1, 1382461, 967831.7, 1382514, + 967836.6, 1382538, 967764.9, 1382589, 967741.8, 1382615, + 967695.0, 1382625, 967639.9, 1382619, 967108.0, 1382436, + 967072.6, 1382434, 967038.1, 1382448, 966982.6, 1382491, + 966947.4, 1382534, 966945.7, 1382549, 966932.3, 1382555, + 966886.3, 1382694, 966876.6, 1382781, 966930.3, 1382957, + 966926.8, 1382988, 966873.1, 1383015, 966851.8, 1383046, + 966807.0, 1383062, 966779.4, 1383172), + ncol = 2, byrow = TRUE) + +# create linestring and Sf dataframe +linestring_geom <- sf::st_linestring(as.matrix(coords)) +net <- sf::st_as_sf( + data.frame(hy_id = "wb-1004970", + tot_drainage_areasqkm = 3.90825, + geom = sf::st_geometry(linestring_geom)), + crs = 5070 +) + +# Test Cases +testthat::test_that("validate_cut_cross_section_inputs correctly validates inputs", { + + # Test valid inputs + testthat::expect_equal(validate_cut_cross_section_inputs(net = net, + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE), + NULL) + + # Test valid inputs + testthat::expect_equal(validate_cut_cross_section_inputs(net = net, + id = "anotherID", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE), + NULL) + + # Test valid inputs with terminal_id + testthat::expect_equal(validate_cut_cross_section_inputs(net = net, + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id ="terminal_id", + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE), + NULL) + + # Test valid inputs with braid_threshold + testthat::expect_equal(validate_cut_cross_section_inputs(net = net, + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = 10, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE), + NULL) + + # Test valid inputs with add + testthat::expect_equal(validate_cut_cross_section_inputs(net = net, + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = TRUE), + NULL) + + # Test invalid sf object + testthat::expect_error(validate_cut_cross_section_inputs(net = data.frame(), + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid id type (id is a numeric) + testthat::expect_error( + validate_cut_cross_section_inputs(net = net, + id = 2, + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid id type (id is NULL) + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = NULL, + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid id type (id is a numeric) + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = 32324, + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id =NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid num type + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = "10", + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid densify type + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = "2", + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid smooth type + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hy_id", + cs_widths = 100, + num = 10, + smooth = "453", + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid rm_self_intersect type 1 + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = "TRUE", + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE)) + + # Test invalid rm_self_intersect type 2 + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = "bad input", + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE)) + + # Test invalid fix_braids type + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = "FALSE", + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE)) + + # Test invalid terminal ID value (terminal ID is a number) + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = 12, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid terminal ID value (terminal ID is a logical) + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = TRUE, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = FALSE) + ) + + # Test invalid braid_method value + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "invalid_method", + precision = 1, + add = FALSE)) + + # Test invalid precision value + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = -1, + add = FALSE)) + + # Test invalid add type + testthat::expect_error(validate_cut_cross_section_inputs(net = net, + id = "hyid", + cs_widths = 100, + num = 10, + smooth = TRUE, + densify = 2, + rm_self_intersect = TRUE, + fix_braids = FALSE, + terminal_id = NULL, + braid_threshold = NULL, + version = 2, + braid_method = "comid", + precision = 1, + add = "FALSE" + )) + +}) +