Adding Czekanowski Site and Group functionality

R/create_constants.R

@@ -1,3 +1,9 @@
+# Taxonomic Backbone Methods ----------------------------------------------
+taxonomicBackboneMethod_options <- c("Bundled" = "bundled",
+                                     "Upload" = "upload",
+                                     "Kew WCVP" = "wcvp",
+                                     "Syntopic Tables" = "syntopicTables")
+
 # Input method options ----------------------------------------------------
 inputMethod_options <- c("Manual" = "manual",
                          "Example" = "example",
@@ -103,9 +109,10 @@ matchSpecies_options <- c("No" = "No",
 # Results to View NVC Assignment ------------------------------------------
 resultsViewNVCAssign_options <- c("Site, Pseudo-quadrat" = "nvcAssignSitePseudo",
                                   "Group, Pseudo-quadrat" = "nvcAssignGroupPseudo",
-                                  "Quadrat, Pseudo-quadrat" = "nvcAssignQuadratPseudo"#,
-                                  # "Site, Czekanowski" = "nvcAssignSiteCzekanowski",
-                                  # "Group, Czekanowski" = "nvcAssignGroupCzekanowski"
+                                  "Quadrat, Pseudo-quadrat" = "nvcAssignQuadratPseudo",
+                                  "Site, Czekanowski" = "nvcAssignSiteCzekanowski",
+                                  "Group, Czekanowski" = "nvcAssignGroupCzekanowski"#,
+                                  # "Quadrat, Czekanowski" = "nvcAssignQuadratCzekanowski"
                                   )
 
 # Results to View EIVs ----------------------------------------------------
@@ -191,10 +198,11 @@ selectSurveyGroups_options <- c()
 
 
 # Report Options ----------------------------------------------------------
-
-reportOptions_options <- list(`NVC Assignment` = c("Site" = "nvcAssignmentResultsSite",
-                                                   "Group" = "nvcAssignmentResultsGroup",
-                                                   "Quadrat" = "nvcAssignmentResultsQuadrat"),
+reportOptions_options <- list(`NVC Assignment Pseudo-quadrat` = c("Site" = "nvcAssignmentResultsSite",
+                                                                  "Group" = "nvcAssignmentResultsGroup",
+                                                                  "Quadrat" = "nvcAssignmentResultsQuadrat"),
+                              `NVC Assignment Czekanowski` = c("Site" = "nvcAssignmentResultsSite_Czekanowski",
+                                                               "Group" = "nvcAssignmentResultsGroup_Czekanowski"),
                               `Floristic Tables` = c("Site" = "composedFloristicTablesSite",
                                                      "Group" = "composedFloristicTablesGroup"),
                               `Species Frequency` = c("Species Frequency" = "speciesFrequencyTable"),
@@ -215,22 +223,3 @@ reportOptions_options <- list(`NVC Assignment` = c("Site" = "nvcAssignmentResult
                               `Survey Table` = c("Survey Table" = "surveyTable")
     )
 
-
-# reportOptions_options <- c("NVC Assignment, Site" = "nvcAssignmentResultsSite",
-#                            "NVC Assignment, Group" = "nvcAssignmentResultsGroup",
-#                            "NVC Assignment, Quadrat" = "nvcAssignmentResultsQuadrat",
-#                            "Floristic Tables, Site" = "composedFloristicTablesSite",
-#                            "Floristic Tables, Group" = "composedFloristicTablesGroup",
-#                            "Species Frequency" = "speciesFrequencyTable",
-#                            "Weighted Mean Hill-Ellenberg Values, Site" = "weightedMeanHEValuesSite",
-#                            "Unweighted Mean Hill-Ellenberg Values, Site" = "unweightedMeanHEValuesSite",
-#                            "Weighted Mean Hill-Ellenberg Values, Group" = "weightedMeanHEValuesGroup",
-#                            "Unweighted Mean Hill-Ellenberg Values, Group" = "unweightedMeanHEValuesGroup",
-#                            "Weighted Mean Hill-Ellenberg Values, Quadrat" = "weightedMeanHEValuesQuadrat",
-#                            "Unweighted Mean Hill-Ellenberg Values, Quadrat" = "unweightedMeanHEValuesQuadrat",
-#                            "MVA, National" = "mvaNationalReference",
-#                            "MVA, Local (restricted)" = "mvaLocalReferenceRestricted",
-#                            "MVA, Local (unrestricted)" = "mvaLocalReferenceUnrestricted",
-#                            "Survey Table" = "surveyTable"
-#                            )
-

R/functions.R

@@ -17,4 +17,39 @@
 # Calculate mean EIVs using surveyTable
 
 # Compose floristic tables from surveyTable
-
+composeSyntopicTables <- function(surveyTable){
+
+  syntopicTables <- surveyTable |>
+    # tidyr::unite(col = "ID", c("Year", "Group"), sep = " - ", remove = TRUE) |>
+    dplyr::mutate("ID" = as.character(Year)) |>
+    dplyr::select(-Year, -Group) |>
+    dplyr::select(-Cover) |>
+    dplyr::mutate("Present" = 1) |>
+    tidyr::pivot_wider(id_cols = c(ID, Species),
+                       values_from = Present,
+                       names_from = Quadrat) |>
+    dplyr::rowwise() |>
+    dplyr::mutate("Sum" = sum(dplyr::c_across(dplyr::where(is.numeric)), na.rm = TRUE)) |>
+    dplyr::ungroup() |>
+    dplyr::mutate("Frequency" = Sum / (ncol(dplyr::pick(dplyr::everything())) - 3)) |> # -2
+    dplyr::select(ID, Species, Sum, Frequency) |>
+    dplyr::mutate(
+      "Constancy" =
+        dplyr::case_when(
+          Frequency <= 0.2 ~ "I",
+          Frequency <= 0.4 ~ "II",
+          Frequency <= 0.6 ~ "III",
+          Frequency <= 0.8 ~ "IV",
+          Frequency <= 1.0 ~ "V",
+          TRUE ~ as.character(Frequency)
+        )
+    ) |>
+    dplyr::select(ID, Species, Constancy) |>
+    dplyr::mutate("Constancy" = factor(Constancy, levels = c("V", "IV", "III", "II", "I"))) |>
+    dplyr::arrange(ID, Constancy, Species)
+
+  return(syntopicTables)
+
+}
+
+

R/load_data.R

@@ -4,6 +4,7 @@ example_data_all <- readRDS(file = "./data/bundled_data/example_data_all.rds")
 
 # NVC floristic tables and community codes --------------------------------
 nvc_floristic_tables <- readRDS(file = "./data/bundled_data/nvc_floristic_tables.rds")
+nvc_floristic_tables_numeric <- readRDS(file = "./data/bundled_data/nvc_floristic_tables_numeric.rds")
 nvc_community_codes <- readRDS(file = "./data/bundled_data/nvc_community_codes.rds")
 nvc_community_namesCodes <- readRDS("./data/bundled_data/nvc_community_namesCodes.rds")
 

R/similarity_functions.R

@@ -0,0 +1,82 @@
+#' Calculate the similarity between vegetation data using the Czekanowski index
+#'
+#' Calculate the Czekanowski's Quantitative Index using either a set of sample 
+#' vegetation plots and a set of reference vegetation plots; or a set of composed
+#' floristic/syntopic tables and a set of references floristic/syntopic tables.
+#' Method follows Bray and Curtis (1957) and  Field and McFarlane (1968).
+#'
+#' @param samp_df A data frame containing either sample vegetation plot data with cover values, or a syntopic/floristic table composed from sample vegetation plot data.
+#' @param comp_df  A data frame containing either
+#' @param samp_species_col 
+#' @param comp_species_col 
+#' @param samp_group_name 
+#' @param comp_group_name 
+#' @param samp_weight_name 
+#'
+#' @return
+#' @export
+#'
+#' @examples
+similarityCzekanowski <- function(samp_df, comp_df, 
+                                  samp_species_col, comp_species_col, 
+                                  samp_group_name, comp_group_name,
+                                  samp_weight_name, comp_weight_name){
+
+  # Check argument types are correct
+  checkmate::assertDataFrame(samp_df)
+  checkmate::assertDataFrame(comp_df)
+  checkmate::assert_character(samp_species_col, any.missing = FALSE)
+  checkmate::assert_character(comp_species_col, any.missing = FALSE)
+  checkmate::assert_character(samp_group_name, any.missing = FALSE)
+  checkmate::assert_character(comp_group_name, any.missing = FALSE)
+  checkmate::assert_character(samp_weight_name, any.missing = FALSE)
+  checkmate::assert_character(comp_weight_name, any.missing = FALSE)
+
+  # Split input data frames into iterable lists
+  samp_df_split <- split(samp_df, samp_df[[samp_group_name]])
+  comp_df_split <- split(comp_df, comp_df[[comp_group_name]])
+
+  # Create a set of pairwise combinations for each samp_group_name and comp_group_name value.
+  eval_combinations <- expand.grid(names(samp_df_split), names(comp_df_split))
+  names(eval_combinations) <- c(samp_group_name, comp_group_name)
+
+  # Calculate the Czekanowski for each combination of samp_group_name and comp_group_name value.
+  similarity_results <- mapply(
+    X = eval_combinations[[samp_group_name]], Y = eval_combinations[[comp_group_name]],
+    SIMPLIFY = FALSE,
+    USE.NAMES = FALSE,
+    FUN = function(X, Y){
+
+      samp_data <- samp_df_split[[X]]
+      comp_data <- comp_df_split[[Y]]
+
+      samp_id <- unique(samp_data[[samp_group_name]])
+      comp_id <- unique(comp_data[[comp_group_name]])
+
+      samp_data_prepped <- samp_data[,c(samp_species_col, samp_weight_name)]
+      comp_data_prepped <- comp_data[,c(comp_species_col, comp_weight_name)]
+
+      eval_table <- merge(x = samp_data_prepped, y = comp_data_prepped, by = "Species", all = TRUE, suffixes = c("_samp", "_comp"))
+
+      eval_table[is.na(eval_table)] <- 0
+
+      eval_table["min"] <- apply(eval_table[c(paste0(samp_weight_name, "_samp"), paste0(comp_weight_name, "_comp"))], 1, min)
+
+      eval_table_sum <- colSums(eval_table[,c(paste0(samp_weight_name, "_samp"), paste0(comp_weight_name, "_comp"), "min")], na.rm = TRUE)
+
+      similarity <- (2 * eval_table_sum[["min"]]) / (eval_table_sum[[paste0(samp_weight_name, "_samp")]] + eval_table_sum[[paste0(comp_weight_name, "_comp")]])
+
+      similarity_list <- list(samp_group_name = samp_id, comp_group_name = comp_id, "Similarity" = similarity)
+      names(similarity_list) <- c(samp_group_name , comp_group_name, "Similarity")
+
+      return(similarity_list)
+
+    }
+  )
+
+  # Collapse list to data frame
+  similarity_df <- do.call(rbind.data.frame, similarity_results)
+
+  return(similarity_df)
+
+}

app.R

@@ -9,6 +9,7 @@ source("R/render_docs.R", local = TRUE)
 
 # Source functions --------------------------------------------------------
 source("R/functions.R", local = TRUE)
+source("R/similarity_functions.R", local = TRUE)
 source("R/reactable_functions.R", local = TRUE)
 
 # Source sub-modules ------------------------------------------------------

data/prep_data/prep_data_assignNVC.R

@@ -43,7 +43,7 @@ nvc_communities_final <- concordance_all_trimmed |>
   dplyr::right_join(assignNVC::NVC_communities, by = "Species") |>
   dplyr::select(-Species, -freq, -BRC) |>
   dplyr::rename("Species" = "proposedSpecies") |>
-  dplyr::rename("NVC.Code" = "NVC")|>
+  dplyr::rename("NVC.Code" = "NVC") |>
   dplyr::mutate(
     "Constancy" = 
       dplyr::case_when(
@@ -73,6 +73,21 @@ nrow(nvc_communities_final) == nrow(assignNVC::NVC_communities)
 
 saveRDS(object = nvc_communities_final, file = "./data/bundled_data/nvc_floristic_tables.rds")
 
+nvc_communities_final_numeric <- nvc_communities_final |>
+  dplyr::mutate(
+    "Constancy" = 
+      dplyr::case_when(
+        Constancy == "I" ~ 0.2,
+        Constancy == "II" ~ 0.4,
+        Constancy == "III" ~ 0.6,
+        Constancy == "IV" ~ 0.8,
+        Constancy == "V" ~ 1.0,
+        TRUE ~ as.numeric(0)
+      )
+  )
+
+saveRDS(object = nvc_communities_final_numeric, file = "./data/bundled_data/nvc_floristic_tables_numeric.rds")
+
 nvc_community_codes <- nvc_communities_final |>
   dplyr::pull(NVC.Code) |>
   unique()