Commit dbdc6dcc authored by Facundo Muñoz's avatar Facundo Muñoz ®️
Browse files

Fix validation: avoid undesirable side effect of filtering dummy adult surveys.

It essentially removed all egg surveys. Thus, filter observations manually rather than using dm_filter().
parent add0f7bb
Pipeline #46520 passed with stages
in 14 minutes and 2 seconds
......@@ -2,7 +2,7 @@ Package: sit
Type: Package
Title: Analyse Mark-Release-Recapture Data from Sterile Insect
Technique (SIT) Field Experiments
Version: 1.1.0
Version: 1.1.1
Authors@R: c(person("Françoise", "Chirara", email =
"francoise.chirara@cirad.fr", role = c("ctb"), comment = "Logo
designer"), person("Facundo", "Muñoz", email =
......
......@@ -52,13 +52,13 @@ sit <- function(traps, release_events, adult_surveys = NULL, egg_surveys = NULL)
## Check whether variable 'trap_type' is required in adult data to uniquely
## identify traps
multiple_adult_traps <- sum(trap_types$stage == 'adult') > 1
non_unique_trap_codes <- any(
duplicated(unique(st_drop_geometry(traps[c("code", "type_id")]))$code)
)
adults_has_type <- 'trap_type' %in% names(adult_surveys)
if (non_unique_trap_codes) {
multiple_adult_traps <- sum(trap_types$stage == 'adult') > 1
if (multiple_adult_traps) {
adults_has_type <- 'trap_type' %in% names(adult_surveys)
if (!adults_has_type) {
stop(
glue(
......
......@@ -33,8 +33,15 @@ validate_sit <- function(x) {
dummy_surveys <- ages$age <= 0 # must be n = 0
if (any(dummy_surveys)) {
dummy_surv_ids <- ages$id[dummy_surveys]
x <- dm_filter(x, 'adult_surveys', !.data$id %in% .env$dummy_surv_ids)
x <- dm_apply_filters(x)
# x <- dm_filter(x, 'adult_surveys', !.data$id %in% .env$dummy_surv_ids)
# x <- dm_apply_filters(x)
x <- dm_mutate_tbl(
x,
adult_surveys = x[["adult_surveys"]][
-match(dummy_surv_ids, x[["adult_surveys"]][["id"]]),
]
)
class(x) <- c("sit", class(x))
}
invisible(x)
......
test_that("dm filters observations upstream", {
## Minimal example demonstrating the behaviour of filtering in dm
library(dm)
squares <- data.frame(
id = 1:3,
side = c(1.5, 3, 2),
colour_id = 3:1
)
circles <- data.frame(
id = 1:2,
radius = c(4.2, 3.4),
colour_id = 4:3
)
colours <- data.frame(
id = 1:4,
label = c("red", "orange", "yellow", "green")
)
polygons <- dm(
squares,
circles,
colours
) %>%
dm_add_pk(squares, "id") %>%
dm_add_pk(circles, "id") %>%
dm_add_pk(colours, "id") %>%
dm_add_fk(squares, "colour_id", "colours") %>%
dm_add_fk(circles, "colour_id", "colours")
# dm_draw(polygons)
# polygons %>%
# dm_get_tables()
# tbl(polygons, "circles")
# polygons[["circles"]]
## Aplying the filter on the squares has the effect of filtering only
## colours that are used in the sqares table, which in turn results in
## filtering the circles that use those specific colours.
expect_identical(
polygons %>%
dm_filter(squares, side <= 2) %>%
dm_apply_filters() %>%
`[[`("circles") %>%
nrow(),
1L
)
})
......@@ -10,6 +10,8 @@ test_that("Import fake data.", {
NA
)
expect_s3_class(res, 'sit')
})
test_that("Detect non-matching trap codes in adult surveys.", {
......@@ -45,7 +47,10 @@ test_that("Import surveys from traps identified by code and type", {
type = rep(c("OVT", "BGS", "HLC"), each = 3)
)
adults <- fake_adults
adults$trap <- letters[c(1:3, 2:3)]
adults$trap <- letters[c(1:3, 3:2)]
eggs <- fake_eggs
eggs$trap <- letters[c(2, 1, 3, 2)]
# If multiple trap types for the same code, require the variable type
expect_error(
......@@ -54,16 +59,20 @@ test_that("Import surveys from traps identified by code and type", {
release_events = c(sit_revents(fake_rpoints), sit_revents(fake_rareal)),
adult_surveys = sit_adult_surveys(adults)
),
"Variable `trap_type` is required"
"Variable `trap_type` is required in adult data"
)
adults$type <- c(rep("BGS", 3), rep("HLC", 2))
adults$type <- c(rep("BGS", 2), rep("HLC", 2), "BGS")
# Fixed for adults, but not for eggs. However, there is only one type
# of ovitrap, thus it must take it correctly.
res <- expect_error(
sit(
traps = sit_traps(traps),
release_events = c(sit_revents(fake_rpoints), sit_revents(fake_rareal)),
adult_surveys = sit_adult_surveys(adults)
adult_surveys = sit_adult_surveys(adults),
egg_surveys = sit_egg_surveys(eggs)
),
NA
)
......@@ -76,6 +85,13 @@ test_that("Import surveys from traps identified by code and type", {
adults$type,
sit_adult_surveys(res)$trap_type
)
expect_identical(
eggs$trap,
sit_egg_surveys(res)$trap_code
)
})
test_that("Detect non-matching trap types in adult surveys.", {
......@@ -199,3 +215,34 @@ test_that("Summarise sit", {
})
test_that("Remove dummy surveys", {
# These are counts of 0 individuals of non-positive age, which may be due to
# an artefact of reshaping data in wide format, with values of 0 representing
# missing observations.
# This is checked in validate_dm() since we need the releases as well as the
# adult surveys.
adults <- fake_adults[-4, ]
adults$survey[2] <- fake_rpoints$date[1]
res <- expect_error(
sit(
traps = sit_traps(fake_traps),
release_events = sit_revents(fake_rpoints),
adult_surveys = sit_adult_surveys(adults),
egg_surveys = sit_egg_surveys(fake_eggs)
),
NA
)
expect_s3_class(res, 'sit')
## Of the 4 adult surveys, the second (yellow pop) has age 0 and is removed
expect_identical(res[["adult_surveys"]]$id, sit_adult_surveys(adults)[-2, ]$id)
## The table of eggs should remain untouched however
expect_identical(
nrow(res[["egg_surveys"]]),
nrow(sit_egg_surveys(fake_eggs))
)
})
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment