diff --git a/R/create_constants.R b/R/create_constants.R index 2a30d88..9b82174 100644 --- a/R/create_constants.R +++ b/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" -# ) - diff --git a/R/functions.R b/R/functions.R index 5464832..2f23b4e 100644 --- a/R/functions.R +++ b/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) + +} + + \ No newline at end of file diff --git a/R/load_data.R b/R/load_data.R index fb21cd4..0d41d16 100644 --- a/R/load_data.R +++ b/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") diff --git a/R/similarity_functions.R b/R/similarity_functions.R new file mode 100644 index 0000000..1b35045 --- /dev/null +++ b/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) + +} \ No newline at end of file diff --git a/app.R b/app.R index ae1f1f4..7bfbf5a 100644 --- a/app.R +++ b/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 ------------------------------------------------------ diff --git a/data/bundled_data/nvc_floristic_tables_numeric.rds b/data/bundled_data/nvc_floristic_tables_numeric.rds new file mode 100644 index 0000000..7d15a60 Binary files /dev/null and b/data/bundled_data/nvc_floristic_tables_numeric.rds differ diff --git a/data/prep_data/prep_data_assignNVC.R b/data/prep_data/prep_data_assignNVC.R index 66f1bdd..1bb25cc 100644 --- a/data/prep_data/prep_data_assignNVC.R +++ b/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() diff --git a/modules/nvcAssignment_server.R b/modules/nvcAssignment_server.R index 1c9b083..54078b7 100644 --- a/modules/nvcAssignment_server.R +++ b/modules/nvcAssignment_server.R @@ -1,4 +1,4 @@ -nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) { +nvcAssignment <- function(input, output, session, surveyTable, floristicTables, sidebar_options) { ns <- session$ns @@ -28,6 +28,13 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) shinyjs::show(id = "nvcAssignmentSiteTable_div") shinyjs::show(id = "nvcAssignmentGroupTable_div") shinyjs::show(id = "nvcAssignmentQuadratTable_div") + + shinyjs::show(id = "nvcAssignmentSiteTable_Czekanowski_div") + shinyjs::show(id = "nvcAssignmentGroupTable_Czekanowski_div") + + # shinyjs::show(id = "nvcAssignmentSiteTable_div") + # shinyjs::show(id = "nvcAssignmentGroupTable_div") + # shinyjs::show(id = "nvcAssignmentQuadratTable_div") }) |> bindEvent(resultsViewNVCAssign(), @@ -55,6 +62,18 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) shinyjs::hide(id = "nvcAssignmentQuadratTable_div") } + if("nvcAssignSiteCzekanowski" %in% resultsViewNVCAssign()){ + shinyjs::show(id = "nvcAssignmentSiteTable_Czekanowski_div") + } else { + shinyjs::hide(id = "nvcAssignmentSiteTable_Czekanowski_div") + } + + if("nvcAssignGroupCzekanowski" %in% resultsViewNVCAssign()){ + shinyjs::show(id = "nvcAssignmentGroupTable_Czekanowski_div") + } else { + shinyjs::hide(id = "nvcAssignmentGroupTable_Czekanowski_div") + } + }) |> bindEvent(resultsViewNVCAssign(), ignoreInit = FALSE, @@ -70,13 +89,18 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) ignoreInit = FALSE, once = TRUE) -# Calculate nvcAssignment results by site ---------------------------------------- + +# Calculate ALL nvcAssignment results ------------------------------------- nvcAssignmentQuadrat_rval <- reactiveVal() nvcAssignmentGroup_rval <- reactiveVal() nvcAssignmentSite_rval <- reactiveVal() + nvcAssignmentSite_Czekanowski_rval <- reactiveVal() + nvcAssignmentGroup_Czekanowski_rval <- reactiveVal() observe({ + shiny::req(floristicTables()) + # req(isFALSE(runAnalysis() == 0)) shinybusy::show_modal_spinner( @@ -106,7 +130,7 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) for(code in habitatRestriction()){ - regex <- paste0("^", code, "\\d{1,}.+(?![a-z*][P])") # + regex <- paste0("^", code, "\\d{1,}.+(?![a-z*][P])") codes_regex <- c(codes_regex, regex) @@ -137,8 +161,6 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) dplyr::ungroup() |> dplyr::left_join(surveyTable_IDs, by = "ID") - # assign(x = "nvcAssignmentQuadrat", value = nvcAssignmentQuadrat, envir = .GlobalEnv) - nvcAssignmentQuadrat_prepped <- nvcAssignmentQuadrat |> dplyr::select(Year, Group, Quadrat, NVC.Code, Mean.Similarity, Standard.Deviation)|> dplyr::group_by(Year, Group, Quadrat) |> @@ -189,6 +211,69 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) }) + # Prepare floristicTables + floristicTables <- floristicTables() + floristicTables_prepped <- floristicTables |> + 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) + ) + ) + + # Prepare nvc_floristic_tables_numeric + if(!is.null(habitatRestriction())){ + + nvc_floristic_tables_numeric_prepped <- nvc_floristic_tables_numeric |> + dplyr::filter(stringr::str_detect(string = NVC.Code, pattern = codes_regex)) + + } else { + + nvc_floristic_tables_numeric_prepped <- nvc_floristic_tables_numeric + + } + + + # assign(x = "habitatRestriction", value = habitatRestriction(), envir = .GlobalEnv) + # assign(x = "codes_regex", value = codes_regex, envir = .GlobalEnv) + + # assign(x = "floristicTables_prepped", value = floristicTables_prepped, envir = .GlobalEnv) + # assign(x = "nvc_floristic_tables_numeric", value = nvc_floristic_tables_numeric, envir = .GlobalEnv) + + # Calculate NVC Similarity by Site using the Czekanowski index + nvcAssignmentSiteGroup_Czekanowski <- similarityCzekanowski(samp_df = floristicTables_prepped, + comp_df = nvc_floristic_tables_numeric_prepped, + samp_species_col = "Species", + comp_species_col = "Species", + samp_group_name = "ID", + comp_group_name = "NVC.Code", + samp_weight_name = "Constancy", + comp_weight_name = "Constancy") + + nvcAssignmentSite_Czekanowski <- nvcAssignmentSiteGroup_Czekanowski |> + dplyr::filter(stringr::str_detect(string = ID, pattern = "^\\b[0-9_]+\\b$")) |> + dplyr::mutate("Year" = ID) |> + dplyr::select(Year, NVC.Code, Similarity)|> + dplyr::arrange(Year, dplyr::desc(Similarity)) + + nvcAssignmentGroup_Czekanowski <- nvcAssignmentSiteGroup_Czekanowski |> + dplyr::filter(stringr::str_detect(string = ID, pattern = "^\\b[0-9_]+\\b$", negate = TRUE)) |> + dplyr::mutate("Year" = stringr::str_extract(string = ID, pattern = "\\d{4}")) |> + dplyr::mutate("Group" = stringr::str_extract(string = ID, pattern = "(?<=\\s-\\s).*$")) |> + dplyr::select(Year, Group, NVC.Code, Similarity) |> + dplyr::arrange(Year, Group, dplyr::desc(Similarity)) + + # assign(x = "nvcAssignmentSite_Czekanowski", value = nvcAssignmentSite_Czekanowski, envir = .GlobalEnv) + # assign(x = "nvcAssignmentGroup_Czekanowski", value = nvcAssignmentGroup_Czekanowski, envir = .GlobalEnv) + + nvcAssignmentSite_Czekanowski_rval(nvcAssignmentSite_Czekanowski) + nvcAssignmentGroup_Czekanowski_rval(nvcAssignmentGroup_Czekanowski) + shinybusy::remove_modal_spinner() }) |> @@ -495,6 +580,198 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) outputOptions(output, "nvcAssignmentQuadratTable", suspendWhenHidden = FALSE) + # Intialise NVC Assignment Site Czekanowski Table ----------------------- + nvcAssignmentSiteTable_Czekanowski_init <- data.frame("Year" = integer(), + "Similarity" = numeric(), + "NVC.Code" = character() + ) + + output$nvcAssignmentSiteTable_Czekanowski <- reactable::renderReactable({ + + nvcAssignmentSiteTable_Czekanowski <- reactable::reactable(data = nvcAssignmentSiteTable_Czekanowski_init, + filterable = FALSE, + pagination = FALSE, + highlight = TRUE, + bordered = TRUE, + sortable = TRUE, + wrap = FALSE, + resizable = TRUE, + style = list(fontSize = "1rem"), + class = "my-tbl", + # style = list(fontSize = "1rem"), + rowClass = "my-row", + defaultColDef = reactable::colDef( + format = reactable::colFormat(digits = 2), + headerClass = "my-header", + class = "my-col", + align = "center" # Needed as alignment is not passing through to header + ) + ) + + return(nvcAssignmentSiteTable_Czekanowski) + + }) + + + + # Update NVC Assignment Site Czekanowski Table -------------------------- + observe({ + + + shiny::req(nvcAssignmentSite_Czekanowski_rval()) + + nvcAssignmentSite_Czekanowski <- nvcAssignmentSite_Czekanowski_rval() |> + dplyr::group_by(Year) |> + dplyr::slice(1:nTopResults()) |> + dplyr::ungroup() + + output$nvcAssignmentSiteTable_Czekanowski <- reactable::renderReactable({ + + nvcAssignmentSiteTable_Czekanowski <- reactable::reactable(data = nvcAssignmentSite_Czekanowski, + filterable = FALSE, + pagination = FALSE, + highlight = TRUE, + bordered = TRUE, + sortable = TRUE, + wrap = FALSE, + resizable = TRUE, + style = list(fontSize = "1rem"), + class = "my-tbl", + # style = list(fontSize = "1rem"), + rowClass = "my-row", + defaultColDef = reactable::colDef( + format = reactable::colFormat(digits = 2), + headerClass = "my-header", + class = "my-col", + align = "center" # Needed as alignment is not passing through to header + ), + columns = list( + Year = reactable::colDef( + format = reactable::colFormat(digits = 0), + filterable = TRUE, + filterMethod = reactable::JS("function(rows, columnId, filterValue) { + return rows.filter(function(row) { + return row.values[columnId] == filterValue + }) + }") + ) + ) + ) + + return(nvcAssignmentSiteTable_Czekanowski) + + }) + + }) |> + bindEvent(nvcAssignmentSite_Czekanowski_rval(), + nTopResults(), + ignoreInit = TRUE, + ignoreNULL = TRUE) + + + outputOptions(output, "nvcAssignmentSiteTable_Czekanowski", suspendWhenHidden = FALSE) + + + # Initialise NVC Assignment Group Czekanowski Table --------------------- + nvcAssignmentGroupTable_Czekanowski_init <- data.frame("Year" = integer(), + "Group" = character(), + "Similarity" = numeric(), + "NVC.Code" = character() + ) + + nvcAssignmentGroupTable_Czekanowski_rval <- reactiveVal(nvcAssignmentGroupTable_Czekanowski_init) + + output$nvcAssignmentGroupTable_Czekanowski <- reactable::renderReactable({ + + nvcAssignmentGroupTable_Czekanowski <- reactable::reactable(data = nvcAssignmentGroupTable_Czekanowski_init, + filterable = FALSE, + pagination = FALSE, + highlight = TRUE, + bordered = TRUE, + sortable = TRUE, + wrap = FALSE, + resizable = TRUE, + style = list(fontSize = "1rem"), + class = "my-tbl", + # style = list(fontSize = "1rem"), + rowClass = "my-row", + defaultColDef = reactable::colDef( + format = reactable::colFormat(digits = 2), + headerClass = "my-header", + class = "my-col", + align = "center" # Needed as alignment is not passing through to header + ) + ) + + return(nvcAssignmentGroupTable_Czekanowski) + + }) + + + # Update NVC Assignment Group CzekanowskiTable ------------------------ + observe({ + + req(nvcAssignmentGroup_Czekanowski_rval()) + + nvcAssignmentGroup_Czekanowski <- nvcAssignmentGroup_Czekanowski_rval() |> + dplyr::group_by(Year, Group) |> + dplyr::slice(1:nTopResults()) |> + dplyr::ungroup() + + output$nvcAssignmentGroupTable_Czekanowski <- reactable::renderReactable({ + + nvcAssignmentGroupTable_Czekanowski <- reactable::reactable(data = nvcAssignmentGroup_Czekanowski, + filterable = FALSE, + pagination = FALSE, + highlight = TRUE, + bordered = TRUE, + sortable = TRUE, + wrap = FALSE, + resizable = TRUE, + style = list(fontSize = "1rem"), + class = "my-tbl", + # style = list(fontSize = "1rem"), + rowClass = "my-row", + defaultColDef = reactable::colDef( + format = reactable::colFormat(digits = 2), + headerClass = "my-header", + class = "my-col", + align = "center" # Needed as alignment is not passing through to header + ), + columns = list( + Year = reactable::colDef( + format = reactable::colFormat(digits = 0), + filterable = TRUE, + filterMethod = reactable::JS("function(rows, columnId, filterValue) { + return rows.filter(function(row) { + return row.values[columnId] == filterValue + }) + }") + ), + Group = reactable::colDef( + filterable = TRUE, + filterMethod = reactable::JS("function(rows, columnId, filterValue) { + return rows.filter(function(row) { + return row.values[columnId] == filterValue + }) + }") + ) + ) + ) + + return(nvcAssignmentGroupTable_Czekanowski) + + }) + + }) |> + bindEvent(nvcAssignmentGroup_Czekanowski_rval(), + nTopResults(), + ignoreInit = TRUE, + ignoreNULL = TRUE) + + + outputOptions(output, "nvcAssignmentGroupTable_Czekanowski", suspendWhenHidden = FALSE) + # Compose All NVC Assignment Results -------------------------------------- nvcAssignmentAll_rval <- reactiveVal() @@ -520,9 +797,21 @@ nvcAssignment <- function(input, output, session, surveyTable, sidebar_options) dplyr::slice(1:nTopResults()) |> dplyr::ungroup() + nvcAssignmentSite_Czekanowski <- nvcAssignmentSite_Czekanowski_rval() |> + dplyr::group_by(Year) |> + dplyr::slice(1:nTopResults()) |> + dplyr::ungroup() + + nvcAssignmentGroup_Czekanowski <- nvcAssignmentGroup_Czekanowski_rval() |> + dplyr::group_by(Year, Group) |> + dplyr::slice(1:nTopResults()) |> + dplyr::ungroup() + nvcAssignmentAll_list <- list("nvcAssignmentSite" = nvcAssignmentSite, "nvcAssignmentGroup" = nvcAssignmentGroup, - "nvcAssignmentQuadrat" = nvcAssignmentQuadrat) + "nvcAssignmentQuadrat" = nvcAssignmentQuadrat, + "nvcAssignmentSite_Czekanowski" = nvcAssignmentSite_Czekanowski, + "nvcAssignmentGroup_Czekanowski" = nvcAssignmentGroup_Czekanowski) nvcAssignmentAll_rval(nvcAssignmentAll_list) diff --git a/modules/nvcAssignment_ui.R b/modules/nvcAssignment_ui.R index 33a8afd..077e23a 100644 --- a/modules/nvcAssignment_ui.R +++ b/modules/nvcAssignment_ui.R @@ -43,6 +43,32 @@ nvcAssignmentUI <- function(id){ shiny::div(shiny::br()) + ), + + shiny::div( + id = ns("nvcAssignmentSiteTable_Czekanowski_div"), + + shiny::h5("Site Similarities"), + + shiny::div( + reactable::reactableOutput(outputId = ns("nvcAssignmentSiteTable_Czekanowski")) + ), + + shiny::div(shiny::br()) + + ), + + shiny::div( + id = ns("nvcAssignmentGroupTable_Czekanowski_div"), + + shiny::h5("Group Similarities"), + + shiny::div( + reactable::reactableOutput(outputId = ns("nvcAssignmentGroupTable_Czekanowski")) + ), + + shiny::div(shiny::br()) + ) ) ) diff --git a/modules/server.R b/modules/server.R index f1d8bab..626bbbd 100644 --- a/modules/server.R +++ b/modules/server.R @@ -31,21 +31,22 @@ server <- function(input, output, session) { surveyTable = surveyTable, sidebar_options = sidebar_options) + floristicTables <- shiny::callModule(module = floristicTables, + id = "floristicTables_id_1", + surveyTable = surveyTable, + surveyTableValidator = surveyTableValidator, + sidebar_options = sidebar_options) + nvcAssignment <- shiny::callModule(module = nvcAssignment, id = "nvcAssignment_id_1", surveyTable = surveyTable, + floristicTables = floristicTables, sidebar_options = sidebar_options) habCor <- shiny::callModule(module = habCor, id = "habCor_id_1", nvcAssignment = nvcAssignment, sidebar_options = sidebar_options) - - floristicTables <- shiny::callModule(module = floristicTables, - id = "floristicTables_id_1", - surveyTable = surveyTable, - surveyTableValidator = surveyTableValidator, - sidebar_options = sidebar_options) speciesFreq <- shiny::callModule(module = speciesFreq, id = "speciesFreq_id_1", diff --git a/modules/setupData_server.R b/modules/setupData_server.R new file mode 100644 index 0000000..d8ffbd5 --- /dev/null +++ b/modules/setupData_server.R @@ -0,0 +1,34 @@ +setupData <- function(input, output, session, sidebar_options) { + + ns <- session$ns + +# Retrieve sidebar options ------------------------------------------------ + taxonomicBackboneMethod <- reactiveVal() + bundledTaxonomicBackbone <- reactiveVal() + wcvpCountries <- reactiveVal() + + observe({ + + taxonomicBackboneMethod(sidebar_options()$taxonomicBackboneMethod) + bundledTaxonomicBackbone(sidebar_options()$bundledTaxonomicBackbone) + wcvpCountries(sidebar_options()$wcvpCountries) + + }) |> + bindEvent(sidebar_options(), ignoreInit = FALSE) + + +# Create Accepted Species Object ------------------------------------------ + observe({ + + }) |> + bindEvent(taxonomicBackboneMethod(), + ignoreInit = TRUE, + ignoreNULL = TRUE) + +# Create Setup Data List -------------------------------------------------- + setupData <- list() + +# Return Setup Data ------------------------------------------------------- + return() + +} \ No newline at end of file diff --git a/modules/sidebar_server.R b/modules/sidebar_server.R index 88cd9ee..bf88741 100644 --- a/modules/sidebar_server.R +++ b/modules/sidebar_server.R @@ -39,8 +39,6 @@ sidebar <- function(input, output, session, surveyTable, surveyTableValidator, n sidebar_options(sidebar_options_list) - # print(input$reportOptions) - }) |> bindEvent(input$inputMethod, # input$resetTable, diff --git a/renv.lock b/renv.lock index e2f0a34..a3fba4a 100644 --- a/renv.lock +++ b/renv.lock @@ -200,6 +200,16 @@ ], "Hash": "b1b1c3be5c75309f6107726fa58ee20c" }, + "brio": { + "Package": "brio", + "Version": "1.1.4", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R" + ], + "Hash": "68bd2b066e1fe780bbf62fc8bcc36de3" + }, "broom": { "Package": "broom", "Version": "1.0.5", @@ -292,6 +302,18 @@ ], "Hash": "f61dbaec772ccd2e17705c1e872e9e7c" }, + "checkmate": { + "Package": "checkmate", + "Version": "2.3.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "backports", + "utils" + ], + "Hash": "c01cab1cb0f9125211a6fc99d540e315" + }, "cli": { "Package": "cli", "Version": "3.6.1", @@ -442,6 +464,34 @@ ], "Hash": "d6fd1b1440c1cacc6623aaa4e9fe352b" }, + "desc": { + "Package": "desc", + "Version": "1.4.3", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "R6", + "cli", + "utils" + ], + "Hash": "99b79fcbd6c4d1ce087f5c5c758b384f" + }, + "diffobj": { + "Package": "diffobj", + "Version": "0.3.5", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "crayon", + "methods", + "stats", + "tools", + "utils" + ], + "Hash": "bcaa8b95f8d7d01a5dedfd959ce88ab8" + }, "digest": { "Package": "digest", "Version": "0.6.33", @@ -1137,6 +1187,21 @@ ], "Hash": "15da5a8412f317beeee6175fbc76f4bb" }, + "pkgbuild": { + "Package": "pkgbuild", + "Version": "1.4.3", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "R6", + "callr", + "cli", + "desc", + "processx" + ], + "Hash": "c0143443203205e6a2760ce553dafc24" + }, "pkgconfig": { "Package": "pkgconfig", "Version": "2.0.3", @@ -1147,6 +1212,27 @@ ], "Hash": "01f28d4278f15c76cddbea05899c5d6f" }, + "pkgload": { + "Package": "pkgload", + "Version": "1.3.4", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "crayon", + "desc", + "fs", + "glue", + "methods", + "pkgbuild", + "rlang", + "rprojroot", + "utils", + "withr" + ], + "Hash": "876c618df5ae610be84356d5d7a5d124" + }, "plotly": { "Package": "plotly", "Version": "4.10.2", @@ -1179,6 +1265,13 @@ ], "Hash": "6c00a09ba7d34917d9a3e28b15dd74e3" }, + "praise": { + "Package": "praise", + "Version": "1.0.0", + "Source": "Repository", + "Repository": "RSPM", + "Hash": "a555924add98c99d2f411e37e7d25e9f" + }, "prettyunits": { "Package": "prettyunits", "Version": "1.1.1", @@ -1435,6 +1528,16 @@ ], "Hash": "79f14e53725f28900d936f692bfdd69f" }, + "rprojroot": { + "Package": "rprojroot", + "Version": "2.0.4", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R" + ], + "Hash": "4c8415e0ec1e29f3f4f6fc108bef0144" + }, "rstudioapi": { "Package": "rstudioapi", "Version": "0.15.0", @@ -1672,6 +1775,35 @@ ], "Hash": "90b28393209827327de889f49935140a" }, + "testthat": { + "Package": "testthat", + "Version": "3.2.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "R6", + "brio", + "callr", + "cli", + "desc", + "digest", + "evaluate", + "jsonlite", + "lifecycle", + "magrittr", + "methods", + "pkgload", + "praise", + "processx", + "ps", + "rlang", + "utils", + "waldo", + "withr" + ], + "Hash": "4767a686ebe986e6cb01d075b3f09729" + }, "textshaping": { "Package": "textshaping", "Version": "0.3.6", @@ -1899,6 +2031,24 @@ ], "Hash": "8318e64ffb3a70e652494017ec455561" }, + "waldo": { + "Package": "waldo", + "Version": "0.5.2", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R", + "cli", + "diffobj", + "fansi", + "glue", + "methods", + "rematch2", + "rlang", + "tibble" + ], + "Hash": "c7d3fd6d29ab077cbac8f0e2751449e6" + }, "webshot": { "Package": "webshot", "Version": "0.5.5", diff --git a/report/Report.Rmd b/report/Report.Rmd index 334f84a..c849a2f 100644 --- a/report/Report.Rmd +++ b/report/Report.Rmd @@ -66,6 +66,9 @@ nvcAssignmentSite <- nvcAssignment$nvcAssignmentSite nvcAssignmentGroup <- nvcAssignment$nvcAssignmentGroup nvcAssignmentQuadrat <- nvcAssignment$nvcAssignmentQuadrat +nvcAssignmentSite_Czekanowski <- nvcAssignment$nvcAssignmentSite_Czekanowski +nvcAssignmentGroup_Czekanowski <- nvcAssignment$nvcAssignmentGroup_Czekanowski + # EIVs weightedMeanHEValuesSite <- avgEIVs$weightedMeanHEValuesSite unweightedMeanHEValuesSite <- avgEIVs$unweightedMeanHEValuesSite @@ -100,9 +103,11 @@ mvaNationalRef_CCA_arrowData <- mvaNationalRefResults$CCA_arrowData # Report options. Load from create_constants.R!!! -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"), @@ -288,6 +293,44 @@ if("nvcAssignmentResultsQuadrat" %in% reportOptions){ ``` +```{r nvcAssignmentResultsSiteCzekanowski, echo=FALSE, message=FALSE, warning=FALSE, results='asis'} + +if("nvcAssignmentResultsSite_Czekanowski" %in% reportOptions){ + + cat("## NVC Assignment Czekanowski, by Site") + + nvcAssignmentSite_Czekanowski_prepped <- nvcAssignmentSite_Czekanowski |> + dplyr::mutate_if(is.numeric, round, digits = 2) + + kableExtra::kbl(x = nvcAssignmentSite_Czekanowski_prepped, format = "latex", booktabs = TRUE, + longtable = TRUE, linesep = "", + caption = "The top NVC communities fitted using the Czekanowski method, for the site by year." + ) |> + kableExtra::kable_styling(latex_options = c("repeat_header", "HOLD_position")) + +} + +``` + +```{r nvcAssignmentResultsGroupCzekanowski, echo=FALSE, message=FALSE, warning=FALSE, results='asis'} + +if("nvcAssignmentResultsGroup_Czekanowski" %in% reportOptions){ + + cat("## NVC Assignment Czekanowski, by Group") + + nvcAssignmentGroup_Czekanowski_prepped <- nvcAssignmentGroup_Czekanowski |> + dplyr::mutate_if(is.numeric, round, digits = 2) + + kableExtra::kbl(x = nvcAssignmentGroup_Czekanowski_prepped, format = "latex", booktabs = TRUE, + longtable = TRUE, linesep = "", + caption = "The top NVC communities fitted using the Czekanowski method, by group and year" + ) |> + kableExtra::kable_styling(latex_options = c("repeat_header", "HOLD_position")) + +} + +``` + ```{r floristicTablesTitle, echo=FALSE, message=FALSE, warning=FALSE, results='asis'} reportOptions_floristicTables <- reportOptions_options$`Floristic Tables` diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..2f6bda4 --- /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(pseudoMAVIS) + +test_check("pseudoMAVIS") diff --git a/www/documentation.html b/www/documentation.html index b27fb64..1ef1984 100644 --- a/www/documentation.html +++ b/www/documentation.html @@ -737,7 +737,7 @@

2.10.1 Options

-NVC Assignment +NVC Assignment Pseudo-quadrat Site @@ -745,7 +745,7 @@

2.10.1 Options

-NVC Assignment +NVC Assignment Pseudo-quadrat Group @@ -753,7 +753,7 @@

2.10.1 Options

-NVC Assignment +NVC Assignment Pseudo-quadrat Quadrat @@ -761,6 +761,22 @@

2.10.1 Options

+NVC Assignment Czekanowski + + +Site + + + + +NVC Assignment Czekanowski + + +Group + + + + Floristic Tables