diff --git a/.Rbuildignore b/.Rbuildignore index 10ca984..a7ad1d3 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,8 @@ +.*\.log +.*\.tex +.*_files +\.Rproj\.user +\.quarto ^.*\.Rproj$ ^CITATION\.cff$ ^LICENSE.md$ @@ -20,10 +25,10 @@ ^inst/*\.log$ ^inst/*css$ ^inst/*figure$ -^inst/*rds$ ^inst/intern_rapport$ ^inst/output$ ^inst/rapport$ +^inst/results.rds$ ^inst/website$ ^man-roxygen$ ^organisation.yml$ diff --git a/.github/workflows/check_on_branch.yml b/.github/workflows/check_on_branch.yml index 1ee5f63..bc635a0 100644 --- a/.github/workflows/check_on_branch.yml +++ b/.github/workflows/check_on_branch.yml @@ -18,5 +18,3 @@ jobs: contents: read steps: - uses: inbo/actions/check_pkg@main - with: - aptget: libpoppler-cpp-dev diff --git a/.github/workflows/check_on_different_r_os.yml b/.github/workflows/check_on_different_r_os.yml index 10c4a14..e769b5b 100644 --- a/.github/workflows/check_on_different_r_os.yml +++ b/.github/workflows/check_on_different_r_os.yml @@ -37,7 +37,7 @@ jobs: - uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} - extra-repositories: https://inbo.r-universe.dev + extra-repositories: https://inbo.r-universe.dev https://inla.r-inla-download.org/R/stable - uses: r-lib/actions/setup-pandoc@v2 diff --git a/.github/workflows/check_on_main.yml b/.github/workflows/check_on_main.yml index 8c32ec6..6e8268d 100644 --- a/.github/workflows/check_on_main.yml +++ b/.github/workflows/check_on_main.yml @@ -17,5 +17,3 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} steps: - uses: inbo/actions/check_pkg@main - with: - aptget: libpoppler-cpp-dev diff --git a/.zenodo.json b/.zenodo.json index 5d36bd3..01bf117 100644 --- a/.zenodo.json +++ b/.zenodo.json @@ -1,6 +1,6 @@ { "title": "abvanalysis: Analysis of the Common Breeding Bird Survey", - "version": "0.2.4", + "version": "0.2.5", "license": "GPL-3.0", "upload_type": "software", "description": "
Read in the raw data and prepare analysis datasets.<\/p>",
diff --git a/CITATION.cff b/CITATION.cff
index 9b3f914..1b06ab8 100644
--- a/CITATION.cff
+++ b/CITATION.cff
@@ -21,4 +21,4 @@ license: GPL-3.0
repository-code: https://github.com/inbo/abvanalysis/
type: software
abstract: "Read in the raw data and prepare analysis datasets."
-version: 0.2.4
+version: 0.2.5
diff --git a/DESCRIPTION b/DESCRIPTION
index 3eb4843..9f85c74 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,17 +1,18 @@
Package: abvanalysis
Title: Analysis of the Common Breeding Bird Survey
-Version: 0.2.4
+Version: 0.2.5
Authors@R: c(
person("Thierry", "Onkelinx", , "thierry.onkelinx@inbo.be", role = c("aut", "cre"),
comment = c(ORCID = "0000-0001-8804-4216", affiliation = "Research Institute for Nature and Forest (INBO)")),
- person("Research Institute for Nature and Forest (INBO)", , , "info@inbo.be", role = c("cph", "fnd"))
+ person("Research Institute for Nature and Forest (INBO)", , , "info@inbo.be", role = c("cph", "fnd"),
+ comment = c(ROR = "00j54wy13"))
)
Description: Read in the raw data and prepare analysis datasets.
License: GPL-3
URL: https://github.com/inbo/abvanalysis
BugReports: https://github.com/inbo/abvanalysis/issues
Depends:
- R (>= 3.1.2)
+ R (>= 4.1.0)
Imports:
assertthat,
DBI,
@@ -25,17 +26,20 @@ Imports:
stringr,
tibble,
tidyr
-Suggests:
+Suggests:
+ DT,
effectclass,
+ gt,
INBOmd,
INBOtheme,
knitr,
pander,
plotly,
+ quarto,
rmarkdown,
scales,
tidyverse
-VignetteBuilder:
+VignetteBuilder:
knitr
Additional_repositories: https://inbo.r-universe.dev
Config/checklist/communities: inbo
@@ -44,4 +48,4 @@ Config/checklist/keywords: common breeding birds; monitoring; analysis;
Encoding: UTF-8
Language: en-GB
Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.3
diff --git a/LICENSE.md b/LICENSE.md
index 2fb2e74..379c1b2 100644
--- a/LICENSE.md
+++ b/LICENSE.md
@@ -1,4 +1,4 @@
-### GNU GENERAL PUBLIC LICENSE
+# GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
diff --git a/NAMESPACE b/NAMESPACE
index ceb1e7a..f907217 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,5 +1,6 @@
# Generated by roxygen2: do not edit by hand
+export(copy_manifest_objects)
export(get_field_id)
export(get_linear_lincomb)
export(get_nonlinear_lincomb)
@@ -27,7 +28,6 @@ importFrom(assertthat,is.number)
importFrom(assertthat,is.string)
importFrom(assertthat,noNA)
importFrom(digest,sha1)
-importFrom(dplyr,"%>%")
importFrom(dplyr,across)
importFrom(dplyr,anti_join)
importFrom(dplyr,arrange)
@@ -35,6 +35,7 @@ importFrom(dplyr,bind_cols)
importFrom(dplyr,bind_rows)
importFrom(dplyr,count)
importFrom(dplyr,distinct)
+importFrom(dplyr,everything)
importFrom(dplyr,filter)
importFrom(dplyr,full_join)
importFrom(dplyr,group_by)
@@ -58,19 +59,24 @@ importFrom(git2rdata,push)
importFrom(git2rdata,read_vc)
importFrom(git2rdata,recent_commit)
importFrom(git2rdata,rm_data)
+importFrom(git2rdata,update_metadata)
importFrom(git2rdata,verify_vc)
importFrom(git2rdata,write_vc)
importFrom(methods,slot)
+importFrom(n2kanalysis,connect_inbo_s3)
importFrom(n2kanalysis,display)
importFrom(n2kanalysis,get_data)
importFrom(n2kanalysis,get_file_fingerprint)
importFrom(n2kanalysis,get_result)
importFrom(n2kanalysis,get_status_fingerprint)
+importFrom(n2kanalysis,manifest_yaml_to_bash)
importFrom(n2kanalysis,n2k_composite)
importFrom(n2kanalysis,n2k_inla)
importFrom(n2kanalysis,n2k_manifest)
+importFrom(n2kanalysis,read_manifest)
importFrom(n2kanalysis,read_model)
importFrom(n2kanalysis,status)
+importFrom(n2kanalysis,store_manifest)
importFrom(n2kanalysis,store_manifest_yaml)
importFrom(n2kanalysis,store_model)
importFrom(purrr,map)
diff --git a/NEWS.md b/NEWS.md
index 947a2dc..82de639 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,8 @@
+# abvanalysis 0.2.5
+
+* Import only the observations from the target species.
+* Provided more metadata about the imported data.
+
# abvanalysis 0.2.4
* Update checklist machinery
diff --git a/R/copy_manifest_objects.R b/R/copy_manifest_objects.R
new file mode 100644
index 0000000..e39992e
--- /dev/null
+++ b/R/copy_manifest_objects.R
@@ -0,0 +1,44 @@
+#' Copy all object of the most recent manifest
+#' @inheritParams n2kanalysis::store_model
+#' @param target_folder Where to store the objects
+#' @export
+#' @importFrom dplyr filter
+#' @importFrom n2kanalysis connect_inbo_s3 read_manifest read_model
+#' store_manifest store_model
+#' @importFrom rlang .data
+copy_manifest_objects <- function(
+ base,
+ project,
+ target_folder = ".",
+ overwrite = FALSE
+) {
+ manifest <- read_manifest(base = base, project = project)
+ store_manifest(manifest, base = target_folder, project = project)
+ manifest |>
+ slot("Manifest") |>
+ filter(is.na(.data$parent)) -> todo
+ file.path(target_folder, project) |>
+ list.files(recursive = TRUE) -> local_objects
+ if (overwrite) {
+ grepv("(converged|insufficient_data)", local_objects) -> local_objects
+ }
+ basename(local_objects) |>
+ gsub(pattern = "\\.rds$", replacement = "") -> done
+ for (hash in todo$fingerprint[!todo$fingerprint %in% done]) {
+ message(hash)
+ x <- try(read_model(hash, base = base, project = project))
+ while (inherits(x, "try-error")) {
+ browser()
+ connect_inbo_s3()
+ x <- try(read_model(hash, base = base, project = project))
+ }
+ store_model(
+ x,
+ base = target_folder,
+ project = project,
+ overwrite = overwrite
+ )
+ rm(x)
+ gc()
+ }
+}
diff --git a/R/get_field_id.R b/R/get_field_id.R
index 0a9164e..24d58aa 100644
--- a/R/get_field_id.R
+++ b/R/get_field_id.R
@@ -4,7 +4,7 @@
#' @param field_name The name of the field.
#' @export
#' @importFrom assertthat assert_that
-#' @importFrom git2rdata read_vc write_vc
+#' @importFrom git2rdata read_vc update_metadata write_vc
get_field_id <- function(repo, table_name, field_name) {
assert_that(
inherits(repo, "git_repository"), is.string(table_name),
@@ -19,6 +19,16 @@ get_field_id <- function(repo, table_name, field_name) {
file = "database_id", root = repo, sorting = c("table", "field"),
stage = TRUE
)
+ update_metadata(
+ file = "database_id", root = repo, stage = TRUE, name = "database_id",
+ title = "Database id for tables and fields",
+ description =
+ "This table describes to which table and field an id refers.",
+ field_description = c(
+ id = "Unique identifier", table = "Name of the table",
+ field = "Name of the field"
+ )
+ )
return(1L)
}
@@ -40,5 +50,15 @@ get_field_id <- function(repo, table_name, field_name) {
)
)
)
+ update_metadata(
+ file = "database_id", root = repo, stage = TRUE, name = "database_id",
+ title = "Database id for tables and fields",
+ description =
+ "This table describes to which table and field an id refers.",
+ field_description = c(
+ id = "Unique identifier", table = "Name of the table",
+ field = "Name of the field"
+ )
+ )
return(current_max + 1L)
}
diff --git a/R/get_linear_lincomb.R b/R/get_linear_lincomb.R
index 3c6720e..14da332 100644
--- a/R/get_linear_lincomb.R
+++ b/R/get_linear_lincomb.R
@@ -3,8 +3,8 @@
#' @param formula the formula for the trend component
#' @export
#' @importFrom assertthat assert_that has_name is.string
-#' @importFrom dplyr %>% across bind_cols bind_rows distinct group_by inner_join
-#' mutate rename select summarise
+#' @importFrom dplyr across bind_cols bind_rows distinct everything group_by
+#' inner_join mutate rename select summarise
#' @importFrom rlang :=
#' @importFrom stats model.matrix
get_linear_lincomb <- function(
@@ -20,16 +20,16 @@ get_linear_lincomb <- function(
has_name(stratum_weights, "weight"), has_name(stratum_weights, stratum_var)
)
- dataset %>%
- select(c(stratum_var, time_var)) %>%
- distinct() %>%
+ dataset |>
+ select(c(stratum_var, time_var)) |>
+ distinct() |>
inner_join(stratum_weights, by = stratum_var) -> all_weight
model.matrix(object = formula, all_weight) -> mm
- (as.data.frame(mm) * all_weight$weight) %>%
- mutate(ID = sprintf("linear_estimate_%02i", all_weight[[time_var]])) %>%
- group_by(.data$ID) %>%
- summarise(across(.fns = sum)) -> mm
- stratum_weights %>%
+ (as.data.frame(mm) * all_weight$weight) |>
+ mutate(ID = sprintf("linear_estimate_%02i", all_weight[[time_var]])) |>
+ group_by(.data$ID) |>
+ summarise(across(.cols = everything(), .fns = sum)) -> mm
+ stratum_weights |>
mutate("{time_var}" := 1) -> trend_weight # nolint: object_name_linter.
mm_trend <- model.matrix(object = formula, trend_weight)
mm_trend <- as.data.frame(mm_trend) * trend_weight$weight
@@ -37,13 +37,13 @@ get_linear_lincomb <- function(
if (has_name(mm_trend, "(Intercept)")) {
mm_trend$`(Intercept)` <- 0
}
- mm_trend %>%
- summarise(across(.fns = sum)) %>%
- mutate(ID = "linear_trend") %>%
+ mm_trend |>
+ summarise(across(.cols = everything(), .fns = sum)) |>
+ mutate(ID = "linear_trend") |>
bind_rows(mm) -> weights
w_names <- weights$ID
- weights %>%
- select(-"ID") %>%
+ weights |>
+ select(-"ID") |>
as.list() -> weights
names(weights[[1]]) <- w_names
weights
diff --git a/R/get_nonlinear_lincomb.R b/R/get_nonlinear_lincomb.R
index 646e9c8..ab0916e 100644
--- a/R/get_nonlinear_lincomb.R
+++ b/R/get_nonlinear_lincomb.R
@@ -6,14 +6,14 @@
#' @param stratum_var variable containing the stratum information.
#' @export
#' @importFrom assertthat assert_that has_name is.string
-#' @importFrom dplyr %>% arrange distinct filter inner_join mutate row_number
+#' @importFrom dplyr arrange distinct filter inner_join mutate row_number
#' select transmute
#' @importFrom purrr map
#' @importFrom rlang .data
#' @importFrom stats setNames
#' @importFrom tidyr expand_grid pivot_longer pivot_wider
get_nonlinear_lincomb <- function(
- dataset, stratum_weights, time_var, label_var, stratum_var
+ dataset, stratum_weights, time_var, label_var, stratum_var
) {
assert_that(is.string(time_var), is.string(stratum_var), is.string(label_var))
assert_that(
@@ -26,50 +26,50 @@ get_nonlinear_lincomb <- function(
)
start <- min(dataset[[label_var]])
end <- max(dataset[[label_var]])
- seq(start, end, by = ifelse(time_var == "cycle", 3, 1)) %>%
+ seq(start, end, by = ifelse(time_var == "cycle", 3, 1)) |>
length() -> n_total
- dataset %>%
- inner_join(stratum_weights, by = stratum_var) %>%
- arrange(.data[[stratum_var]], .data[[time_var]]) %>%
+ dataset |>
+ inner_join(stratum_weights, by = stratum_var) |>
+ arrange(.data[[stratum_var]], .data[[time_var]]) |>
mutate(
- id = row_number() %>%
+ id = row_number() |>
sprintf(fmt = "%04i")
) -> base_weights
- base_weights %>%
+ base_weights |>
pivot_wider(
id_cols = label_var, names_from = .data$id, values_from = .data$weight,
values_fill = 0
) -> year_effect
- dataset %>%
- select(c(time_var, label_var)) %>%
- distinct() %>%
+ dataset |>
+ select(c(time_var, label_var)) |>
+ distinct() |>
arrange(.data[[time_var]]) -> time_steps
strata <- sort(unique(dataset[[stratum_var]]))
expand_grid(
from = time_steps[[time_var]], to = time_steps[[time_var]],
stratum = strata, to_s = strata
- ) %>%
- filter(.data$from < .data$to, .data$stratum == .data$to_s) %>%
- select(-.data$to_s) %>%
- inner_join(time_steps, by = c(from = time_var)) %>%
- mutate(rowname = paste0("index_", .data$label, "_")) %>%
- select(-.data$label) %>%
- inner_join(time_steps, by = c(to = time_var)) %>%
- mutate(rowname = paste0(.data$rowname, .data$label)) %>%
- select(-.data$label) %>%
+ ) |>
+ filter(.data$from < .data$to, .data$stratum == .data$to_s) |>
+ select(-"to_s") |>
+ inner_join(time_steps, by = c(from = time_var)) |>
+ mutate(rowname = paste0("index_", .data$label, "_")) |>
+ select(-"label") |>
+ inner_join(time_steps, by = c(to = time_var)) |>
+ mutate(rowname = paste0(.data$rowname, .data$label)) |>
+ select(-"label") |>
pivot_longer(
c("from", "to"), names_to = "direction", values_to = time_var
- ) %>%
- inner_join(stratum_weights, by = stratum_var) %>%
+ ) |>
+ inner_join(stratum_weights, by = stratum_var) |>
transmute(
- id = interaction(.data[[time_var]], .data[[stratum_var]]) %>%
- as.integer() %>%
+ id = interaction(.data[[time_var]], .data[[stratum_var]]) |>
+ as.integer() |>
sprintf(fmt = "%04i"),
.data$rowname,
weight = ifelse(.data$direction == "to", 1, -1) * .data$weight
- ) %>%
- arrange(.data$id, .data$rowname) %>%
+ ) |>
+ arrange(.data$id, .data$rowname) |>
pivot_wider(
names_from = .data$id, values_from = .data$weight, values_fill = 0
) -> indices
@@ -83,18 +83,18 @@ get_nonlinear_lincomb <- function(
n_window = ifelse(time_var == "cycle", 4, 12)
),
moving_trend(n_total = n_total, n_window = n_total, start = start)
- ) %>%
- map(.x = stratum_weights$weight, .f = `*`) %>%
+ ) |>
+ map(.x = stratum_weights$weight, .f = `*`) |>
do.call(what = "cbind") -> trend_coef
- select(year_effect, -.data$label) %>%
- bind_rows(select(indices, -.data$rowname)) %>%
- as.matrix() %>%
+ select(year_effect, -"label") |>
+ bind_rows(select(indices, -"rowname")) |>
+ as.matrix() |>
`row.names<-`(
c(sprintf("estimate_%i", year_effect$label), indices$rowname)
- ) %>%
- rbind(trend_coef) %>%
- list() %>%
- setNames(time_var) %>%
+ ) |>
+ rbind(trend_coef) |>
+ list() |>
+ setNames(time_var) |>
c(list(
`(Intercept)` = c(
rep(1, nrow(year_effect)), rep(0, nrow(indices) + nrow(trend_coef))
diff --git a/R/prepare_analysis.R b/R/prepare_analysis.R
index 6c21ff0..06e71fb 100755
--- a/R/prepare_analysis.R
+++ b/R/prepare_analysis.R
@@ -16,47 +16,65 @@
#' left_join mutate pull select transmute
#' @importFrom git2rdata verify_vc
#' @importFrom methods slot
-#' @importFrom n2kanalysis display get_file_fingerprint n2k_manifest
-#' store_manifest_yaml
+#' @importFrom n2kanalysis display get_file_fingerprint manifest_yaml_to_bash
+#' n2k_manifest store_manifest_yaml
#' @importFrom purrr map map_chr pmap_dfr
#' @importFrom rlang .data
#' @importFrom tidyr complete nest replace_na unnest
prepare_analysis <- function(
- repo, base, project, overwrite = FALSE, seed = 20070315, verbose = TRUE,
- min_observation = 100, min_stratum = 3, min_cycle = 2, proportion = 0.15,
- scheme_id = "ABV", volume,
- docker = "inbobmk/rn2k:0.7", dependencies = c(
- "inbo/n2khelper@v0.4.3", "inbo/n2kanalysis@v0.2.9"
+ repo,
+ base,
+ project,
+ overwrite = FALSE,
+ seed = 20070315,
+ verbose = TRUE,
+ min_observation = 100,
+ min_stratum = 3,
+ min_cycle = 2,
+ proportion = 0.15,
+ scheme_id = "ABV",
+ volume,
+ docker = "inbobmk/rn2k:0.7",
+ dependencies = c(
+ "inbo/n2khelper@v0.4.3",
+ "inbo/n2kanalysis@v0.2.9"
)
) {
display(verbose, "Read data from repository")
raw_visit <- verify_vc(
- file = file.path("observation", "visit"), root = repo,
+ file = file.path("observation", "visit"),
+ root = repo,
variables = c("id", "year", "period", "point_id", "datafield_id")
)
raw_point <- verify_vc(
- file = file.path("location", "point"), root = repo,
+ file = file.path("location", "point"),
+ root = repo,
variables = c("id", "description", "square_id")
)
raw_square <- verify_vc(
- file = file.path("location", "square"), root = repo,
+ file = file.path("location", "square"),
+ root = repo,
variables = c("id", "description", "stratum_id")
)
raw_stratum <- verify_vc(
- file = file.path("location", "stratum"), root = repo,
+ file = file.path("location", "stratum"),
+ root = repo,
variables = c("id", "description", "n")
)
raw_speciesgroup <- verify_vc(
- file = file.path("species", "speciesgroup"), root = repo,
+ file = file.path("species", "speciesgroup"),
+ root = repo,
variables = c("id", "description")
)
raw_speciesgroup_species <- verify_vc(
- file = file.path("species", "speciesgroup_species"), root = repo,
+ file = file.path("species", "speciesgroup_species"),
+ root = repo,
variables = c("speciesgroup_id", "parent_id", "species")
)
raw_distribution <- verify_vc(
- file = file.path("distribution", "distribution"), root = repo,
+ file = file.path("distribution", "distribution"),
+ root = repo,
variables = c("species_id", "family")
)
@@ -64,12 +82,15 @@ prepare_analysis <- function(
raw_square |>
transmute(
- square_id = .data$id, .data$stratum_id, square = factor(.data$description)
+ square_id = .data$id,
+ .data$stratum_id,
+ square = factor(.data$description)
) |>
inner_join(
raw_stratum |>
transmute(
- stratum_id = .data$id, stratum = factor(.data$description),
+ stratum_id = .data$id,
+ stratum = factor(.data$description),
.data$n
),
by = "stratum_id"
@@ -77,22 +98,31 @@ prepare_analysis <- function(
inner_join(
raw_point |>
transmute(
- point_id = .data$id, point = factor(.data$description),
+ point_id = .data$id,
+ point = factor(.data$description),
.data$square_id
),
by = "square_id"
) |>
inner_join(raw_visit, by = "point_id") |>
- select(-"square_id", -"stratum_id", -"point_id", sample_id = "id") ->
- observation
+ select(
+ -"square_id",
+ -"stratum_id",
+ -"point_id",
+ sample_id = "id"
+ ) -> observation
+ file.path(repo$path, "..", "observation") |>
+ list.files(pattern = "[0-9]+\\.tsv$") |>
+ gsub(pattern = "\\.tsv$", replacement = "") |>
+ as.integer() -> available_species
raw_speciesgroup_species |>
- filter(.data$species) |>
+ filter(.data$species, .data$parent_id %in% available_species) |>
left_join(raw_distribution, by = c("parent_id" = "species_id")) |>
inner_join(raw_speciesgroup, by = c("speciesgroup_id" = "id")) |>
transmute(
species_group_id = .data$speciesgroup_id,
species = sprintf("%05i", .data$external_id),
- family = as.character(.data$family) %>%
+ family = as.character(.data$family) |>
replace_na("poisson"),
) |>
arrange(.data$species_group_id) -> speciesgroup
@@ -100,131 +130,85 @@ prepare_analysis <- function(
display(verbose, "Prepare analysis per species")
pmap_dfr(
- as.list(speciesgroup), prepare_analysis_dataset, scheme_id = scheme_id,
- location_group_id = "Vlaanderen", seed = seed, observation = observation,
- repo = repo, base = base, project = project, overwrite = overwrite,
- min_observation = min_observation, min_stratum = min_stratum,
- min_cycle = min_cycle, proportion = proportion, verbose = verbose
+ as.list(speciesgroup),
+ prepare_analysis_dataset,
+ scheme_id = scheme_id,
+ location_group_id = "Vlaanderen",
+ seed = seed,
+ observation = observation,
+ repo = repo,
+ base = base,
+ project = project,
+ overwrite = overwrite,
+ min_observation = min_observation,
+ min_stratum = min_stratum,
+ min_cycle = min_cycle,
+ proportion = proportion,
+ verbose = verbose
) -> base_analysis
display(verbose, "Prepare model composite")
base_analysis |>
- inner_join(raw_speciesgroup_species, by = "parent_id") |>
+ inner_join(
+ raw_speciesgroup_species,
+ by = "parent_id",
+ relationship = "many-to-many"
+ ) |>
select(-"parent_id", -"species", species_group_id = "speciesgroup_id") |>
mutate(species_group_id = as.character(.data$species_group_id)) |>
nest(
models = c(
- .data$fingerprint, .data$status_fingerprint, .data$status,
- .data$result_datasource, .data$first_imported_year,
- .data$last_imported_year, .data$analysis_date
+ "fingerprint",
+ "status_fingerprint",
+ "status",
+ "result_datasource",
+ "first_imported_year",
+ "last_imported_year",
+ "analysis_date"
)
) |>
arrange(.data$species_group_id, .data$frequency, .data$type) -> composite
pmap_dfr(
- as.list(composite), prepare_analysis_composite, scheme_id = scheme_id,
- location_group_id = "Vlaanderen", seed = seed, verbose = verbose,
- base = base, project = project, overwrite = overwrite
+ as.list(composite),
+ prepare_analysis_composite,
+ scheme_id = scheme_id,
+ location_group_id = "Vlaanderen",
+ seed = seed,
+ verbose = verbose,
+ base = base,
+ project = project,
+ overwrite = overwrite
) |>
bind_cols(composite) -> composite
display(verbose, "Prepare manifests")
+
composite |>
transmute(
- location_group = "Vlaanderen", species_group = .data$species_group_id,
- .data$frequency, .data$type, .data$fingerprint,
+ location_group = "Vlaanderen",
+ species_group = .data$species_group_id,
+ .data$frequency,
+ .data$type,
+ .data$fingerprint,
data = map(.data$models, select, parent = "fingerprint")
- ) %>%
+ ) |>
unnest(cols = "data") -> meta_composite
- meta_composite |>
- select(-"fingerprint", fingerprint = "parent") |>
- bind_rows(meta_composite) |>
- nest(data = c("fingerprint", "parent")) |>
- mutate(manifest = map(.data$data, n2k_manifest)) -> manifest_composite
-
base_analysis |>
- anti_join(meta_composite, by = c("fingerprint" = "parent")) |>
- transmute(.data$parent_id, .data$fingerprint, parent = NA_character_) |>
- nest(data = c("fingerprint", "parent")) |>
- pull(.data$data) |>
- map(n2k_manifest) |>
- c(manifest_composite$manifest) |>
- map(
- store_manifest_yaml, base = base, project = project, docker = docker,
- dependencies = dependencies
- )
-
- manifest_composite |>
- transmute(manifest = map(.data$manifest, slot, "Manifest")) |>
- unnest(cols = .data$manifest) |>
- mutate(parent = !is.na(.data$parent)) |>
- distinct(.data$fingerprint, .data$parent) |>
- arrange(.data$parent, .data$fingerprint) |>
- pull(.data$fingerprint) -> models
-
- manifests <- map_chr(manifest_composite$manifest, get_file_fingerprint)
-
- args <- ", dependencies = FALSE, upgrade = \\\"never\\\", keep_source = FALSE"
- docker_hash <- sha1(manifests)
- sprintf(
- "Rscript -e 'remotes::install_github(\\\"%s\\\"%s)'", dependencies, args
- ) -> deps
- sprintf(
- "#!/bin/bash
-echo \"FROM %s
-RUN %s\" > Dockerfile
-docker build --pull --tag rn2k:%s .
-rm Dockerfile",
- docker, paste(deps, collapse = " \\\n&& "), docker_hash
- ) -> init
-
- if (inherits(base, "s3_bucket")) {
- sprintf(
- "echo \"model %i of %i\"
-docker run %s --name=%s rn2k:%s ./fit_model_aws.sh -b %s -p %s -m %s
-date
-docker stop --time 14400 %s
-date",
- seq_along(models), length(models), "--rm -d --env-file ./env.list",
- models, docker_hash, attr(base, "Name"), project, models, models
- ) -> model_scripts
-
- sprintf(
- "echo \"manifest %i of %i\"
-docker run %s --name=%s rn2k:%s ./fit_model_aws.sh -b %s -p %s -m %s
-date
-docker stop --time 14400 %s
-date",
- seq_along(manifests), length(manifests), "--rm -d --env-file ./env.list",
- manifests, docker_hash, attr(base, "Name"), project,
- paste0(manifests, ".manifest"), manifests
- ) -> manifest_scripts
- } else {
- base <- normalizePath(base, winslash = "/")
- if (missing(volume)) {
- volume <- paste(base, base, "rw", sep = ":")
- }
- sprintf(
- "echo \"model %i of %i\"
-docker run %s --name=%s -v %s rn2k:%s ./fit_model_file.sh -b %s -p %s -m %s
-date
-docker stop --time 14400 %s
-date",
- seq_along(models), length(models), "--rm -d", models, volume, docker_hash,
- base, project, models, models
- ) -> model_scripts
-
- sprintf(
- "echo \"manifest %i of %i\"
-docker run %s --name=%s -v %s rn2k:%s ./fit_model_file.sh -b %s -p %s -m %s
-date
-docker stop --time 14400 %s
-date",
- seq_along(manifests), length(manifests), "--rm -d", manifests, volume,
- docker_hash, base, project, paste0(manifests, ".manifest"), manifests
- ) -> manifest_scripts
- }
-
- return(list(init = init, models = model_scripts, manifest = manifest_scripts))
+ select("fingerprint") |>
+ bind_rows(meta_composite) |>
+ n2k_manifest() |>
+ store_manifest_yaml(
+ base = base,
+ project = project,
+ docker = docker,
+ dependencies = dependencies,
+ overwrite = TRUE
+ ) -> yaml
+ manifest_yaml_to_bash(
+ base = base,
+ project = project,
+ hash = basename(yaml)
+ )
}
diff --git a/R/prepare_analysis_composite.R b/R/prepare_analysis_composite.R
index ca2e8a1..fc460db 100644
--- a/R/prepare_analysis_composite.R
+++ b/R/prepare_analysis_composite.R
@@ -8,7 +8,7 @@
#' @export
#' @importFrom assertthat assert_that is.string has_name
#' @importFrom n2kanalysis n2k_composite
-#' @importFrom dplyr %>% select mutate arrange filter slice
+#' @importFrom dplyr select mutate arrange filter slice
#' @importFrom rlang .data
#' @importFrom tibble rownames_to_column
prepare_analysis_composite <- function(
@@ -35,20 +35,20 @@ prepare_analysis_composite <- function(
extractor <- function(model) {
stopifnot(requireNamespace("tibble", quietly = TRUE))
stopifnot(requireNamespace("dplyr", quietly = TRUE))
- model$summary.lincomb.derived %>%
- tibble::rownames_to_column("value") %>%
- dplyr::select("value", estimate = "mean", variance = "sd") %>%
+ model$summary.lincomb.derived |>
+ tibble::rownames_to_column("value") |>
+ dplyr::select("value", estimate = "mean", variance = "sd") |>
dplyr::mutate(
variance = .data$variance ^ 2,
number = suppressWarnings(as.integer(.data$value))
- ) %>%
- dplyr::arrange(.data$number, .data$value) %>%
+ ) |>
+ dplyr::arrange(.data$number, .data$value) |>
dplyr::select(-"number")
}
n2k_composite(
result_datasource_id = models$result_datasource[1],
- parent_status = models %>%
+ parent_status = models |>
select(
parent_analysis = "fingerprint", parent_status = "status",
parentstatus_fingerprint = "status_fingerprint"
@@ -60,6 +60,6 @@ prepare_analysis_composite <- function(
model_type = paste("composite index:", frequency, type),
formula = paste("~", frequency), extractor = extractor,
analysis_date = max(models$analysis_date), status = "waiting"
- ) %>%
+ ) |>
storage(base = base, project = project, overwrite = overwrite)
}
diff --git a/R/prepare_analysis_dataset.R b/R/prepare_analysis_dataset.R
index 4db9787..0fa85e6 100644
--- a/R/prepare_analysis_dataset.R
+++ b/R/prepare_analysis_dataset.R
@@ -125,8 +125,8 @@ prepare_analysis_dataset <- function(
hyper = list(theta = list(prior = \"pc.prec\", param = c(1, 0.01))))",
"f(point, model = \"iid\",
hyper = list(theta = list(prior = \"pc.prec\", param = c(1, 0.01))))"[
- length(levels(dataset$point)) > 2 * length(levels(dataset$square))
- ]
+ length(levels(dataset$point)) > 2 * length(levels(dataset$square))
+ ]
)
# analysis on data by year
@@ -178,8 +178,9 @@ prepare_analysis_dataset <- function(
stratum_weights = stratum_weights, time_var = "cyear",
label_var = "label", stratum_var = "stratum"
) -> lin_comb
- c(base_effects,
- "f(cyear, model = \"rw1\", replicate = as.integer(stratum),
+ c(
+ base_effects,
+ "f(cyear, model = \"rw1\", replicate = as.integer(stratum),
hyper = list(theta = list(prior = \"pc.prec\", param = c(0.5, 0.01))))"
) |>
paste(collapse = " + ") |>
diff --git a/R/prepare_dataset_location.R b/R/prepare_dataset_location.R
index 20fde2e..41d5b99 100755
--- a/R/prepare_dataset_location.R
+++ b/R/prepare_dataset_location.R
@@ -2,33 +2,33 @@
#' @inheritParams prepare_dataset
#' @inheritParams git2rdata::write_vc
#' @importFrom DBI dbGetQuery dbQuoteIdentifier dbQuoteString Id
-#' @importFrom dplyr %>% arrange count filter full_join inner_join mutate
-#' row_number transmute
+#' @importFrom dplyr arrange count filter full_join inner_join mutate
+#' row_number select transmute
#' @importFrom rlang .data
-#' @importFrom git2rdata prune_meta read_vc rm_data write_vc
+#' @importFrom git2rdata prune_meta read_vc rm_data update_metadata write_vc
#' @export
prepare_dataset_location <- function(
- origin, repo, end_date, strict = TRUE, db_scheme = ""
+ origin, repo, end_date, strict = TRUE, db_scheme = ""
) {
+ strata <- try(
+ read_vc(file.path("location", "stratum"), root = repo), silent = TRUE
+ )
rm_data(root = repo, path = "location", stage = TRUE)
# import sampling framework
sampling_frame <- read_vc("sampling_frame", repo)
- sampling_frame %>%
- count(description = .data$Stratum) %>%
- filter(!is.na(.data$description)) %>%
- arrange(.data$description) %>%
+ sampling_frame |>
+ count(description = .data$Stratum) |>
+ filter(!is.na(.data$description)) |>
+ arrange(.data$description) |>
mutate(description = as.character(.data$description)) -> new_strata
- strata <- try(
- read_vc(file.path("location", "stratum"), root = repo), silent = TRUE
- )
if (inherits(strata, "try-error")) {
- new_strata %>%
+ new_strata |>
mutate(id = row_number()) -> strata
} else {
- strata %>%
- full_join(new_strata, by = "description") %>%
- arrange(.data$id) %>%
+ strata |>
+ full_join(new_strata, by = "description") |>
+ arrange(.data$id) |>
transmute(
.data$description,
n = ifelse(is.na(.data$id), .data$n.y, .data$n.x),
@@ -43,17 +43,28 @@ prepare_dataset_location <- function(
strata, file = file.path("location", "stratum"), root = repo,
sorting = "description", stage = TRUE, strict = strict
)
- strata %>%
- select(stratum = .data$description, stratum_id = .data$id) %>%
+ update_metadata(
+ file = file.path("location", "stratum"), root = repo, name = "stratum",
+ title = "Strata using in the Common Breeding Bird Cencus in Flanders",
+ field_description = c(
+ description = "Name of the stratum",
+ n = "Total number of squares in the stratum",
+ id = "Unique identifier of the stratum"
+ ),
+ stage = TRUE
+ )
+
+ strata |>
+ select(stratum = "description", stratum_id = "id") |>
inner_join(
- sampling_frame %>%
+ sampling_frame |>
transmute(
description = sprintf("ABV_%s", .data$ExternalCode),
stratum = .data$Stratum
),
by = c("stratum")
- ) %>%
- select(-.data$stratum) -> strata
+ ) |>
+ select(-"stratum") -> strata
# import UTM squares
sprintf("
@@ -88,18 +99,29 @@ prepare_dataset_location <- function(
dbQuoteIdentifier(
origin, Id(scheme = db_scheme, table = "locations_location")
)
- ) %>%
- dbGetQuery(conn = origin) %>%
- inner_join(strata, by = "description") %>%
+ ) |>
+ dbGetQuery(conn = origin) |>
+ inner_join(strata, by = "description") |>
mutate(
datafield_id = get_field_id(
repo = repo, table_name = "locations_location", field_name = "id"
)
- ) %>%
+ ) |>
write_vc(
file = file.path("location", "square"), root = repo,
sorting = "description", stage = TRUE, strict = strict
)
+ update_metadata(
+ file = file.path("location", "square"), root = repo, stage = TRUE,
+ name = "square",
+ title = "UTM squares used in the Common Breeding Bird Cencus in Flanders",
+ field_description = c(
+ description = "Name of the UTM square",
+ id = "Unique identifier of the UTM square",
+ stratum_id = "Unique identifier of the stratum",
+ datafield_id = "Unique identifier of the datafield"
+ )
+ )
# import points
sprintf("
@@ -134,17 +156,28 @@ prepare_dataset_location <- function(
dbQuoteIdentifier(
origin, Id(scheme = db_scheme, table = "locations_location")
)
- ) %>%
- dbGetQuery(conn = origin) %>%
+ ) |>
+ dbGetQuery(conn = origin) |>
mutate(
datafield_id = get_field_id(
repo = repo, table_name = "locations_location", field_name = "id"
)
- ) %>%
+ ) |>
write_vc(
file = file.path("location", "point"), root = repo, stage = TRUE,
sorting = "description", strict = strict
)
+ update_metadata(
+ file = file.path("location", "point"), root = repo, stage = TRUE,
+ name = "point",
+ title = "Points used in the Common Breeding Bird Cencus in Flanders",
+ field_description = c(
+ description = "Name of the point",
+ id = "Unique identifier of the point",
+ square_id = "Unique identifier of the UTM square",
+ datafield_id = "Unique identifier of the datafield"
+ )
+ )
prune_meta(root = repo, path = "location", stage = TRUE)
diff --git a/R/prepare_dataset_observation.R b/R/prepare_dataset_observation.R
index 6d6ee11..fb86184 100755
--- a/R/prepare_dataset_observation.R
+++ b/R/prepare_dataset_observation.R
@@ -1,9 +1,9 @@
#' Read the observations and save them to git and the results database
#' @inheritParams prepare_dataset
#' @export
-#' @importFrom git2rdata rm_data write_vc prune_meta
+#' @importFrom git2rdata prune_meta rm_data update_metadata write_vc
#' @importFrom DBI dbGetQuery dbQuoteIdentifier dbQuoteString Id
-#' @importFrom dplyr %>% inner_join rename semi_join select group_by filter
+#' @importFrom dplyr inner_join rename semi_join select group_by filter
#' mutate pull
#' @importFrom tidyr nest
#' @importFrom purrr map2 map_int
@@ -28,14 +28,14 @@ prepare_dataset_observation <- function(
fv.start_date <= %s AND
fs.not_counted = %s AND
%s",
- ifelse(
- inherits(origin, "Microsoft SQL Server"),
- "YEAR(fv.start_date)",
- "EXTRACT(YEAR FROM fv.start_date)"
- ),
- ifelse(
- inherits(origin, "Microsoft SQL Server"),
- "CASE
+ ifelse(
+ inherits(origin, "Microsoft SQL Server"),
+ "YEAR(fv.start_date)",
+ "EXTRACT(YEAR FROM fv.start_date)"
+ ),
+ ifelse(
+ inherits(origin, "Microsoft SQL Server"),
+ "CASE
WHEN
fv.start_date < CAST(
CAST(YEAR(fv.start_date) AS VARCHAR) + '-04-16' AS DATETIME
@@ -48,40 +48,40 @@ prepare_dataset_observation <- function(
THEN 2
ELSE 3
END",
- "CASE
+ "CASE
WHEN fv.start_date <
CAST(EXTRACT(YEAR FROM fv.start_date) || '-04-16' AS TIMESTAMP) THEN 1
WHEN fv.start_date <
CAST(EXTRACT(YEAR FROM fv.start_date) || '-06-01' AS TIMESTAMP) THEN 2
ELSE 3
END"
- ),
- dbQuoteIdentifier(
- origin, Id(scheme = db_scheme, table = "projects_project")
- ),
- dbQuoteIdentifier(
- origin, Id(scheme = db_scheme, table = "fieldwork_visit")
- ),
- dbQuoteIdentifier(
- origin, Id(scheme = db_scheme, table = "fieldwork_sample")
- ),
- dbQuoteString(origin, as.character(end_date)),
- ifelse(inherits(origin, "Microsoft SQL Server"), "0", "FALSE"),
- ifelse(
- inherits(origin, "Microsoft SQL Server"),
- "CAST(
+ ),
+ dbQuoteIdentifier(
+ origin, Id(scheme = db_scheme, table = "projects_project")
+ ),
+ dbQuoteIdentifier(
+ origin, Id(scheme = db_scheme, table = "fieldwork_visit")
+ ),
+ dbQuoteIdentifier(
+ origin, Id(scheme = db_scheme, table = "fieldwork_sample")
+ ),
+ dbQuoteString(origin, as.character(end_date)),
+ ifelse(inherits(origin, "Microsoft SQL Server"), "0", "FALSE"),
+ ifelse(
+ inherits(origin, "Microsoft SQL Server"),
+ "CAST(
CAST(YEAR(fv.start_date) AS VARCHAR) + '-3-1' AS DATETIME
) <= fv.start_date AND
fv.start_date <= CAST(
CAST(YEAR(fv.start_date) AS VARCHAR) + '-7-16' AS DATETIME
)",
- "CAST(EXTRACT(YEAR FROM fv.start_date) || '-3-1' AS TIMESTAMP) <=
+ "CAST(EXTRACT(YEAR FROM fv.start_date) || '-3-1' AS TIMESTAMP) <=
fv.start_date AND
fv.start_date <=
CAST(EXTRACT(YEAR FROM fv.start_date) || '-7-16' AS TIMESTAMP)"
- )
+ )
) |>
- dbGetQuery(conn = origin) %>%
+ dbGetQuery(conn = origin) |>
mutate(
datafield_id = get_field_id(
repo = repo, table_name = "fieldwork_sample", field_name = "id"
@@ -92,6 +92,17 @@ END"
sorting = c("year", "period", "point_id", "id"),
strict = strict
)
+ update_metadata(
+ file = "observation/visit", root = repo, stage = TRUE, name = "visit",
+ title = "Visits in the Common Breeding Bird Census in Flanders",
+ field_description = c(
+ id = "Unique identifier of the visit",
+ point_id = "Unique identifier of the point",
+ year = "Year of the visit",
+ period = "Period of the visit",
+ datafield_id = "Unique identifier of the datafield"
+ )
+ )
# counts per species
sprintf("
@@ -135,26 +146,46 @@ END"
fv.start_date <=
CAST(EXTRACT(YEAR FROM fv.start_date) || '-7-16' AS TIMESTAMP)"
)
- ) %>%
+ ) |>
dbGetQuery(conn = origin) -> counts
- counts %>%
- semi_join(observations, by = c("sample_id" = "id")) %>%
+ counts |>
+ semi_join(observations, by = c("sample_id" = "id")) |>
mutate(
count = as.integer(count),
datafield_id = get_field_id(
repo = repo, table_name = "fieldwork_sample", field_name = "id"
)
- ) %>%
- group_by(.data$species_id) %>%
- nest() %>%
- mutate(n = map_int(.data$data, nrow)) %>%
- filter(.data$n >= min_observation) %>%
+ ) |>
+ group_by(.data$species_id) |>
+ nest() |>
+ mutate(n = map_int(.data$data, nrow)) |>
+ filter(.data$n >= min_observation) |>
+ inner_join(
+ file.path("species", "species") |>
+ read_vc(root = repo) |>
+ select("id", "scientific_name"),
+ by = c("species_id" = "id")
+ ) |>
mutate(
filename = file.path("observation", sprintf("%05i", .data$species_id)),
hash = map2(
.data$data, .data$filename, write_vc, root = repo, stage = TRUE,
sorting = "sample_id", strict = strict
)
+ ) |>
+ mutate(
+ metadata = map2(
+ .data$filename, .data$scientific_name,
+ ~update_metadata(
+ .x, root = repo, stage = TRUE,
+ name = .data$filename, title = paste("Observations of", .y),
+ field_description = c(
+ sample_id = "Unique identifier of the sample",
+ count = "Number of individuals",
+ datafield_id = "Identifier of the datafield"
+ )
+ )
+ )
)
prune_meta(root = repo, path = "observation", stage = TRUE)
diff --git a/R/prepare_dataset_species.R b/R/prepare_dataset_species.R
index 33b24e2..260a837 100755
--- a/R/prepare_dataset_species.R
+++ b/R/prepare_dataset_species.R
@@ -3,29 +3,29 @@
#' @inheritParams git2rdata::write_vc
#' @importFrom DBI dbGetQuery dbQuoteLiteral dbQuoteString Id
#' @importFrom digest sha1
-#' @importFrom dplyr %>% transmute select mutate bind_rows
+#' @importFrom dplyr bind_rows mutate select transmute
#' @importFrom purrr map_chr
#' @importFrom rlang .data
-#' @importFrom git2rdata prune_meta rm_data write_vc
+#' @importFrom git2rdata prune_meta rm_data update_metadata write_vc
#' @export
prepare_dataset_species <- function(
origin, repo, end_date, strict = FALSE, db_scheme = ""
) {
- rm_data(root = repo, path = "location", stage = TRUE)
+ rm_data(root = repo, path = "species", stage = TRUE)
sprintf("
WITH cte AS (
- SELECT fo.species_id
+ SELECT ps.species_id
FROM %s AS pp
+ INNER JOIN %s AS ps ON pp.id = ps.project_id
INNER JOIN %s AS fv ON pp.id = fv.project_id
INNER JOIN %s AS fs ON fv.id = fs.visit_id
INNER JOIN %s AS fo ON fs.id = fo.sample_id
WHERE
pp.name = 'Algemene Broedvogelmonitoring (ABV)' AND
fv.validation_status != -1 AND
- fv.start_date <= %s AND
- fs.not_counted = %s
- GROUP BY species_id
+ fv.start_date <= %s AND fs.not_counted = %s
+ GROUP BY ps.species_id
)
SELECT
@@ -36,6 +36,9 @@ prepare_dataset_species <- function(
dbQuoteIdentifier(
origin, Id(scheme = db_scheme, table = "projects_project")
),
+ dbQuoteIdentifier(
+ origin, Id(scheme = db_scheme, table = "projects_projectspecies")
+ ),
dbQuoteIdentifier(
origin, Id(scheme = db_scheme, table = "fieldwork_visit")
),
@@ -50,8 +53,8 @@ prepare_dataset_species <- function(
dbQuoteIdentifier(
origin, Id(scheme = db_scheme, table = "species_species")
)
- ) %>%
- dbGetQuery(conn = origin) %>%
+ ) |>
+ dbGetQuery(conn = origin) |>
mutate(
datafield_id = get_field_id(
repo = repo, table_name = "species_species", field_name = "id"
@@ -59,7 +62,18 @@ prepare_dataset_species <- function(
) -> species
write_vc(
species, file = file.path("species", "species"), root = repo,
- sorting = "euring", stage = TRUE
+ sorting = "euring", strict = FALSE
+ )
+ update_metadata(
+ file = file.path("species", "species"), root = repo, stage = TRUE,
+ name = "species", title = "Species in the Common Breeding Bird Census",
+ field_description = c(
+ id = "Unique identifier of the species",
+ scientific_name = "Scientific name of the species",
+ nl = "Dutch name of the species",
+ euring = "Euring code of the species",
+ datafield_id = "Unique identifier of the datafield"
+ )
)
sprintf(
"SELECT
@@ -72,7 +86,7 @@ prepare_dataset_species <- function(
origin, Id(scheme = db_scheme, table = "species_group")
)
) |>
- dbGetQuery(conn = origin) %>%
+ dbGetQuery(conn = origin) |>
mutate(
description = gsub(" \\(.*\\)", "", .data$description),
datafield_id = get_field_id(
@@ -80,7 +94,7 @@ prepare_dataset_species <- function(
),
id = map_chr(.data$description, sha1)
) -> speciesgroup
- species %>%
+ species |>
transmute(
external_id = .data$id,
id = map_chr(.data$nl, sha1),
@@ -88,7 +102,7 @@ prepare_dataset_species <- function(
.data$datafield_id
) -> speciesgroup2
sprintf(
- "SELECT
+ "SELECT
sg.id AS external_id,
sgs.species_id AS species_id
FROM %s AS sg
@@ -101,44 +115,67 @@ WHERE sg.name LIKE '%% (ABV)'",
origin, Id(scheme = db_scheme, table = "species_speciesgrouprelation")
)
) |>
- dbGetQuery(conn = origin) |>
+ dbGetQuery(conn = origin) |>
inner_join(
- speciesgroup %>%
- select(speciesgroup_id = .data$id, .data$external_id),
+ speciesgroup |>
+ select(speciesgroup_id = "id", "external_id"),
by = "external_id"
- ) %>%
+ ) |>
inner_join(
- speciesgroup2 %>%
- select(species_id = .data$external_id, parent_id = .data$id),
+ speciesgroup2 |>
+ select(species_id = "external_id", parent_id = "id"),
by = "species_id"
- ) %>%
- transmute(.data$speciesgroup_id, .data$parent_id, species = FALSE) %>%
+ ) |>
+ transmute(.data$speciesgroup_id, .data$parent_id, species = FALSE) |>
bind_rows(
- species %>%
- select(external_id = .data$id, parent = .data$id) %>%
+ species |>
+ select(external_id = "id", parent = "id") |>
inner_join(
- speciesgroup2 %>%
- select(speciesgroup_id = .data$id, .data$external_id),
+ speciesgroup2 |>
+ select(speciesgroup_id = "id", "external_id"),
by = "external_id"
- ) %>%
+ ) |>
transmute(
.data$speciesgroup_id, parent_id = as.character(.data$parent),
species = TRUE
)
- ) %>%
+ ) |>
mutate(
speciesgroup_id = factor(.data$speciesgroup_id),
parent_id = factor(.data$parent_id)
- ) %>%
+ ) |>
write_vc(
file = file.path("species", "speciesgroup_species"), root = repo,
sorting = c("speciesgroup_id", "parent_id"), stage = TRUE, strict = strict
)
- bind_rows(speciesgroup, speciesgroup2) %>%
+ update_metadata(
+ file = file.path("species", "speciesgroup_species"), root = repo,
+ stage = TRUE, name = "speciesgroup_species",
+ title = "Species per species groups",
+ description =
+ "This table describes which species belong to which species group.",
+ field_description = c(
+ speciesgroup_id = "Unique identifier of the species group",
+ parent_id = "Unique identifier of the parent species group",
+ species = "Is this a species or a species group?"
+ )
+ )
+ bind_rows(speciesgroup, speciesgroup2) |>
write_vc(
file = file.path("species", "speciesgroup"), root = repo, sorting = "id",
stage = TRUE, strict = strict
)
+ update_metadata(
+ file = file.path("species", "speciesgroup"), root = repo, stage = TRUE,
+ name = "speciesgroup",
+ title = "Species groups in the Common Breeding Bird Census",
+ field_description = c(
+ id = "Unique identifier of the species group",
+ external_id = "External identifier of the species group",
+ description = "Name of the species group",
+ datafield_id = "Unique identifier of the datafield"
+ )
+ )
prune_meta(root = repo, path = "species", stage = TRUE)
diff --git a/R/read_relevant.R b/R/read_relevant.R
new file mode 100644
index 0000000..b4f12e7
--- /dev/null
+++ b/R/read_relevant.R
@@ -0,0 +1,90 @@
+read_relevant <- function(base, project, verbose = TRUE) {
+ UseMethod("read_relevant", base)
+}
+
+#' @importFrom dplyr mutate
+#' @importFrom n2kanalysis display
+#' @importFrom purrr map_dfr
+#' @importFrom rlang .data
+#' @importFrom stringr str_remove str_subset
+read_relevant.character <- function(base, project, verbose = TRUE) {
+ file.path(base, project) |>
+ list.files(pattern = "rds$", recursive = TRUE, full.names = TRUE) |>
+ str_subset("converged") -> todo
+ map_dfr(todo, verbose = verbose, function(i, verbose) {
+ display(verbose, i)
+ readRDS(i) |>
+ extract_relevant()
+ }) |>
+ mutate(analysis = factor(.data$analysis))
+}
+
+#' @importFrom dplyr filter transmute
+#' @importFrom n2kanalysis display read_manifest
+#' @importFrom purrr map_dfr
+#' @importFrom stringr str_subset
+#' @importFrom rlang .data
+read_relevant.s3_bucket <- function(base, project, verbose = TRUE) {
+ read_manifest(base = base, project = project) |>
+ slot("Manifest") |>
+ filter(is.na(.data$parent)) -> todo
+ map_dfr(
+ todo$fingerprint, verbose = verbose,
+ function(i, verbose) {
+ display(verbose, i)
+ read_model(x = i, base = base, project = project) |>
+ extract_relevant()
+ }
+ ) |>
+ mutate(analysis = factor(.data$analysis))
+}
+
+#' @importFrom dplyr count group_by inner_join mutate n select summarise
+#' @importFrom n2kanalysis get_data get_file_fingerprint
+#' @importFrom stringr str_remove
+#' @importFrom rlang .data
+#' @importFrom tidyr complete pivot_wider
+extract_relevant <- function(x) {
+ if (!inherits(x, "n2kInla")) {
+ return(NULL)
+ }
+ if (!grepl("year:stratum", x@AnalysisMetadata$model_type)) {
+ return(NULL)
+ }
+ get_data(x) |>
+ mutate(tmp = sprintf("%s_%0.5f", .data$stratum, .data$weight)) |>
+ count(
+ .data$tmp, .data$square, .data$point, name = "visits"
+ ) |>
+ group_by(.data$tmp, .data$square) |>
+ summarise(
+ points = n(), visits = sum(.data$visits), .groups = "drop"
+ ) |>
+ group_by(.data$tmp, .data$points) |>
+ summarise(
+ squares = n(), visits = sum(.data$visits), .groups = "drop"
+ ) -> tmp
+ tmp |>
+ select(-"visits") |>
+ complete(
+ .data$tmp, points = 1:6, fill = list(squares = 0)
+ ) |>
+ mutate(points = sprintf("points_%i", .data$points)) |>
+ pivot_wider(names_from = "points", values_from = "squares") |>
+ inner_join(
+ tmp |>
+ group_by(.data$tmp) |>
+ summarise(
+ relevant = sum(.data$squares), visits = sum(.data$visits),
+ .groups = "drop"
+ ),
+ by = "tmp"
+ ) |>
+ mutate(
+ analysis = get_file_fingerprint(x),
+ stratum = str_remove(.data$tmp, "_.*"),
+ weight = str_remove(.data$tmp, ".*_") |>
+ as.numeric()
+ ) |>
+ select(-"tmp")
+}
diff --git a/R/retrieve_results.R b/R/retrieve_results.R
index e5557bc..ee35919 100644
--- a/R/retrieve_results.R
+++ b/R/retrieve_results.R
@@ -6,61 +6,73 @@
#' @param target_repo A [git2rdata::repository()] object containing the package
#' code.
#' @export
-#' @importFrom dplyr %>% count inner_join mutate select
+#' @importFrom dplyr count inner_join mutate select
#' @importFrom git2rdata read_vc write_vc
-#' @importFrom n2kanalysis get_result
+#' @importFrom n2kanalysis get_result read_manifest
#' @importFrom rlang .data
#' @importFrom stats qnorm
#' @importFrom stringr str_detect str_replace
#' @importFrom utils file_test
retrieve_results <- function(
- base, project, source_repo, target_repo, verbose = TRUE, strict = TRUE
+ base, project, source_repo, target_repo, verbose = TRUE, strict = TRUE
) {
- target_rds <- file.path(base, paste(project, "results.rds", sep = "_"))
- if (file_test("-f", target_rds)) {
- results <- readRDS(target_rds)
- } else {
- results <- get_result(file.path(base, project), verbose = verbose)
- saveRDS(results, target_rds)
+ file.path(target_repo$path, "..", "inst", "results.rds") |>
+ normalizePath() -> target_rds
+ if (!file_test("-f", target_rds)) {
+ read_manifest(base = base, project = project) |>
+ get_result(base = base, project = project, verbose = verbose) |>
+ saveRDS(file = target_rds)
}
+ results <- readRDS(target_rds)
- read_vc(file.path("location", "stratum"), root = source_repo) %>%
+ file.path("location", "stratum") |>
+ read_vc(root = source_repo) |>
write_vc(
file = file.path("inst", "results", "stratum"), root = target_repo,
sorting = "description", strict = strict
)
# overview of the effort
- read_vc(file.path("observation", "visit"), root = source_repo) %>%
+ file.path("observation", "visit") |>
+ read_vc(root = source_repo) |>
inner_join(
read_vc(file.path("location", "point"), root = source_repo),
by = c("point_id" = "id")
- ) %>%
+ ) |>
inner_join(
read_vc(file.path("location", "square"), root = source_repo),
by = c("square_id" = "id")
- ) %>%
+ ) |>
inner_join(
read_vc(file.path("location", "stratum"), root = source_repo),
by = c("stratum_id" = "id")
- ) %>%
+ ) |>
count(
.data$year, location = .data$square_id, stratum = .data$description,
name = "visits"
- ) %>%
- mutate(stratum = factor(.data$stratum)) %>%
+ ) |>
+ mutate(stratum = factor(.data$stratum)) |>
write_vc(
file = file.path("inst", "results", "effort"), root = target_repo,
sorting = c("stratum", "location", "year"), strict = strict
)
+ file.path("inst", "results", "effort") |>
+ update_metadata(
+ root = target_repo, name = "effort", title = "Sampling effort",
+ field_description = c(
+ year = "year of the survey", location = "identifier of the location",
+ stratum = "name of the stratum",
+ visits = "number of visited point locations"
+ )
+ )
# analysis metadata
- results@AnalysisMetadata %>%
+ results@AnalysisMetadata |>
inner_join(
- read_vc(file.path("species", "speciesgroup"), source_repo) %>%
+ read_vc(file.path("species", "speciesgroup"), source_repo) |>
select("id", speciesgroup = "description"),
by = c("species_group_id" = "id")
- ) %>%
+ ) |>
transmute(
analysis = .data$file_fingerprint,
speciesgroup = factor(.data$speciesgroup),
@@ -71,284 +83,360 @@ retrieve_results <- function(
str_detect(.data$model_type, "composite index: .*"),
NA,
str_replace(.data$model_type, "inla (.*): .*", "\\1")
- ) %>%
+ ) |>
factor(),
.data$status_fingerprint, status = factor(.data$status)
- ) %>%
+ ) |>
left_join(
- results@Parameter %>%
- filter(.data$description == "WAIC") %>%
+ results@Parameter |>
+ filter(.data$description == "WAIC") |>
semi_join(
x = results@ParameterEstimate, by = c("parameter" = "fingerprint")
- ) %>%
+ ) |>
select("analysis", waic = "estimate"),
by = "analysis"
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "meta"), root = target_repo,
sorting = "analysis", strict = strict
)
- results@AnalysisRelation %>%
- mutate(
- analysis = factor(.data$analysis), parent = factor(.data$parent_analysis)
- ) %>%
+ file.path("inst", "results", "meta") |>
+ update_metadata(
+ root = target_repo, name = "meta", title = "Metadata on the analyses",
+ field_description = c(
+ analysis = "Unique identifier of the analysis",
+ speciesgroup = "Name of the species or species group",
+ composite = "TRUE indicates a species group, FALSE a species",
+ cycle = "TRUE indicates a three year cycle, FALSE yearly cycle",
+ linear = "TRUE indicates a linear trend, FALSE a nonlinear trend",
+ family = "Statistical distribution used in the analysis",
+ status_fingerprint = "Status fingerprint of the analysis",
+ status = "Status of the analysis",
+ waic = "Wantabe-Akaike Information Criterion"
+ )
+ )
+
+ results@AnalysisRelation |>
+ transmute(
+ analysis = factor(.data$analysis), parent = .data$parent_analysis
+ ) |>
write_vc(
file = file.path("inst", "results", "parent"), root = target_repo,
sorting = c("analysis", "parent"), strict = strict
)
+ file.path("inst", "results", "parent") |>
+ update_metadata(
+ file = file.path("inst", "results", "parent"), root = target_repo,
+ name = "parent", title = "Parent-child links between analyses",
+ description = "Lists only analyses with at least one parent",
+ field_description = c(
+ analysis = "Identifier of the child analysis.",
+ parent = "Identifier of the parent analysis."
+ )
+ )
+
# differences among year or cycle
- results@Contrast %>%
- filter(str_detect(.data$description, "^index")) %>%
+ results@Contrast |>
+ filter(str_detect(.data$description, "^index")) |>
mutate(
- reference = str_replace(.data$description, "index_(.*)_.*", "\\1") %>%
+ reference = str_replace(.data$description, "index_(.*)_.*", "\\1") |>
as.integer(),
- alternative = str_replace(.data$description, "index_.*_(.*)", "\\1") %>%
+ alternative = str_replace(.data$description, "index_.*_(.*)", "\\1") |>
as.integer()
- ) %>%
- inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) %>%
+ ) |>
+ inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
analysis = factor(.data$analysis), .data$reference, .data$alternative,
estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "index"), root = target_repo,
sorting = c("analysis", "reference", "alternative"), strict = strict
)
+ file.path("inst", "results", "index") |>
+ update_metadata(
+ root = target_repo, name = "index", title = "Estimated indices",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ reference = "Year or period used as reference",
+ alternative = "Year of period compared with the reference",
+ estimate = "Estimate of the different on the log-scale",
+ lower_confidence_limit = "5% quantile of the distribution of the index",
+ upper_confidence_limit = "95% quantile of the distribution of the index"
+ )
+ )
+
# estimated average count per year or cycle
- results@Contrast %>%
- filter(str_detect(.data$description, "^estimate")) %>%
+ results@Contrast |>
+ filter(str_detect(.data$description, "^estimate")) |>
mutate(
- year = str_replace(.data$description, "estimate_(.*)", "\\1") %>%
+ year = str_replace(.data$description, "estimate_(.*)", "\\1") |>
as.integer()
- ) %>%
- inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) %>%
+ ) |>
+ inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
analysis = factor(.data$analysis), .data$year,
estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "estimate"), root = target_repo,
sorting = c("analysis", "year"), strict = strict
)
+ file.path("inst", "results", "estimate") |>
+ update_metadata(
+ root = target_repo, name = "estimate",
+ title = "Estimate average number of bird per point",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ year = "Year or period of the estimate",
+ estimate = "Estimate on the log-scale",
+ lower_confidence_limit =
+ "5% quantile of the distribution on the log-scale",
+ upper_confidence_limit =
+ "95% quantile of the distribution on the log-scale"
+ )
+ )
+
# trend in moving window
- results@Contrast %>%
- filter(str_detect(.data$description, "^trend")) %>%
+ results@Contrast |>
+ filter(str_detect(.data$description, "^trend")) |>
mutate(
- midpoint = str_replace(.data$description, "trend_(.*)_.*", "\\1") %>%
+ midpoint = str_replace(.data$description, "trend_(.*)_.*", "\\1") |>
as.numeric(),
- window = str_replace(.data$description, "trend_.*_(.*)", "\\1") %>%
+ window = str_replace(.data$description, "trend_.*_(.*)", "\\1") |>
as.integer()
- ) %>%
- inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) %>%
+ ) |>
+ inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
analysis = factor(.data$analysis), .data$midpoint, .data$window,
estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "moving_trend"), root = target_repo,
sorting = c("analysis", "window", "midpoint"), strict = strict
)
+ file.path("inst", "results", "moving_trend") |>
+ update_metadata(
+ root = target_repo, name = "moving_trend",
+ title = "Trend for different moving windows",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ midpoint = "Year in the middle of the interval",
+ window = "Width of the interval as a number of years",
+ estimate = "Estimate on the log-scale",
+ lower_confidence_limit =
+ "5% quantile of the distribution on the log-scale",
+ upper_confidence_limit =
+ "95% quantile of the distribution on the log-scale"
+ )
+ )
+
# linear trend
- results@Contrast %>%
- filter(str_detect(.data$description, "^linear_trend")) %>%
- inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) %>%
+ results@Contrast |>
+ filter(str_detect(.data$description, "^linear_trend")) |>
+ inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
analysis = factor(.data$analysis), estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "linear_trend"), root = target_repo,
sorting = "analysis", strict = strict
)
+ file.path("inst", "results", "linear_trend") |>
+ update_metadata(
+ root = target_repo, name = "linear_trend",
+ title = "Slope of the linear trend",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ estimate = "Estimate on the log-scale",
+ lower_confidence_limit =
+ "5% quantile of the distribution on the log-scale",
+ upper_confidence_limit =
+ "95% quantile of the distribution on the log-scale"
+ )
+ )
+
# estimate along linear trend
- results@Contrast %>%
- filter(str_detect(.data$description, "^linear_estimate")) %>%
+ results@Contrast |>
+ filter(str_detect(.data$description, "^linear_estimate")) |>
mutate(
- year = str_replace(.data$description, "linear_estimate_(.*)", "\\1") %>%
+ year = str_replace(.data$description, "linear_estimate_(.*)", "\\1") |>
as.integer()
- ) %>%
- inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) %>%
+ ) |>
+ inner_join(results@ContrastEstimate, by = c("fingerprint" = "contrast")) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
analysis = factor(.data$analysis), .data$year,
estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "linear_estimate"),
root = target_repo, sorting = c("analysis", "year"), strict = strict
)
+ file.path("inst", "results", "linear_estimate") |>
+ update_metadata(
+ root = target_repo, name = "linear_estimate",
+ title = "Estimates along a linear trend",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ year = "Year of estimate, centered to the start of the analysis",
+ estimate = "Estimate on the log-scale",
+ lower_confidence_limit =
+ "5% quantile of the distribution on the log-scale",
+ upper_confidence_limit =
+ "95% quantile of the distribution on the log-scale"
+ )
+ )
# composite index
- results@AnalysisMetadata %>%
- filter(str_detect(.data$model_type, "composite")) %>%
+ results@AnalysisMetadata |>
+ filter(str_detect(.data$model_type, "composite")) |>
semi_join(
x = results@ParameterEstimate,
by = c("analysis" = "file_fingerprint")
- ) %>%
+ ) |>
inner_join(
- results@Parameter %>%
- filter(str_detect(.data$description, "^index")) %>%
+ results@Parameter |>
+ filter(str_detect(.data$description, "^index")) |>
mutate(
- reference = str_replace(.data$description, "index_(.*)_.*", "\\1") %>%
+ reference = str_replace(.data$description, "index_(.*)_.*", "\\1") |>
as.integer(),
alternative = str_replace(
.data$description, "index_.*_(.*)", "\\1"
- ) %>%
+ ) |>
as.integer()
),
by = c("parameter" = "fingerprint")
- ) %>%
+ ) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
analysis = factor(.data$analysis), .data$reference, .data$alternative,
estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "composite_index"), strict = strict,
root = target_repo, sorting = c("analysis", "reference", "alternative")
)
+ file.path("inst", "results", "composite_index") |>
+ update_metadata(
+ root = target_repo, name = "composite_index",
+ title = "Indices by species group",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ reference = "Year or period used as reference",
+ alternative = "year or period to compare with the reference",
+ estimate = "Estimate on the log-scale",
+ lower_confidence_limit =
+ "5% quantile of the distribution on the log-scale",
+ upper_confidence_limit =
+ "95% quantile of the distribution on the log-scale"
+ )
+ )
+
# trend in moving window
- results@Parameter %>%
- filter(str_detect(.data$description, "^trend")) %>%
+ results@Parameter |>
+ filter(str_detect(.data$description, "^trend")) |>
mutate(
- midpoint = str_replace(.data$description, "trend_(.*)_.*", "\\1") %>%
+ midpoint = str_replace(.data$description, "trend_(.*)_.*", "\\1") |>
as.numeric(),
- window = str_replace(.data$description, "trend_.*_(.*)", "\\1") %>%
+ window = str_replace(.data$description, "trend_.*_(.*)", "\\1") |>
as.integer()
- ) %>%
+ ) |>
inner_join(
results@ParameterEstimate, by = c("fingerprint" = "parameter")
- ) %>%
+ ) |>
semi_join(
- results@AnalysisMetadata %>%
+ results@AnalysisMetadata |>
filter(str_detect(.data$model_type, "composite")),
by = c("analysis" = "file_fingerprint")
- ) %>%
+ ) |>
mutate(
s = (.data$upper_confidence_limit - .data$lower_confidence_limit) /
(2 * qnorm(0.975)),
lower_confidence_limit = qnorm(0.05, mean = .data$estimate, sd = .data$s),
upper_confidence_limit = qnorm(0.95, mean = .data$estimate, sd = .data$s)
- ) %>%
+ ) |>
transmute(
.data$analysis, .data$midpoint, .data$window,
estimate = round(.data$estimate, 4),
lower_confidence_limit = round(.data$lower_confidence_limit, 4),
upper_confidence_limit = round(.data$upper_confidence_limit, 4)
- ) %>%
+ ) |>
write_vc(
file = file.path("inst", "results", "composite_moving_trend"),
root = target_repo, sorting = c("analysis", "window", "midpoint"),
strict = strict
)
- # stratum weights
- read_relevant(base = base, project = project, verbose = verbose) %>%
+ file.path("inst", "results", "composite_moving_trend") |>
+ update_metadata(
+ root = target_repo, name = "composite_moving_trend",
+ title = "Moving trend for the composite indices",
+ field_description = c(
+ analysis = "Identifier of the analysis",
+ midpoint = "Year in the middle of the interval",
+ window = "Width of the interval as a number of years",
+ estimate = "Estimate on the log-scale",
+ lower_confidence_limit =
+ "5% quantile of the distribution on the log-scale",
+ upper_confidence_limit =
+ "95% quantile of the distribution on the log-scale"
+ )
+ )
+
+ read_relevant(base = base, project = project, verbose = verbose) |>
write_vc(
file = file.path("inst", "results", "stratum_weight"),
root = target_repo, sorting = c("analysis", "stratum"), strict = strict
)
+ file.path("inst", "results", "stratum_weight") |>
+ update_metadata(
+ root = target_repo, name = "stratum_weight"
+ )
return(invisible(NULL))
}
-
-#' @importFrom dplyr %>% count group_by mutate n summarise
-#' @importFrom n2kanalysis display get_data get_file_fingerprint
-#' @importFrom purrr map_dfr
-#' @importFrom rlang .data
-#' @importFrom stringr str_remove str_subset
-read_relevant <- function(base, project, verbose = TRUE) {
- file.path(base, project) %>%
- list.files(pattern = "rds$", recursive = TRUE, full.names = TRUE) %>%
- str_subset("converged") -> todo
- map_dfr(todo, verbose = verbose, function(i, verbose) {
- display(verbose, i)
- x <- readRDS(i)
- if (!inherits(x, "n2kInla")) {
- return(NULL)
- }
- if (!grepl("year:stratum", x@AnalysisMetadata$model_type)) {
- return(NULL)
- }
- get_data(x) %>%
- mutate(tmp = sprintf("%s_%0.5f", .data$stratum, .data$weight)) %>%
- count(
- .data$tmp, .data$square, .data$point, name = "visits"
- ) %>%
- group_by(.data$tmp, .data$square) %>%
- summarise(
- points = n(), visits = sum(.data$visits), .groups = "drop"
- ) %>%
- group_by(.data$tmp, .data$points) %>%
- summarise(
- squares = n(), visits = sum(.data$visits), .groups = "drop"
- ) -> tmp
- tmp %>%
- select(-.data$visits) %>%
- complete(
- .data$tmp, points = 1:6, fill = list(squares = 0)
- ) %>%
- mutate(points = sprintf("points_%i", .data$points)) %>%
- pivot_wider(names_from = "points", values_from = "squares") %>%
- inner_join(
- tmp %>%
- group_by(.data$tmp) %>%
- summarise(
- relevant = sum(.data$squares), visits = sum(.data$visits),
- .groups = "drop"
- ),
- by = "tmp"
- ) %>%
- mutate(
- analysis = get_file_fingerprint(x),
- stratum = str_remove(.data$tmp, "_.*"),
- weight = str_remove(.data$tmp, ".*_") %>%
- as.numeric()
- ) %>%
- select(-.data$tmp)
- }) %>%
- mutate(analysis = factor(.data$analysis))
-}
diff --git a/R/select_relevant.R b/R/select_relevant.R
index d9dcf9d..bef0ec6 100644
--- a/R/select_relevant.R
+++ b/R/select_relevant.R
@@ -18,7 +18,7 @@
#' @inheritParams prepare_dataset
#' @export
#' @importFrom assertthat assert_that has_name is.count is.number is.string
-#' @importFrom dplyr %>% count distinct filter left_join mutate rename select
+#' @importFrom dplyr count distinct filter left_join mutate rename select
#' semi_join
#' @importFrom git2rdata is_git2rdata read_vc
#' @importFrom rlang .data
@@ -47,9 +47,9 @@ select_relevant <- function(
return(NULL)
}
- read_vc(file, root = repo) %>%
- select(-.data$datafield_id) %>%
- left_join(x = observation, by = "sample_id") %>%
+ read_vc(file, root = repo) |>
+ select(-"datafield_id") |>
+ left_join(x = observation, by = "sample_id") |>
mutate(
count = replace_na(.data$count, 0),
cycle = 1 + (.data$year - 2007) %/% 3,
@@ -60,28 +60,28 @@ select_relevant <- function(
return(NULL)
}
# require at least one observation per point
- rawdata %>%
- filter(.data$count > 0) %>%
- distinct(.data$point) %>%
+ rawdata |>
+ filter(.data$count > 0) |>
+ distinct(.data$point) |>
semi_join(x = rawdata, by = "point") -> rawdata
# require observation during at least min_cycle different cycles for each
# square
- rawdata %>%
- filter(.data$count > 0) %>%
- distinct(.data$square, .data$cycle) %>%
- count(.data$square) %>%
- filter(.data$n >= min_cycle) %>%
+ rawdata |>
+ filter(.data$count > 0) |>
+ distinct(.data$square, .data$cycle) |>
+ count(.data$square) |>
+ filter(.data$n >= min_cycle) |>
semi_join(x = rawdata, by = "square") -> rawdata
if (sum(rawdata$count > 0) < min_observation) {
return(NULL)
}
# require at least min_stratum locations per stratum
- rawdata %>%
- filter(.data$count > 0) %>%
- distinct(.data$stratum, .data$square) %>%
- count(.data$stratum) %>%
- filter(.data$n >= min_stratum) %>%
+ rawdata |>
+ filter(.data$count > 0) |>
+ distinct(.data$stratum, .data$square) |>
+ count(.data$stratum) |>
+ filter(.data$n >= min_stratum) |>
semi_join(x = rawdata, by = "stratum") -> rawdata
if (sum(rawdata$count > 0) < min_observation) {
return(NULL)
@@ -90,35 +90,35 @@ select_relevant <- function(
model <- glm(count ~ 0 + period, data = rawdata, family = poisson)
log_threshold <- max(coef(model)) + log(proportion)
selection <- levels(rawdata$period)[coef(model) >= log_threshold]
- rawdata %>%
- filter(.data$period %in% selection) %>%
+ rawdata |>
+ filter(.data$period %in% selection) |>
mutate(period = factor(.data$period)) -> rawdata
if (sum(rawdata$count > 0) < min_observation) {
return(NULL)
}
model <- glm(count ~ 0 + period, data = rawdata, family = poisson)
- rawdata %>%
+ rawdata |>
mutate(
period = relevel(.data$period, which.max(coef(model)))
) -> rawdata
# require observation during at least min_cycle different cycles for each
# location
- rawdata %>%
- filter(.data$count > 0) %>%
- distinct(.data$square, .data$cycle) %>%
- count(.data$square) %>%
- filter(.data$n >= min_cycle) %>%
+ rawdata |>
+ filter(.data$count > 0) |>
+ distinct(.data$square, .data$cycle) |>
+ count(.data$square) |>
+ filter(.data$n >= min_cycle) |>
semi_join(x = rawdata, by = "square") -> rawdata
if (sum(rawdata$count > 0) < min_observation) {
return(NULL)
}
# require at least min_stratum locations per stratum
- rawdata %>%
- filter(.data$count > 0) %>%
- distinct(.data$stratum, .data$square) %>%
- count(.data$stratum) %>%
- filter(.data$n >= min_stratum) %>%
- semi_join(x = rawdata, by = "stratum") %>%
+ rawdata |>
+ filter(.data$count > 0) |>
+ distinct(.data$stratum, .data$square) |>
+ count(.data$stratum) |>
+ filter(.data$n >= min_stratum) |>
+ semi_join(x = rawdata, by = "stratum") |>
rename(observation_id = .data$sample_id) -> rawdata
if (sum(rawdata$count > 0) < min_observation) {
return(NULL)
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 485eb1c..744bc1d 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -19,4 +19,4 @@ navbar:
authors:
Research Institute for Nature and Forest (INBO):
href: "https://www.vlaanderen.be/inbo/en-gb"
- html: "
"
+ html: "
"
diff --git a/abvanalysis.Rproj b/abvanalysis.Rproj
index e4a061f..600e4af 100644
--- a/abvanalysis.Rproj
+++ b/abvanalysis.Rproj
@@ -1,4 +1,5 @@
Version: 1.0
+ProjectId: 90bc52d8-09d8-496a-b6ae-ae375a1199c8
RestoreWorkspace: Default
SaveWorkspace: Default
diff --git a/checklist.yml b/checklist.yml
index e4a11f8..8d3e1d4 100644
--- a/checklist.yml
+++ b/checklist.yml
@@ -30,6 +30,7 @@ required:
- folder conventions
- license
- lintr
+- organisation
- repository secret
- spelling
spelling:
@@ -41,20 +42,18 @@ spelling:
other:
nl-BE:
- inst/interactive/composite.qmd
+ - inst/interactive/composite_pdf.qmd
- inst/interactive/index.md
- inst/interactive/methodologie/index.qmd
+ - inst/interactive/methodologie/inzameling.qmd
- inst/interactive/methodologie/reproduceerbaarheid.qmd
- inst/interactive/methodologie/verwerking.qmd
- inst/interactive/methodologie/voorstelling.qmd
- inst/interactive/samenvatting.md
- inst/interactive/species.qmd
+ - inst/interactive/species_pdf.qmd
- inst/interactive/trends.qmd
- - inst/website/0_methodologie.Rmd
- - inst/website/1_samengesteld.Rmd
- - inst/website/2_trend_per_soort.Rmd
- - inst/website/_samengesteld.Rmd
- - inst/website/_soort.Rmd
- - inst/website/download_html.Rmd
- - inst/website/download_non_html.Rmd
- - inst/website/index.Rmd
- - inst/website/zzz_bibliografietitel.Rmd
+ - inst/interactive/trends_pdf.qmd
+ - inst/interactive/vbp_species.qmd
+pak:
+- pdftools
diff --git a/inst/CITATION b/inst/CITATION
index 2150e00..1d3d6f4 100644
--- a/inst/CITATION
+++ b/inst/CITATION
@@ -2,12 +2,12 @@ citHeader("To cite `abvanalysis` in publications please use:")
# begin checklist entry
bibentry(
bibtype = "Manual",
- title = "abvanalysis: Analysis of the Common Breeding Bird Survey. Version 0.2.4",
- author = c( author = c(person(given = "Thierry", family = "Onkelinx"))),
- year = 2024,
+ title = "abvanalysis: Analysis of the Common Breeding Bird Survey. Version 0.2.5",
+ author = c(person(given = "Thierry", family = "Onkelinx")),
+ year = 2026,
url = "https://github.com/inbo/abvanalysis/",
abstract = "Read in the raw data and prepare analysis datasets.",
- textVersion = "Onkelinx, Thierry (2024) abvanalysis: Analysis of the Common Breeding Bird Survey. Version 0.2.4. https://github.com/inbo/abvanalysis/",
+ textVersion = "Onkelinx, Thierry (2026) abvanalysis: Analysis of the Common Breeding Bird Survey. Version 0.2.5. https://github.com/inbo/abvanalysis/",
keywords = "common breeding birds; monitoring; analysis; reproducible science",
)
# end checklist entry
diff --git a/inst/WORDLIST b/inst/WORDLIST
deleted file mode 100644
index 3f27f91..0000000
--- a/inst/WORDLIST
+++ /dev/null
@@ -1,8 +0,0 @@
-ABV
-Codecov
-INBO
-INLA
-Lifecycle
-Natuurpunt
-Studie
-Vogelnieuws
diff --git a/inst/WORDLIST_nl_BE b/inst/WORDLIST_nl_BE
deleted file mode 100644
index 4b557c8..0000000
--- a/inst/WORDLIST_nl_BE
+++ /dev/null
@@ -1,46 +0,0 @@
-ABV
-Bayesiaanse
-Bosonderzoek
-Data-hashes
-GBIF
-Gaussiaanse
-INBO
-INLA
-Poisson
-R-script
-SHA-1
-WAIC
-Waarderingkaart
-aantalsontwikkelingen
-data-hash
-exponentiëren
-geaggregreerd
-geparametriseerd
-gestratificeerde
-habitats
-hash
-hashes
-hashfunctie
-herbezoeken
-kommagescheiden
-kwantielen
-linkeras
-log-schaal
-log-transformatie
-nulwaarnemingen
-overbemonsterd
-overdisperieparameter
-overdispersie
-package
-packages
-rechteras
-referentiejaartal
-rekenbladprogramma
-strata
-stratum
-stratumeffecten
-stratumgewicht
-stratumgewichten
-t.e.m.
-varianties
-zestientallig
diff --git a/inst/analysis_local.R b/inst/analysis_local.R
index d9fc51e..43657c4 100644
--- a/inst/analysis_local.R
+++ b/inst/analysis_local.R
@@ -1,38 +1,66 @@
+# import data
library(abvanalysis)
repo <- git2rdata::repository(file.path("~", "n2k", "abv"))
-origin <- RPostgreSQL::dbConnect(
- RPostgreSQL::PostgreSQL(), host = "127.0.0.1", user = "readonly",
- dbname = "meetnetten", port = "65432",
- password = keyring::key_get("meetnetten", username = "readonly")
-) # postgres server
origin <- odbc::dbConnect(
- odbc::odbc(), driver = "ODBC Driver 17 for SQL Server",
+ odbc::odbc(),
+ driver = "ODBC Driver 18 for SQL Server",
server = "inbo-sql08-prd.inbo.be",
- database = "S0008_00_Meetnetten", port = 1433, uid = "bmkreader",
+ Encrypt = "no",
+ database = "S0008_00_Meetnetten",
+ port = 1433,
+ uid = "bmkreader",
pwd = keyring::key_get("meetnetten", username = "bmkreader")
) # sql server
-
+project <- "abv"
prepare_dataset(
- origin = origin, repo = repo, end_date = Sys.time(), verbose = TRUE,
- push = FALSE, strict = TRUE
+ origin = origin,
+ repo = repo,
+ end_date = Sys.time(),
+ verbose = TRUE,
+ push = FALSE,
+ strict = FALSE,
+ db_scheme = "staging_Meetnetten"
)
-base <- file.path("~", "n2kanalysis")
+# prepare analysis
+library(abvanalysis)
+library(n2kanalysis)
+repo <- git2rdata::repository(file.path("~", "n2k", "abv"))
project <- "abv"
-dir.create(file.path(base, project), recursive = TRUE, showWarnings = FALSE)
-script <- prepare_analysis(
- repo = repo, base = base, project = project, docker = "inbobmk/rn2k:0.9",
- dependencies = c("inbo/n2khelper@v0.5.0", "inbo/n2kanalysis@v0.3.2")
-)
+connect_inbo_s3()
+base <- aws.s3::get_bucket(Sys.getenv("N2KBUCKET"), prefix = project, max = 1)
+prepare_analysis(
+ repo = repo,
+ base = base,
+ project = project,
+ docker = "inbobmk/rn2k:dev-0.10",
+ dependencies = c("inbo/n2khelper@v0.5.0", "inbo/n2kanalysis@0.4.1")
+) -> bash_script
+sprintf(
+ "aws s3 cp s3://%s/%s ~/abv.sh\nchmod +x ~/abv.sh",
+ Sys.getenv("N2KBUCKET"),
+ bash_script
+) |>
+ cat()
-writeLines(
- c(script$init, script$model), file.path(base, project, "abv_model.sh")
-)
-writeLines(
- c(script$init, script$manifest), file.path(base, project, "abv.sh")
-)
+# fit models
+library(n2kanalysis)
+connect_inbo_s3()
+base <- aws.s3::get_bucket(Sys.getenv("N2KBUCKET"), prefix = project, max = 1)
+read_manifest(base = base, project = project) |>
+ fit_model(base = base, project = project)
+# get results
+library(abvanalysis)
+library(n2kanalysis)
+connect_inbo_s3()
+project <- "abv"
+base <- aws.s3::get_bucket(Sys.getenv("N2KBUCKET"), prefix = project, max = 1)
+repo <- git2rdata::repository(file.path("~", "n2k", "abv"))
retrieve_results(
- base = base, project = project, source_repo = repo,
- target_repo = git2rdata::repository(), strict = FALSE
+ base = base,
+ project = project,
+ source_repo = repo,
+ target_repo = git2rdata::repository(),
+ strict = FALSE
)
diff --git a/inst/extensions/flandersqmd-report-website/_extension.yml b/inst/extensions/flandersqmd-report-website/_extension.yml
deleted file mode 100644
index f182c6f..0000000
--- a/inst/extensions/flandersqmd-report-website/_extension.yml
+++ /dev/null
@@ -1,23 +0,0 @@
-title: Corporate identity of the Flemish government quarto websites
-author: Thierry Onkelinx
-version: 0.1.0
-quarto-required: ">=1.4.0"
-contributes:
- project:
- project:
- type: website
- website:
- sidebar:
- search: true
- style: "floating"
- format:
- html:
- css: [css/agency.css, css/flanders_generic.css]
- template: "partials/template.html"
- number-sections: true
- toc: true
- html-math-method: katex
- filters:
- - filters/translations.lua
- shortcodes:
- - shortcodes/colophon.lua
diff --git a/inst/extensions/flandersqmd-report-website/filters/translations.lua b/inst/extensions/flandersqmd-report-website/filters/translations.lua
deleted file mode 100644
index 8fce5ea..0000000
--- a/inst/extensions/flandersqmd-report-website/filters/translations.lua
+++ /dev/null
@@ -1,130 +0,0 @@
-function is_empty(s)
- return s == nil or s == ''
-end
-
-function translation(lang)
- local result
- if (lang == "nl-BE") then
- result = {
- author = "Geschreven door",
- address = "Vlaamse overheid, Herman Teirlinckgebouw, Havenlaan 88, 1000 Brussel",
- citation = "Wijze van citeren",
- city = "Brussel",
- country = "België",
- depotnr = "Depotnummer",
- export = "Exporteer referentie als",
- location = "Vestiging",
- mission = "Hier komt de missie",
- name = "Vlaamse overheid",
- ordernr = "Opdrachtnummer",
- reviewer = "Nagelezen door",
- series = "Rapporten van het",
- url = "https://www.vlaanderen.be",
- url_text = "vlaanderen.be",
- vu = "Verantwoordelijke uitgever",
- year = "Gepubliceerd in"
- }
- elseif (lang == "fr-FR") then
- result = {
- author = "Écrit par",
- address = "Autorité flamande, Herman Teirlinckgebouw, Avenu du Port 88, 1000 Bruxelles",
- citation = "Citation recommandée",
- city = "Bruxelles",
- country = "Belgique",
- depotnr = "Numéro de dépôt",
- export = "Exporter la référence à",
- location = "Adresse",
- mission = "Mission statement",
- name = "l'Autorité flamande ",
- ordernr = "Numéro de commande",
- reviewer = "Examiné par",
- series = "Rapports de",
- url = "https://www.vlaanderen.be/fr",
- url_text = "vlaanderen.be",
- vu = "Éditeur responsable",
- year = "Publié en"
- }
- else
- result = {
- author = "Written by",
- address = "Government of Flanders, Herman Teirlinck, Havenlaan 88, 1000 Brussel",
- citation = "Way of quoting",
- city = "Brussels",
- country = "Belgium",
- depotnr = "Deposit number",
- export = "Export reference to",
- location = "Location:",
- mission = "Misson statement",
- name = "Government of Flanders",
- ordernr = "Order number",
- reviewer = "Reviewed by",
- series = "Reports of the",
- url = "https://www.vlaanderen.be/en",
- url_text = "vlaanderen.be",
- vu = "Responsible publisher",
- year = "Published during"
- }
- end
- return result
-end
-
-function abbreviate_person(person, i, type, n)
- if i > 2 then
- return ''
- end
- if i == 2 and n > 2 then
- return ' et al.'
- end
- if (i > 1) then
- res = ' & '
- else
- res = ''
- end
- if is_empty(person.name) then
- res = res .. '
$subtitle$
-$endif$ -$for(author)$ - -$endfor$ -$if(date)$ -$date$
-$endif$ -$if(abstract)$ --
-
-
- $shortauthor$
- $publicationyear$
- $if(flandersqmd.doi)$$flandersqmd.doi$$else$
'
- end
- z = z .. '