diff --git a/.Rbuildignore b/.Rbuildignore index 6cbba32..4340385 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,4 @@ ^bccamtrap\.code-workspace$ ^[.]?air[.]toml$ ^\.vscode$ +^\.claude$ diff --git a/.gitignore b/.gitignore index 3ce0719..8f262f2 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,7 @@ .quarto .Rprofile docs +.claude + +/.quarto/ +**/*.quarto_ipynb diff --git a/DESCRIPTION b/DESCRIPTION index a575b87..670e90a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,17 +14,19 @@ URL: https://github.com/bcgov/bccamtrap, https://bcgov.github.io/bccamtrap/ BugReports: https://github.com/bcgov/bccamtrap/issues Depends: - R (>= 2.10) + R (>= 4.1.0) Imports: bcmaps (>= 2.2.0), bslib, cli, + DBI, dplyr, ggiraph, ggplot2, glue, gt, janitor, + jsonlite, leaflet, lubridate, mapview, @@ -33,6 +35,7 @@ Imports: readr, readxl, rlang (>= 1.1.0), + RSQLite, sf, shiny, shinycssloaders, @@ -40,12 +43,9 @@ Imports: withr, zoo Suggests: - DBI, googledrive, - jsonlite, - RSQLite, - testthat (>= 3.0.0), + testthat (>= 3.0.0) Config/testthat/edition: 3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.3 diff --git a/R/classes.R b/R/classes.R index 5130820..bf843f1 100644 --- a/R/classes.R +++ b/R/classes.R @@ -22,8 +22,13 @@ as.deployments <- function(x, subclass, ...) { ) } -as.image_data <- function(x, ...) { - structure(x, class = c("image_data", class(x)), ...) +as.image_data <- function(x, template, ...) { + structure( + x, + class = c("image_data", class(x)), + template = template, + ... + ) } as.sample_sessions <- function(x, ...) { diff --git a/R/image-data.R b/R/image-data.R index 1ca9a01..fd330ef 100644 --- a/R/image-data.R +++ b/R/image-data.R @@ -2,20 +2,39 @@ #' #' In addition to reading in the data, this function copies snow depth data #' from the timelapse photo for each day into the motion photos for that day, -#' to facilitate analysis. +#' to facilitate analysis. It also does basic standardization of trigger mode values, +#' creates numeric snow depth columns, and checks for the presence of a +#' total_count_episode column, adding one if missing. If the data has separate +#' Date and Time columns instead of a combined DateTime column, +#' these will be reconciled into a single DateTime column. All column names are +#' standardized to snake_case. +#' +#' For wallow data, this also removes static images (both timelapse and motion activated), +#' and only keeps the video records. #' #' @param path path to directory of image files, a single .csv file, or a character #' vector of .csv files. #' @param pattern an optional regular expression. Only file names which match #' the regular expression will read. Default `FALSE`. #' @param recursive should files found within subfolders of `path` also be read? +#' @param template path to a "`.tdb`" TimeLapse Template file. Optional; if not provided, +#' the function will attempt to identify the appropriate internal template +#' based on the file names in `path`. #' @param ... arguments passed on to [readr::read_csv()] #' -#' @return a `data.frame` of Timelapse image data from the files found in `path` +#' @return a `data.frame` of Timelapse image data from the files found in `path`. +#' The data.frame will have an "image_data" class, and an attribute "template" +#' with the name of the template used to read the data. #' @export -read_image_data <- function(path, pattern, recursive = FALSE, ...) { +read_image_data <- function( + path, + pattern, + recursive = FALSE, + template = NULL, + ... +) { if (!all(file.exists(path))) { - cli::cli_abort("Directory {.path {path}} does not exist") + cli::cli_abort("Path(s) {.path {path}} do not exist") } if (!any(grepl("\\.csv$", path))) { @@ -35,7 +54,7 @@ read_image_data <- function(path, pattern, recursive = FALSE, ...) { cli::cli_abort("No appropriate files found in {.path {path}}") } - template <- check_template(path) + template <- check_template(path, template) df_list <- lapply(path, read_one_image_csv, template = template, ...) @@ -43,51 +62,114 @@ read_image_data <- function(path, pattern, recursive = FALSE, ...) { df <- janitor::clean_names(df) df <- dplyr::relocate(df, "date_time", .after = "deployment_label") + df <- clean_timelapse_video_data(df) df <- standardize_trigger_mode(df) df <- fill_snow_values(df) df <- make_snow_range_cols(df) + df <- check_add_total_count_episode(df) - as.image_data(df) + as.image_data(df, template = basename(template)) } -check_template <- function(files) { +check_template <- function(files, template = NULL) { + if (!is.null(template)) { + if (!file.exists(template)) { + cli::cli_abort("Provided template {.path {template}} does not exist") + } + return(template) + } + # This is an escape hatch for shiny - since the file names assigned from # fileInput() are random, we assign the csv files vector names from the original # filenames, and use those here to find the template files <- names(files) %||% files - pattern <- ".+Template_(v[0-9]{8}.*)\\.csv$" + pattern <- ".+Template_(.+)\\.csv$" + if (!any(grepl(pattern, files))) { + if (rlang::is_interactive()) { + return(choose_package_template()) + } cli::cli_abort("No recognized Timelapse template in filenames") } - templates <- gsub(pattern, "\\1", files) - template <- unique(templates) + templates <- unique(gsub(pattern, "\\1", files)) + template <- sort(templates)[length(templates)] - if (length(template) == 0) { - cli::cli_warn("Unrecognized Timelapse template in filenames") - } - - if (length(template) > 1) { + if (length(templates) > 1) { + # use the one with the latest version number cli::cli_warn( "More than one image labelling template found in - {.path {dirname(files)[1]}}: {.str {template}}" + {.path {dirname(files)[1]}}: {.str {templates}}. + Using {.path {template}}." ) } - template + + pkg_templates <- get_package_templates() + + template_tdb <- grep(template, pkg_templates, value = TRUE, fixed = TRUE) + + if (length(template_tdb) == 0) { + cli::cli_abort("Unrecognized Timelapse template in filenames") + } + + template_tdb[length(template_tdb)] +} + +choose_package_template <- function(error_call = rlang::caller_env()) { + pkg_templates <- get_package_templates() + # Exclude the master picklist, which is not a labelling template + pkg_templates <- pkg_templates[ + !grepl("MasterTemplateFieldPicklist", basename(pkg_templates)) + ] + + names <- tools::file_path_sans_ext(basename(pkg_templates)) + title <- cli::format_inline( + "No Timelapse template found in filenames. Which template do you want to use? (0 to exit)" + ) + choice <- utils::menu( + choices = cli::style_bold(names), + title = title + ) + if (choice == 0L) { + cli::cli_abort("No template selected", call = error_call) + } + + pkg_templates[[choice]] } read_one_image_csv <- function(path, template, ...) { col_names <- strsplit(readLines(path, n = 1), ",")[[1]] - col_spec <- image_file_cols(template, col_names) + col_spec <- tdb_to_colspec(template, col_names) + df <- readr::read_csv( path, col_types = col_spec, name_repair = "unique_quiet", ... ) + + df <- drop_empty_unnamed_cols(df) + + if (length(setdiff(names(df), names(col_spec$cols))) > 0) { + cli::cli_warn( + "File {.path {path}} has unexpected columns: {.str {setdiff(names(df), names(col_spec$cols))}}" + ) + } reconcile_date_time_fields(df, path) } +drop_empty_unnamed_cols <- function(df) { + # Drop auto-generated column names (e.g. `...41`) that arise from trailing + # commas in CSV, but only when the column contains no data. + auto_named <- grep("^[.]{3}[0-9]+$", names(df), value = TRUE) + empty_auto <- auto_named[vapply( + df[auto_named], + \(col) all(is.na(col)), + logical(1) + )] + df[, !names(df) %in% empty_auto, drop = FALSE] +} + reconcile_date_time_fields <- function(df, path) { if ("DateTime" %in% names(df)) { return(df) @@ -105,62 +187,11 @@ reconcile_date_time_fields <- function(df, path) { df } -image_file_cols <- function(template, names) { - all_col_names <- list( - v20230518 = readr::cols_only( - RootFolder = readr::col_character(), - Study_Area_Name = readr::col_character(), - Sample_Station_Label = readr::col_character(), - Deployment_Label = readr::col_character(), - Date = readr::col_character(), - Time = readr::col_character(), - DateTime = readr::col_datetime(), - Episode = readr::col_character(), - Species = readr::col_character(), - Total_Count_Episode = readr::col_double(), - Obj_Count_Image = readr::col_integer(), - Adult_Male = readr::col_integer(), - Adult_Female = readr::col_integer(), - Adult_Unclassified_Sex = readr::col_integer(), - Yearling_Male = readr::col_integer(), - Yearling_Female = readr::col_integer(), - Yearling_Unclassified_Sex = readr::col_integer(), - Young_of_Year_Unclassified_Sex = readr::col_integer(), - Juvenile_Unclassified_Sex = readr::col_integer(), - Male_Unclassified_Age = readr::col_integer(), - Female_Unclassified_Age = readr::col_integer(), - Unclassified_Life_Stage_and_Sex = readr::col_integer(), - Antler_Class = readr::col_character(), - Animal_Identifiable = readr::col_logical(), - Animal_Tagged = readr::col_logical(), - Behaviour_1 = readr::col_character(), - Behaviour_2 = readr::col_character(), - Behaviour_3 = readr::col_character(), - Human_Use_Type = readr::col_character(), - Human_Transport_Mode = readr::col_character(), - Temperature = readr::col_number(), - Snow_Depth = readr::col_character(), - Lens_Obscured = readr::col_logical(), - Starred = readr::col_logical(), - Needs_Review = readr::col_logical(), - Comment = readr::col_character(), - Surveyor = readr::col_character(), - Trigger_Mode = readr::col_character(), - File = readr::col_character(), - RelativePath = readr::col_character(), - DeleteFlag = readr::col_logical() - ) - ) - - # Get the cols that match the template - col_types <- all_col_names[[template]] - - # Subset to match the names in the data - col_types$cols <- col_types$cols[names] - col_types -} - make_snow_range_cols <- function(x) { + if (!"snow_depth" %in% names(x)) { + return(x) + } + x <- dplyr::mutate( x, snow_is_est = grepl("Est", .data$snow_depth), @@ -195,12 +226,18 @@ make_snow_range_cols <- function(x) { } standardize_trigger_mode <- function(x) { + if (!"trigger_mode" %in% names(x)) { + return(x) + } + x$trigger_mode <- dplyr::case_when( x$trigger_mode == "M" ~ "Motion Detection", x$trigger_mode == "T" ~ "Time Lapse", .default = x$trigger_mode ) - if (!all(x$trigger_mode %in% c("Motion Detection", "Time Lapse"))) { + if ( + !all(x$trigger_mode %in% c("Motion Detection", "Time Lapse", NA_character_)) + ) { cli::cli_abort( "Unexpected values found in {.var trigger_mode} column." ) @@ -222,6 +259,10 @@ bin_snow_depths <- function(x) { } fill_snow_values <- function(x) { + if (!"snow_depth" %in% names(x)) { + return(x) + } + snow_vals <- dplyr::filter( x, !is.na(.data$snow_depth), @@ -238,5 +279,67 @@ fill_snow_values <- function(x) { x$snow_depth[is.na(x$snow_depth)] <- x$snow_depth_src[is.na(x$snow_depth)] - dplyr::select(x, , -"date", -"snow_depth_src") + dplyr::select(x, -"date", -"snow_depth_src") +} + +check_add_total_count_episode <- function(df) { + if ("total_count_episode" %in% names(df)) { + return(df) + } + + df |> + dplyr::rowwise() |> + dplyr::mutate( + total_count_episode = sum( + dplyr::c_across(dplyr::any_of(animal_count_cols())), + na.rm = TRUE + ) + ) |> + dplyr::ungroup() +} + +animal_count_cols <- function() { + c( + "adult_male", + "adult_female", + "adult_unclassified_sex", + "yearling_male", + "yearling_female", + "yearling_unclassified_sex", + "young_of_year_unclassified_sex", + "juvenile_unclassified_sex", + "male_unclassified_age", + "female_unclassified_age", + "unclassified_life_stage_and_sex" + ) +} + +clean_timelapse_video_data <- function(df) { + file_ext <- tolower(tools::file_ext(df$file)) + + img_file_types <- c("jpg", "jpeg", "png") + video_file_types <- c("mp4", "avi", "mov", "mkv", "wmv") + + file_ext[file_ext %in% img_file_types] <- "image" + file_ext[file_ext %in% video_file_types] <- "video" + + if (length(unique(file_ext)) %in% 0:1 && !anyNA(df$trigger_mode)) { + # should be just videos, not blank lines where trigger mode + return(df) + } + + df |> + dplyr::mutate(file_type = file_ext) |> + dplyr::filter( + (.data$file_type == "video" & !is.na(.data$episode)) | + .data$trigger_mode == "Time Lapse" + ) |> + dplyr::mutate( + trigger_mode = ifelse( + is.na(.data$trigger_mode), + "Motion Detection", + .data$trigger_mode + ) + ) |> + dplyr::select(-"file_type") } diff --git a/R/qa-images.R b/R/qa-images.R index 46692f9..59fc36d 100644 --- a/R/qa-images.R +++ b/R/qa-images.R @@ -66,12 +66,16 @@ qa_image_data <- function( dplyr::if_any(dplyr::starts_with("QA")) ) + # Identify QA_ columns that are all FALSE (no issues flagged) # and drop QA columns with no issues - dplyr::select( - out, - dplyr::everything(), - -(dplyr::starts_with("QA_") & dplyr::where(~ is.logical(.x) && !any(.x))) - ) + qa_cols <- grep("^QA_", names(out), value = TRUE) + empty_qa_cols <- qa_cols[vapply( + out[qa_cols], + \(x) is.logical(x) && !any(x, na.rm = TRUE), + logical(1) + )] + + dplyr::select(out, -dplyr::any_of(empty_qa_cols)) } find_blanks <- function(x) { @@ -105,24 +109,12 @@ find_unmatched <- function(x, y, z, exclude_human_use) { validate_counts <- function( x, - cols = c( - "adult_male", - "adult_female", - "adult_unclassified_sex", - "yearling_male", - "yearling_female", - "yearling_unclassified_sex", - "young_of_year_unclassified_sex", - "juvenile_unclassified_sex", - "male_unclassified_age", - "female_unclassified_age", - "unclassified_life_stage_and_sex" - ), + cols = animal_count_cols(), exclude_human_use ) { x <- dplyr::mutate( x, - sum_counts = rowSums(dplyr::pick(dplyr::all_of(cols)), na.rm = TRUE), + sum_counts = rowSums(dplyr::pick(dplyr::any_of(cols)), na.rm = TRUE), QA_sum_counts = is_true_vec( .data$sum_counts != .data$total_count_episode | .data$sum_counts > 0 & is.na(.data$total_count_episode) diff --git a/R/summary.R b/R/summary.R index bacb1fe..d4f40a4 100644 --- a/R/summary.R +++ b/R/summary.R @@ -98,35 +98,51 @@ summary.image_data <- function(object, ...) { "{.val {length(unique(object$sample_station_label))}} sample stations." )) - cli::cli_alert_info("Image counts by trigger mode:") - table_print_helper(object$trigger_mode) + if ("trigger_mode" %in% names(object)) { + cli::cli_alert_info("Image counts by trigger mode:") + table_print_helper(object$trigger_mode) + } - cli::cli_alert_info( - "{.val {sum(object$lens_obscured, na.rm = TRUE)}} images with lens obscured." - ) + if ("lens_obscured" %in% names(object)) { + cli::cli_alert_info( + "{.val {sum(object$lens_obscured, na.rm = TRUE)}} images with lens obscured." + ) + } - cli::cli_alert_info( - "{.val {sum(object$needs_review, na.rm = TRUE)}} images starred." - ) + if ("starred" %in% names(object)) { + cli::cli_alert_info( + "{.val {sum(object$starred, na.rm = TRUE)}} images starred." + ) + } - cli::cli_alert_warning( - "{.val {sum(object$needs_review, na.rm = TRUE)}} images flagged for review." - ) + if ("needs_review" %in% names(object)) { + cli::cli_alert_warning( + "{.val {sum(object$needs_review, na.rm = TRUE)}} images flagged for review." + ) + } - cli::cli_alert_info( - "Dates are between {.val {range(as.Date(object$date_time), na.rm = TRUE)}}." - ) + if ("date_time" %in% names(object)) { + cli::cli_alert_info( + "Dates are between {.val {range(as.Date(object$date_time), na.rm = TRUE)}}." + ) + } - cli::cli_alert_info( - "Temperatures are between {.val {range(object$temperature, na.rm = TRUE)}} C." - ) + if ("temperature" %in% names(object)) { + cli::cli_alert_info( + "Temperatures are between {.val {range(object$temperature, na.rm = TRUE)}} C." + ) + } - cli::cli_alert_info( - "Snow depths are between {.val {range(object$snow_depth_lower, na.rm = TRUE)}} cm." - ) + if ("snow_depth_lower" %in% names(object)) { + cli::cli_alert_info( + "Snow depths are between {.val {range(object$snow_depth_lower, na.rm = TRUE)}} cm." + ) + } - cli::cli_alert_info("Species counts:") - table_print_helper(object$species) + if ("species" %in% names(object)) { + cli::cli_alert_info("Species counts:") + table_print_helper(object$species) + } cli::cat_line("") cli::cli_alert_warning( diff --git a/R/sysdata.rda b/R/sysdata.rda index 0b8ca1c..9fd9747 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/tdb-to-colspec.R b/R/tdb-to-colspec.R new file mode 100644 index 0000000..13dd916 --- /dev/null +++ b/R/tdb-to-colspec.R @@ -0,0 +1,139 @@ +tdb_to_colspec <- function(tdb, col_names = NULL) { + template <- parse_tdb(tdb) + template_list <- map_tdb_types_to_colspec(template, col_names) + + # Master template has more specific field type mapping, so + # use it to fill in any character fields in the template that might + # have better-defined types in the master template + master_template <- master_template_path() |> + parse_tdb() |> + map_tdb_types_to_colspec(names(template_list), warn_missing = FALSE) + + # For columns present in both templates, only let the master template + # override when the current mapped type is a generic character column. + overlapping <- intersect(names(master_template), names(template_list)) + for (nm in overlapping) { + if (inherits(template_list[[nm]], "collector_character")) { + template_list[[nm]] <- master_template[[nm]] + } + } + + do.call(readr::cols, template_list) +} + +parse_tdb <- function(tdb) { + con <- DBI::dbConnect( + RSQLite::SQLite(), + tdb + ) + + on.exit(DBI::dbDisconnect(con)) + + template_tbl <- DBI::dbReadTable(con, "TemplateTable") + + template_tbl <- template_tbl[order(template_tbl$SpreadsheetOrder), ] + + tl_template <- lapply(seq_len(nrow(template_tbl)), \(i) { + row <- template_tbl[i, ] + list( + col = row$DataLabel, + desc = row$Tooltip, + type = row$Type, + default = row$DefaultValue, + list = if (!nzchar(row$List)) NULL else jsonlite::fromJSON(row$List) + ) + }) + + names(tl_template) <- vapply( + tl_template, + `[[`, + "col", + FUN.VALUE = "" + ) + + tl_template +} + +map_tdb_types_to_colspec <- function( + tdb_template, + col_names = NULL, + warn_missing = TRUE +) { + # Map tdb types to readr col_spec types + type_map <- list( + "Note" = readr::col_character(), + "IntegerPositive" = readr::col_integer(), + "DateTime" = readr::col_datetime(), + "Date" = readr::col_character(), + "Time" = readr::col_character(), + # Could be readr::col_factor with levels from the list column + "FixedChoice" = readr::col_character(), + "MultiChoice" = readr::col_character(), + "RelativePath" = readr::col_character(), + "File" = readr::col_character(), + "DeleteFlag" = readr::col_logical(), + "Flag" = readr::col_logical() + ) + + col_spec_list <- lapply(tdb_template, function(field) { + type_map[[field$type]] %||% readr::col_character() + }) + + if (!is.null(col_names)) { + missing_cols <- setdiff(col_names, names(col_spec_list)) + + if (length(missing_cols) > 0) { + if (warn_missing) { + ok_missing_cols <- c("RootFolder", "Date", "Time") + warn_cols <- setdiff(missing_cols, ok_missing_cols) + if (length(warn_cols) > 0) { + cli::cli_warn( + "The following columns are in the data but not in the template: {.str {warn_cols}}. + They will be read as character types; please cast to the appropriate type if necessary." + ) + } + } + + for (col in missing_cols) { + col_spec_list[[col]] <- readr::col_character() + } + } + } else { + col_names <- names(col_spec_list) + } + + col_spec_list <- col_spec_list[intersect(names(col_spec_list), col_names)] + + override_types(col_spec_list) +} + +get_package_templates <- function() { + list.files( + system.file( + "extdata", + "timelapse-templates", + package = "bccamtrap" + ), + pattern = "\\.tdb$", + full.names = TRUE + ) +} + +master_template_path <- function() { + templates <- get_package_templates() + templates[ + basename(templates) == "RISC_WCR_MasterTemplateFieldPicklist_20250109.tdb" + ] +} + +override_types <- function(col_spec_list) { + # Override types for specific columns based on column name pattern + for (col in names(col_spec_list)) { + if (col == "Temperature") { + col_spec_list[[col]] <- readr::col_number() + } else if (col == "Obj_Count_Image") { + col_spec_list[[col]] <- readr::col_integer() + } + } + col_spec_list +} diff --git a/README.Rmd b/README.Rmd index c34af12..7382f99 100644 --- a/README.Rmd +++ b/README.Rmd @@ -281,9 +281,16 @@ deployments <- read_deployments_csv("path-to-deployments.csv") ### Image data -We can read in an entire directory of image data from multiple csv files, as long -as they all follow the same TimeLapse template. Currently it is expected that -they follow the `v20230518` template. +Read in an entire directory of image data from multiple csv files using +`read_image_data()`. The function needs to know which TimeLapse template +was used to label the images so it can parse the columns correctly. There +are three ways to specify the template: + +**1. Template name in the filenames (default)** + +If your csv filenames contain a TimeLapse template identifier - for example +`Camera01_Template_Ungulate_General_v2.csv` - `read_image_data()` will detect +it automatically and select the matching bundled template: ```{r} #| eval: false @@ -291,6 +298,38 @@ image_data <- read_image_data(data_path) image_data ``` +**2. Interactive picklist** + +If your filenames don't contain a template identifier, `read_image_data()` will present an +interactive menu of the bundled templates to choose from when run in an +interactive R session: + +```r +image_data <- read_image_data(data_path) +#> No Timelapse template found in filenames. Which template do you want to use? (0 to exit) +#> +#> 1: RISC_WCR_ImageLabelling_Template_v20230518.1 +#> 2: RISC_WCR_ImageLabelling_Template_v20230518.2 +#> 3: TimelapseTemplate_Elk_Migration_v1 +#> 4: TimelapseTemplate_Elk_Wallows_v1 +#> 5: TimelapseTemplate_Ungulate_General_v1 +#> 6: TimelapseTemplate_Ungulate_General_v2 +#> +#> Selection: +``` + +**3. Supply a template file directly** + +Pass the path to any `.tdb` TimeLapse template file via the `template` argument. +This is useful when working with a custom or newer template not yet bundled with +the package: + +```{r} +#| eval: false +image_data <- read_image_data(data_path, template = "path/to/MyTemplate.tdb") +image_data +``` + ```{r} #| echo: false image_data <- read_image_data(data_path) diff --git a/README.md b/README.md index e8e360e..8c11fc6 100644 --- a/README.md +++ b/README.md @@ -324,13 +324,52 @@ deployments <- read_deployments_csv("path-to-deployments.csv") ### Image data -We can read in an entire directory of image data from multiple csv -files, as long as they all follow the same TimeLapse template. Currently -it is expected that they follow the `v20230518` template. +Read in an entire directory of image data from multiple csv files using +`read_image_data()`. The function needs to know which TimeLapse template +was used to label the images so it can parse the columns correctly. +There are three ways to specify the template: + +**1. Template name in the filenames (default)** + +If your csv filenames contain a TimeLapse template identifier - for +example `Camera01_Template_Ungulate_General_v2.csv` - +`read_image_data()` will detect it automatically and select the matching +bundled template: ``` r image_data <- read_image_data(data_path) image_data +``` + +**2. Interactive picklist** + +If your filenames don’t contain a template identifier, +`read_image_data()` will present an interactive menu of the bundled +templates to choose from when run in an interactive R session: + +``` r +image_data <- read_image_data(data_path) +#> No Timelapse template found in filenames. Which template do you want to use? (0 to exit) +#> +#> 1: RISC_WCR_ImageLabelling_Template_v20230518.1 +#> 2: RISC_WCR_ImageLabelling_Template_v20230518.2 +#> 3: TimelapseTemplate_Elk_Migration_v1 +#> 4: TimelapseTemplate_Elk_Wallows_v1 +#> 5: TimelapseTemplate_Ungulate_General_v1 +#> 6: TimelapseTemplate_Ungulate_General_v2 +#> +#> Selection: +``` + +**3. Supply a template file directly** + +Pass the path to any `.tdb` TimeLapse template file via the `template` +argument. This is useful when working with a custom or newer template +not yet bundled with the package: + +``` r +image_data <- read_image_data(data_path, template = "path/to/MyTemplate.tdb") +image_data ``` #> # A tibble: 11,833 × 43 @@ -348,7 +387,7 @@ image_data #> 10 100RECNX Test Project 19_1 19_1_20230605 #> # ℹ 11,823 more rows #> # ℹ 39 more variables: date_time , episode , species , - #> # total_count_episode , obj_count_image , adult_male , + #> # total_count_episode , obj_count_image , adult_male , #> # adult_female , adult_unclassified_sex , yearling_male , #> # yearling_female , yearling_unclassified_sex , #> # young_of_year_unclassified_sex , juvenile_unclassified_sex , @@ -369,7 +408,7 @@ summary(image_data) #> Motion Detection Time Lapse #> 8657 3176 #> ℹ 117 images with lens obscured. -#> ℹ 4 images starred. +#> ℹ 25 images starred. #> ! 4 images flagged for review. #> ℹ Dates are between 2022-11-07 and 2023-07-10. #> ℹ Temperatures are between -10 and 37 C. @@ -425,7 +464,7 @@ images_with_metadata #> 9 100RECNX 19_1_20230605 2022-11-14 12:00:00 5:1|1 #> 10 100RECNX 19_1_20230605 2022-11-15 12:00:00 6:1|1 #> # ℹ 11,823 more rows -#> # ℹ 92 more variables: total_count_episode , obj_count_image , +#> # ℹ 92 more variables: total_count_episode , obj_count_image , #> # adult_male , adult_female , adult_unclassified_sex , #> # yearling_male , yearling_female , #> # yearling_unclassified_sex , young_of_year_unclassified_sex , @@ -659,7 +698,7 @@ make_sample_sessions(image_data) #> 15 2023-01-10 2022-11-15 2023-01-10 197 8 #> 16 31_20230605 2023-01-25 2023-06-05 382 15 #> 17 35_20230708 2022-11-18 2023-07-08 261 3 - #> # ℹ 8 more variables: n_species , n_individuals , + #> # ℹ 8 more variables: n_species , n_individuals , #> # n_motion_photos , n_motion_photos_lens_obscured , #> # n_tl_photos , n_tl_photos_lens_obscured , sample_gaps , #> # trap_days @@ -693,7 +732,7 @@ make_sample_sessions( #> 14 2023-01-10 2022-12-01 2023-01-10 95 4 #> 15 31_20230605 2023-01-25 2023-04-30 311 8 #> 16 35_20230708 2022-12-01 2023-04-30 152 0 - #> # ℹ 8 more variables: n_species , n_individuals , + #> # ℹ 8 more variables: n_species , n_individuals , #> # n_motion_photos , n_motion_photos_lens_obscured , #> # n_tl_photos , n_tl_photos_lens_obscured , sample_gaps , #> # trap_days @@ -722,7 +761,7 @@ sample_rai(image_data) #> 9 2023-01-10 2022-11-15 2023-01-10 56 Cougar #> 10 2023-01-10 2022-11-15 2023-01-10 56 Roosevelt Elk #> # ℹ 43 more rows -#> # ℹ 3 more variables: n_detections , total_count , rai +#> # ℹ 3 more variables: n_detections , total_count , rai ``` You can set it to do a subset of species and/or deployment labels, and @@ -742,7 +781,7 @@ sample_rai( #> #> 1 19_2_20230605 2022-12-01 2023-04-30 151 Roosevelt Elk #> 2 29_1_20230605 2022-12-01 2023-04-30 148 Roosevelt Elk -#> # ℹ 3 more variables: n_detections , total_count , rai +#> # ℹ 3 more variables: n_detections , total_count , rai ``` You can also calculate RAI across all deployments by setting @@ -758,7 +797,7 @@ sample_rai( ) #> # A tibble: 1 × 7 #> sample_start_date sample_end_date trap_days species n_detections total_count -#> +#> #> 1 2022-12-01 2023-04-30 151 Roosevel… 51 146 #> # ℹ 1 more variable: rai ``` @@ -776,7 +815,7 @@ spp_comp <- sample_rai( spp_comp #> # A tibble: 7 × 7 #> sample_start_date sample_end_date trap_days species n_detections total_count -#> +#> #> 1 2022-12-01 2023-04-30 131 Avian (c… 1 1 #> 2 2022-12-01 2023-04-30 151 Black Be… 28 28 #> 3 2022-12-01 2023-04-30 151 Cougar 8 8 @@ -855,7 +894,7 @@ rai_by_time(image_data) #> 9 Avian (comments) Test Project 2022-11-15 2 0.5 #> 10 Avian (comments) Test Project 2022-11-16 2 -1 #> # ℹ 2,195 more rows -#> # ℹ 4 more variables: n_detections , total_count , trap_days , +#> # ℹ 4 more variables: n_detections , total_count , trap_days , #> # rai ``` @@ -884,9 +923,9 @@ elk_roll_avg #> 9 Roosevelt Elk Test Project 2022-11-15 2 0.5 #> 10 Roosevelt Elk Test Project 2022-11-16 2 -1 #> # ℹ 235 more rows -#> # ℹ 10 more variables: n_detections , total_count , trap_days , +#> # ℹ 10 more variables: n_detections , total_count , trap_days , #> # rai , roll_mean_max_snow , roll_mean_temp , -#> # roll_trap_days , roll_detections , roll_count , +#> # roll_trap_days , roll_detections , roll_count , #> # roll_rai ggplot(elk_roll_avg, aes(x = date, y = roll_rai)) + @@ -920,7 +959,7 @@ ggplot(elk_roll_avg, aes(x = date, y = roll_mean_max_snow)) + #> (`geom_line()`). ``` - + We can change the way snow measurements are aggregated across sites when `by_deployment = FALSE`. By default it uses `max`, but we can set it to @@ -947,7 +986,7 @@ ggplot(elk_roll_avg, aes(x = date, y = roll_mean_mean_snow)) + #> (`geom_line()`). ``` - + And we can compare Elk activity to snow levels: @@ -969,7 +1008,7 @@ ggplot( #> (`geom_point()`). ``` - + And temperature: @@ -986,7 +1025,7 @@ ggplot(elk_roll_avg, aes(x = roll_mean_temp, y = roll_rai)) + #> (`geom_point()`). ``` - + We can compare raw counts vs snow depth across deployments. Note that for daily counts (`by = "date"`) when `by_deployment = TRUE`, the @@ -1009,7 +1048,7 @@ ggplot( geom_point() ``` - + If we want to compare the RAI of two species, we can specify them in the `species` argument, and colour our plot by species (if we left the diff --git a/data-raw/data-raw.R b/data-raw/data-raw.R index 283b8c3..6e84025 100644 --- a/data-raw/data-raw.R +++ b/data-raw/data-raw.R @@ -1,8 +1,6 @@ -source("data-raw/field_info.R") source("data-raw/spp-codes.R") usethis::use_data( - tl_template_v20230518_1, spp_codes, overwrite = TRUE, internal = TRUE diff --git a/data-raw/field_info.R b/data-raw/field_info.R deleted file mode 100644 index a044a76..0000000 --- a/data-raw/field_info.R +++ /dev/null @@ -1,45 +0,0 @@ -# Copyright 2024 Province of British Columbia -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and limitations under the License. - -# Timelapse templates are simply a sqlite database with the extension .tdb -# This takes a timelapse template (Currently v20230518.1), reads it from the -# database, and transforms it into an R list with all of the field info. -# usethis::use_data() stores it as an interal dataset inside the package to use -# for field validation of input data. - -library(DBI) -library(RSQLite) -library(jsonlite) - -con <- DBI::dbConnect( - RSQLite::SQLite(), - "data-raw/RISC_WCR_ImageLabelling_Template_v20230518.1.tdb" -) - -# dbListTables(con) - -template_tbl <- dbReadTable(con, "TemplateTable") - -template_tbl <- template_tbl[order(template_tbl$SpreadsheetOrder), ] - -tl_template_v20230518_1 <- lapply(seq_len(nrow(template_tbl)), \(i) { - row <- template_tbl[i, ] - list( - col = row$DataLabel, - desc = row$Tooltip, - type = row$type, - default = row$DefaultValue, - list = if (!nzchar(row$List)) NULL else jsonlite::fromJSON(row$List) - ) -}) - -names(tl_template_v20230518_1) <- template_tbl$DataLabel diff --git a/data-raw/RISC_WCR_ImageLabelling_Template_v20230518.1.tdb b/inst/extdata/timelapse-templates/RISC_WCR_ImageLabelling_Template_v20230518.1.tdb similarity index 100% rename from data-raw/RISC_WCR_ImageLabelling_Template_v20230518.1.tdb rename to inst/extdata/timelapse-templates/RISC_WCR_ImageLabelling_Template_v20230518.1.tdb diff --git a/inst/extdata/timelapse-templates/RISC_WCR_ImageLabelling_Template_v20230518.2.tdb b/inst/extdata/timelapse-templates/RISC_WCR_ImageLabelling_Template_v20230518.2.tdb new file mode 100644 index 0000000..beb789e Binary files /dev/null and b/inst/extdata/timelapse-templates/RISC_WCR_ImageLabelling_Template_v20230518.2.tdb differ diff --git a/inst/extdata/timelapse-templates/RISC_WCR_MasterTemplateFieldPicklist_20250109.tdb b/inst/extdata/timelapse-templates/RISC_WCR_MasterTemplateFieldPicklist_20250109.tdb new file mode 100644 index 0000000..37086a4 Binary files /dev/null and b/inst/extdata/timelapse-templates/RISC_WCR_MasterTemplateFieldPicklist_20250109.tdb differ diff --git a/inst/extdata/timelapse-templates/TimelapseTemplate_Elk_Migration_v1.tdb b/inst/extdata/timelapse-templates/TimelapseTemplate_Elk_Migration_v1.tdb new file mode 100644 index 0000000..7b3c832 Binary files /dev/null and b/inst/extdata/timelapse-templates/TimelapseTemplate_Elk_Migration_v1.tdb differ diff --git a/inst/extdata/timelapse-templates/TimelapseTemplate_Elk_Wallows_v1.tdb b/inst/extdata/timelapse-templates/TimelapseTemplate_Elk_Wallows_v1.tdb new file mode 100644 index 0000000..8f8c226 Binary files /dev/null and b/inst/extdata/timelapse-templates/TimelapseTemplate_Elk_Wallows_v1.tdb differ diff --git a/inst/extdata/timelapse-templates/TimelapseTemplate_Ungulate_General_v1.tdb b/inst/extdata/timelapse-templates/TimelapseTemplate_Ungulate_General_v1.tdb new file mode 100644 index 0000000..5103d5a Binary files /dev/null and b/inst/extdata/timelapse-templates/TimelapseTemplate_Ungulate_General_v1.tdb differ diff --git a/inst/extdata/timelapse-templates/TimelapseTemplate_Ungulate_General_v2.tdb b/inst/extdata/timelapse-templates/TimelapseTemplate_Ungulate_General_v2.tdb new file mode 100644 index 0000000..d69183d Binary files /dev/null and b/inst/extdata/timelapse-templates/TimelapseTemplate_Ungulate_General_v2.tdb differ diff --git a/inst/scratch-templates.R b/inst/scratch-templates.R new file mode 100644 index 0000000..154749f --- /dev/null +++ b/inst/scratch-templates.R @@ -0,0 +1,52 @@ +# devtools::install_github("bcgov/bccamtrap") +library(bccamtrap) + +migration_data <- read_image_data( + "inst/extdata/example-data/Example-input-CSV_migration-cams_Migration_v1.csv" +) +# Choose from the menu of templates (#3 - Migration Template) since the template name is not in the file name + +head(migration_data) + +summary(migration_data) + +migration_data_qa <- qa_image_data( + migration_data, + check_snow = FALSE, + exclude_human_use = FALSE +) + +migration_data_qa + +wallow_elk_data <- read_image_data( + "inst/extdata/example-data/Example-input-CSV_wallow-cams_Elk_Template_Wallows_v1.csv" +) + +# The name of the template is in the file name, so it should be automatically +# detected and used to read the data + +summary(wallow_elk_data) + +wallow_elk_data_qa <- qa_image_data( + wallow_elk_data, + check_snow = FALSE, + exclude_human_use = FALSE +) + +wallow_elk_data_qa + +new_wallow_elk_data <- read_image_data( + "inst/extdata/example-data/Example-input-CSV_wallow-cams_updated_approach.csv" +) + +# Choose from the menu of temlates (#4 - Wallows) + +summary(new_wallow_elk_data) + +new_wallow_elk_data_qa <- qa_image_data( + new_wallow_elk_data, + check_snow = FALSE, + exclude_human_use = FALSE +) + +new_wallow_elk_data_qa diff --git a/man/figures/README-unnamed-chunk-28-1.png b/man/figures/README-unnamed-chunk-28-1.png index c932fe8..e1a441f 100644 Binary files a/man/figures/README-unnamed-chunk-28-1.png and b/man/figures/README-unnamed-chunk-28-1.png differ diff --git a/man/figures/README-unnamed-chunk-29-1.png b/man/figures/README-unnamed-chunk-29-1.png index 8b007af..c932fe8 100644 Binary files a/man/figures/README-unnamed-chunk-29-1.png and b/man/figures/README-unnamed-chunk-29-1.png differ diff --git a/man/figures/README-unnamed-chunk-30-1.png b/man/figures/README-unnamed-chunk-30-1.png index 35619d0..8b007af 100644 Binary files a/man/figures/README-unnamed-chunk-30-1.png and b/man/figures/README-unnamed-chunk-30-1.png differ diff --git a/man/figures/README-unnamed-chunk-31-1.png b/man/figures/README-unnamed-chunk-31-1.png index 79e388b..35619d0 100644 Binary files a/man/figures/README-unnamed-chunk-31-1.png and b/man/figures/README-unnamed-chunk-31-1.png differ diff --git a/man/figures/README-unnamed-chunk-32-1.png b/man/figures/README-unnamed-chunk-32-1.png new file mode 100644 index 0000000..79e388b Binary files /dev/null and b/man/figures/README-unnamed-chunk-32-1.png differ diff --git a/man/read_image_data.Rd b/man/read_image_data.Rd index 97c4973..71c27e2 100644 --- a/man/read_image_data.Rd +++ b/man/read_image_data.Rd @@ -4,7 +4,7 @@ \alias{read_image_data} \title{Read image data from a collection of csvs from TimeLapse} \usage{ -read_image_data(path, pattern, recursive = FALSE, ...) +read_image_data(path, pattern, recursive = FALSE, template = NULL, ...) } \arguments{ \item{path}{path to directory of image files, a single .csv file, or a character @@ -15,13 +15,28 @@ the regular expression will read. Default \code{FALSE}.} \item{recursive}{should files found within subfolders of \code{path} also be read?} +\item{template}{path to a "\code{.tdb}" TimeLapse Template file. Optional; if not provided, +the function will attempt to identify the appropriate internal template +based on the file names in \code{path}.} + \item{...}{arguments passed on to \code{\link[readr:read_delim]{readr::read_csv()}}} } \value{ -a \code{data.frame} of Timelapse image data from the files found in \code{path} +a \code{data.frame} of Timelapse image data from the files found in \code{path}. +The data.frame will have an "image_data" class, and an attribute "template" +with the name of the template used to read the data. } \description{ In addition to reading in the data, this function copies snow depth data from the timelapse photo for each day into the motion photos for that day, -to facilitate analysis. +to facilitate analysis. It also does basic standardization of trigger mode values, +creates numeric snow depth columns, and checks for the presence of a +total_count_episode column, adding one if missing. If the data has separate +Date and Time columns instead of a combined DateTime column, +these will be reconciled into a single DateTime column. All column names are +standardized to snake_case. +} +\details{ +For wallow data, this also removes static images (both timelapse and motion activated), +and only keeps the video records. } diff --git a/tests/testthat/_snaps/image-data.md b/tests/testthat/_snaps/image-data.md index 9eab28f..aa46a3c 100644 --- a/tests/testthat/_snaps/image-data.md +++ b/tests/testthat/_snaps/image-data.md @@ -48,7 +48,7 @@ { "type": "character", "attributes": {}, - "value": ["numeric"] + "value": ["integer"] }, { "type": "character", @@ -278,7 +278,7 @@ { "type": "character", "attributes": {}, - "value": ["numeric"] + "value": ["integer"] }, { "type": "character", @@ -464,23 +464,34 @@ read_image_data("foofydir") Condition Error in `read_image_data()`: - ! Directory 'foofydir' does not exist + ! Path(s) 'foofydir' do not exist -# check_template() works +# read_one_image_csv() warns when file has extra named columns Code - check_template(files) + read_one_image_csv(f, master_template_path()) Condition Warning: - More than one image labelling template found in 'dirname': "v12345678" and "v87654321" + The following columns are in the data but not in the template: "Extra_Col". They will be read as character types; please cast to the appropriate type if necessary. Output - [1] "v12345678" "v87654321" + # A tibble: 1 x 3 + RootFolder DateTime Extra_Col + + 1 /root 2023-01-01 12:00:00 foo ---- +# invalid template errors correctly Code - check_template("temp_foobar.csv") + check_template("Template_5.csv") Condition Error in `check_template()`: ! No recognized Timelapse template in filenames +# interactive template menu with no selection errors + + Code + check_template("no_template_in_name.csv") + Condition + Error in `choose_package_template()`: + ! No template selected + diff --git a/tests/testthat/_snaps/rai.md b/tests/testthat/_snaps/rai.md index 7d0f2f4..d14b6cb 100644 --- a/tests/testthat/_snaps/rai.md +++ b/tests/testthat/_snaps/rai.md @@ -17,7 +17,7 @@ 9 B4_20230517 2022-12-16 2023-05-17 143 Roosevelt Elk 10 C1_20230517 2022-12-17 2023-05-17 145 Black Bear # i 19 more rows - # i 3 more variables: n_detections , total_count , rai + # i 3 more variables: n_detections , total_count , rai --- @@ -31,7 +31,7 @@ 2 A4_20230517 2022-12-16 2023-05-17 153 Mule Deer 3 A4_20230517 2022-12-16 2023-05-17 153 Roosevelt Elk 4 A4_20230517 2022-12-16 2023-05-17 153 Unknown - # i 3 more variables: n_detections , total_count , rai + # i 3 more variables: n_detections , total_count , rai --- @@ -51,7 +51,7 @@ 8 D2_20230517 2022-11-28 2023-05-17 164 Roosevelt Elk 9 D3_20230517 2022-11-28 2023-05-17 161 Roosevelt Elk 10 D5_20230517 2022-12-16 2023-05-17 152 Roosevelt Elk - # i 3 more variables: n_detections , total_count , rai + # i 3 more variables: n_detections , total_count , rai --- @@ -60,7 +60,7 @@ Output # A tibble: 1 x 6 sample_start_date sample_end_date trap_days n_detections total_count rai - + 1 2022-11-28 2023-05-17 166 175 300 1.81 --- @@ -70,7 +70,7 @@ Output # A tibble: 7 x 7 sample_start_date sample_end_date trap_days species n_detections total_count - + 1 2022-11-28 2023-05-17 164 Avian (c~ 1 1 2 2022-12-16 2023-05-17 153 Beaver 1 1 3 2022-12-16 2023-05-17 152 Black Be~ 2 2 @@ -99,7 +99,7 @@ 9 D2_20230517 2022-11-28 2023-05-17 164 19 10 D3_20230517 2022-11-28 2023-05-17 161 11 11 D5_20230517 2022-12-16 2023-05-17 152 9 - # i 2 more variables: total_count , rai + # i 2 more variables: total_count , rai --- @@ -124,7 +124,7 @@ 13 D3_20230517 2022-12-16 2023-02-05 48 Mule Deer 14 D3_20230517 2022-12-16 2023-02-05 48 Roosevelt Elk 15 D5_20230517 2022-12-16 2023-02-05 52 Mule Deer - # i 3 more variables: n_detections , total_count , rai + # i 3 more variables: n_detections , total_count , rai --- @@ -136,7 +136,7 @@ deployment_label sample_start_date sample_end_date trap_days species 1 19_1_20230605 2022-12-16 2023-02-05 52 Roosevelt Elk - # i 3 more variables: n_detections , total_count , rai + # i 3 more variables: n_detections , total_count , rai # rai_by_time works @@ -145,7 +145,7 @@ Output # A tibble: 1,368 x 8 species date max_snow_index mean_temperature n_detections total_count - + 1 Avian (c~ 2022-11-28 1 3 0 0 2 Avian (c~ 2022-11-29 1 -3.67 0 0 3 Avian (c~ 2022-11-30 2 -3.5 0 0 @@ -166,7 +166,7 @@ Output # A tibble: 2,205 x 8 species date max_snow_index mean_temperature n_detections total_count - + 1 Avian (c~ 2022-11-07 2 6 0 0 2 Avian (c~ 2022-11-08 2 -1.75 0 0 3 Avian (c~ 2022-11-09 2 -3.25 0 0 @@ -187,7 +187,7 @@ Output # A tibble: 2,496 x 8 species date max_snow_index mean_temperature n_detections total_count - + 1 Black Be~ 2020-10-02 0 15 0 0 2 Black Be~ 2020-10-03 0 12 0 0 3 Black Be~ 2020-10-04 0 11 0 0 @@ -209,7 +209,7 @@ Output # A tibble: 156 x 8 species date max_snow_index mean_temperature n_detections total_count - + 1 Mule Deer 2022-12-16 3 -2 1 1 2 Mule Deer 2022-12-17 3 -2.18 0 0 3 Mule Deer 2022-12-18 3 -3.91 0 0 @@ -231,7 +231,7 @@ Output # A tibble: 52 x 8 species date max_snow_index mean_temperature n_detections total_count - + 1 Roosevel~ 2022-12-16 4 -1 0 0 2 Roosevel~ 2022-12-17 4 -1 0 0 3 Roosevel~ 2022-12-18 4 -1 0 0 @@ -252,7 +252,7 @@ Output # A tibble: 171 x 7 date max_snow_index mean_temperature n_detections total_count trap_days - + 1 2022-11-28 1 3 0 1 1 2 2022-11-29 1 -3.67 1 1 3 3 2022-11-30 2 -3.5 0 0 2 @@ -286,7 +286,7 @@ 9 COU_AlberniInlet_1_20~ 2021-12-20 0 -4 Mule D~ 0 10 COU_AlberniInlet_1_20~ 2021-12-20 0 -4 0 # i 272 more rows - # i 1 more variable: total_count + # i 1 more variable: total_count --- @@ -308,9 +308,9 @@ 9 Roosevelt Elk 2023-W-01 2023-01-02 2023-01-08 5 1.68 10 Roosevelt Elk 2023-W-02 2023-01-09 2023-01-15 5 2.89 # i 26 more rows - # i 10 more variables: n_detections , total_count , trap_days , + # i 10 more variables: n_detections , total_count , trap_days , # rai , roll_mean_max_snow , roll_mean_temp , - # roll_trap_days , roll_detections , roll_count , + # roll_trap_days , roll_detections , roll_count , # roll_rai --- @@ -335,7 +335,7 @@ 11 COU_AlberniInlet_1_2021_2~ 2021 2021-01-01 2021-12-31 0 12 COU_AlberniInlet_1_2021_2~ 2022 2022-01-01 2022-09-12 0 # i 11 more variables: mean_temperature , n_detections , - # total_count , trap_days , rai , roll_mean_max_snow , + # total_count , trap_days , rai , roll_mean_max_snow , # roll_mean_temp , roll_trap_days , roll_detections , # roll_count , roll_rai @@ -347,7 +347,7 @@ Output # A tibble: 88 x 6 roll_mean_max_snow roll_mean_temp roll_trap_days roll_detections roll_count - + 1 NA NA NA NA NA 2 NA NA NA NA NA 3 NA NA NA NA NA diff --git a/tests/testthat/_snaps/sessions.md b/tests/testthat/_snaps/sessions.md index 605f524..7519031 100644 --- a/tests/testthat/_snaps/sessions.md +++ b/tests/testthat/_snaps/sessions.md @@ -678,7 +678,7 @@ 10 McKay Lake D3 D3_20230517 2022-11-28 11 McKay Lake D5 D5_20230517 2022-12-16 # i 11 more variables: sample_end_date , n_photos , - # n_photos_spp_id , n_species , n_individuals , + # n_photos_spp_id , n_species , n_individuals , # n_motion_photos , n_motion_photos_lens_obscured , # n_tl_photos , n_tl_photos_lens_obscured , sample_gaps , # trap_days @@ -703,7 +703,7 @@ 10 McKay Lake D3 D3_20230517 2022-12-16 11 McKay Lake D5 D5_20230517 2022-12-16 # i 11 more variables: sample_end_date , n_photos , - # n_photos_spp_id , n_species , n_individuals , + # n_photos_spp_id , n_species , n_individuals , # n_motion_photos , n_motion_photos_lens_obscured , # n_tl_photos , n_tl_photos_lens_obscured , sample_gaps , # trap_days @@ -734,7 +734,7 @@ 16 Taylor River 31 31_20230605 2023-01-25 17 Taylor River 35 35_20230708 2022-11-18 # i 11 more variables: sample_end_date , n_photos , - # n_photos_spp_id , n_species , n_individuals , + # n_photos_spp_id , n_species , n_individuals , # n_motion_photos , n_motion_photos_lens_obscured , # n_tl_photos , n_tl_photos_lens_obscured , sample_gaps , # trap_days diff --git a/tests/testthat/_snaps/summary.md b/tests/testthat/_snaps/summary.md index 59386b1..f6f8e56 100644 --- a/tests/testthat/_snaps/summary.md +++ b/tests/testthat/_snaps/summary.md @@ -201,7 +201,7 @@ 3371 1740 Message i 71 images with lens obscured. - i 0 images starred. + i 14 images starred. ! 0 images flagged for review. i Dates are between 2022-11-28 and 2023-05-17. i Temperatures are between -14 and 27 C. @@ -238,7 +238,7 @@ 8657 3176 Message i 117 images with lens obscured. - i 4 images starred. + i 25 images starred. ! 4 images flagged for review. i Dates are between 2022-11-07 and 2023-07-10. i Temperatures are between -10 and 37 C. diff --git a/tests/testthat/test-image-data.R b/tests/testthat/test-image-data.R index feb6c6b..276cf29 100644 --- a/tests/testthat/test-image-data.R +++ b/tests/testthat/test-image-data.R @@ -1,6 +1,7 @@ test_that("read_image_data() works", { imgs_1 <- read_image_data(test_dir_1) imgs_2 <- read_image_data(test_dir_2) + expect_s3_class(imgs_1, c("image_data", "tbl")) expect_s3_class(imgs_2, c("image_data", "tbl")) expect_equal(ncol(imgs_1), 43) @@ -25,15 +26,89 @@ test_that("read_image_data() fails appropriately", { expect_error(read_image_data(dir)) }) -test_that("check_template() works", { - files <- "dirname/123_Template_v12345678.csv" - expect_equal(check_template(files), "v12345678") - files <- c( - files, - "dirname/f123_Template_v87654321.csv" +test_that("read_one_image_csv() warns when file has extra named columns", { + f <- withr::local_tempfile(fileext = ".csv") + writeLines( + c( + "RootFolder,DateTime,Extra_Col", + "/root,2023-01-01 12:00:00,foo" + ), + f + ) + expect_snapshot( + read_one_image_csv(f, master_template_path()), + transform = \(x) gsub(f, "", x, fixed = TRUE) + ) +}) + +test_that("read_one_image_csv() retains extra named columns in output", { + f <- withr::local_tempfile(fileext = ".csv") + writeLines( + c( + "RootFolder,DateTime,Extra_Col", + "/root,2023-01-01 12:00:00,foo" + ), + f + ) + result <- suppressWarnings(read_one_image_csv(f, master_template_path())) + expect_contains(names(result), "Extra_Col") +}) + +test_that("read_one_image_csv() silently drops empty unnamed columns (trailing commas)", { + f <- withr::local_tempfile(fileext = ".csv") + writeLines( + c( + "RootFolder,DateTime,", + "/root,2023-01-01 12:00:00," + ), + f + ) + result <- read_one_image_csv(f, master_template_path()) + expect_equal(names(result), c("RootFolder", "DateTime")) +}) + +test_that("manually supplied template works", { + f <- withr::local_tempfile(fileext = ".csv") + writeLines( + c( + "Study_Area_Name,Deployment_Label,DateTime,Temperature,Adult_Female", + "A,Dep123,2023-01-01 12:00:00,16,5" + ), + f + ) + template_path <- system.file( + "extdata", + "timelapse-templates", + "TimelapseTemplate_Elk_Wallows_v1.tdb", + package = "bccamtrap" + ) + result <- read_image_data(f, template = template_path) +}) + +test_that("invalid template errors correctly", { + expect_snapshot(check_template("Template_5.csv"), error = TRUE) +}) + +test_that("interactive template menu returns selected template", { + pkg_templates <- get_package_templates() + pkg_templates <- pkg_templates[ + !grepl("MasterTemplateFieldPicklist", basename(pkg_templates)) + ] + local_mocked_bindings( + choose_package_template = function(...) pkg_templates[[1]] + ) + withr::local_options(rlang_interactive = TRUE) + expect_equal(check_template("no_template_in_name.csv"), pkg_templates[[1]]) +}) + +test_that("interactive template menu with no selection errors", { + local_mocked_bindings( + choose_package_template = function(...) { + cli::cli_abort("No template selected") + } ) - expect_snapshot(check_template(files)) - expect_snapshot(check_template("temp_foobar.csv"), error = TRUE) + withr::local_options(rlang_interactive = TRUE) + expect_snapshot(check_template("no_template_in_name.csv"), error = TRUE) }) test_that("bin_snow_depths() works", {