R/fokus.gen.R
In zdaarau/fokus: Provides an API around the FOKUS Post-voting Surveys
Defines functions
raw_qstnr_suppl_proposal
raw_qstnr_suppl_lvl_canton
raw_qstnr_suppl_lvl
raw_qstnr_suppl
.onLoad
Documented in
raw_qstnr_suppl
raw_qstnr_suppl_lvl
raw_qstnr_suppl_lvl_canton
raw_qstnr_suppl_proposal
# DO NOT EDIT THIS FILE BY HAND! Instead edit the R Markdown source file `Rmd/fokus.Rmd` and run `pkgpurl::purl_rmd()`.
# See `README.md#r-markdown-format` for more information on the literate programming approach used applying the R Markdown format.
# fokus: Provides an API around the FOKUS Post-voting Surveys
# Copyright (C) 2024 Centre for Democracy Studies Aarau (ZDA)
#
# This program is free software: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License as published by the Free
# Software Foundation, either version 3 of the License, or any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
.onLoad <- function(libname, pkgname) {
# clear pkgpins cache
tryCatch(expr = pkgpins::clear_cache(board = pkgpins::board(pkg = pkgname),
max_age = pal::pkg_config_val(key = "global_max_cache_age",
pkg = pkgname)),
error = function(e) cli::cli_alert_warning(text = "Failed to clear pkgpins cache on load of {.pkg {pkgname}}. Error message: {e$message}"))
}
utils::globalVariables(names = c(".",
# tidyselect fns
"all_of",
"any_of",
"ends_with",
"everything",
"starts_with",
"where",
# other
"alignment",
"allowed_at",
"block",
"date_begin",
"date_end",
"enumerator",
"enumerator_base",
"full_expressions",
"Geschlecht",
"has_fallback",
"has_same_length",
"Haushaltsgr\u00f6sse Anzahl Personen Total",
"Haushaltsgr\u00f6sse Anzahl Personen \u00fcber 18 Jahren",
"household_size_official",
"i",
"id",
"ID-Nummer",
"is_likely_default",
"j",
"Jahrgang",
"length_response_options",
"length_value_labels",
"length_variable_values",
"lvl",
"marital_status_official",
"matches_length",
"max_age",
"min_age",
"n_adults_in_household_official",
"n_cantonal_majoritarian_elections",
"n_cantonal_proportional_elections",
"n_cantonal_proposals",
"n_char_short",
"n_federal_majoritarian_elections",
"n_federal_proportional_elections",
"n_federal_proposals",
"n_kids_in_household_official",
"name",
"name.de.qstnr",
"nr",
"question",
"question_full",
"question_intro_i",
"question_intro_j",
"receives_print",
"response_options",
"sep",
"sex_official",
"string",
"term",
"topic",
"value_labels",
"variable_label",
"variable_name",
"variable_values",
"who",
"width",
"year_of_birth_official",
"Zivilstand"))
#' Raw FOKUS questionnaire data
#'
#' A structured list of the raw questionnaire data of the FOKUS surveys.
#'
#' @format `r pkgsnip::return_lbl("strict_list")`
#' @docType data
#' @family qstnr_raw
#' @keywords internal
#'
#' @name raw_qstnr
NULL
#' Raw supplemental date-specific FOKUS questionnaire data
#'
#' A structured list of raw supplemental date-specific questionnaire data of the FOKUS surveys.
#'
#' @format `r pkgsnip::return_lbl("strict_list")`
#' @docType data
#' @family qstnr_raw
#' @keywords internal
#'
#' @name raw_qstnrs_suppl
#'
#' @examples
#' fokus:::raw_qstnrs_suppl[["2018-09-23"]]$mode
NULL
#' Get raw supplemental date-specific FOKUS questionnaire data
#'
#' Returns a structured list of the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnrs_suppl] for the specified ballot date.
#'
#' @inheritParams cantons
#'
#' @return `r pkgsnip::return_lbl("strict_list")`
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl(ballot_date = "2018-09-23") |> _$mode
raw_qstnr_suppl <- function(ballot_date = pal::pkg_config_val("ballot_date")) {
ballot_date %<>% as_ballot_date_chr()
raw_qstnrs_suppl[[ballot_date]]
}
#' Get a political level's raw supplemental date-specific FOKUS questionnaire data
#'
#' Returns a structured list of the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl] for the specified ballot date and political
#' level.
#'
#' @inheritParams cantons
#' @param lvl Political level. One of `r pal::enum_fn_param_defaults(param = "lvl", fn = raw_qstnr_suppl_lvl)`.
#'
#' @inherit raw_qstnr_suppl return seealso
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_lvl(ballot_date = "2018-09-23",
#' lvl = "cantonal") |>
#' names()
raw_qstnr_suppl_lvl <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls) {
lvl <- rlang::arg_match(lvl)
result <- raw_qstnr_suppl(ballot_date = ballot_date) |> purrr::pluck(lvl)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
cli::cli_abort("No {.val {lvl}} level present in the supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result
}
#' Get a canton's political-level-specific raw supplemental date-specific FOKUS questionnaire data
#'
#' Returns a structured list of the [raw supplemental date-specific FOKUS questionnaire data for the specified ballot date and political
#' level][raw_qstnr_suppl_lvl] that applies for the specified canton only.
#'
#' @inheritParams raw_qstnr_suppl_lvl
#' @inheritParams lvls
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_lvl_canton(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau") |>
#' names()
raw_qstnr_suppl_lvl_canton <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton")) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <-
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = lvl) |>
purrr::pluck(canton)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
cli::cli_abort("No {.val {lvl}} supplemental {.val {ballot_date}} FOKUS questionnaire data present for canton {.val {canton}}.")
}
result
}
#' Get raw proposal supplemental questionnaire data
#'
#' Returns a structured list of a proposal's data from the [supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @param proposal_nr Proposal number. A positive integerish scalar.
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_proposal(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1) |>
#' _$name
raw_qstnr_suppl_proposal <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
lvl <- rlang::arg_match(lvl)
checkmate::assert_count(proposal_nr,
positive = TRUE)
proposals <-
lvl |>
pal::when(. == "federal" ~
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = .),
~ raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = .,
canton = canton)) |>
purrr::pluck("proposal")
if (is.null(proposals)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} proposals present",
" for {.val {canton}}"[lvl == "cantonal"],
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
proposal <- proposals |> purrr::pluck(as.character(proposal_nr))
if (is.null(proposal)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} proposal {.val {proposal_nr}} present",
" for {.val {canton}}"[lvl == "cantonal"],
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
proposal
}
#' Safely get raw proposal supplemental questionnaire data
#'
#' Returns a structured list of a proposal's data from the [supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl], or `NULL` if no referendums
#' proposals were covered.
#'
#' @inheritParams raw_qstnr_suppl_proposal
#' @param proposal_nr Proposal number. Either a positive integerish scalar or `NULL` to return the data for all proposals.
#'
#' @return A [strict list][xfun::strict_list()], or `NULL` if no referendums proposals were covered.
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_proposal_safe(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
raw_qstnr_suppl_proposal_safe <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = NULL) {
lvl <- rlang::arg_match(lvl)
checkmate::assert_count(proposal_nr,
positive = TRUE,
null.ok = TRUE)
if (lvl == "cantonal") {
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
}
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck(lvl) |>
pal::when(lvl == "cantonal" ~ purrr::pluck(., canton),
~ .) |>
purrr::pluck("proposal") |>
pal::when(is.null(proposal_nr) ~ .,
~ purrr::pluck(., proposal_nr))
}
#' Get a proposal's raw name supplemental questionnaire data
#'
#' Returns a structured list of proposal name data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_proposal_name(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2)
raw_qstnr_suppl_proposal_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
result <-
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("name")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No names present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a proposal's raw argument supplemental questionnaire data
#'
#' Returns a structured list of argument data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_arguments(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2)
raw_qstnr_suppl_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
result <-
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("argument")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No arguments present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a proposal argument's raw supplemental questionnaire data
#'
#' Returns a structured list of a proposal argument's data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_arguments
#' @inheritParams proposal_argument
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_argument(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2,
#' side = "pro",
#' argument_nr = 2)
raw_qstnr_suppl_argument <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L,
side = all_argument_sides,
argument_nr = 1L) {
side <- rlang::arg_match(side)
checkmate::assert_count(argument_nr,
positive = TRUE)
result <-
raw_qstnr_suppl_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::keep(\(x) x$side %in% side && x$nr %in% argument_nr) |>
dplyr::first()
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {side}} argument {.val {argument_nr}} present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a proposal's raw main motive supplemental questionnaire data
#'
#' Returns a structured list of main motive data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_main_motives(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2)
raw_qstnr_suppl_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
result <-
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("main_motive")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No main motives present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get raw supplemental election questionnaire data
#'
#' Returns a structured list of election data from the [canton's political-level-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_lvl_canton].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_elections(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau") |>
#' _$skill_questions_source
raw_qstnr_suppl_elections <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton")) {
result <-
raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::pluck("election")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort("No {.val {lvl}} elections for canton {.val {canton}} present in the supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result
}
#' Get an election's raw supplemental questionnaire data
#'
#' Returns a structured list of an election's data from the [canton's political-level-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_lvl_canton].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @inheritParams election_name
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_election(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "majoritarian") |>
#' _$n_seats
raw_qstnr_suppl_election <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
prcd = all_prcds,
election_nr = 1L) {
prcd <- rlang::arg_match(prcd)
checkmate::assert_count(election_nr,
positive = TRUE)
result <-
raw_qstnr_suppl_elections(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::pluck(prcd)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} {.val {prcd}} elections for canton {.val {canton}} present in the supplemental {.val {ballot_date}} FOKUS ",
"questionnaire data."))
}
result %<>% purrr::pluck(as.character(election_nr))
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} {.val {prcd}} election {.val {election_nr}} for canton {.val {canton}} present in the supplemental ",
"{.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get raw supplemental election name questionnaire data
#'
#' Returns a structured list of an election's name data from the [political-level-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_lvl].
#'
#' @inheritParams raw_qstnr_suppl_election
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_election_name(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "majoritarian")
raw_qstnr_suppl_election_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
prcd = all_prcds,
election_nr = 1L) {
lvl <- rlang::arg_match(lvl)
prcd <- rlang::arg_match(prcd)
checkmate::assert_count(election_nr,
positive = TRUE)
# federal proportional election names are defined once for all cantons together
if (lvl == "federal" && prcd == "proportional") {
result <-
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = lvl) |>
purrr::chuck("election", prcd, as.character(election_nr))
} else {
result <- raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd,
election_nr = election_nr)
}
result %<>% purrr::pluck("name")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No names present for {.val {lvl}} {.val {prcd}} election {.val {election_nr}} in canton {.val {canton}} in the supplemental ",
"{.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get raw supplemental survey mode questionnaire data
#'
#' Returns a structured list of survey mode data from the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_mode(ballot_date = "2018-09-23",
#' canton = "aargau")
raw_qstnr_suppl_mode <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = pal::pkg_config_val("canton")) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <-
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck("mode", canton)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
cli::cli_abort("No survey mode data present for canton {.val {canton}} in supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result
}
#' Get raw supplemental skill question questionnaire data
#'
#' Returns a structured list of skill question data from the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, non-proposal-specific skill question data is returned.
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_skill_questions(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1) |>
#' purrr::map_depth(1L, "de") |>
#' purrr::list_c(ptype = character())
raw_qstnr_suppl_skill_questions <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = NULL) {
lvl <- rlang::arg_match(lvl)
result <-
lvl |>
pal::when(
# federal non-proposal-specific skill questions (e.g. at federal elections)
length(proposal_nr) == 0L && . == "federal" ~
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = .),
# cantonal non-proposal-specific skill questions (e.g. at cantonal elections)
length(proposal_nr) == 0L && . == "cantonal" ~
raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = .,
canton = canton),
# federal or cantonal proposal-specific skill questions
~ raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = .,
canton = canton,
proposal_nr = proposal_nr)) |>
purrr::pluck("skill_question")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No skill questions present",
ifelse(length(proposal_nr) == 0L,
paste0(" on the {.val {lvl}} level",
" for {.val {canton}}"[lvl == "cantonal"]),
" for {.val {lvl}} proposal {.val {proposal_nr}}"),
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a single skill question's raw supplemental questionnaire data
#'
#' Returns a structured list of a single skill question's data from the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @inheritParams skill_question
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_skill_question(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 1)
raw_qstnr_suppl_skill_question <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = NULL,
skill_question_nr = 1L) {
checkmate::assert_count(skill_question_nr,
positive = TRUE)
result <-
raw_qstnr_suppl_skill_questions(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck(skill_question_nr)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No skill question {.val {skill_question_nr}} present",
ifelse(length(proposal_nr) == 0L,
paste0(" on the {.val {lvl}} level", " for {.val {canton}}"[lvl == "cantonal"]),
" for {.val {lvl}} proposal {.val {proposal_nr}}"),
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data. Only {length(skill_questions)} skill questions included."))
}
result
}
#' Pick right raw questionnaire value
#'
#' Picks the right value of a certain raw questionnaire key based on ballot date and canton (recursively).
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @param x Questionnaire key. A list object.
#' @param key Questionnaire key name, used to determine the correct default value fallback. A character scalar or `NULL`. If `NULL`, no fallback is used (and an
#' error is thrown in case none of the subkeys matches).
#'
#' @return Value of `x` that corresponds to `canton` and `ballot_date`.
#' @family qstnr_raw
#' @keywords internal
raw_pick_right <- function(x,
key = NULL,
ballot_date,
canton) {
# force evaluation of `ballot_date`, `canton` and `key` to ensure immediate error (with better msg) in case they are missing
ballot_date %<>% as_ballot_date_chr()
canton
key
if (purrr::pluck_depth(x) > 1L) {
x <-
pick_right_helper(x = x,
key = key,
ballot_date = ballot_date,
canton = canton) |>
raw_pick_right(key = key,
ballot_date = ballot_date,
canton = canton)
}
x
}
pick_right_helper <- function(x,
ballot_date,
canton,
key) {
if (purrr::is_list(x) && (length(x) > 1L || purrr::pluck_depth(x) > 1L)) {
# create plain ballot date as in subkeys
ballot_date_squeezed <- stringr::str_remove_all(string = ballot_date,
pattern = stringr::fixed("-"))
# convert ballot date to type date
ballot_date %<>% clock::date_parse()
# handle begin-end date subkeys
begin_end_subkeys <-
names(x) |>
stringr::str_subset(pattern = "^\\d+_\\d+$")
matches_begin_end_subkeys <-
begin_end_subkeys |>
purrr::map_lgl(function(x) {
begin <- x |> stringr::str_extract(pattern = "^\\d+") |> lubridate::as_date()
end <- x |> stringr::str_extract(pattern = "\\d+$") |> lubridate::as_date()
begin <= ballot_date && ballot_date <= end
})
# integrity check: ensure there aren't any overlapping intervals
if (length(which(matches_begin_end_subkeys)) > 1L) {
cli::cli_abort(c("Illegal overlapping interval subkeys found: {.var {begin_end_subkeys[matches_begin_end_subkeys]}}",
">" = "Please fix this and run again."),
.internal = TRUE)
}
ballot_types <- ballot_types(ballot_date = ballot_date,
canton = canton)
x <- names(x) |> pal::when(
# canton and ballot date
## consider overrides for binary keys
canton %in% x[["false"]] || ballot_date %in% x[["false"]] ~ FALSE,
canton %in% x[["true"]] || ballot_date %in% x[["true"]] ~ TRUE,
## consider overrides for non-binary keys
### single canton subkey
canton %in% . ~ x[[canton]],
### single date subkey
ballot_date_squeezed %in% . ~ x[[ballot_date_squeezed]],
### begin-end date subkey
any(matches_begin_end_subkeys) ~ x[[begin_end_subkeys[matches_begin_end_subkeys]]],
# consider overrides for ballot types (we take the first one in case of ambiguity)
any(ballot_types %in% .) ~ x[[intersect(., ballot_types)[1L]]],
# return default value if defined
"default" %in% . ~ x[["default"]],
# fall back on key's default value if no subkey matches canton and ballot date
key %in% qstnr_item_keys$key ~ unlist(qstnr_item_keys$default_val[qstnr_item_keys$key == key]),
# abort in any remaining case
~ cli::cli_abort("Undefined behavior, please debug. {.arg {key}} is {.val {key}}, {.arg {x}} is {.field {x}}.",
.internal = TRUE)
)
}
x
}
init_heritable_map <- function(block) {
xfun::strict_list(lvl = "?",
i = NA_integer_,
j = NA_integer_,
block = block,
variable_name = "???",
topic = NULL,
who = "alle",
question_intro_i = NULL,
question_intro_j = NULL,
question = NULL,
question_full = NULL,
question_common = NULL,
allow_multiple_answers = FALSE,
variable_label = "???",
variable_label_common = NULL,
response_options = NULL,
variable_values = NULL,
value_labels = NULL,
value_scale = "nominal",
randomize_response_options = FALSE,
is_mandatory = FALSE,
ballot_types = all_ballot_types,
include = TRUE)
}
resolve_qstnr_val <- function(x,
ballot_date,
canton,
key,
lvl,
i,
j,
...) {
ballot_date %<>% as_ballot_date_chr()
checkmate::assert_string(lvl,
na.ok = TRUE,
null.ok = TRUE)
checkmate::assert_count(i,
na.ok = TRUE,
null.ok = TRUE)
checkmate::assert_count(j,
na.ok = TRUE,
null.ok = TRUE)
x |>
raw_pick_right(key = key,
ballot_date = ballot_date,
canton = canton) |>
pal::when(is.character(.) ~ interpolate_qstnr_val(.,
ballot_date = ballot_date,
canton = canton,
key = key,
lvl = lvl,
i = i,
j = j,
... = ...),
~ .) |>
# convert to proper type
pal::when(
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "character"] ~
as.character(.),
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "logical"] ~
as.logical(.),
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "integer"] ~
as.integer(.),
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "double"] ~
as.double(.),
# undefined behaviour
~ cli::cli_abort("Undefined behaviour in {.fun resolve_qstnr_val}. Please debug.",
.internal = TRUE)
)
}
interpolate_qstnr_val <- function(x,
ballot_date,
canton,
key,
lvl,
i,
j,
...) {
# assign objects in dots to current env ensuring glue/cli fns respect them
rlang::env_bind(.env = rlang::current_env(),
...)
if (key %in% qstnr_item_keys$key[qstnr_item_keys$is_scalar]) {
result <- cli::pluralize(x,
.na = NULL,
.null = NA_character_,
.trim = FALSE)
} else {
result <-
x |>
purrr::map(\(x) glue::glue(x,
.envir = rlang::current_env(),
.na = NULL,
.null = NA_character_,
.trim = FALSE)) |>
unlist()
}
result
}
#' Generate questionnaire tibble
#'
#' @inheritParams ballot_title
#' @param verbose Whether or not to print detailed progress information during questionnaire generation. Note that it will take considerably more time when this
#' is set to `TRUE`.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_gen
#' @keywords internal
gen_qstnr_tibble <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(verbose)
cli::start_app(theme = cli_theme)
pal::cli_progress_step_quick(msg = "Generating {.val {canton}} @ {.val {ballot_date}} questionnaire tibble")
purrr::map2_dfr(.x = raw_qstnr,
.y = names(raw_qstnr),
.f = ~ {
if (verbose && !(.y %in% qstnr_non_item_lvls)) cli::cli_h1("BLOCK: {.val {.y}}")
assemble_qstnr_tibble(ballot_date = ballot_date,
canton = canton,
raw_qstnr_branch = .x,
qstnr_lvl = .y,
heritable_map = init_heritable_map(block = .y),
verbose = verbose)
}) |>
# add ballot date and canton
dplyr::mutate(ballot_date = !!ballot_date,
canton = !!canton,
.before = 1L)
}
assemble_qstnr_tibble <- function(ballot_date,
canton,
raw_qstnr_branch,
qstnr_lvl,
heritable_map,
verbose) {
if (verbose && stringr::str_detect(qstnr_lvl, "\\..+\\.item$")) {
cli::cli_h2("BRANCH PATH: {.val {stringr::str_remove(qstnr_lvl, '\\\\.item$')}}")
}
map <- heritable_map
# only complement with non-table-array qstnr lvls (would be completely wrong to complement with the `item` table arrays, which are also *unnamed* lists)
if (rlang::is_named(raw_qstnr_branch)) {
map %<>%
purrr::list_modify(!!!raw_qstnr_branch) %>%
purrr::keep_at(at = qstnr_item_keys$key)
}
result <- NULL
if ("variable_name" %in% names(raw_qstnr_branch)) {
result <- assemble_qstnr_item_tibble(ballot_date = ballot_date,
canton = canton,
item_map = map,
verbose = verbose)
} else if (purrr::pluck_depth(raw_qstnr_branch) > 2L) {
result <- purrr::map2_dfr(.x = raw_qstnr_branch,
.y = names(raw_qstnr_branch) %||% seq_along(raw_qstnr_branch),
.f = ~ assemble_qstnr_tibble(ballot_date = ballot_date,
canton = canton,
raw_qstnr_branch = .x,
qstnr_lvl = paste(qstnr_lvl, .y,
sep = "."),
heritable_map = map,
verbose = verbose))
}
result
}
assemble_qstnr_item_tibble <- function(ballot_date,
canton,
item_map,
verbose) {
# iterate over `lvl`...
resolve_qstnr_val(x = item_map$lvl,
ballot_date = ballot_date,
canton = canton,
key = "lvl",
lvl = "",
i = NA_integer_,
j = NA_integer_) |>
purrr::map(
.f = function(lvl) {
# ...`i`...
resolve_qstnr_val(x = item_map$i,
ballot_date = ballot_date,
canton = canton,
key = "i",
lvl = lvl,
i = NA_integer_,
j = NA_integer_) |>
purrr::map(
lvl = lvl,
.f = function(i,
lvl) {
# ...and `j`
resolve_qstnr_val(x = item_map$j,
ballot_date = ballot_date,
canton = canton,
key = "j",
lvl = lvl,
i = i,
j = NA_integer_) |>
purrr::map(
i = i,
lvl = lvl,
.f = function(j,
i,
lvl) {
# respect keys `include` and `ballot_types`
is_incl <- resolve_qstnr_val(x = item_map$include,
ballot_date = ballot_date,
canton = canton,
key = "include",
lvl = lvl,
i = i,
j = j)
has_ballot_type <-
resolve_qstnr_val(x = item_map$ballot_types,
ballot_date = ballot_date,
canton = canton,
key = "ballot_types",
lvl = lvl,
i = i,
j = j) |>
intersect(ballot_types(ballot_date = ballot_date,
canton = canton)) |>
rlang::is_empty() |>
magrittr::not()
result <- NULL
if (is_incl && has_ballot_type) {
if (verbose) cli::cli_h3("ITEM: {.var {item_map$variable_name}}")
# resolve all keys in item map
result <-
names(item_map) |>
setdiff(c("lvl",
"i",
"j",
"ballot_types",
"include")) %>%
magrittr::set_names(x = .,
value = .) |>
purrr::map(~ {
if (verbose) cli::cli_progress_step("KEY: {.field {.x}}")
# pre-resolve `question` for dependent `question_full` resolution
if (.x == "question_full") {
question <- resolve_qstnr_val(x = item_map[["question"]],
ballot_date = ballot_date,
canton = canton,
key = "question",
lvl = lvl,
i = i,
j = j)
} else {
question <- NA_character_
}
resolve_qstnr_val(x = item_map[[.x]],
ballot_date = ballot_date,
canton = canton,
key = .x,
lvl = lvl,
i = i,
j = j,
question = question) |>
pal::when(
# replace empty scalars with NA
length(.) == 0L && .x %in% qstnr_item_keys$key[qstnr_item_keys$is_scalar] ~
.[NA],
# wrap vectors in list
.x %in% qstnr_item_keys$key[!qstnr_item_keys$is_scalar] ~
list(.),
~ .
)
}) |>
# add iterators
c(lvl = lvl,
i = i,
j = j)
# handle special cases
## 1: fill empty non-iterator multi-value keys with NA(s) if all other non-empty multi-value keys have the same length
lengths_multi_val_keys <-
qstnr_item_keys_multival %>%
magrittr::set_names(., .) |>
purrr::map_int(\(x) length(result[[x]][[1L]]))
positive_lengths_multi_val_keys <-
lengths_multi_val_keys %>%
magrittr::extract(. > 0L)
if (any(lengths_multi_val_keys == 0L) && length(unique(positive_lengths_multi_val_keys)) == 1L) {
for (k in (lengths_multi_val_keys %>%
magrittr::extract(. == 0L) |>
names())) {
result[[k]] <- list(rep(result[[k]][[1L]][NA],
times = length(result[[names(positive_lengths_multi_val_keys)[1L]]][[1L]])))
}
}
## 2: if no `question_common` is defined, fall back on
## a) `question_full.default`
## b) `question.default`
## c) `question_full`
## if either exists and actually differs from `question`
if (is.null(result$question_common)) {
question_common_fallback <-
item_map |>
pal::when("default" %in% names(.$question_full) ~
resolve_qstnr_val(x = item_map$question_full$default,
ballot_date = ballot_date,
canton = canton,
key = "question_full",
lvl = lvl,
i = i,
j = j),
"default" %in% names(.$question) ~
resolve_qstnr_val(x = item_map$question$default,
ballot_date = ballot_date,
canton = canton,
key = "question",
lvl = lvl,
i = i,
j = j),
~ result$question_full)
if (isTRUE(question_common_fallback != result$question)) {
result$question_common <- question_common_fallback
}
}
## 3: if no `variable_label_common` is defined, fall back on `variable_label.default` if it exists and actually differs from
## variable_label`
if (is.null(result$variable_label_common) && "default" %in% names(item_map$variable_label)) {
default_variable_label <- resolve_qstnr_val(x = item_map$variable_label$default,
ballot_date = ballot_date,
canton = canton,
key = "variable_label",
lvl = lvl,
i = i,
j = j)
if (isTRUE(default_variable_label != result$variable_label)) {
result$variable_label_common <- default_variable_label
}
}
## 4: add `who`-constraint to `variable_label` and `variable_label_common`
### get English `who` value
who_en <-
raw_qstnr$who |>
purrr::detect(\(x) result$who == cli::pluralize(x$value$de,
.null = NA_character_,
.trim = FALSE)) |>
purrr::chuck("value", "en") |>
cli::pluralize(.null = NA_character_,
.trim = FALSE)
### add who-constraints
if (!is.null(result$variable_label_common)
&& !is.na(result$variable_label_common)
&& !has_who_constraint(result$variable_label_common)) {
# ensure `who` doesn't vary over time
if (length(item_map$who) > 1L) {
cli::cli_abort(paste0("{.field who} of variable {.var {result$variable_name}} has changed over time. Thus an explicit {.field who}-",
"constraint has to be specified at the end of {.field variable_label_common} in the raw ",
"{.file questionnaire.toml}."),
.internal = TRUE)
}
result$variable_label_common %<>% add_who_constraint(who = who_en)
}
result$variable_label %<>% add_who_constraint(who = who_en)
}
# convert result to tibble
tibble::as_tibble(result)
}) |>
purrr::list_rbind()
}) |>
purrr::list_rbind()
}) |>
purrr::list_rbind()
}
#' Expand questionnaire tibble to long format
#'
#' Expands a [questionnaire tibble][gen_qstnr_tibble] to [long format](https://en.wikipedia.org/wiki/Wide_and_narrow_data).
#'
#' @param qstnr_tibble Questionnaire tibble as returned by [gen_qstnr_tibble()].
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_gen
#' @keywords internal
expand_qstnr_tibble <- function(qstnr_tibble) {
# run integrity checks...
validate_qstnr_tibble(qstnr_tibble) |>
# ...expand questionnaire data to long format...
tidyr::unnest(cols = any_of(qstnr_item_keys_multival))
}
clean_qstnr_tibble <- function(qstnr_tibble) {
qstnr_tibble |>
# remove (single) placeholders
dplyr::mutate(dplyr::across(any_of(qstnr_item_keys_multival) & where(\(x) is.character(x[[1L]])),
\(col) purrr::map(col,
\(x) {
if (length(x) == 1L && isTRUE(stringr::str_detect(x, "^_.+_$"))) {
character()
} else {
x
}
}))) |>
# strip MD
dplyr::mutate(dplyr::across(where(is.character),
pal::strip_md),
dplyr::across(where(is.list) & where(\(x) is.character(x[[1L]])),
\(x) purrr::map(x,
pal::strip_md)))
}
validate_qstnr_tibble <- function(qstnr_tibble) {
# integrity check 1: ensure there are no duplicated topics, variable names and variable labels
c("topic",
"variable_name",
"variable_label") |>
purrr::walk(.f = function(var) {
is_dup <- duplicated(qstnr_tibble[[var]])
if (any(is_dup)) {
dup_indices <- which(is_dup)
for (i in dup_indices) {
dup_var <- qstnr_tibble[[var]][i]
cli::cli_alert_warning(paste0("{.var {var}} {.val {dup_var}} is included more than once in the questionnaire."))
}
}
})
# integrity check 2: ensure all multi-value columns have the same length or alternatively are empty, and if not, tell which ones don't
multi_val_var_lengths <-
qstnr_tibble |>
dplyr::mutate(dplyr::across(where(is.list),
lengths),
.keep = "none") |>
dplyr::rename_with(\(x) paste0("length_", x)) |>
dplyr::mutate(matches_length = length_variable_values == 0L | length_value_labels == 0L | length_variable_values == length_value_labels) |>
dplyr::mutate(matches_length =
matches_length & (length_response_options == 0L | length_value_labels == 0L | length_response_options == length_value_labels),
matches_length =
matches_length & (length_response_options == 0L | length_variable_values == 0L | length_response_options == length_variable_values))
i_violated <- which(!multi_val_var_lengths$matches_length)
if (length(i_violated)) {
multi_val_var_names <-
qstnr_tibble |>
dplyr::select(where(is.list)) |>
colnames()
# print affected variable names first since long error msg gets truncated
cli::cli({
cli::cli_alert_danger("Affected variable names:")
cli::cli_ul(items = qstnr_tibble$variable_name[i_violated])
})
bullets <-
qstnr_tibble$variable_name[i_violated] |>
purrr::map_chr(\(x) glue::glue("{{.var {x}}}")) |>
rlang::set_names("*")
cli::cli_abort(c("The number of {.var {multi_val_var_names}} differs for the following variable names:",
bullets),
.internal = TRUE)
}
invisible(qstnr_tibble)
}
has_who_constraint <- function(x) {
isTRUE(stringr::str_detect(string = x,
pattern = "(\\(|; )(\\d{4}-\\d{2}-\\d{2} )?only [^\\)]+\\)$"))
}
add_who_constraint <- function(x,
who) {
if (who != "all") {
result <- who %>% pal::when(endsWith(x, ")") ~ stringr::str_replace(string = x,
pattern = "\\)$",
replacement = paste0("; only *", ., "*)")),
~ paste0(x, " (only *", ., "*)"))
} else {
result <- x
}
result
}
#' Generate Markdown questionnaire
#'
#' @inheritParams expand_qstnr_tibble
#' @param incl_title Whether or not to generate an `<h1>` questionnaire title at the beginning of the document. If the result is intended to be fed to Pandoc,
#' it's recommended to set this to `FALSE` and provide the title via [Pandoc's `--metadata` option](https://pandoc.org/MANUAL.html#option--metadata) instead.
#'
#' @return A character vector.
#' @family qstnr_gen
#' @keywords internal
gen_qstnr_md <- function(qstnr_tibble,
incl_title = FALSE) {
# ensure we have a single ballot date and canton
ballot_date <-
qstnr_tibble |>
dplyr::pull("ballot_date") |>
unique() |>
as_ballot_date()
canton <-
qstnr_tibble |>
dplyr::pull("canton") |>
unique() |>
rlang::arg_match0(values = all_cantons,
arg_nm = "unique(qstnr_tibble$canton)")
pal::cli_progress_step_quick(msg = "Generating {.val {canton}} @ {.val {ballot_date}} Markdown questionnaire")
block_lines <-
qstnr_tibble |>
# add block title and across-block item enumerator base/group
dplyr::mutate(enumerator_base =
block |>
purrr::map_int(\(x) raw_qstnr |> purrr::pluck(x, "prefix",
.default = 0L))) |>
# add across-block item enumerator
dplyr::group_by(enumerator_base) |>
dplyr::group_modify(\(d, k) tibble::rowid_to_column(d,
var = "enumerator")) |>
dplyr::ungroup() |>
dplyr::mutate(enumerator = enumerator_base + enumerator) |>
dplyr::arrange(block, enumerator) |>
# iterate over every block and generate block header plus table
dplyr::group_by(block) |>
dplyr::group_map(~ {
block <- .y$block
block_nr <- block_name_to_nr(block)
block_title <- raw_qstnr |> purrr::chuck(block, "title")
block_intro <-
raw_qstnr |>
purrr::pluck(block, "intro") |>
raw_pick_right(key = "intro",
ballot_date = ballot_date,
canton = canton) |>
cli::pluralize(.trim = FALSE)
c(glue::glue("## Block {block_nr}: {block_title}",
.null = NA_character_),
"",
block_intro,
""[length(block_intro)],
qstnr_md_table_header,
qstnr_md_table_body(qstnr_tibble_block = .x,
block = block),
"",
"")
}) |>
purrr::list_c(ptype = character())
# add title, technical notes, introduction, footnotes and link references
title <- glue::glue("# FOKUS-{ stringr::str_to_sentence(canton) }-Fragebogen f\u00fcr den ",
ballot_title(ballot_date = ballot_date,
canton = canton),
"\n",
.trim = FALSE)
technical_notes <-
raw_qstnr$who |>
# assemble who lines
purrr::map_depth(.depth = 1L,
.f = function(who_map) {
lvl <- resolve_qstnr_val(x = who_map$lvl %||% "",
ballot_date = ballot_date,
canton = canton,
key = "lvl",
lvl = "",
i = 1L,
j = 1L)
i <- resolve_qstnr_val(x = who_map$i %||% 1L,
ballot_date = ballot_date,
canton = canton,
key = "i",
lvl = "",
i = 1L,
j = 1L)
j <- resolve_qstnr_val(x = who_map$j %||% 1L,
ballot_date = ballot_date,
canton = canton,
key = "j",
lvl = "",
i = 1L,
j = 1L)
value <-
lvl |>
purrr::map(\(lvl) {
i |>
purrr::map(lvl = lvl,
\(lvl, i) {
j |>
purrr::map_chr(lvl = lvl,
i = i,
.f = \(lvl, i, j) {
glue::glue(who_map$value$de,
.null = NA_character_,
.trim = FALSE)
})
})
}) |>
purrr::flatten() |>
purrr::list_c(ptype = character())
description <-
lvl |>
purrr::map(\(lvl) {
i |>
purrr::map(lvl = lvl,
\(lvl, i) {
j |>
purrr::map_chr(lvl = lvl,
i = i,
.f = \(lvl, i, j) {
# hack to support desc variation @ 2024-10-20
if ("de" %in% names(who_map$description)) {
result <- glue::glue(who_map$description$de,
.null = NA_character_,
.trim = FALSE)
} else {
result <-
who_map$description[[stringr::str_remove_all(ballot_date, "-")]] %||%
who_map$description$default |>
purrr::chuck("de") |>
glue::glue(.null = NA_character_,
.trim = FALSE)
}
result
})
})
}) |>
purrr::flatten() |>
purrr::list_c(ptype = character())
# reduce to who's that actually occur in data
ix_keep <- which(value %in% qstnr_tibble$who)
value %<>% magrittr::extract(ix_keep)
description %<>% magrittr::extract(ix_keep)
glue::glue("- { md_emphasize(value) }: { description }")
}) |>
purrr::list_c(ptype = character()) %>%
c("## Technische Vorbemerkungen",
"",
"### `Wer`",
"",
"Die Spalte `Wer` dient dem Fragebogen-Routing. Sie kennt folgende Werte:",
"",
.,
"",
md_snippets$qstnr_technical_notes_multiple_responses,
md_snippets$qstnr_technical_notes_free_text_fields)
footnotes <-
raw_qstnr$footnote |>
# reduce to footnotes that actually occur in table body
purrr::keep(~ any(stringr::str_detect(block_lines, glue::glue("\\[\\^{.x$id}\\]",
.null = NA_character_)))) |>
purrr::map(~ c(glue::glue("[^{.x$id}]: ", glue::glue(.x$text,
.null = NA_character_,
.trim = FALSE),
.null = NA_character_,
.trim = FALSE),
"")) |>
purrr::list_c(ptype = character())
link_refs <-
raw_qstnr$link |>
# reduce to link references that actually occur in table body
purrr::keep(~ any(stringr::str_detect(block_lines, glue::glue("\\[[^]]+\\]\\[{.x$id}\\]",
.null = NA_character_)))) |>
purrr::map(~ c(glue::glue("[{.x$id}]: {.x$url}",
.null = NA_character_),
"")) |>
purrr::list_c(ptype = character())
c(title[incl_title],
technical_notes,
paste0(glue::glue(md_snippets$qstnr_introduction,
.envir = rlang::current_env(),
.na = NULL,
.null = NA_character_,
.trim = TRUE),
"\n"),
block_lines,
footnotes,
link_refs)
}
qstnr_md_table_body <- function(qstnr_tibble_block,
block) {
qstnr_tibble_block |>
# replace logicals by German ja/nein
dplyr::mutate(dplyr::across(where(is.logical),
\(x) ifelse(x,
"ja",
"nein"))) |>
purrr::pmap_chr(function(ballot_date,
canton,
enumerator,
variable_name,
topic,
who,
question_intro_i,
question_intro_j,
question,
allow_multiple_answers,
variable_label,
response_options,
variable_values,
value_labels,
randomize_response_options,
is_mandatory,
i,
j,
...) {
paste(enumerator,
tidyr::replace_na(topic,
"-"),
who,
question |> pal::when(is.na(.) ~ "-",
~ c(c(question_intro_i[isTRUE(i == 1L && j %in% c(1L, NA_integer_))],
question_intro_j[isTRUE(j == 1L)]) %>%
magrittr::extract(!is.na(.)) |>
pal::as_str(),
.) %>%
magrittr::extract(!is.na(.)) |>
pal::as_str(sep = " <br><br>")),
allow_multiple_answers,
pal::wrap_chr(variable_name,
wrap = "`"),
shorten_var_names(var_names = variable_name,
max_n_char = ifelse(block %in% c("x_polling_agency", "y_generated", "z_generated")
|| stringr::str_detect(string = variable_name,
pattern = paste0("^", pal::fuse_regex(c("agreement_contra_argument_",
"information_source_",
"reason_non_participation_",
"political_occasions_")))),
32L,
30L)) |>
pal::wrap_chr("`"),
variable_label,
response_options |>
pal::when(is_skill_question_var(variable_name) ~
format_md_multival_col(x = .,
collapse_break = FALSE) |>
md_emphasize(which = skill_question_answer_nr(ballot_date = ballot_date,
lvl = var_lvls(var_names = variable_name),
canton = canton,
proposal_nr =
var_proposal_nr(variable_name) |>
pal::when(is.na(.) ~ NULL,
~ .),
skill_question_nr = var_skill_question_nr(variable_name))) |>
collapse_break(),
~ format_md_multival_col(.)),
format_md_multival_col(variable_values),
format_md_multival_col(value_labels),
randomize_response_options,
is_mandatory,
sep = " | ")
})
}
format_md_multival_col <- function(x,
collapse_break = TRUE) {
result <- x
if (all(is.na(x))) {
result <- "-"
} else if (length(x) > 1L
&& all(stringr::str_detect(string = x,
pattern = "^_.+_$",
negate = TRUE),
na.rm = TRUE)) {
result <-
x |>
pal::wrap_chr(wrap = "`") |>
pal::when(collapse_break ~ collapse_break(.),
~ .)
}
result
}
block_name_to_nr <- function(x) {
x |>
stringr::str_extract("^.[^_]?(_\\d)?") |>
stringr::str_replace("_(\\d)", "-\\1") |>
stringr::str_remove("^0") |>
stringr::str_to_upper()
}
#' Extract questionnaire item field value
#'
#' Extracts a single questionnaire item field value for every first- for every second-level iterator from the [raw FOKUS questionnaire data][raw_qstnr] based on
#' the specified variable name and branch path.
#'
#' When used in questionnaire item field values via [string interpolation][glue::glue], be careful to not create infinite loops via circular references.
#'
#' @inheritParams ballot_title
#' @param var_name Variable name, without resolved string interpolation, i.e. 1:1 as stated in the raw FOKUS questionnaire data. A character scalar.
#' @param branch_path Sequence of questionnaire table levels that lead to the `item` leaf node where `var_name` is defined. A character vector.
#' @param key Questionnaire item key. One of
#' `r pal::as_md_val_list(qstnr_item_keys$key)`
#' @param lvl Political-level loop iterator that can be referred to in field value via [string interpolation][glue::glue]. A character vector.
#' @param i Second-level loop iterator that can be referred to in field value via [string interpolation][glue::glue]. An integerish vector.
#' @param j Third-level loop iterator that can be referred to in field value via [string interpolation][glue::glue]. An integerish vector.
#'
#' @return A vector of the resolved item field values. Type and length of resolved values depend on `key`.
#' @family qstnr_internal
#' @keywords internal
#'
#' @examples
#' fokus:::qstnr_item_val(ballot_date = "2018-09-23",
#' canton = "aargau",
#' branch_path = c("03_proposal_specific", "004_participants"),
#' var_name = "appeal_federal_proposals",
#' key = "include")
#'
#' fokus:::qstnr_item_val(
#' ballot_date = "2019-10-20",
#' canton = "aargau",
#' branch_path = c("02_political_start", "002_non_participation",
#' "003_election", "z01_hypothetical"),
#' var_name = "hypothetical_voting_decision_federal_majoritarian_election_{i}_seat_{j}",
#' key = "topic",
#' i = 1:2,
#' j = 1:3
#' )
qstnr_item_val <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
branch_path,
var_name,
key = qstnr_item_keys$key,
lvl = "?",
i = NA_integer_,
j = NA_integer_) {
ballot_date %<>% as_ballot_date_chr()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_character(branch_path,
any.missing = FALSE,
min.len = 1L)
if ("item" %in% branch_path) {
cli::cli_abort("{.arg branch_path} must be specified {.emph without} the {.val item} leaf node.")
}
checkmate::assert_string(var_name)
key <- rlang::arg_match(key)
item_map <-
raw_qstnr |>
purrr::chuck(!!!branch_path, "item") |>
purrr::keep(.p = \(x) isTRUE(x$variable_name == var_name)) |>
purrr::list_flatten()
if (!rlang::has_name(x = item_map, name = "variable_name")) {
cli::cli_abort(paste0("There is no item with {.arg variable_name} {.val {var_name}} defined under the questionnaire branch path {.field ",
cli::ansi_collapse(x = branch_path,
x = branch_path,
sep = " -> ",
sep2 = " -> ",
last = " -> "),
"}."))
}
# traverse questionnaire branch path and complement heritable map
parent_map <- init_heritable_map(block = branch_path[1L])
for (branch_depth in purrr::accumulate(branch_path, c)) {
parent_map <-
raw_qstnr |>
purrr::chuck(!!!branch_depth) %>%
purrr::list_modify(.x = parent_map,
!!!.) |>
purrr::keep_at(at = qstnr_item_keys$key)
}
# evaluate requested item value
raw_val <-
parent_map |>
purrr::list_modify(!!!item_map) |>
purrr::chuck(key)
lvl |>
purrr::map(function(lvl) {
i |>
purrr::map(lvl = lvl,
.f = function(i,
lvl) {
j |>
purrr::map(i = i,
lvl = lvl,
.f = function(j,
i,
lvl) {
resolve_qstnr_val(x = raw_val,
ballot_date = ballot_date,
canton = canton,
key = key,
lvl = lvl,
i = i,
j = j)
})
})
}) |>
unlist()
}
#' Get political parties
#'
#' Returns a tibble of ballot-date-specific political party metadata defined in the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_internal
#' @keywords internal
qstnr_parties <- function(ballot_date = pal::pkg_config_val("ballot_date")) {
ballot_date <- as_ballot_date(ballot_date)
raw_qstnr |>
purrr::chuck("party") |>
purrr::map(~ {
tibble::tibble_row(code = .x$code,
de.long = .x$de$long,
de.short = .x$de$short,
en.short = .x$en$short %||% .x$de$short,
date_begin = .x$date_begin %||% clock::date_build(year = 1970L,
month = 1L,
day = 1L),
date_end = .x$date_end %||% as.Date(Inf))
}) |>
purrr::list_rbind() |>
dplyr::filter(date_begin <= ballot_date & date_end >= ballot_date)
}
#' Get response option codes
#'
#' Extracts response option codes of the specified type(s) from the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' Note that only codes of recurring response options are returned which are defined under the `response_options` top-level key in the file
#' `data-raw/questionnaire/questionnaire.toml`.
#'
#' @param types Response option types. One or more of
#' `r pal::as_md_val_list(all_response_option_types)`
#'
#' @return An integer vector.
#' @family qstnr_internal
#' @keywords internal
#'
#' @examples
#' fokus:::qstnr_response_option_codes(types = "abstain")
#'
#' fokus:::qstnr_response_option_codes(types = c("dunno",
#' "custom",
#' "abstain"))
qstnr_response_option_codes <- function(types = all_response_option_types) {
types <- rlang::arg_match(arg = types,
multiple = TRUE)
types |> purrr::map_int(\(x) raw_qstnr |> purrr::chuck("response_options", x, "code"))
}
#' Determine questionnaire data's value label column
#'
#' Determines the [questionnaire data][qstnrs] column that holds variable value labels, returned as a [symbol][as.symbol].
#'
#' The questionnaire data column that holds variable value labels is language-dependent. While the column
#' `r qstnr_lbl_col_sym("de") |> as.character() |> pal::wrap_chr("\x60")` holds the German value labels, their English counterpars are found in the column
#' `r qstnr_lbl_col_sym("en") |> as.character() |> pal::wrap_chr("\x60")`. `qstnr_lbl_col_sym()` is intended to ease language-agnostic questionnaire data
#' programming.
#'
#' @inheritParams lang_to_locale
#'
#' @return `r pkgsnip::return_lbl("sym")`
#' @family qstnr_predicate
#' @keywords internal
#'
#' @examples
#' fokus:::qstnr_lbl_col_sym(lang = "de")
#'
#' fokus:::qstnr_lbl_col_sym(lang = "en")
qstnr_lbl_col_sym <- function(lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
as.symbol(ifelse(lang == "de",
"response_options",
"value_labels"))
}
#' Print structure of the private FOKUS repository
#'
#' Returns a textual representation of the structure of the private FOKUS repository, formatted as a Markdown [fenced code
#' block](https://pandoc.org/MANUAL.html#extension-fenced_code_blocks).
#'
#' @includeRmd data-raw/snippets/fokus_private_description.Rmd
#'
#' @return A character scalar.
#' @family private
#' @keywords internal
print_private_repo_structure <- function() {
pal::cat_lines("``` default")
fokus_private_structure |> pal::flatten_path_tree() |> pal::draw_path_tree()
pal::cat_lines("```",
"",
"The following placeholders are used in the schema above:",
"",
"- `...` for further files and/or folders",
"- `*` for a variable character sequence",
"- `#` for a count starting with `1`",
"- `{canton}` for the name of the FOKUS-covered canton (in lower case), e.g. `aargau`",
"- `{ballot_date}` for the FOKUS-covered ballot date (in the format `YYYY-MM-DD`), e.g. `2018-09-23`",
paste0("- `{date_delivery_statistical_office}` for the delivery date of the voting register data provided by the cantonal statistical ",
"office (in the format `YYYY-MM-DD`), e.g. `2019-09-11`"))
}
private_file_hash <- function(path,
auth_token = pal::pkg_config_val("token_repo_private")) {
req_private_file(path = path,
method = "HEAD",
auth_token = auth_token) |>
httr2::req_perform() |>
httr2::resp_header(header = "X-Gitlab-Content-Sha256")
}
req_private_file <- function(path,
method,
max_tries = 3L,
auth_token = pal::pkg_config_val("token_repo_private")) {
checkmate::assert_string(auth_token)
httr2::request(base_url = glue::glue("https://gitlab.com/api/v4/projects/{repo_private_proj_id}/repository/files/", utils::URLencode(path,
reserved = TRUE))) |>
httr2::req_url_query(ref = repo_private_default_branch) |>
httr2::req_method(method = method) |>
httr2::req_headers(`PRIVATE-TOKEN` = auth_token,
.redact = "PRIVATE-TOKEN") |>
httr2::req_retry(max_tries = max_tries) |>
httr2::req_error(body = \(resp) {
if (httr2::resp_has_body(resp)) {
return(httr2::resp_body_json(resp)$message)
}
NULL
})
}
#' Assemble private FOKUS repository URL
#'
#' @param ... Optional path components added to the base URL.
#' @param .branch Git branch name to use in URL. A character scalar. Only relevant if `...` is non-empty.
#'
#' @return A character scalar.
#' @family private
#' @keywords internal
#'
#' @examples
#' fokus:::url_repo_private("generated")
url_repo_private <- function(...,
.branch = repo_private_default_branch) {
result <- "https://gitlab.com/zdaarau/private/fokus_private/"
if (...length() > 0L) {
checkmate::assert_string(.branch)
result <- paste0(result, fs::path("-/tree", .branch, ..., "?ref_type=heads"))
}
result
}
assert_countish <- function(x,
positive = TRUE,
null_ok = FALSE) {
if (null_ok && is.null(x)) {
x
} else {
checkmate::assert_count(as.integer(x),
positive = positive)
}
}
assert_integerish <- function(x,
lower = -Inf,
upper = Inf,
any_missing = FALSE,
all_missing = FALSE,
null_ok = FALSE) {
if (null_ok && is.null(x)) {
x
} else {
checkmate::assert_integerish(as.integer(x),
lower = lower,
upper = upper,
any.missing = any_missing,
all.missing = all_missing,
coerce = TRUE)
}
}
assert_var_names_present <- function(data,
var_names) {
checkmate::assert_data_frame(data)
var_names |> purrr::walk(\(var_name) {
if (!(var_name %in% colnames(data))) {
cli::cli_abort("{.arg data} must contain a column {.var {var_name}}")
}
})
invisible(data)
}
assert_var_names_valid <- function(var_names,
as_scalar = FALSE,
null_ok = FALSE) {
checkmate::assert_flag(as_scalar)
if (as_scalar) {
checkmate::assert_choice(var_names,
choices = unique(fokus::qstnrs$variable_name),
null.ok = null_ok)
} else {
purrr::map_chr(var_names,
checkmate::assert_choice,
choices = unique(fokus::qstnrs$variable_name),
null.ok = null_ok)
}
}
#' Abbreviations used in the **fokus** package
#'
#' Returns a [tibble][tibble::tbl_df] listing an opinionated set of abbreviations used in the \R code and documentation of the **fokus** package.
#'
#' @inheritParams pkgsnip::abbrs
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @keywords internal
abbrs <- function(unnest = FALSE) {
rlang::check_installed("pkgsnip",
reason = pal::reason_pkg_required())
tibble::tibble(full_expressions = list("google"),
abbreviation = "g") |>
dplyr::bind_rows(pkgsnip::abbrs()) |>
dplyr::arrange(purrr::map_chr(full_expressions,
\(x) stringr::str_to_lower(dplyr::first(x)))) |>
pal::when(unnest ~ tidyr::unnest_longer(data = .,
col = full_expressions,
values_to = "full_expression"),
~ .)
}
as_ballot_date <- function(ballot_date,
error_call = rlang::caller_env()) {
result <- ballot_date[1L]
if (lubridate::is.Date(result)) {
if (!(result %in% all_ballot_dates)) {
cli::cli_abort("{.arg ballot_date} must be one of {.val all_ballot_dates}, not {.val {ballot_date}}.")
}
} else {
result %<>%
as_ballot_date_chr(error_call = error_call) %>%
clock::date_parse()
}
result
}
as_ballot_date_chr <- function(ballot_date,
error_call = rlang::caller_env()) {
checkmate::assert_atomic(ballot_date,
len = 1L)
rlang::arg_match0(arg = as.character(ballot_date),
values = as.character(all_ballot_dates),
arg_nm = "ballot_date",
error_call = error_call)
}
as_ballot_dates <- function(ballot_dates,
error_call = rlang::caller_env()) {
ballot_dates |>
purrr::map(\(x) as_ballot_date(ballot_date = x,
error_call = error_call)) |>
purrr::list_c(ptype = as.Date(NULL))
}
as_flat_list <- function(x) {
result <- x
depth <- purrr::pluck_depth(result)
# unlist until only a single list level remains
while (depth > 2L) {
result %<>% unlist(recursive = FALSE)
depth <- purrr::pluck_depth(result)
}
# wrap in list if necessary
if (depth < 2L && !is.list(x)) {
result <- list(x)
}
result
}
as_sym_part_regex <- function(x) {
paste0(sym_part_regex_start, x, sym_part_regex_end)
}
collapse_break <- function(s) {
paste0(s, collapse = "<br>")
}
#' Convert language code to country-specific locale ID
#'
#' Converts a language code as used in many of this package's functions to a country-specific locale identifier.
#'
#' @param lang Language. One of `r all_langs |> pal::as_md_vals() |> pal::enum_str(sep2 = " or ")`.
#'
#' @return A character scalar.
#' @keywords internal
#'
#' @examples
#' fokus:::lang_to_locale("de")
#' fokus:::lang_to_locale("en")
lang_to_locale <- function(lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
switch(lang,
de = "de-CH",
en = "en-US")
}
var_predicate <- function(predicate,
var_name,
ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
predicate <- rlang::arg_match(predicate,
values = setdiff(colnames(fokus::qstnrs),
c("ballot_date",
"canton",
"variable_name")))
assert_var_names_valid(var_names = var_name,
as_scalar = TRUE)
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
fokus::qstnrs |>
dplyr::filter(canton == !!canton
& ballot_date == !!ballot_date
& variable_name == !!var_name) %$%
eval(as.symbol(predicate)) |>
unique()
}
wrap_backtick <- function(x) {
dplyr::if_else(x == "-" | stringr::str_detect(string = x,
pattern = "^(_.*_|\\*.*\\*)$"),
as.character(x),
paste0("`", x, "`"))
}
this_pkg <- utils::packageName()
cli_theme <-
cli::builtin_theme() |>
purrr::list_modify(h2 = list("margin-bottom" = 0.0),
h3 = list("margin-top" = 0.0))
global_max_cache_age <- "30 days"
#' Questionnaire item keys
#'
#' A tibble of item keys supported in the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @docType data
#' @family metadata
#' @keywords internal
#'
#' @name qstnr_item_keys
#'
#' @examples
#' fokus:::qstnr_item_keys
NULL
qstnr_md_table_header <-
tibble::tribble(
~name, ~width, ~alignment,
"\\#", 2L, "left",
"Thema", 5L, "left",
"Wer", 3L, "left",
"Frage", 15L, "left",
"Mehrfachnennungen", 3L, "left",
"Variablenname", 5L, "left",
"Variablenname (gek\u00fcrzt auf 32 Zeichen)", 5L, "left",
"Variablenlabel", 15L, "left",
"Antwortoptionen", 5L, "left",
"Variablenauspr\u00e4gungen", 5L, "left",
"Auspr\u00e4gungslabels", 5L, "left",
"Antwortoptionen in Zufallsreihenfolge", 3L, "left",
"Antwort obligatorisch", 3L, "left"
) |>
dplyr::mutate(sep = purrr::map2_chr(.x = width,
.y = alignment,
.f = ~
rep(x = "-",
times = .x) |>
paste0(collapse = "") |>
pal::when(.y == "left" ~ stringr::str_replace(string = .,
pattern = "^.",
replacement = ":"),
.y == "right" ~ stringr::str_replace(string = .,
pattern = ".$",
replacement = ":"),
.y == "center" ~ stringr::str_replace_all(string = .,
pattern = "(^.|.$)",
replacement = ":"),
~ .))) %$%
c(paste0(name, collapse = " | "),
paste0(sep, collapse = " | "))
repo_private_proj_id <- 21325371L
sym_part_regex_start <- "(^|_|\\b)"
sym_part_regex_end <- "(\\b|_|$)"
unicode_checkmark <- "\u2705"
unicode_crossmark <- "\u274C"
unicode_ellipsis <- "\u2026"
url_qstnr <- list(aargau = "https://qstnr.fokus.ag")
url_survey_host <- list(aargau = "https://umfrage.fokus.ag")
url_parameter_survey <- list(aargau = "pw")
#' FOKUS-covered ballot dates
#'
#' A vector of ballot dates covered by FOKUS surveys up until `r max(all_ballot_dates)`.
#'
#' @format `r pkgsnip::return_lbl("dates")`
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_ballot_dates
"all_ballot_dates"
#' FOKUS-covered cantons
#'
#' A vector of all [cantons][cantons] covered by FOKUS surveys.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_cantons
"all_cantons"
#' Ballot types
#'
#' A vector of all possible [ballot types][ballot_types].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_ballot_types
"all_ballot_types"
#' Political levels
#'
#' A vector of all possible [political levels][lvls].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_lvls
"all_lvls"
#' Election procedures
#'
#' A vector of all possible [election procedures][prcds].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_prcds
"all_prcds"
#' Referendum proposal types
#'
#' A vector of all possible [referendum proposal types][proposal_type].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_proposal_types
"all_proposal_types"
#' Standardized referendum proposal question groups
#'
#' A vector of all possible referendum [proposal question groups][proposal_qstn_groups].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_qstn_groups
"all_qstn_groups"
#' Referendum proposal argument sides
#'
#' A vector of all possible referendum proposal argument sides.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_argument_sides
"all_argument_sides"
#' Referendum proposal main motive types
#'
#' A vector of all possible referendum proposal main motive types.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_main_motive_types
"all_main_motive_types"
#' Election seat types
#'
#' A vector of all possible election seat types.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_election_seat_types
"all_election_seat_types"
#' Response option types
#'
#' A vector of all possible response option types defined in the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_response_option_types
"all_response_option_types"
#' Postal dispatch types
#'
#' A vector of all possible postal dispatch types.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_postal_dispatch_types
"all_postal_dispatch_types"
#' Postal dispatch ways
#'
#' A vector of all possible [postal dispatch ways][postal_dispatch_way].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_postal_dispatch_ways
"all_postal_dispatch_ways"
#' Languages
#'
#' A vector of all possible survey metadata languages.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_langs
"all_langs"
#' Name types
#'
#' A vector of all possible name types for various entities.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_name_types
"all_name_types"
#' Get cantons covered by FOKUS survey
#'
#' Determines the cantons covered by the FOKUS survey at the specified ballot date.
#'
#' @param ballot_date FOKUS-covered ballot date. One of
#' `r pal::as_md_val_list(as.character(all_ballot_dates))`
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::cantons(ballot_date = "2018-09-23")
#'
#' # determine all cantons covered per ballot date
#' library(magrittr)
#'
#' fokus::all_ballot_dates %>%
#' magrittr::set_names(., .) |>
#' purrr::map_chr(fokus::cantons)
cantons <- function(ballot_date = pal::pkg_config_val("ballot_date")) {
ballot_date %<>% as_ballot_date_chr()
cantons_at[[ballot_date]]
}
#' Get ballot's political levels
#'
#' Determines the [political levels][all_lvls] covered by the FOKUS survey for the specified canton of the specified ballot type at the specified ballot date.
#'
#' @inheritParams cantons
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#' @param ballot_type Ballot type. One of `r all_ballot_types |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#' @param prcds Election procedure(s). One or more of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' Only relevant if `ballot_type = "election"`.
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::lvls(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::lvls(ballot_date = "2018-09-23",
#' canton = "aargau",
#' ballot_type = "election")
#'
#' fokus::lvls(ballot_date = "2019-10-20",
#' canton = "aargau",
#' ballot_type = "election")
#'
#' fokus::lvls(ballot_date = "2019-10-20",
#' canton = "aargau",
#' ballot_type = "election",
#' prcds = "proportional")
lvls <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
ballot_type = ballot_types(ballot_date = ballot_date,
canton = canton),
prcds = all_prcds) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
ballot_type <- rlang::arg_match(arg = ballot_type,
values = all_ballot_types)
prcds <- unique(rlang::arg_match(arg = prcds,
multiple = TRUE))
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if (ballot_type == "referendum") {
result <- c("cantonal"[length(raw$cantonal[[canton]]$proposal) > 0L],
"federal"[length(raw$federal$proposal) > 0L])
} else {
result <- c("cantonal"[any(purrr::map_lgl(prcds,
~ length(raw$cantonal[[canton]]$election[[.x]]) > 0L))],
"federal"[any(purrr::map_lgl(prcds,
~ length(raw$federal[[canton]]$election[[.x]]) > 0L))])
}
result
}
#' Get ballot types
#'
#' Determines the [types of the ballot][all_ballot_types] covered by the FOKUS survey for the specified canton on the specified political level(s) at the
#' specified ballot date.
#'
#' @inheritParams lvls
#' @param lvls Political level(s). One or more of `r all_lvls |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::ballot_types(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' # in case of no ballot types at lvl, an empty character vector is returned
#' fokus::ballot_types(ballot_date = "2020-10-18",
#' lvls = "federal",
#' canton = "aargau")
ballot_types <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date)) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- character()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if ("federal" %in% lvls) {
result <- c("referendum"[length(raw$federal$proposal) > 0L],
"election"[any(purrr::map_lgl(all_prcds,
~ length(raw$federal[[canton]]$election[[.x]]) > 0L))])
}
if ("cantonal" %in% lvls) {
result %<>% c("referendum"[length(raw$cantonal[[canton]]$proposal) > 0L],
"election"[any(purrr::map_lgl(all_prcds,
~ length(raw$cantonal[[canton]]$election[[.x]]) > 0L))])
}
unique(result)
}
#' Get ballot's election procedures
#'
#' Determines the [election procedures][all_prcds] covered by the FOKUS survey for the specified canton on the specified political level at the specified ballot
#' date.
#'
#' @inheritParams lvls
#' @param lvl Political level. One of `r all_lvls |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::prcds(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::prcds(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
#'
#' # in case of no elections, an empty character vector is returned
#' fokus::prcds(ballot_date = "2020-10-18",
#' lvl = "federal",
#' canton = "aargau")
prcds <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date)) {
if (length(lvl)) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- character()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if (isTRUE(lvl == "federal")) {
result <-
names(raw$federal[[canton]]$election) |>
intersect(all_prcds) |>
as.character()
} else if (isTRUE(lvl == "cantonal")) {
result <-
names(raw$cantonal[[canton]]$election) |>
intersect(all_prcds) |>
as.character()
}
result
}
#' Get ballot's referendum proposal numbers
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level.
#'
#' @inheritParams prcds
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvl = "cantonal"`.
#'
#' @return An integer vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::proposal_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::proposal_nrs(ballot_date = "2018-09-23",
#' lvl = "federal",
#' canton = "aargau")
#'
#' # in case of no referendum proposals, an empty integer vector is returned
#' fokus::proposal_nrs(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
if (length(lvl) > 0L) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
result <- integer()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if (isTRUE(lvl == "federal")) {
result <-
raw$federal$proposal |>
names() |>
as.integer()
} else if (isTRUE(lvl == "cantonal")) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <-
raw$cantonal[[canton]]$proposal |>
names() |>
as.integer()
}
result
}
#' Get ballot's election numbers
#'
#' Determines the election numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political level and of the
#' specified election procedure(s).
#'
#' @inheritParams prcds
#' @param prcd Election procedure. One of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#'
#' @return An integer vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::election_nrs(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau",
#' prcd = "majoritarian")
#'
#' # in case of no (matching) elections, an empty integer vector is returned
#' fokus::election_nrs(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "proportional")
election_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
prcd = prcds(ballot_date = ballot_date,
lvl = lvl,
canton = canton)) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- integer()
if (length(prcd) > 0L) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
prcd <- rlang::arg_match(arg = prcd,
values = all_prcds)
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
result <- as.integer(names(raw[[lvl]][[canton]]$election[[prcd]]))
}
result
}
#' Get ballot's election procedures
#'
#' Determines the election procedures covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political level.
#'
#' @inheritParams prcds
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::election_prcds(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
#'
#' # in case of no (matching) elections, an empty integer vector is returned
#' fokus::election_prcds(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
election_prcds <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date)) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- character()
if (length(lvl) > 0L) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
result <-
names(raw[[lvl]][[canton]]$election) |>
intersect(y = all_prcds)
}
result
}
#' Get referendum proposal question groups
#'
#' Determines the referendum proposal [question groups][all_qstn_groups] covered by the FOKUS survey for the specified canton on the specified political level
#' at the specified ballot date.
#'
#' @inheritParams proposal_nrs
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @return A character vector of question group identifiers.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::proposal_qstn_groups(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' fokus::proposal_qstn_groups(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 2)
proposal_qstn_groups <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = cantons(ballot_date),
proposal_nr = 1L) {
raw_qstnr_suppl_proposal_safe(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
names() |>
intersect(all_qstn_groups) %||%
character()
}
#' Get referendum proposal numbers with question group
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level for which at least one question of each of the specified standardized question groups has been asked.
#'
#' @inheritParams proposal_nrs
#' @param qstn_groups One or more of the standardized question groups `r pal::enum_fn_param_defaults(param = "qstn_groups", fn = qstn_groups_proposal_nrs)`.
#'
#' @return An integer vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::qstn_groups_proposal_nrs(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
qstn_groups_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = cantons(ballot_date),
qstn_groups = all_qstn_groups) {
raw_qstnr_suppl_proposal_safe(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::keep(\(x) all(qstn_groups %in% names(x))) |>
names() |>
as.integer()
}
#' Get survey channels
#'
#' Determines the channels the surevy was conducted over.
#'
#' @inheritParams lvls
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::survey_channels(ballot_date = "2023-06-18",
#' canton = "aargau")
survey_channels <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::chuck("channels")
}
#' Determine whether survey is based on representative sample
#'
#' Determines whether or not the survey was conducted among a representative sample of the electorate (i.e. drawn randomly).
#'
#' @inheritParams lvls
#'
#' @return A logical scalar.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::is_representative(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::is_representative(ballot_date = "2024-10-20",
#' canton = "aargau")
is_representative <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::chuck("is_representative")
}
#' Get number of referendum proposals
#'
#' Determines the number of referendum proposals covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level(s).
#'
#' The number of *federal* proposals is independent from the canton, i.e. the returned number of *federal* proposals at a specific ballot date is always the
#' same, thus `canton` is ignored if `!("cantonal" %in% lvls)`.
#'
#' @inheritParams ballot_types
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvls` includes `"cantonal"`.
#'
#' @return An integer vector of the same length as and named after `lvls`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::n_proposals(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::n_proposals(ballot_date = "2018-09-23",
#' lvls = "cantonal",
#' canton = "aargau")
#'
#' fokus::n_proposals(ballot_date = "2019-10-20")
n_proposals <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date)) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
result <- integer()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if ("cantonal" %in% lvls) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- c(cantonal = length(raw$cantonal[[canton]]$proposal))
}
if ("federal" %in% lvls) {
result %<>% c(federal = length(raw$federal$proposal))
}
result
}
#' Get number of elections
#'
#' Determines the number of elections covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) and
#' of the specified election procedure(s).
#'
#' @inheritParams ballot_types
#' @param prcds Election procedure(s). One or more of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' @return An integer vector of length `lvls` × `prcds`, named after `lvls.prcds`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::n_elections(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::n_elections(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::n_elections(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau",
#' prcds = "majoritarian")
n_elections <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
prcds = all_prcds) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
prcds <- unique(rlang::arg_match(arg = prcds,
multiple = TRUE))
result <- integer()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if ("federal" %in% lvls) {
result <-
prcds %>%
magrittr::set_names(., .) |>
purrr::map_int(\(x) length(raw$federal[[canton]]$election[[x]])) |>
list(federal = _) |>
unlist()
}
if ("cantonal" %in% lvls) {
result <-
prcds %>%
magrittr::set_names(., .) |>
purrr::map_int(\(x) length(raw$cantonal[[canton]]$election[[x]])) |>
list(cantonal = _) |>
unlist() |>
c(result)
}
result
}
#' Determine whether ballot includes a referendum
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) covered a referendum.
#'
#' @inheritParams n_proposals
#'
#' @return A logical vector of the same length as and named after `lvls`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_referendum(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_referendum(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau")
has_referendum <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date)) {
n_proposals(ballot_date = ballot_date,
lvls = lvls,
canton = canton) > 0L
}
#' Determine whether ballot includes an election
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) covered an election of
#' the specified election procedure(s).
#'
#' @inheritParams n_elections
#'
#' @return A logical vector of length `lvls` × `prcds`, named after `lvls.prcds`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_election(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::has_election(ballot_date = "2019-10-20",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::has_election(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau",
#' prcds = "proportional")
has_election <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
prcds = all_prcds) {
n_elections(ballot_date = ballot_date,
lvls = lvls,
canton = canton,
prcds = prcds) > 0L
}
#' Determine whether ballot includes type
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) covered the specified
#' [ballot types][ballot_types].
#'
#' @inheritParams lvls
#' @inheritParams n_elections
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvls` includes `"cantonal"` or `ballot_type = "election"`.
#'
#' @return A logical vector of the same length as `lvl` (× `prcds`), named after `lvls(.prcds).ballot_type`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_ballot_type(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_ballot_type(ballot_date = "2018-09-23",
#' canton = "aargau",
#' ballot_type = "election")
#'
#' fokus::has_ballot_type(ballot_date = "2019-10-20",
#' canton = "aargau",
#' ballot_type = "election",
#' prcds = "proportional")
has_ballot_type <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
ballot_type = ballot_types(ballot_date = ballot_date,
lvls = lvls,
canton = canton),
prcds = all_prcds) {
ballot_type <- rlang::arg_match(arg = ballot_type,
values = all_ballot_types)
if (isTRUE(ballot_type == "election")) {
result <-
has_election(ballot_date = ballot_date,
lvls = lvls,
canton = canton,
prcds = prcds) %>%
magrittr::set_names(paste(names(.), "election",
sep = "."))
} else if (isTRUE(ballot_type == "referendum")) {
result <-
has_referendum(ballot_date = ballot_date,
lvls = lvls,
canton = canton) %>%
magrittr::set_names(paste(names(.), "referendum",
sep = "."))
}
result
}
#' Determine whether ballot includes a political level
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date covered the specified political level.
#'
#' @inheritParams cantons
#' @param lvl Political level to test for. One of `r all_lvls |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvl = "cantonal"` or `ballot_types` includes `"election"`.
#' @param ballot_types Ballot type(s). One or more of `r pal::enum_fn_param_defaults(param = "ballot_types", fn = has_lvl)`
#' @param prcds Election procedure(s). One or more of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' Only relevant if `ballot_types` includes `"election"`.
#'
#' @return A logical vector of the same length as (`prcds` ×) `ballot_types`, named after `lvl(.prcds).ballot_types`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_lvl(ballot_date = "2018-09-23",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::has_lvl(ballot_date = "2018-09-23",
#' lvl = "federal",
#' canton = "aargau",
#' ballot_types = "election")
#'
#' fokus::has_lvl(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau",
#' ballot_types = "election")
has_lvl <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
ballot_types = all_ballot_types,
prcds = all_prcds) {
if (length(lvl)) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
ballot_types <- rlang::arg_match(arg = ballot_types,
multiple = TRUE)
result <- logical()
if ("election" %in% ballot_types) {
result <-
has_election(ballot_date = ballot_date,
lvls = lvl,
canton = canton,
prcds = prcds) %>%
magrittr::set_names(paste(names(.), "election",
sep = "."))
}
if ("referendum" %in% ballot_types) {
result <-
has_referendum(ballot_date = ballot_date,
lvls = lvl,
canton = canton) %>%
magrittr::set_names(paste(names(.), "referendum",
sep = ".")) |>
c(result)
}
result
}
#' Determine whether ballot includes referendum proposals
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political levels covered the specified
#' referendum proposal numbers.
#'
#' @inheritParams n_proposals
#' @param proposal_nrs Proposals number(s) to test for. An integerish vector or `NULL`. If `NULL`, falls back to [`1:n_proposals()`][n_proposals] present
#' matching the specified parameters.
#'
#' @return Either
#' - **an unnamed logical scalar** if `proposal_nrs` is `NULL` and there was no FOKUS-covered referendum at `ballot_date` on any `lvls`, or
#' - **a logical vector** of the same length as `lvls` × `proposal_nrs`, **named** after `lvls.proposal_nrs`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_proposal_nrs(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_proposal_nrs(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::has_proposal_nrs(ballot_date = "2018-09-23",
#' canton = "aargau",
#' proposal_nrs = 1:5)
#'
#' fokus::has_proposal_nrs(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::has_proposal_nrs(ballot_date = "2021-11-28",
#' lvls = "cantonal",
#' canton = "aargau")
has_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
proposal_nrs = NULL) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
checkmate::assert_integerish(proposal_nrs,
lower = 1L,
any.missing = FALSE,
null.ok = TRUE)
lvls %>%
magrittr::set_names(., .) |>
purrr::map(~ {
present_proposal_nrs <- proposal_nrs(ballot_date = ballot_date,
lvl = .x,
canton = canton)
if (is.null(proposal_nrs)) {
proposal_nrs <- present_proposal_nrs
}
proposal_nrs %>%
magrittr::set_names(., .) |>
purrr::map(\(x) x %in% present_proposal_nrs)
}) |>
unlist() |>
pal::when(is.null(.) ~ FALSE,
~ .)
}
#' Determine whether ballot includes elections
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political levels covered the specified
#' election numbers of the specified procedures.
#'
#' @inheritParams n_elections
#' @param election_nrs Election number(s) to test for. An integerish vector or `NULL`. If `NULL`, falls back to [`1:n_elections()`][n_elections] present
#' matching the specified parameters.
#'
#' @return Either
#' - **an unnamed logical scalar** if `election_nrs` is `NULL` and there was no FOKUS-covered election of any `prcds` at `ballot_date` on any `lvls`, or
#' - **a logical vector** of the same length as `lvls` × `prcds` × `election_nrs`, **named** after `lvls.prcds.election_nrs`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_election_nrs(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::has_election_nrs(ballot_date = "2019-10-20",
#' lvls = "federal",
#' canton = "aargau",
#' prcds = "proportional")
#'
#' fokus::has_election_nrs(ballot_date = "2019-10-20",
#' canton = "aargau",
#' election_nrs = 1:2)
#'
#' fokus::has_election_nrs(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_election_nrs(ballot_date = "2020-10-18",
#' lvls = "federal",
#' canton = "aargau")
has_election_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
prcds = all_prcds,
election_nrs = NULL) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
checkmate::assert_integerish(election_nrs,
lower = 1L,
any.missing = FALSE,
null.ok = TRUE)
lvls %>%
magrittr::set_names(., .) |>
purrr::map(function(lvl) {
prcds %>%
magrittr::set_names(., .) |>
purrr::map(lvl = lvl,
.f = function(prcd,
lvl) {
present_election_nrs <- election_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd)
if (is.null(election_nrs)) {
election_nrs <- present_election_nrs
}
election_nrs %>%
magrittr::set_names(., .) |>
purrr::map(\(x) x %in% present_election_nrs)
})
}) |>
unlist() |>
pal::when(is.null(.) ~ FALSE,
~ .)
}
#' Get ballot type combinations
#'
#' Returns a list with a metadata item per ballot type, ballot date, canton and optionally political level.
#'
#' @inheritParams ballot_types
#' @inheritParams has_lvl
#' @param ballot_dates FOKUS-covered ballot date(s). One or more of
#' `r pal::as_md_val_list(as.character(all_ballot_dates))`
#' @param cantons FOKUS-covered canton name(s). One or more of
#' `r pal::as_md_val_list(all_cantons)`
#' @param incl_lvl Whether or not to include the political levels in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#'
#' @return A list with an element per ballot-type and optionally -political-level combination.
#' @family combo
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' # of all covered ballots
#' fokus::combos_ballot_types()
#'
#' # only of 2023-06-18 ballot in aargau
#' fokus::combos_ballot_types(ballot_dates = "2023-06-18",
#' cantons = "aargau")
combos_ballot_types <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
ballot_types = all_ballot_types,
incl_lvl = TRUE) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
ballot_types <- rlang::arg_match(arg = ballot_types,
multiple = TRUE)
checkmate::assert_flag(incl_lvl)
result <-
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
if (incl_lvl) {
sub_result <-
lvls |>
purrr::map(\(lvl) {
ballot_types(ballot_date = ballot_date,
lvls = lvl,
canton = canton) |>
intersect(y = ballot_types) |>
purrr::map(\(x) list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
ballot_type = x))
}) |>
purrr::list_flatten()
} else {
sub_result <-
ballot_types(ballot_date = ballot_date,
lvls = lvls,
canton = canton) |>
intersect(y = ballot_types) |>
purrr::map(\(x) list(ballot_date = ballot_date,
canton = canton,
ballot_type = x))
}
sub_result
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
result
}
#' Get referendum proposal type
#'
#' Returns the [type][all_proposal_types] of the specified referendum proposal.
#'
#' @inheritParams proposal_name
#'
#' @return Proposal type. One of
#' `r pal::as_md_val_list(all_proposal_types)`
#'
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_type(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
proposal_type <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L) {
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck("type")
}
#' Get referendum proposal name
#'
#' Returns the name of the specified referendum proposal in the specified language.
#'
#' @inheritParams proposal_nrs
#' @inheritParams raw_qstnr_suppl_proposal
#' @inheritParams lang_to_locale
#' @param type Name type. One of `r all_name_types |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#'
#' @return A character scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_name(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "long")
proposal_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
lang = pal::pkg_config_val("lang"),
type = all_name_types) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
type <- rlang::arg_match(type)
raw_qstnr_suppl_proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck(lang, type, "text")
}
#' Get German referendum proposal name's grammatical gender
#'
#' Returns the grammatical gender of the German name of the specified referendum proposal.
#'
#' @inheritParams proposal_name
#'
#' @return A character scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_name_gender(ballot_date = "2018-09-23",
#' lvl = "federal",
#' proposal_nr = 1,
#' type = "short")
#'
#' fokus::proposal_name_gender(ballot_date = "2018-09-23",
#' lvl = "federal",
#' proposal_nr = 1,
#' type = "long")
proposal_name_gender <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_name_types) {
type <- rlang::arg_match(type)
raw_qstnr_suppl_proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck("de", type, "gender")
}
#' Determine whether German referendum proposal name is plural
#'
#' Determines whether or not the German name of the specified referendum proposal is a plural.
#'
#' @inheritParams proposal_name
#'
#' @return A logical scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::is_proposal_name_plural(ballot_date = "2020-09-27",
#' lvl = "federal",
#' proposal_nr = 3,
#' type = "short")
is_proposal_name_plural <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_name_types) {
type <- rlang::arg_match(type)
raw_qstnr_suppl_proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("de", type, "is_plural",
.default = FALSE)
}
#' Get referendum proposal's arguments
#'
#' Returns text, side and number of all referendum arguments on the specified proposal.
#'
#' @inheritParams proposal_name
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_arguments(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
proposal_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L) {
raw_qstnr_suppl_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::map(as_flat_list) |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind() |>
dplyr::relocate(any_of(c("side", "nr")),
any_of("de.short"),
starts_with("de."),
any_of("en.short"),
starts_with("en."))
}
#' Get referendum proposal argument
#'
#' Returns the specified referendum proposal argument's text of the specified type in the specified language.
#'
#' @inheritParams proposal_name
#' @param side Proposal argument side. One of `r all_argument_sides |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#' @param argument_nr Proposal argument number. A positive integerish scalar.
#'
#' @return A character scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_argument(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' side = "contra",
#' argument_nr = 3,
#' type = "long")
proposal_argument <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
side = all_argument_sides,
argument_nr = 1L,
lang = pal::pkg_config_val("lang"),
type = all_name_types) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
type <- rlang::arg_match(type)
raw_qstnr_suppl_argument(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
side = side,
argument_nr = argument_nr) |>
purrr::chuck(lang, type)
}
#' Get referendum proposal's main motives
#'
#' Returns text and code number of all main motives of the specified `type` for the specified referendum proposal.
#'
#' @inheritParams proposal_name
#' @param type Main motive type. One of `r pal::enum_fn_param_defaults(param = "type", fn = proposal_main_motives)`.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_main_motives(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "no")
proposal_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_main_motive_types) {
type <- rlang::arg_match(type)
raw_qstnr_suppl_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck(type) |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get referendum proposal's number of arguments
#'
#' Determines the number of arguments on the specified referendum proposal of the specified sides.
#'
#' @inheritParams proposal_name
#' @param sides Proposal argument side(s). One or more of `r all_argument_sides |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' @return An integer scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::n_proposal_arguments(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' fokus::n_proposal_arguments(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' sides = "pro")
n_proposal_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
sides = all_argument_sides) {
sides <- rlang::arg_match(arg = sides,
multiple = TRUE)
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("argument") |>
purrr::keep(\(x) x$side %in% sides) |>
length()
}
#' Get referendum proposal's number of main motives
#'
#' Determines the number of main motives for the specified proposal and motive type.
#'
#' @inheritParams proposal_main_motives
#' @param types Main motive type(s). One or more of `r pal::enum_fn_param_defaults(param = "type", fn = proposal_main_motives, sep2 = " and ")`.
#'
#' @return An integer scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' # count all motive types
#' fokus::n_proposal_main_motives(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' # count only motives of type "no"
#' fokus::n_proposal_main_motives(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' types = "no")
n_proposal_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
types = all_main_motive_types) {
types <- rlang::arg_match(types,
multiple = TRUE)
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("main_motive") |>
purrr::keep_at(at = types) |>
pal::when(length(.) > 0L ~
purrr::map_depth(.,
.depth = 1L,
length) |>
purrr::list_c(ptype = integer()),
~ 0L) |>
sum()
}
#' Determine whether arguments have been queried for referendum proposal
#'
#' Determines whether or not arguments have been queried for the specified referendum proposal.
#'
#' @inheritParams n_proposal_arguments
#'
#' @return A logical scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::has_proposal_arguments(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::has_proposal_arguments(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 2)
has_proposal_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
sides = all_argument_sides) {
n_proposal_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
sides = sides) > 0L
}
#' Determine whether main motives have been queried for referendum proposal
#'
#' Determines whether or not main motives have been queried for the specified referendum proposal.
#'
#' @inheritParams n_proposal_main_motives
#'
#' @return A logical scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::has_proposal_main_motives(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::has_proposal_main_motives(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 2)
has_proposal_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
types = all_main_motive_types) {
n_proposal_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
types = types) > 0L
}
#' Get referendum proposal numbers with arguments
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level for which at least one pro/contra argument has been queried.
#'
#' @inheritParams proposal_nrs
#'
#' @return An integer vector.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::argument_proposal_nrs(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
argument_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
qstn_groups_proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
qstn_groups = "argument")
}
#' Get referendum proposal numbers with arguments
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level for which at least one pro/contra argument has been queried.
#'
#' @inheritParams proposal_nrs
#'
#' @return An integer vector.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::main_motive_proposal_nrs(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
main_motive_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
qstn_groups_proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
qstn_groups = "main_motive")
}
#' Get referendum proposal combinations
#'
#' Returns a list with a metadata item per ballot date, political level, canton and optionally proposal number.
#'
#' @inheritParams combos_ballot_types
#' @param incl_nr Whether or not to include proposal numbers in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#'
#' @return A list with an element per political-level and optionally -proposal-number combination.
#' @family combo
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::combos_proposals(ballot_dates = "2023-06-18",
#' cantons = "aargau")
#'
#' # without proposal numbers
#' fokus::combos_proposals(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_nr = FALSE)
combos_proposals <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
incl_nr = TRUE) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
checkmate::assert_flag(incl_nr)
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
if (incl_nr) {
result <-
proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::map(\(nr) list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = nr))
} else if (has_lvl(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
ballot_types = "referendum")) {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton)
} else {
result <- NULL
}
result
}) |>
pal::when(incl_nr ~ purrr::list_flatten(.),
~ .) |>
purrr::compact()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get referendum proposal combinations for which arguments have been queried
#'
#' Returns a list with a metadata item per ballot date, political level, canton, proposal number and optionally proposal argument side (pro/contra) and number.
#'
#' @inheritParams combos_ballot_types
#' @param incl_side Whether or not to include argument sides (pro/contra) in the resulting list. Setting this to `FALSE` potentially results in fewer
#' combinations.
#' @param incl_argument_nr Whether or not to include argument numbers in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#' Setting this to `TRUE` implies `incl_side = TRUE`.
#'
#' @return A list with an element per political-level-proposal-number and optionally -argument-side and -argument-number combination.
#' @family combo
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::combos_proposal_arguments(ballot_dates = "2023-06-18",
#' cantons = "aargau")
#' # without argument numbers
#' fokus::combos_proposal_arguments(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_argument_nr = FALSE)
#' # without argument sides and numbers
#' fokus::combos_proposal_arguments(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_side = FALSE,
#' incl_argument_nr = FALSE)
combos_proposal_arguments <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
incl_side = TRUE,
incl_argument_nr = incl_side) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
checkmate::assert_flag(incl_side)
checkmate::assert_flag(incl_argument_nr)
# ensure `incl_argument_nr` and `incl_side` do not conflict
if (incl_argument_nr && !incl_side) {
cli::cli_abort("{.arg incl_argument_nr} cannot be {.val {TRUE}} when {.arg incl_side} is {.val {FALSE}}.")
}
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::map(\(proposal_nr) {
if (has_proposal_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)) {
if (incl_side) {
result <-
raw_qstnr_suppl_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::map(\(arg) {
if (incl_argument_nr) {
return(list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
side = arg$side,
argument_nr = arg$nr))
} else {
return(list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
side = arg$side))
}
}) |>
unique()
} else {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)
}
} else {
result <- NULL
}
result
}) |>
purrr::compact() |>
pal::when(incl_side ~ purrr::list_flatten(.),
~ .)
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get referendum proposal combinations for which main motives have been queried
#'
#' Returns a list with a metadata item per ballot date, political level, canton, proposal number and optionally motive type for which [main
#' motives][proposal_main_motives] have been queried in the respective post-voting survey.
#'
#' @inheritParams combos_ballot_types
#' @param incl_type Whether or not to include motive types (yes/no) in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#'
#' @return A list with an element per political-level-proposal-number and optionally -type combination.
#' @family combo
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::combos_proposal_main_motives(ballot_dates = "2023-06-18",
#' cantons = "aargau")
#' # without types
#' fokus::combos_proposal_main_motives(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_type = FALSE)
combos_proposal_main_motives <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
incl_type = TRUE) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
checkmate::assert_flag(incl_type)
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::map(\(proposal_nr) {
if (incl_type) {
result <-
all_main_motive_types |>
purrr::map(\(type) {
if (has_proposal_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
types = type)) {
list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
type = type)
} else {
NULL
}
}) |>
purrr::compact()
} else if (has_proposal_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)) {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)
} else {
result <- NULL
}
result
}) |>
purrr::compact() |>
pal::when(incl_type ~ purrr::list_flatten(.),
~ .)
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get election name
#'
#' Returns the name of the specified election in the specified language.
#'
#' @inheritParams election_nrs
#' @inheritParams proposal_name
#' @param election_nr Election number. A positive integerish scalar.
#' @param type Name type. One of `r pal::enum_fn_param_defaults(param = "type", fn = election_name)`.
#'
#' @return A character scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_name(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "majoritarian",
#' election_nr = 1,
#' type = "body")
election_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
prcd = prcds(ballot_date,
lvl,
canton),
election_nr = 1L,
lang = pal::pkg_config_val("lang"),
type = c("short", "long", "body", "body_alt")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
type <- rlang::arg_match(type)
# this is required to trigger a proper error message in case `prcds` is not explicitly set and there are no elections (`prcd = character()`)
if (!length(prcd)) {
cli::cli_abort(paste0("{.arg prcd} must be one of ", cli::ansi_collapse(paste0("{.val ", all_prcds, "}"), sep2 = " or ", last = " or "), "."))
}
raw_qstnr_suppl_election_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd,
election_nr = election_nr) |>
purrr::chuck(lang, type, "text")
}
#' Get combined elections name
#'
#' Returns the combined name of all elections at the specified date on the specified level(s) for the specified canton in the specified language.
#'
#' @inheritParams n_elections
#' @inheritParams lang_to_locale
#' @param federal_first Whether or not to list federal elections before cantonal ones. Only has an effect if `"federal" %in% lvls`.
#'
#' @return A character scalar, empty if no elections were held.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_names_combined(ballot_date = "2019-10-20",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::election_names_combined(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::election_names_combined(ballot_date = "2019-10-20",
#' canton = "aargau",
#' federal_first = FALSE)
election_names_combined <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang"),
federal_first = TRUE) {
lvls <- unique(rlang::arg_match(arg = lvls,
multiple = TRUE))
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_flag(federal_first)
sep <- switch(EXPR = lang,
de = " sowie ",
en = " as well as ")
lvls |>
intersect(lvls(ballot_date = ballot_date,
canton = canton,
ballot_type = "election")) |>
purrr::map_chr(\(x) {
raw_qstnr_suppl_elections(ballot_date = ballot_date,
lvl = x,
canton = canton) |>
purrr::chuck("names_combined", lang, "short")
}) |>
pal::when(federal_first ~ .[sort(x = seq_along(.),
decreasing = TRUE)],
~ .) |>
cli::ansi_collapse(sep2 = sep,
last = sep)
}
#' Get majoritarian election's candidates
#'
#' Returns the name and party of all candidates running for the specified majoritarian election.
#'
#' @inheritParams n_election_seats
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_candidates(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
election_candidates <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("candidate") |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get proportional election's political parties
#'
#' Returns the questionnaire code as well as different versions of the name of all parties for the specified proportional election.
#'
#' @inheritParams n_election_seats
#' @param past Whether to process the current or the predecessor election's parties.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @seealso [fct_relabel_election_parties()]
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_parties(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::election_parties(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau",
#' past = TRUE)
election_parties <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election",
prcds = "proportional"),
canton = cantons(ballot_date),
election_nr = 1L,
past = FALSE) {
checkmate::assert_flag(past)
if (past) {
# priority 1: from current election's metadata (past election was *not* covered by FOKUS survey)
result <-
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::pluck("past_party")
# priority 2: from past election's metadata (past election was covered by FOKUS survey)
if (is.null(result)) {
result <-
raw_qstnr_suppl_election(ballot_date = past_election_date(ballot_date = ballot_date,
lvl = lvl,
canton = canton),
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::chuck("party")
}
} else {
result <-
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::chuck("party")
}
result |>
purrr::map(as_flat_list) |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get proportional election's tickets
#'
#' Returns the name, number and party of all tickets for the specified proportional election.
#'
#' @inheritParams n_election_seats
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_tickets(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
election_tickets <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::chuck("ticket") |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get election's past date
#'
#' Determines the ordinary date (i.e. 1st round of voting) on which the specified election was *last* held (i.e. 4 years earlier than `ballot_date`).
#'
#' @inheritParams election_name
#'
#' @return `r pkgsnip::return_lbl("date")`
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::past_election_date(ballot_date = "2019-10-20")
#' fokus::past_election_date(ballot_date = "2020-10-18")
#' fokus::past_election_date(ballot_date = "2024-10-20")
#' fokus::past_election_date(ballot_date = "2019-10-20",
#' lvl = "federal")
past_election_date <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date)) {
ballot_date %<>% as_ballot_date()
if (length(lvl)) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
# priority 1: from current election's metadata (past election was *not* covered by FOKUS survey)
result <-
lvl |>
pal::when(. == "federal" ~
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = .),
~ raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = .,
canton = canton)) |>
purrr::pluck("election", "past_ballot_date") |>
checkmate::assert_date(any.missing = FALSE,
null.ok = TRUE)
# priority 2: from past election's metadata (past election was covered by FOKUS survey)
if (is.null(result)) {
# NOTE: we assume the past election must be *4* years before `ballot_date`
past_election_year <- clock::get_year(ballot_date) - 4L
result <-
combos_elections(ballot_dates = all_ballot_dates,
lvls = lvl,
cantons = canton,
incl_prcd = FALSE,
incl_nr = FALSE) |>
purrr::keep(.p = \(x) {
clock::get_year(x$ballot_date) == past_election_year
}) |>
purrr::map_depth(.depth = 1L,
.f = \(x) x$ballot_date) |>
purrr::list_c(ptype = as.Date(NULL)) |>
pal::safe_min()
}
if (length(result) == 0L) {
cli::cli_abort(paste0("Past election date couldn't be determined. Please set `past_ballot_date` explicitly in the supplemental {.val {ballot_date}} FOKUS ",
"questionnaire data."))
}
result
}
#' Get number of majoritarian election seats
#'
#' Determines the number of election seats of the specified type for the specified majority election.
#'
#' @inheritParams ballot_types
#' @inheritParams election_name
#' @param seat_type Seat type. One of `r pal::enum_fn_param_defaults(param = "seat_type", fn = n_election_seats)`.
#'
#' @return An integer scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::n_election_seats(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' seat_type = "total")
n_election_seats <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L,
seat_type = all_election_seat_types) {
seat_type <- rlang::arg_match(seat_type)
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("n_seats", seat_type)
}
#' Get number of (officially registered) majoritarian election candidates
#'
#' Determines the number of (officially registered) candidates of a majority election at the specified ballot date on the specified political level.
#'
#' @inheritParams n_election_seats
#'
#' @return An integer scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::n_election_candidates(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
n_election_candidates <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("candidate") |>
length()
}
#' Determine whether majoritarian election requires candidate registration
#'
#' Determines whether or not candidates must be officially registered prior to the specified majority election.
#'
#' The absence of a candidate registration requirement usually means that every eligible citizen can be elected, i.e. receive valid votes.
#'
#' @inheritParams n_election_seats
#'
#' @return A logical scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::requires_candidate_registration(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
requires_candidate_registration <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("requires_candidate_registration")
}
#' Get election combinations
#'
#' Returns a list with a metadata item per ballot date, political level and optionally election procedure and number.
#'
#' @inheritParams combos_ballot_types
#' @inheritParams n_elections
#' @param incl_prcd Whether or not to include election procedures in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#' @param incl_nr Whether or not to include election numbers in the resulting list. Setting this to `FALSE` potentially results in fewer combinations. Only
#' relevant if `incl_prcd = TRUE`.
#'
#' @return A list with an element per political-level and optionally -election-procedure and -election-number combination.
#' @family combo
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::combos_elections(ballot_dates = "2019-10-20",
#' cantons = "aargau")
#'
#' # without election numbers
#' fokus::combos_elections(ballot_dates = "2019-10-20",
#' cantons = "aargau",
#' incl_prcd = TRUE,
#' incl_nr = FALSE)
#'
#' # without election procedures and numbers
#' fokus::combos_elections(ballot_dates = "2019-10-20",
#' cantons = "aargau",
#' incl_prcd = FALSE,
#' incl_nr = FALSE)
combos_elections <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
prcds = all_prcds,
incl_prcd = TRUE,
incl_nr = incl_prcd) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
prcds <- rlang::arg_match(arg = prcds,
multiple = TRUE)
checkmate::assert_flag(incl_prcd)
checkmate::assert_flag(incl_nr)
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
if (incl_prcd) {
result <-
election_prcds(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
intersect(y = prcds) |>
purrr::map(\(prcd) {
if (incl_nr) {
return(election_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd) |>
purrr::map(\(nr) list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd,
election_nr = nr)))
} else {
return(list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd))
}
}) |>
pal::when(incl_nr ~ purrr::list_flatten(.),
~ .)
} else if (any(has_lvl(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
ballot_types = "election"))) {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton)
} else {
result <- NULL
}
result
}) |>
pal::when(incl_prcd ~ purrr::list_flatten(.),
~ .) |>
purrr::compact()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get skill question numbers
#'
#' Determines the skill questions numbers at the specified ballot date on the specified political level. Note that by default (`proposal_nr = NULL`),
#' non-proposal-specific skill question numbers are returned.
#'
#' @inheritParams proposal_nrs
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, the numbers of non-proposal-specific skill questions are returned.
#'
#' @return An integer vector.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' # note that by default, non-proposal-specific skill question numbers are returned
#' fokus::skill_question_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::skill_question_nrs(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
skill_question_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL) {
pal::safe_seq_len(n_skill_questions(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr))
}
#' Get number of skill questions
#'
#' Determines the number of skill questions at the specified ballot date on the specified political level. Note that by default (`proposal_nr = NULL`), the
#' number of non-proposal-specific skill questions is returned.
#'
#' @inheritParams proposal_nrs
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, the number of non-proposal-specific skill questions is returned.
#'
#' @return An integer scalar.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::n_skill_questions(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' # note that by default, the number of non-proposal-specific skill questions is returned
#' fokus::n_skill_questions(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::n_skill_questions(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
n_skill_questions <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
if (lvl == "cantonal") {
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
}
checkmate::assert_count(proposal_nr,
positive = TRUE,
null.ok = TRUE)
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck(lvl) |>
pal::when(lvl == "cantonal" ~ purrr::pluck(., canton),
~ .) |>
# get non-proposal-specific skill questions if `proposal_nr = NULL`
pal::when(length(proposal_nr) > 0L ~ purrr::pluck(., "proposal", proposal_nr),
~ .) |>
purrr::pluck("skill_question") |>
length()
}
#' Get skill question
#'
#' Returns the skill question text in the specified language. Note that by default (`proposal_nr = NULL`), only non-proposal-specific skill questions are
#' returned.
#'
#' @inheritParams proposal_name
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, it is considered to be a non-proposal-specific skill question
#' (the case at elections).
#' @param skill_question_nr Skill question number. A positive integerish scalar.
#'
#' @return A character scalar.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 2,
#' lang = "en")
skill_question <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL,
skill_question_nr = 1L,
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
raw_qstnr_suppl_skill_question(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
skill_question_nr = skill_question_nr) |>
purrr::chuck(lang)
}
#' Get skill question response options
#'
#' Returns the response options of the specified skill question together with the information whether they are correct or not.
#'
#' @inheritParams skill_question
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_response_options(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 2)
skill_question_response_options <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL,
skill_question_nr = 1L) {
raw_qstnr_suppl_skill_question(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
skill_question_nr = skill_question_nr) |>
purrr::chuck("response_option") |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get correct skill question answer number
#'
#' Returns the sequential number of the correct answer for the specified skill question.
#'
#' @inheritParams skill_question
#'
#' @return An integer scalar.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_answer_nr(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 2)
skill_question_answer_nr <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL,
skill_question_nr = 1L) {
raw_qstnr_suppl_skill_question(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
skill_question_nr = skill_question_nr) |>
purrr::chuck("response_option") |>
purrr::map_depth(.depth = 1L,
.f = \(x) x$is_correct) |>
purrr::list_c(ptype = logical()) |>
which()
}
#' Get referendum proposal numbers with skill questions
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level that have at least one skill question.
#'
#' @inheritParams proposal_nrs
#'
#' @return An integer vector.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_proposal_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
skill_question_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
qstn_groups_proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
qstn_groups = "skill_question")
}
#' Get ballot title
#'
#' Returns the ballot title consisting of the [ballot type][ballot_types()] and the ballot date, phrased in German.
#'
#' @inheritParams lvls
#' @inheritParams lang_to_locale
#'
#' @return A character scalar.
#' @family predicate_other
#' @export
#'
#' @examples
#' fokus::ballot_title(ballot_date = "2019-10-20",
#' canton = "aargau")
ballot_title <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang")) {
ballot_date %<>% as_ballot_date()
lang <- rlang::arg_match(arg = lang,
values = all_langs)
ballot_types <- ballot_types(ballot_date = ballot_date,
canton = canton)
if (!length(ballot_types)) {
cli::cli_abort("No ballot type could be determined. Please debug.",
.internal = TRUE)
}
if (lang == "de") {
result <-
ballot_types |>
pal::when(length(.) > 1L ~ "Abstimmungs- und Wahl",
. == "referendum" ~ "Abstimmungs",
. == "election" ~ "Wahl") |>
paste0("termin vom ", stringi::stri_datetime_format(time = ballot_date,
format = "date_long",
locale = lang_to_locale(lang)))
} else if (lang == "en") {
result <-
ballot_types |>
pal::when(length(.) > 1L ~ "Referendum and election",
~ stringr::str_to_sentence(.)) |>
paste0(" date of ", stringi::stri_datetime_format(time = ballot_date,
format = "date_long",
locale = lang_to_locale(lang)))
}
result
}
#' Get political issues
#'
#' Returns the political issues in the specified language at the specified ballot date.
#'
#' @inheritParams proposal_name
#'
#' @return A character vector.
#' @family predicate_other
#' @export
#'
#' @examples
#' fokus::political_issues(ballot_date = "2019-10-20",
#' lang = "en")
political_issues <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
result <-
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck("political_issues")
if (is.null(result)) {
# reduce to proper arg value for error msg
ballot_date %<>% as_ballot_date()
cli::cli_abort("No political issues present in the supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result |>
purrr::chuck("issue") |>
purrr::map_depth(.depth = 1L,
.f = \(x) purrr::chuck(x, lang)) |>
purrr::list_c(ptype = character())
}
#' Get postal dispatch way
#'
#' Returns the FOKUS survey's postal dispatch way of the specified type for the specified canton at the specified ballot date.
#'
#' @inheritParams lvls
#' @param dispatch_type Postal dispatch type. One of `r pal::enum_fn_param_defaults(param = "dispatch_type", fn = postal_dispatch_way)`.
#'
#' @return A character scalar.
#' @family predicate_other
#' @family postal_dispatch
#' @export
#'
#' @examples
#' fokus::postal_dispatch_way(ballot_date = "2018-09-23",
#' canton = "aargau",
#' dispatch_type = "invitation")
postal_dispatch_way <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
dispatch_type = all_postal_dispatch_types) {
dispatch_type <- rlang::arg_match(dispatch_type)
raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::chuck("postal_dispatch", "type", dispatch_type)
}
#' Get response options
#'
#' Returns response options of the specified type and optionally subtype(s) from the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' Note that only recurring response options are returned which are defined under the `response_options` top-level key in the file
#' `data-raw/questionnaire/questionnaire.toml`.
#'
#' @inheritParams lang_to_locale
#' @param type Response option type. One of
#' `r pal::as_md_val_list(all_response_option_types)`
#' @param subtypes Hierarchical response option subtypes as a character vector, or `NULL`. If `NULL`, all subtypes are returned.
#'
#' @return A character vector.
#' @family predicate_other
#' @export
#'
#' @examples
#' fokus:::response_options(type = "abstain",
#' lang = "de")
#'
#' fokus:::response_options(type = "abstain",
#' lang = "de",
#' subtypes = "election")
#'
#' fokus:::response_options(type = "abstain",
#' lang = "de",
#' subtypes = c("election", "proportional"))
response_options <- function(type = all_response_option_types,
lang = pal::pkg_config_val("lang"),
subtypes = NULL) {
type <- rlang::arg_match(type)
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_character(subtypes,
any.missing = FALSE,
min.len = 1L,
null.ok = TRUE)
raw_qstnr |>
purrr::chuck("response_options", type, lang, !!!subtypes) |>
pal::as_chr()
}
#' Questionnaire data
#'
#' A tibble containing all FOKUS questionnaires as structured data.
#'
#' `qstnrs` was generated based on the following steps:
#'
#' 1. [gen_qstnr_tibble()] was run for all valid combinations of `canton` and `ballot_date`, some validation checks were performed, and the results were merged
#' into a single tibble.
#' 2. List columns were [expanded][expand_qstnr_tibble] to [long format](https://en.wikipedia.org/wiki/Wide_and_narrow_data).
#' 3. Columns [`question_intro_i` and `question_intro_j`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) were merged into the single
#' column `question_intro`.
#' 4. Column [`question_full`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) was complemented, i.e. made to fall back on `question` if
#' `NA`.
#' 5. Columns [`question_common`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) and
#' [`variable_label_common`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) were complemented, i.e. made to fall back on
#' `question_full` and `variable_label` respectively if `NA`.
#' 6. Markdown formatting was [stripped][pal::strip_md] from all character columns.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::qstnrs
"qstnrs"
#' Proposal data
#'
#' A tibble containing basic referendum proposal data of all FOKUS questionnaires.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::proposals
"proposals"
#' Election data
#'
#' A tibble containing basic election data of all FOKUS questionnaires.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::elections
"elections"
#' Ballot data
#'
#' A list of tibbles containing official statistical data about all FOKUS-covered ballots. The data includes i.a. the total electorate as well as participation
#' numbers per voting channel and per voting decision.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::ballots
"ballots"
#' Read in easyvote municipality data
#'
#' Reads in the latest dataset of easyvote municipality information provided to us not earlier than 90 days before and up until 20 days after the `ballot_date`.
#'
#' If both columns `min_age` and `max_age` are `NA` in the data returned, it means that
#'
#' - the municipality did not provide easyvote with specific information on the target age range, and
#' - the municipality has subscribed to parcel mailing (instead of direct delivery to households) and delivers the brochures itself -- very likely to young
#' adults between 18--25 years.
#'
#' @inheritParams lvls
#' @inheritParams read_private_file
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_easyvote_municipalities(ballot_date = "2020-09-27",
#' canton = "aargau") |>
#' colnames()
#' )
read_easyvote_municipalities <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
# get date of latest dataset delivered *not earlier than 90 days before ballot date* and *up until 20 days after ballot date*
date_boundary_lower <- ballot_date - 90L
date_boundary_upper <- ballot_date + 20L
date_data <-
gitlab::dir_ls(ref = repo_private_default_branch,
path = "raw",
id_project = repo_private_proj_id,
token = auth_token) |>
dplyr::pull("path") |>
stringr::str_subset(pattern = stringr::fixed("raw/easyvote_municipalities_")) |>
stringr::str_extract(glue::glue("\\d{{4}}-\\d{{2}}-\\d{{2}}(?=_{canton}\\.csv$)")) |>
clock::date_parse() %>%
magrittr::extract(. >= date_boundary_lower & . <= date_boundary_upper) |>
pal::safe_max()
if (length(date_data) == 0L) {
cli::cli_abort(paste0("No easyvote municipality data present for canton {.val {canton}} with effective date at minimum 90 days before and at maximum 20 ",
"days after the ballot date {.val {ballot_date}}."))
}
read_private_file(path = glue::glue("raw/easyvote_municipalities_{date_data}_{canton}.csv"),
use_cache = use_cache,
auth_token = auth_token) |>
readr::read_csv(col_types = "ciii")
}
#' Read in online participation codes
#'
#' Reads in the online participation codes externally generated by the survey institute that are necessary to [generate QR codes with personalized survey
#' URLs][export_qr_codes].
#'
#' @inheritParams read_easyvote_municipalities
#'
#' @return A character vector.
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_online_participation_codes(ballot_date = "2018-11-25",
#' canton = "aargau") |>
#' length()
#' )
read_online_participation_codes <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
path <- glue::glue("raw/online_participation_codes_{ballot_date}_{canton}.txt")
if (!gitlab::file_exists(path = path,
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token)) {
cli::cli_abort("No online participation codes present for canton {.val {canton}} @ {.val {ballot_date}}.")
}
read_private_file(path = path,
use_cache = use_cache,
auth_token = auth_token) |>
stringr::str_split_1(pattern = stringr::fixed("\n"))
}
#' Read in generated survey data
#'
#' @description
#' Reads in the FOKUS survey dataset exported by [export_survey_data()] for the specified ballot date in the specified canton and language, optionally merged
#' with all prior survey datasets for that canton and language.
#'
#' @includeRmd data-raw/snippets/merged_data.Rmd
#'
#' @inheritParams ballot_title
#' @inheritParams read_private_file
#' @param merged Whether or not to read in the *merged* dataset that includes the data from **all** ballot dates up until `ballot_date` that were covered by
#' FOKUS surveys in the specified `canton`. See section *Merged data* below for details. If `FALSE`, only the data for `ballot_date` itself is returned.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_survey_data(ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "en") |>
#' nrow()
#' )
#'
#' try(
#' fokus::read_survey_data(ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "en",
#' merged = TRUE) |>
#' nrow()
#' )
read_survey_data <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang"),
merged = FALSE,
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_flag(merged)
read_private_file(path = glue::glue("generated/survey_data_", ifelse(merged, "merged_", ""), "{lang}_{ballot_date}_{canton}.rds"),
use_cache = use_cache,
auth_token = auth_token) |>
memDecompress() |>
unserialize()
}
#' Read in extra voting register data
#'
#' Reads in the raw extra voting register data provided by the statistical office, performs various integrity checks and returns it in tidy shape.
#'
#' @inheritParams read_easyvote_municipalities
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_voting_register_data_extra(ballot_date = "2019-10-20",
#' canton = "aargau") |>
#' colnames()
#' )
read_voting_register_data_extra <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
rlang::check_installed("readxl",
reason = pal::reason_pkg_required())
# get date of latest dataset delivered *before* ballot date
date_data <-
gitlab::dir_ls(ref = repo_private_default_branch,
path = "raw",
id_project = repo_private_proj_id,
token = auth_token) |>
dplyr::pull("path") |>
stringr::str_subset(pattern = stringr::fixed("raw/voting_register_data_extra_")) |>
stringr::str_extract(glue::glue("\\d{{4}}-\\d{{2}}-\\d{{2}}(?=_{canton}\\.xlsx$)")) |>
clock::date_parse() %>%
magrittr::extract(. < ballot_date) |>
pal::safe_max()
if (length(date_data) == 0L) {
cli::cli_abort("No voting register data present for canton {.val {canton}} with effective date before the ballot on {.val {ballot_date}}.")
}
# NOTE: `readxl::read_xlsx()` can only read from file, so we have to temporarily write the file to disk
tmp_file <- fs::file_temp(pattern = glue::glue("voting_register_data_extra_{date_data}_{canton}"),
ext = "xlsx")
read_private_file(path = glue::glue("raw/voting_register_data_extra_{date_data}_{canton}.xlsx"),
use_cache = use_cache,
auth_token = auth_token) |>
brio::write_file_raw(path = tmp_file)
data <-
readxl::read_xlsx(path = tmp_file,
col_types = "text") |>
# rename variables to our scheme
dplyr::rename(id = `ID-Nummer`,
sex_official = Geschlecht,
year_of_birth_official = Jahrgang,
marital_status_official = Zivilstand,
household_size_official = "Haushaltsgr\u00f6sse Anzahl Personen Total",
n_adults_in_household_official = "Haushaltsgr\u00f6sse Anzahl Personen \u00fcber 18 Jahren",
n_kids_in_household_official = "Haushaltsgr\u00f6sse Anzahl Personen unter 18 Jahren") |>
# convert numeric columns to type integer
dplyr::mutate(dplyr::across(c(id,
year_of_birth_official,
household_size_official,
n_adults_in_household_official,
n_kids_in_household_official),
as.integer)) |>
# transform variable values to our scheme
dplyr::mutate(dplyr::across(c(sex_official, marital_status_official),
stringr::str_to_lower)) |>
dplyr::mutate(marital_status_official = dplyr::case_match(.x = marital_status_official,
"eingetragene partnerschaft" ~ "in eingetragener Partnerschaft",
"aufgel\u00f6ste partnerschaft" ~ "aufgel\u00f6ste Partnerschaft",
"unverheiratet" ~ "ledig",
.default = marital_status_official))
# integrity check 1: ensure no unexpected columns occur
if (ncol(data) > 7L) {
unknown_colnames <-
colnames(data) |>
setdiff(c(id,
sex_official,
year_of_birth_official,
marital_status_official,
household_size_official,
n_adults_in_household_official,
n_kids_in_household_official))
cli::cli_abort("Unexpected column(s) detected in private file {.file raw/voting_register_data_extra_{date_data}_{canton}.xlsx}: {.val unknown_colnames}",
.internal = TRUE)
}
# integrity check 2: ensure no unexpected values occur
## in `sex_official`
unknown_sex_official_i <-
data$sex_official |>
magrittr::is_in(var_val_set(var_name = "sex_official",
ballot_date = ballot_date,
canton = canton,
lang = "de")) |>
magrittr::not() |>
which()
if (length(unknown_sex_official_i) > 0L) {
cli::cli_abort("{.var sex_official} in raw extra voting register data has unknown values: {.val {unique(data$sex_official[unknown_sex_official_i])}}")
}
## in `marital_status_official`
unknown_marital_status_official_i <-
data$marital_status_official |>
magrittr::is_in(var_val_set(var_name = "marital_status_official",
ballot_date = ballot_date,
canton = canton,
lang = "de")) |>
magrittr::not() |>
which()
if (length(unknown_marital_status_official_i)) {
cli::cli_abort(paste0("{.var marital_status_official} in raw extra voting register data has unknown values: ",
"{.val {unique(data$sex_official[unknown_marital_status_official_i])}}"))
}
data
}
#' Read in voting register identifiers
#'
#' Reads in the voting register identifiers of the population that was invited to participate in the FOKUS survey at the specified ballot date in the specified
#' canton.
#'
#' Note that this data is not available for all FOKUS surveys.
#'
#' @inheritParams read_easyvote_municipalities
#'
#' @return `r pkgsnip::return_lbl("tibble_cols", cols = "id_voting_register")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_voting_register_ids(ballot_date = "2019-10-20",
#' canton = "aargau") |>
#' nrow()
#' )
read_voting_register_ids <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
path <- glue::glue("raw/voting_register_ids_{ballot_date}_{canton}.csv")
if (!gitlab::file_exists(path = path,
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token)) {
cli::cli_abort("No voting register ID data present for canton {.val {canton}} @ {.val {ballot_date}}.")
}
read_private_file(path = glue::glue("raw/voting_register_ids_{ballot_date}_{canton}.csv"),
use_cache = use_cache,
auth_token = auth_token) |>
readr::read_csv(col_types = "i") |>
# integrity check
pal::when(ncol(.) > 1L ~ cli::cli_abort("More than one column present in {.file {path}}. Please debug.",
.internal = TRUE),
~ .) |>
dplyr::rename(id_voting_register = 1L)
}
#' Read in file from private FOKUS repository
#'
#' Downloads a file from the [private FOKUS repository](`r url_repo_private()`) and returns it as a character scalar in case of a text file, or a [raw] vector
#' otherwise.
#'
#' Files are downloaded via [GitLab's RESTful API (v4)](https://docs.gitlab.com/ee/api/rest/). If `use_cache = TRUE` (the default), a downloaded file is cached
#' on disk in this package's [user-cache pins board][pkgpins::board] and only newly fetched from the private FOKUS repository GitLab remote if is has changed
#' since being downloaded the last time. Caching saves a bit of time and (potentially) a lot of bandwidth.
#'
#' @param path File path relative to the repository root.
#' @param use_cache Whether or not to return cached results if possible. Caching is done based on file content hashing, so the file is only newly fetched if it
#' actually changed since the last download. If `FALSE`, the file is always newly fetched.
#' @param auth_token [Personal access token of a gitlab.com account](https://gitlab.com/-/user_settings/personal_access_tokens) with access to the [private
#' FOKUS repository](`r url_repo_private()`).
#'
#' @return The file content, as character scalar for text files, otherwise as a [raw vector][raw].
#' @family data_import
#' @family private
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_private_file("raw/survey_data_2018-09-23_aargau.xlsx") |>
#' length()
#' )
read_private_file <- function(path,
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
checkmate::assert_string(path)
pkgpins::with_cache(expr = gitlab::file_content(path = path,
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token),
pkg = this_pkg,
from_fn = "read_private_file",
gitlab::file_meta(path = path,
attribute = "content_sha256",
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token),
use_cache = use_cache,
max_cache_age = Inf)
}
#' Tidy columns
#'
#' Renames a data frame's columns and converts them to their proper types. Aimed at datasets published by cantonal statistical offices.
#'
#' @param data Data frame whose columns are to be converted.
#' @param default_type [readr column type][readr::col_character] to which columns are to be converted for which no explicit type is predefined.
#'
#' @return `data`
#' @family data_import
#' @export
tidy_cols <- function(data,
default_type = readr::col_character()) {
data |>
# rename cols
pal::rename_from(dict = dicts$colnames$ballots) |>
# remove `.0` suffix from numbers to avoid warnings from `readr::type_convert()` below
dplyr::mutate(dplyr::across(.cols = where(is.character),
.fns = \(x) stringr::str_replace(string = x,
pattern = "^(\\d+)\\.0$",
replacement = "\\1"))) %>%
# tidy col types
# NOTE: we must reduce `col_types` to the ones actually present in `data` to avoid warnings
readr::type_convert(col_types = readr::cols(!!!col_types[intersect(names(col_types),
colnames(.))],
.default = default_type))
}
#' Export questionnaire data
#'
#' Generates the [questionnaire tibble][gen_qstnr_tibble], the [Markdown questionnaire][gen_qstnr_md] and optionally a CSV, an HTML and an XLSX version of it,
#' and writes all of them to `path` and optionally uploads them to a Google Drive folder.
#'
#' The generated files are named according to the scheme `{ballot_date}_{canton}.{ext}`, so if the `qstnr_tibble` of the 2018-09-23 survey in the canton of
#' Aargau is input, the following files will be written to `path` by default:
#'
#' - `2018-09-23_aargau.csv`
#' - `2018-09-23_aargau.html`
#' - `2018-09-23_aargau.md`
#' - `2018-09-23_aargau.xlsx`
#'
#' @inheritParams expand_qstnr_tibble
#' @param path Path to the directory to write the generated questionnaire files to. A character scalar.
#' @param verbose Whether or not to print detailed progress information during questionnaire generation and Google Drive file upload. Note that questionnaire
#' generation takes considerably more time when this is set to `TRUE`.
#' @param incl_csv Whether or not to also generate and export a CSV version of the questionnaire.
#' @param incl_html Whether or not to also generate and export an HTML version of the questionnaire.
#' @param incl_xlsx Whether or not to also generate and export an XLSX version of the questionnaire.
#' @param upload_to_g_drive Whether or not to upload the generated files to the Google Drive folder `g_drive_folder`.
#' @param g_drive_folder Google Drive folder to upload the generated files to. Ignored if `upload_to_g_drive = FALSE`.
#'
#' @return `path`, invisibly.
#' @family data_export
#' @export
export_qstnr <- function(qstnr_tibble,
path,
verbose = FALSE,
incl_csv = TRUE,
incl_html = TRUE,
incl_xlsx = incl_html,
upload_to_g_drive = FALSE,
g_drive_folder = "fokus/aargau/Umfragen/Dateien f\u00fcr Umfrageinstitut/Fragebogen/") {
path <- fs::path_abs(path)
fs::dir_create(path)
checkmate::assert_flag(incl_csv)
checkmate::assert_flag(incl_html)
checkmate::assert_flag(incl_xlsx)
if (incl_xlsx && !incl_html) {
cli::cli_abort("{.arg incl_html} must be set to {.val TRUE} when {.code incl_xlsx = TRUE} because the XLSX file is generated from the HTML file.")
}
checkmate::assert_flag(upload_to_g_drive)
rlang::check_installed("rmarkdown",
reason = pal::reason_pkg_required())
rlang::check_installed("yay",
reason = pal::reason_pkg_required())
# extract ballot date and canton from `qstnr_tibble`
ballot_date <- as_ballot_date(unique(qstnr_tibble$ballot_date))
canton <- rlang::arg_match0(arg = unique(qstnr_tibble$canton),
values = all_cantons,
arg_nm = "unique(qstnr_tibble$canton)")
# Generate Markdown version
md_path <- fs::path(path, glue::glue("{ballot_date}_{canton}.md"))
qstnr_tibble |>
gen_qstnr_md() |>
brio::write_lines(path = md_path)
# create CSV version from tibble if requested
if (incl_csv) {
pal::cli_progress_step_quick(msg = "Converting {.val {canton}} @ {.val {ballot_date}} questionnaire tibble to CSV")
csv_path <- fs::path_ext_set(path = md_path,
ext = "csv")
qstnr_tibble |>
clean_qstnr_tibble() |>
dplyr::mutate(variable_name_32 =
purrr::map2_chr(.x = variable_name,
.y = dplyr::if_else(block %in% c("x_polling_agency", "y_generated", "z_generated")
| stringr::str_detect(string = variable_name,
pattern = paste0("^", pal::fuse_regex(c("agreement_contra_argument_",
"information_source_",
"reason_non_participation_",
"political_occasions_")))),
32L,
30L),
.f = ~ shorten_var_names(var_names = .x,
max_n_char = .y)),
.after = variable_name) |>
dplyr::select(-ends_with("_common"),
-c(lvl,
i,
j,
question_intro_i,
question_intro_j,
question_full)) |>
expand_qstnr_tibble() |>
readr::write_csv(file = csv_path,
na = "")
cli::cli_progress_done()
}
# create HTML version from Markdown questionnaire if requested
if (incl_html) {
html_path <- fs::path_ext_set(path = md_path,
ext = "html")
pal::cli_progress_step_quick(msg = "Converting {.val {canton}} @ {.val {ballot_date}} Markdown questionnaire to HTML using Pandoc")
rmarkdown::pandoc_convert(input = md_path,
to = "html5",
from = "markdown",
output = html_path,
options = c("--standalone",
"--css=github-pandoc.css",
glue::glue('--metadata=title:FOKUS-{ stringr::str_to_sentence(canton) }-Fragebogen f\u00fcr den ',
ballot_title(ballot_date = ballot_date,
canton = canton))),
verbose = FALSE)
cli::cli_progress_done()
}
# create XLSX version from HTML questionnaire if requested
if (incl_xlsx) {
pal::cli_progress_step_quick(msg = "Converting {.val {canton}} @ {.val {ballot_date}} HTML questionnaire to XLSX using LibreOffice")
system2(command = "flatpak",
args = glue::glue("run --command=libreoffice",
"org.libreoffice.LibreOffice",
"--calc",
"--headless",
"--convert-to xlsx",
"--outdir \"{path}\"",
"\"{html_path}\"",
.sep = " "),
stdout = ifelse(verbose, "", FALSE))
cli::cli_progress_done()
}
# upload files to Google Drive for polling agency if requested
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = c(md_path,
csv_path[incl_csv],
html_path[incl_html],
fs::path(path, "github-pandoc.css")[incl_html],
fs::path_ext_set(path = html_path,
ext = "xlsx")[incl_xlsx]),
g_drive_folder = g_drive_folder,
quiet = !verbose)
}
invisible(path)
}
#' Export QR codes with personalized survey URL
#'
#' Exports a ZIP file, that contains a [QR code](https://en.wikipedia.org/wiki/QR_code) in SVG and in EPS format for each survey participant storing the
#' personalized survey URL, to the [private FOKUS repository][print_private_repo_structure].
#'
#' @inheritParams lvls
#' @inheritParams export_qstnr
#' @inheritParams upload_to_g_drive
#' @inheritParams read_online_participation_codes
#' @param quiet `r pkgsnip::param_lbl("quiet")`
#' @param verbose Whether or not to print detailed status output from [Google Drive file upload][upload_to_g_drive].
#'
#' @return A [tibble][tibble::tbl_df] containing metadata about the contents of the created ZIP archive, invisibly.
#' @family data_export
#' @export
export_qr_codes <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
upload_to_g_drive = TRUE,
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/QR-Codes/"),
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE,
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(upload_to_g_drive)
checkmate::assert_flag(quiet)
checkmate::assert_flag(verbose)
rlang::check_installed("archive",
reason = pal::reason_pkg_required())
rlang::check_installed("qrencoder",
reason = pal::reason_pkg_required())
rlang::check_installed("rsvg",
reason = pal::reason_pkg_required())
participation_codes <- read_online_participation_codes(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token)
tmp_dir <-
glue::glue("fokus_qr_codes_{ballot_date}_{canton}") |>
fs::path_temp() |>
fs::dir_create()
on.exit(fs::dir_delete(tmp_dir),
add = TRUE,
after = FALSE)
tmp_dir_svg <-
fs::path(tmp_dir, "svg") |>
fs::dir_create()
tmp_dir_eps <-
fs::path(tmp_dir, "eps") |>
fs::dir_create()
# create SVG and EPS image files
if (!quiet) {
cli_id <- pal::cli_progress_step_quick(
msg = "Generating {length(participation_codes)} personalized QR code{?s} in SVG and EPS format for canton {.val {canton}} @ {.val {ballot_date}}"
)
}
participation_codes |>
purrr::walk2(.progress = !quiet,
.x = participation_codes,
.y = _,
.f = ~ {
path_svg <- fs::path(tmp_dir_svg, .x,
ext = "svg")
# create SVG file
url <- url_survey_host |> purrr::chuck(canton)
url_parameter <- url_parameter_survey |> purrr::chuck(canton)
qrencoder::qrencode_svg(to_encode = glue::glue("{url}?{url_parameter}={.x}"),
level = 3L) |>
brio::write_file(path = path_svg)
# create EPS file from SVG file
rsvg::rsvg_eps(svg = path_svg,
file = fs::path(tmp_dir_eps, .x,
ext = "eps"))
})
if (!quiet) {
cli::cli_progress_done(id = cli_id)
}
# create ZIP archive of SVG and EPS files
if (!quiet) {
cli_id <- pal::cli_progress_step_quick(msg = "Compressing SVG and EPS QR code files to ZIP archive")
}
filename_zip <- glue::glue("{ballot_date}_{canton}_qr_codes.zip")
tmp_path_zip <- fs::path(tmp_dir, filename_zip)
result <- archive::archive_write_dir(archive = tmp_path_zip,
dir = tmp_dir,
format = "zip")
if (!quiet) {
cli::cli_progress_done(id = cli_id)
}
# upload ZIP archive to private repo
write_private_file(path = fs::path("generated/for-polling-agency", filename_zip),
content = tmp_path_zip,
from_file = TRUE,
auth_token = auth_token,
quiet = quiet)
# upload ZIP archive to Google Drive for polling agency if requested
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = tmp_path_zip,
g_drive_folder = g_drive_folder,
quiet = quiet || !verbose)
}
invisible(result)
}
#' Export print recipients data
#'
#' Exports a CSV dataset containing the two columns `id` and `receives_print` to the [private FOKUS repository][print_private_repo_structure].
#'
#' @inheritParams export_qr_codes
#'
#' @return `NULL` if no export for the specified ballot date is possible, otherwise a [tibble][tibble::tbl_df] of the exported data, invisibly.
#' @family data_export
#' @export
export_print_recipients <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
upload_to_g_drive = TRUE,
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/Print-Zielgruppen/"),
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE,
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(upload_to_g_drive)
checkmate::assert_flag(quiet)
checkmate::assert_flag(verbose)
# only export if `reminder_print_*` constraint present
if (raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::pluck("constraints") |>
stringr::str_detect("^reminder_print_.+") |>
any()) {
pal::cli_progress_step_quick(msg = "Exporting print recipients data for canton {.val {canton}} @ {.val {ballot_date}}")
# read in statistical office IDs used for current survey
ids <-
read_voting_register_ids(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token) |>
dplyr::pull("id_voting_register")
# ensure output folder exists
filename <- glue::glue("{ballot_date}_{canton}_print_recipients.csv")
tmp_path <- fs::path_temp(filename)
on.exit(fs::file_delete(tmp_path),
add = TRUE,
after = FALSE)
# export data
result <-
read_voting_register_data_extra(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token) |>
dplyr::filter(id %in% !!ids) |>
dplyr::mutate(receives_print = year_of_birth_official < 1970L) |>
dplyr::select(id, receives_print) |>
readr::write_csv(file = tmp_path)
gitlab::file_write(content = tmp_path,
path = fs::path("generated/for-polling-agency", filename),
id_project = repo_private_proj_id,
start_branch = repo_private_default_branch)
write_private_file(path = fs::path("generated/for-polling-agency", filename),
content = tmp_path,
from_file = TRUE,
auth_token = auth_token,
quiet = quiet)
# upload data to Google Drive for polling agency if requested
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = tmp_path,
g_drive_folder = g_drive_folder,
quiet = quiet || !verbose)
}
} else {
cli::cli_alert_info("No print recipients data export sensible or possible for canton {.val {canton}} @ {.val {ballot_date}}.")
result <- NULL
}
invisible(result)
}
#' Export easyvote municipality details
#'
#' Exports a CSV dataset containing the columns `municipality`, `municipality_id`, `min_age` and `max_age` to the [private FOKUS
#' repository][print_private_repo_structure].
#'
#' The meaning of the individual columns is as follows:
#'
#' | **column name** | **description** |
#' | --------------- | --------------- |
#' | `municipality` | official name of the municipality |
#' | `municipality_id` | [official Swiss community identification number](https://en.wikipedia.org/wiki/Community_Identification_Number#Switzerland) (also called "GEOSTAT"/"BFS" number, see the [corresponding German Wikipedia article](https://de.wikipedia.org/wiki/Gemeindenummer)) |
#' | `min_age` | `r var_lbl("easyvote_municipality_min_age")` |
#' | `max_age` | `r var_lbl("easyvote_municipality_max_age")` |
#'
#' @inheritParams export_qr_codes
#'
#' @return A [tibble][tibble::tbl_df] of the exported data, invisibly.
#' @family data_export
#' @export
export_easyvote_municipalities <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
upload_to_g_drive = TRUE,
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/easyvote-Gemeinden/"),
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE,
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(upload_to_g_drive)
checkmate::assert_flag(quiet)
checkmate::assert_flag(verbose)
file_basename <- glue::glue("{ballot_date}_{canton}_easyvote_municipalities")
tmp_path <- fs::file_temp(pattern = file_basename,
ext = "csv")
on.exit(fs::file_delete(tmp_path),
add = TRUE,
after = FALSE)
result <-
read_easyvote_municipalities(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token) |>
# assume 18-25 age range if both min/max age are NA
dplyr::mutate(is_likely_default = is.na(min_age) & is.na(max_age),
min_age = dplyr::if_else(is_likely_default,
18L,
min_age),
max_age = dplyr::if_else(is_likely_default,
25L,
max_age)) |>
dplyr::select(-is_likely_default) |>
readr::write_csv(file = tmp_path)
write_private_file(path = fs::path("generated/for-polling-agency", file_basename,
ext = "csv"),
content = tmp_path,
from_file = TRUE,
auth_token = auth_token,
quiet = quiet)
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = tmp_path,
g_drive_folder = g_drive_folder,
quiet = quiet || !verbose)
}
invisible(result)
}
#' Export generated survey data
#'
#' @description
#' Exports a FOKUS survey dataset generated via *TODO* to the [private FOKUS repository][print_private_repo_structure].
#'
#' @includeRmd data-raw/snippets/merged_data.Rmd
#'
#' @inheritParams write_private_file
#' @param data FOKUS survey dataset. `r pkgsnip::param_lbl("tibble")`
#' @param lang Language. Either `NULL` to read the language from `data`'s `fokus_lang` attribute or one of
#' `r all_langs |> pal::as_md_vals() |> pal::enum_str(sep2 = " or ")`.
#' @param merged Whether or not `data` is a *merged* dataset, i.e. one that includes the data from **all** ballot dates that were covered by FOKUS surveys up
#' until the most recent `ballot_date` contained in `data`. See section *Merged data* below for details.
#'
#' If `NULL`, a merged dataset is assumed if `data` covers multiple `ballot_date`s.
#'
#' @return `data`, invisibly.
#' @family data_export
#' @export
export_survey_data <- function(data,
lang = NULL,
merged = NULL,
auth_token = pal::pkg_config_val("token_repo_private")) {
lang <-
lang %||%
attr(data, "fokus_lang") %||%
cli::cli_abort("{.arg lang} must be explicitly specified since {.arg data} lacks a {.field fokus_lang} attribute to detect the language from.")
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_flag(merged,
null.ok = TRUE)
assert_var_names_present(data = data,
var_names = c("ballot_date", "canton"))
if (is.null(merged)) {
merged <- length(unique(data$ballot_date)) > 1L
}
ballot_date <- checkmate::assert_date(unique(data$ballot_date),
any.missing = FALSE,
min.len = 1L)
canton <- checkmate::assert_character(unique(data$canton),
any.missing = FALSE,
min.len = 1L)
# assemble target path
path <- "generated/survey_data_"
if (!merged) {
if (!checkmate::test_scalar(ballot_date)) {
cli::cli_abort("Column {.var ballot_date} mustn't contain different dates when {.code merged = FALSE}.")
}
if (!checkmate::test_scalar(canton)) {
cli::cli_abort("Column {.var canton} mustn't contain different cantons when {.code merged = FALSE}.")
}
path %<>% paste0("{lang}_{ballot_date}_{canton}")
} else {
if (length(ballot_date) > 1L) {
ballot_date %<>% max()
}
if (length(canton) > 1L) {
path %<>% paste0("merged_{lang}_{ballot_date}")
} else {
path %<>% paste0("merged_{lang}_{ballot_date}_{canton}")
}
}
# write data
data |>
serialize(connection = NULL,
xdr = FALSE) |>
memCompress(type = "xz") |>
write_private_file(path = glue::glue(path, ".rds"),
auth_token = auth_token)
invisible(data)
}
#' Write file to private FOKUS repository
#'
#' Uploads a file to the [private FOKUS repository](`r url_repo_private()`) via [GitLab's RESTful API (v4)](https://docs.gitlab.com/ee/api/rest/).
#'
#' @inheritParams read_private_file
#' @param content File content, as a character scalar for text files, or a [raw vector][raw] for binary files. Or the path to a local file as a character scalar
#' if `from_file = TRUE`.
#' @param from_file Whether or not `content` indicates the path to a local file instead of the actual file content.
#' @param overwrite Whether or not to overwrite an already existing file.
#' @param commit_message Git commit message for file creation/update.
#' @param branch Git branch name to upload the file to.
#' @param quiet `r pkgsnip::param_lbl("quiet")`
#'
#' @return `path`, invisibly.
#' @family data_export
#' @family private
#' @export
write_private_file <- function(path,
content,
from_file = FALSE,
overwrite = TRUE,
commit_message = "auto: update file via fokus R pkg",
branch = repo_private_default_branch,
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE) {
gitlab::file_write(content = content,
path = path,
id_project = repo_private_proj_id,
start_branch = branch,
from_file = from_file,
overwrite = overwrite,
commit_message = commit_message,
token = auth_token,
quiet = quiet)
}
#' Get variable description
#'
#' Extracts a variable's (common) description from the [questionnaire data][qstnrs].
#'
#' If no `ballot_date` and `canton` are specified or `var_name` is not included at `ballot_date`,
#' [`variable_label_common`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) is returned, otherwise
#' [`variable_label`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys). Note that `ballot_date` and `canton` either must both be `NULL` or
#' set to a valid canton name and ballot date respectively.
#'
#' @param var_name Variable name. A character scalar.
#' @param ballot_date `NULL` or a FOKUS-covered ballot date, i.e. one of
#' `r pal::as_md_val_list(as.character(all_ballot_dates))`
#' @param canton `NULL` or a FOKUS-covered canton name, i.e. one of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' @return A character scalar.
#' @family vars
#' @export
#'
#' @examples
#' # if `ballot_date` and `canton` are not supplied, `variable_label_common` is returned:
#' fokus::var_lbl("participation_federal")
#'
#' # otherwise `variable_label`:
#' fokus::var_lbl(var_name = "participation_federal",
#' ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::var_lbl(var_name = "participation_federal",
#' ballot_date = "2019-10-20",
#' canton = "aargau")
var_lbl <- function(var_name,
ballot_date = NULL,
canton = NULL) {
is_common <- is.null(ballot_date) && is.null(canton)
if (!is_common) {
is_arg_invalid <- purrr::map_lgl(list(ballot_date, canton),
is.null)
arg_names <- c("ballot_date", "canton")
if (any(is_arg_invalid)) {
cli::cli_abort(paste0("Either {.arg ballot_date} and {.arg canton} must both be {.val NULL} or set to a valid canton name and ballot date, but ",
"{.arg {arg_names[is_arg_invalid]}} is {.val NULL} while {.arg {arg_names[!is_arg_invalid]}} is ",
"{.val {get(arg_names[!is_arg_invalid])}}."))
}
result <- var_predicate(predicate = "variable_label",
var_name = var_name,
ballot_date = ballot_date,
canton = canton)
is_common <- length(result) == 0L
}
if (is_common) {
result <-
fokus::qstnrs |>
dplyr::filter(variable_name == !!var_name) |>
dplyr::pull("variable_label_common") |>
unique()
}
result
}
#' Determine variable's political level(s)
#'
#' Determines political level(s) of one or more variables.
#'
#' Note that the political levels are determined by simply parsing `var_names`.
#'
#' @inheritParams is_skill_question_var
#'
#' @return A character vector of political levels, of length 0 if no specific levels could be determined.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(lvls = purrr::map(variable_name,
#' fokus::var_lvls)) |>
#' dplyr::filter(purrr::map_lgl(lvls,
#' \(x) length(x) > 0)) |>
#' dplyr::select(variable_name, lvls) |>
#' tidyr::unnest_longer(col = lvls,
#' values_to = "lvl") |>
#' unique()
var_lvls <- function(var_names) {
checkmate::assert_character(var_names)
is_cantonal <- var_names |> stringr::str_detect(pattern = as_sym_part_regex("cantonal")) |> any()
is_federal <- var_names |> stringr::str_detect(pattern = as_sym_part_regex("federal")) |> any()
c("cantonal"[is_cantonal], "federal"[is_federal])
}
#' Determine variable's election procedure
#'
#' Determines the election procedure each variable corresponds to. In case no election procedure could be determined for a variable, `NA_character` is returned.
#'
#' @inherit is_skill_question_var details
#'
#' @inheritParams is_skill_question_var
#'
#' @return A character vector of the same length as `var_names`.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(prcd = fokus::var_prcd(variable_name)) |>
#' dplyr::filter(!is.na(prcd)) |>
#' dplyr::select(variable_name, prcd) |>
#' unique()
var_prcd <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(pattern = paste0(pal::fuse_regex(all_prcds), glue::glue("(?=_election{sym_part_regex_end})")))
}
#' Determine variable's election number
#'
#' Determines the election number each variable corresponds to. In case no election number could be determined for a variable, `NA_character` is returned.
#'
#' @inherit is_skill_question_var details
#'
#' @inheritParams is_skill_question_var
#'
#' @return An integer vector of the same length as `var_names`.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(election_nr = fokus::var_election_nr(variable_name)) |>
#' dplyr::filter(!is.na(election_nr)) |>
#' dplyr::select(variable_name, election_nr) |>
#' unique()
var_election_nr <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(glue::glue("(?<={sym_part_regex_start}election_)\\d+")) |>
as.integer()
}
#' Determine variable's proposal number
#'
#' Determines the proposal number each variable corresponds to. In case no proposal number could be determined for a variable, `NA_character` is returned.
#'
#' @inherit is_skill_question_var details
#'
#' @inheritParams is_skill_question_var
#'
#' @return An integer vector of the same length as `var_names`.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(proposal_nr = fokus::var_proposal_nr(variable_name)) |>
#' dplyr::filter(!is.na(proposal_nr)) |>
#' dplyr::select(variable_name, proposal_nr) |>
#' unique()
var_proposal_nr <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(glue::glue("(?<={sym_part_regex_start}proposal_)\\d+")) |>
as.integer()
}
#' Determine variable's skill question number
#'
#' Determines the skill question number each variable corresponds to. In case no skill question number could be determined for a variable, `NA_character` is
#' returned.
#'
#' @inherit var_proposal_nr details return
#'
#' @inheritParams is_skill_question_var
#'
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(skill_question_nr = fokus::var_skill_question_nr(variable_name)) |>
#' dplyr::filter(!is.na(skill_question_nr)) |>
#' dplyr::select(variable_name, skill_question_nr) |>
#' unique()
var_skill_question_nr <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(glue::glue("(?<={sym_part_regex_start}skill_question_)\\d+")) |>
as.integer()
}
#' Get variable title
#'
#' Extracts a variable's title from the [questionnaire data][qstnrs], adapted to the actual [election_name()] if applicable.
#'
#' @inheritParams lvls
#' @inheritParams var_lbl
#'
#' @return `NULL` if the variable is not present at the specified `ballot_date` and `canton`, otherwise a character scalar.
#' @family vars
#' @export
#'
#' @examples
#' fokus::var_title(var_name = "weight_decision",
#' ballot_date = "2018-11-25",
#' canton = "aargau")
#'
#' fokus::var_title(var_name = "weight_decision",
#' ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::var_title(var_name = "voting_decision_cantonal_proportional_election_1_party",
#' ballot_date = "2024-10-20",
#' canton = "aargau")
var_title <- function(var_name,
ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
ballot_date %<>% as_ballot_date()
lang <- "de"
result <- var_predicate(predicate = "topic",
var_name = var_name,
ballot_date = ballot_date,
canton = canton)
# replace generic with actual election name
prcd <- var_prcd(var_name)
if (!is.na(prcd)) {
lvl <- checkmate::assert_string(var_lvls(var_name))
election_nr <- var_election_nr(var_name)
regex_cut <-
phrased_terms |>
dplyr::filter(term == "lvl") |>
dplyr::pull(!!lang) |>
paste(collapse = "|") %>%
paste0("(?=", ., ")")
if (has_election(ballot_date = ballot_date,
lvls = lvl,
canton = canton,
prcds = prcd)) {
result %<>%
stringr::str_extract(pattern = paste0("^.+?", regex_cut)) %>%
paste0(election_name(ballot_date = ballot_date,
lvl = lvl, canton = canton,
prcd = prcd,
election_nr = election_nr,
lang = lang,
type = "short"),
"\u00a0",
clock::get_year(ballot_date))
}
}
# return `NULL` instead of empty chr vctr
if (length(result) == 0L) {
result <- NULL
}
result
}
#' Get variable's value set
#'
#' Extracts a variable's value set from the [questionnaire data][qstnrs] in the specified language (or its integer representation if `lang = "int"`).
#'
#' @inheritParams lvls
#' @inheritParams var_lbl
#' @param lang Language. One of `r c(all_langs, "int") |> pal::as_md_vals() |> pal::enum_str(sep2 = " or ")` for the value set's integer codes."
#'
#' @return A character scalar.
#' @family vars
#' @export
#'
#' @examples
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2023-06-18",
#' canton = "aargau")
#'
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "en")
#'
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "int")
var_val_set <- function(var_name,
ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = c(all_langs, "int"))
var_predicate(predicate = switch(EXPR = lang,
de = "response_options",
en = "value_labels",
int = "variable_values",
cli::cli_abort("Not implemented. Please debug.",
.internal = TRUE)),
var_name = var_name,
ballot_date = ballot_date,
canton = canton)
}
#' Add variable names to combination list
#'
#' Adds one or more `var_name`s to a combination list.
#'
#' @inheritParams shorten_var_names
#' @param list A list as returned by the `combos_*()` functions like [combos_ballot_types()].
#'
#' @return A list with `list` × `var_names` elements.
#' @family combo
#' @family vars
#' @export
#'
#' @examples
#' fokus::combos_proposals(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_nr = FALSE) |>
#' fokus::add_vars_to_combos(var_names = c("age_group", "favored_party"))
add_vars_to_combos <- function(list,
var_names) {
checkmate::assert_list(list,
any.missing = FALSE)
checkmate::assert_character(var_names,
min.chars = 1L,
any.missing = FALSE)
list |>
purrr::map(\(x) {
purrr::map(var_names,
\(var_name) purrr::assign_in(x = x,
where = "var_name",
value = var_name))
}) |>
purrr::list_flatten()
}
#' Determine whether variable is skill question
#'
#' Determines for each variable whether or not it is a skill question.
#'
#' Note that the determination is performed by simply parsing `var_names`.
#'
#' @param var_names A character vector of FOKUS variable names.
#'
#' @return A logical vector of the same length as `var_names`.
#' @family vars
#' @export
is_skill_question_var <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_detect(pattern = "^skill_question_\\d+_(cantonal|federal)(_proposal_\\d+)?$")
}
#' Relabel factor of election parties
#'
#' Relabels a [factor] that contains election parties from/to the different FOKUS election party name types.
#'
#' @inheritParams election_parties
#' @param fct Factor to be relabelled.
#' @param from_type Name type to convert from. One of `r pal::enum_fn_param_defaults(param = "from_type", fn = fct_relabel_election_parties)`.
#' @param to_type Name type to convert to. One of `r pal::enum_fn_param_defaults(param = "to_type", fn = fct_relabel_election_parties)`.
#' @param strict Whether or not to strictly ensure that all of `fct` levels are matched by [known election parties][election_parties].
#'
#' @return A factor.
#' @seealso [election_parties()]
#' @family fcts
#' @export
#'
#' @examples
#' d <- fokus::read_survey_data(ballot_date = "2024-10-20",
#' canton = "aargau",
#' lang = "de")
#' # before
#' levels(d$voting_decision_cantonal_proportional_election_1_party)
#'
#' fct_new <- fct_relabel_election_parties(
#' fct = d$voting_decision_cantonal_proportional_election_1_party,
#' to_type = "short",
#' ballot_date = "2024-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' election_nr = 1L,
#' past = FALSE
#' )
#'
#' # after
#' levels(fct_new)
#'
#' # set `strict = FALSE` if your factor contains non-standard levels
#' d$voting_decision_cantonal_proportional_election_1_party |>
#' forcats::fct_lump_min(other_level = "Kleinparteien",
#' min = 5L) |>
#' fct_relabel_election_parties(to_type = "short",
#' ballot_date = "2024-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' election_nr = 1L,
#' past = FALSE,
#' strict = FALSE) |>
#' levels()
fct_relabel_election_parties <- function(fct,
from_type = c("qstnr", "run", "short"),
to_type = c("short", "run", "qstnr"),
ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election",
prcds = "proportional"),
canton = cantons(ballot_date),
election_nr = 1L,
past = FALSE,
strict = TRUE) {
from_type <- rlang::arg_match(from_type)
to_type <- rlang::arg_match(to_type)
checkmate::assert_flag(strict)
ref <-
election_parties(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
election_nr = election_nr,
past = past) |>
# TODO: determine below "none" val dynamically instead of hardcoding it
tibble::add_row(code = 0L,
name.de.qstnr = "keine (leer eingelegt oder nicht teilgenommen)",
name.de.run = name.de.qstnr,
name.de.short = "keine",
.before = 1L)
checkmate::assert_factor(fct,
levels = if (strict) ref[[paste0("name.de.", from_type)]])
forcats::fct_relabel(.f = fct,
.fun = \(fct_lvls) purrr::map_chr(fct_lvls,
\(old_val) {
new_val <-
ref |>
dplyr::filter(!!as.symbol(paste0("name.de.", from_type)) == old_val) |>
dplyr::pull(paste0("name.de.", to_type))
if (length(new_val) != 1L) {
new_val <- old_val
}
new_val
}))
}
#' Shorten variable names to a maximum length of 32 characters
#'
#' @param var_names A character vector of variable names.
#' @param reverse Whether to apply the inversion of the shortening logic, i.e. to restore original/unshortened variable names.
#' @param max_n_char Maximum allowed number of characters. It is ensured that the maximum resulting variable name length doesn't exceed this limit. Has no
#' influence on the applied shortening logic. An integerish scalar or `Inf` for no limit.
#'
#' @return A character vector of the same length as `var_names`.
#' @family var_name_shortening
#' @export
shorten_var_names <- function(var_names,
reverse = FALSE,
max_n_char = 32L) {
checkmate::assert_character(var_names,
any.missing = FALSE)
checkmate::assert_flag(reverse)
if (!isTRUE(is.infinite(max_n_char))) {
checkmate::assert_count(max_n_char)
}
rules <- shortening_rules
if (reverse) colnames(rules) %<>% .[c(2L, 1L, 3L)]
rules %<>% dplyr::mutate(pattern = purrr::map2_chr(
.x = string,
.y = allowed_at,
.f = ~ .y |> pal::when(. == "begin" ~
paste0("^", .x, "(?=_)"),
. == "middle" ~
paste0("(?<=_)", .x, "(?=_)"),
. == "end" ~
paste0("(?<=_)", .x, "$"),
. == "begin-middle" ~
paste0("(?<=(^|_))", .x, "(?=_)"),
. == "begin-end" ~
paste0("(^", .x, "(?=_)|(?<=_)", .x, "$)"),
. == "middle-end" ~
paste0("(?<=_)", .x, "(?=(_|$))"),
. == "begin-middle-end" ~
paste0("(?<=(^|_))", .x, "(?=(_|$))"),
~ cli::cli_abort("Unknown {.var allowed_at} type: {.val {.}}.",
.internal = TRUE))
))
pattern_replacement <- rules$replacement
names(pattern_replacement) <- rules$pattern
var_names_new <- var_names |> stringr::str_replace_all(pattern = pattern_replacement)
# ensure we did our job
if (!is.null(max_n_char) && !reverse && any(nchar(var_names_new) > max_n_char)) {
# NOTE: `cli::cli_abort()` doesn't properly print the output of `pal::capture_print()` because:
# - it just seems to ignore the output if it includes ANSI escape sequences (this can be worked around by an additional `cli::ansi_strip()`)
# - it normalizes whitespace chars **incl. tabs** to a single regular whitespace, thus breaking the formatting
rlang::abort(glue::glue("There are still variable names left of a length greater than {max_n_char} characters after applying `shorten_var_names()`. ",
"Affected are the following (shortened) variable names:\n\n",
tibble::tibble(var_name = var_names,
var_name_short = var_names_new,
n_char = nchar(var_names),
n_char_short = nchar(var_names_new)) |>
dplyr::filter(n_char_short > max_n_char) |>
pal::capture_print(collapse = "\n"),
.null = NA_character_,
.trim = FALSE))
}
var_names_new
}
#' Shorten column names to a maximum length of 32 characters
#'
#' This is useful for DTA export since Stata has a built-in variable name length limit of [32
#' characters](https://www.stata.com/manuals/r.pdf#rLimits) (see also
#' [here](https://www.statalist.org/forums/forum/general-stata-discussion/general/1452366-number-of-characters-in-variable-names)).
#'
#' @inheritParams shorten_var_names
#' @param x `r pkgsnip::param_lbl("tbl_data")`
#'
#' @return `x` with column names shortened to a maximum length of 32 characters.
#' @family var_name_shortening
#' @export
shorten_colnames <- function(x,
max_n_char = 32L) {
x |> magrittr::set_colnames(value = shorten_var_names(var_names = colnames(x),
max_n_char = max_n_char))
}
#' Restore original/unshortened column names
#'
#' Applies the inversion of [shorten_colnames()].
#'
#' @inheritParams shorten_colnames
#' @inheritParams shorten_var_names
#'
#' @return `x` with original/unshortened column names restored.
#' @family var_name_shortening
#' @export
restore_colnames <- function(x) {
x |> magrittr::set_colnames(value = shorten_var_names(var_names = colnames(x),
reverse = TRUE))
}
#' Phrase term
#'
#' Transforms a term's value into a phrased string representation.
#'
#' @inheritParams lang_to_locale
#' @param term Term to be phrased. A character scalar.
#' @param vals Value(s) of `term` to be phrased. A character vector.
#'
#' @return A character scalar.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase(term = "side",
#' vals = c("pro", "pro", "contra"),
#' lang = "de")
phrase <- function(term,
vals,
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
term <- rlang::arg_match(arg = term,
values = unique(phrased_terms_tidy$term))
data <- phrased_terms_tidy |> dplyr::filter(term == !!term & lang == !!lang)
vals <- rlang::arg_match(arg = vals,
values = unique(data$value),
multiple = TRUE)
vals |>
purrr::map_chr(\(val) {
data$phrase[data$value == val]
})
}
#' Phrase (ballot) date
#'
#' Phrases a date according to the specified `format` and `lang`.
#'
#' @inheritParams salim::phrase_datetime
#' @inheritParams lang_to_locale
#'
#' @return A character scalar.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase_date()
phrase_date <- function(x = pal::pkg_config_val("ballot_date"),
format = "date_long",
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
salim::phrase_datetime(x = x,
format = format,
locale = lang)
}
#' Phrase majoritarian election's candidate(s)
#'
#' Assembles one or more majoritarian election candidate strings consisting of the candidate's first name, last name and optionally political party (in
#' parentheses).
#'
#' @inheritParams n_election_seats
#' @param candidate_nrs Election candidate numbers to include. A vector of positive integers or `NULL`. If `NULL`, all candidates will be included.
#' @param incl_party Whether or not to include the candidate's political party in the resulting string (in parentheses).
#'
#' @return A character vector.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase_election_candidate(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' candidate_nrs = 1:3)
phrase_election_candidate <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L,
candidate_nrs = NULL,
incl_party = TRUE) {
data_candidates <- election_candidates(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
election_nr = election_nr)
checkmate::assert_integerish(candidate_nrs,
lower = 1L,
upper = nrow(data_candidates),
any.missing = FALSE,
null.ok = TRUE)
checkmate::assert_flag(incl_party)
if (length(candidate_nrs)) {
data_candidates %<>% dplyr::filter(dplyr::row_number() %in% candidate_nrs)
}
data_candidates |> purrr::pmap_chr(\(first_name, last_name, party, ...) paste0(first_name, " ", last_name, paste0(" (", party, ")")[incl_party]))
}
#' Get declined German proposal name
#'
#' Declines a German [proposal name][proposal_name] to the specified grammatical `case`. Simple convenience function combining [proposal_name()],
#' [proposal_name_gender()] and [salim::decline_noun_de()].
#'
#' @inheritParams proposal_name
#' @inheritParams salim::decline_noun_de
#'
#' @return A character scalar.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase_proposal_name_de(ballot_date = "2023-06-18",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "short",
#' case = "dative")
#'
#' fokus::phrase_proposal_name_de(ballot_date = "2023-06-18",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "short",
#' case = "genitive")
phrase_proposal_name_de <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_name_types,
case = c("nominative", "genitive", "dative", "accusative")) {
rlang::check_installed("salim",
reason = pal::reason_pkg_required())
proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
lang = "de",
type = type) |>
salim::decline_noun_de(gender = proposal_name_gender(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
type = type),
case = case)
}
#' Authorize googledrive using GCP Service Account Key
#'
#' Authorizes the googledrive package to access and manage files on your Google Drive via a [Google Cloud Platform (GCP) Service
#' Account Key](https://cloud.google.com/iam/docs/creating-managing-service-account-keys) file (in JSON format). See the [relevant
#' documentation](https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly) for details.
#'
#' The recommended way to provide the filesystem path to the GCP Service Account Key file is to set the [environment
#' variable](https://en.wikipedia.org/wiki/Environment_variable) `PATH_GCP_KEY_ZDA` to that path, e.g. via the [`.Renviron`
#' file](https://rstats.wtf/r-startup.html#renviron).
#'
#' @param path_gcp_service_account_key Path to the GCP Service Account Key JSON file.
#'
#' @return `path_gcp_service_account_key`, invisibly.
#' @family g_apps
#' @keywords internal
auth_g_drive_gcp <- function(path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA")) {
rlang::check_installed("googledrive",
reason = pal::reason_pkg_required())
is_file <- checkmate::test_file_exists(path_gcp_service_account_key,
access = "r")
if (is_file) {
googledrive::drive_auth(path = path_gcp_service_account_key,
use_oob = TRUE)
} else {
cli::cli_abort(paste0("No Google Cloud Platform service account key found under {.path {path_gcp_service_account_key}}. ",
"Instructions to store such a key can be found here: ",
"{.url https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly}"))
}
invisible(path_gcp_service_account_key)
}
#' Authorize googlesheets4 using GCP Service Account Key
#'
#' Authorizes the googlesheets4 package to access and manage Google Sheets via a [Google Cloud Platform (GCP) Service
#' Account Key](https://cloud.google.com/iam/docs/creating-managing-service-account-keys) file (in JSON format). See the [relevant
#' documentation](https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly) for details.
#'
#' The recommended way to provide the filesystem path to the GCP Service Account Key file is to set the [environment
#' variable](https://en.wikipedia.org/wiki/Environment_variable) `PATH_GCP_KEY_ZDA` to that path, e.g. via the [`.Renviron`
#' file](https://rstats.wtf/r-startup.html#renviron).
#'
#' @param path_gcp_service_account_key Path to the GCP Service Account Key JSON file.
#'
#' @return `path_gcp_service_account_key`, invisibly.
#' @family g_apps
#' @keywords internal
auth_g_sheets_gcp <- function(path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA")) {
rlang::check_installed("googlesheets4",
reason = pal::reason_pkg_required())
is_file <- checkmate::test_file_exists(path_gcp_service_account_key,
access = "r")
if (is_file) {
googlesheets4::gs4_auth(path = path_gcp_service_account_key,
use_oob = TRUE)
} else {
cli::cli_abort(paste0("No Google Cloud Platform service account key found under {.path {path_gcp_service_account_key}} ",
"Instructions to store such a key can be found here: ",
"{.url https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly}"))
}
invisible(path_gcp_service_account_key)
}
#' Backup Google Drive file locally
#'
#' Creates a local backup of a [Google Drive](https://en.wikipedia.org/wiki/Google_Drive) file.
#'
#' Essentially a convenience wrapper around [googledrive::drive_download()].
#'
#' If a [Google Sheet](https://en.wikipedia.org/wiki/Google_Sheets) that includes multiple worksheets is backed up to a file `type` that doesn't support
#' worksheets like `"csv"`, only the default (first) worksheet is written. In contrast, [backup_g_sheet()] allows to specify any worksheet to be backed up (but
#' always writes a single worksheet only regardless of the filetype).
#'
#' @inheritParams g_file_mod_time
#' @inheritParams upload_to_g_drive
#' @param path Path to the local file backup destination. A character scalar.
#' @param type Desired type of the Google Drive file to be backed up. Only consulted if `g_id` identifies a native Google Apps file. Will be processed via
#' [googledrive::drive_mime_type()], so it can either be a file extension like `"pdf"`, a full MIME type like `"application/pdf"`, or `NULL` to determine the
#' type based on the file extension of `path` (if none is specified, falls back on the default type determined by the [Google Drive
#' API](https://developers.google.com/drive/api/v3/)). Note that `type` takes precedence over a possible file extension of `path`, but specifying only the
#' latter should normally suffice.
#' @param overwrite Whether or not to overwrite an already existing file under `path`.
#' @param force Whether or not to force overwriting the file regardless whether it has changed since the last backup or not.
#'
#' @return An object of class [dribble][googledrive::dribble], a tibble with one row per file if local backup was (over)written, otherwise `NULL`, meaning
#' the remote file hasn't deviated from the local backup since the last run, invisibly.
#' @family g_apps
#' @export
backup_g_file <- function(g_id,
path,
type = NULL,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA"),
overwrite = TRUE,
force = FALSE,
quiet = TRUE) {
checkmate::assert_string(g_id)
checkmate::assert_path_for_output(path,
overwrite = TRUE)
checkmate::assert_flag(overwrite)
checkmate::assert_flag(force)
checkmate::assert_flag(quiet)
rlang::check_installed("googledrive",
reason = pal::reason_pkg_required())
if (quiet) {
googledrive::local_drive_quiet()
}
result <- NULL
remote_mod <- g_file_mod_time(g_id,
path_gcp_service_account_key = path_gcp_service_account_key)
local_mod <- ifelse(fs::file_exists(path),
pal::path_mod_time(path),
lubridate::as_datetime(0L))
if (local_mod < remote_mod || force) {
result <- googledrive::drive_download(file = googledrive::as_id(g_id),
path = path,
type = type,
overwrite = overwrite)
}
invisible(result)
}
#' Backup Google Sheet locally
#'
#' Creates a local backup of a [Google Sheet](https://en.wikipedia.org/wiki/Google_Sheets). It is accessed via [googlesheets4::read_sheet()] and written via
#' [readr::write_csv()] or [writexl::write_xlsx()], depending on the file extension of `path`.
#'
#' `backup_g_sheet()` only backs up a single worksheet at once (specified by the optional `sheet` argument). If you intend to backup multiple worksheets of the
#' same Google Sheet, consider using [backup_g_file()] in combination with a file `type` that supports multiple worksheets like `"ods"` or `"xlsx"`.
#'
#' @inheritParams backup_g_file
#' @inheritParams googlesheets4::read_sheet
#' @param ... Further arguments passed on to [googlesheets4::read_sheet()].
#' @param quiet Whether or not to [suppress printing status output from googledrive][googledrive::local_drive_quiet] and [googlesheets4
#' operations][googlesheets4::local_gs4_quiet].
#'
#' @return A [tibble][tibble::tbl_df] if the local backup was (over)written, otherwise `NULL`, meaning the remote file hasn't deviated from the local backup
#' since the last run, invisibly.
#' @family g_apps
#' @export
backup_g_sheet <- function(g_id,
path,
...,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA"),
overwrite = TRUE,
force = FALSE,
quiet = TRUE) {
checkmate::assert_string(g_id)
checkmate::assert_path_for_output(path,
overwrite = TRUE)
checkmate::assert_flag(overwrite)
checkmate::assert_flag(force)
checkmate::assert_flag(quiet)
rlang::check_installed("googledrive",
reason = pal::reason_pkg_required())
rlang::check_installed("googlesheets4",
reason = pal::reason_pkg_required())
pal::check_dots_named(...,
.fn = googlesheets4::read_sheet,
.forbidden = "ss")
if (quiet) {
googledrive::local_drive_quiet()
googlesheets4::local_gs4_quiet()
}
# authenticate Google account
auth_g_drive_gcp(path_gcp_service_account_key)
# ensure `g_id` refers to a spreadsheet
mime_type <-
googledrive::drive_get(id = g_id) |>
dplyr::pull("drive_resource") |>
dplyr::first() |>
purrr::chuck("mimeType")
if (mime_type != "application/vnd.google-apps.spreadsheet") {
cli::cli_abort("The supplied {.arg g_id} {.val {g_id}} doesn't seem to refer to a Google Sheet. Its Google Drive MIME type is {.val {mime_type}}.")
}
data <- NULL
remote_mod <- g_file_mod_time(g_id,
path_gcp_service_account_key = path_gcp_service_account_key)
local_mod <- ifelse(fs::file_exists(path),
pal::path_mod_time(path),
lubridate::as_datetime(0L))
if (local_mod < remote_mod || force) {
# authenticate Google account
auth_g_sheets_gcp(path_gcp_service_account_key)
filetype <- fs::path_ext(path)
data <- googlesheets4::read_sheet(ss = g_id,
...)
if (overwrite || !fs::file_exists(path)) {
filetype |>
pal::when(. == "csv" ~
readr::write_csv(x = data,
file = path,
na = ""),
. == "xlsx" ~ {
rlang::check_installed("writexl",
reason = pal::reason_pkg_required())
writexl::write_xlsx(x = data,
path = path)
},
. == "" ~
cli::cli_abort("{.arg path} must have a file extension ({.file .csv} or {.file .xlsx})."),
~ cli::cli_abort("Exporting filetype {.file {.}} is not yet implemented."))
} else {
cli::cli_alert_warning("A file already exists under {.arg path} {.file {path}} but {.arg overwrite} was set to {.val FALSE}. Nothing done.")
}
}
invisible(data)
}
#' Upload files to Google Drive
#'
#' Uploads one or more files to Google Drive.
#'
#' Essentially a convenience wrapper around [googledrive::drive_put()].
#'
#' @inheritParams g_file_mod_time
#' @param filepaths Local path(s) to the file(s) to be uploaded.
#' @param g_drive_folder Destination path on Google Drive where the files are to be uploaded to.
#' @param quiet Whether or not to [suppress printing status output from googledrive operations][googledrive::local_drive_quiet].
#'
#' @return `filepaths`, invisibly.
#' @family g_apps
#' @export
upload_to_g_drive <- function(filepaths,
g_drive_folder,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA"),
quiet = FALSE) {
checkmate::assert_character(filepaths,
any.missing = FALSE)
checkmate::assert_string(g_drive_folder)
checkmate::assert_flag(quiet)
# mute googledrive msgs if requested
if (quiet) googledrive::local_drive_quiet()
# extract filenames
filenames <- fs::path_file(filepaths)
# authenticate Google account
auth_g_drive_gcp(path_gcp_service_account_key)
# upload files
pal::cli_progress_step_quick(msg = "Uploading {length(filepaths)} file{?s} to Google Drive folder {.field {g_drive_folder}}")
purrr::walk2(.x = filenames,
.y = filepaths,
.f = ~ {
# overwrite existing file if possible or create new one otherwise
googledrive::drive_put(media = .y,
path = g_drive_folder,
name = .x)
})
invisible(filepaths)
}
#' Get Google Drive file modification timestamp
#'
#' @param g_id Google Drive file ID. A character scalar.
#' @param path_gcp_service_account_key Path to the GCP Service Account Key JSON file. See [auth_g_drive_gcp()] for details.
#'
#' @return `r pkgsnip::return_lbl("datetime")`
#' @family g_apps
#' @export
g_file_mod_time <- function(g_id,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA")) {
auth_g_drive_gcp(path_gcp_service_account_key = path_gcp_service_account_key)
googledrive::drive_get(id = g_id) |>
dplyr::pull("drive_resource") |>
dplyr::first() |>
purrr::chuck("modifiedTime") |>
lubridate::as_datetime()
}
#' Convert logical vector to Unicode symbols `r unicode_checkmark` and `r unicode_crossmark`
#'
#' @param x A logical vector.
#'
#' @return A character vector.
#' @export
#'
#' @examples
#' fokus::lgl_to_unicode(c(TRUE, TRUE, FALSE, NA))
lgl_to_unicode <- function(x) {
checkmate::assert_logical(x)
dplyr::if_else(x,
unicode_checkmark,
unicode_crossmark)
}
#' Emphasize xth element of character vector (Markdown)
#'
#' @param x Input as a character vector.
#' @param which Indices of the elements to be emphasized.
#' @param emph Character sequence used for emphasis.
#'
#' @return A character vector of the same length as `x`.
#' @export
md_emphasize <- function(x,
which = TRUE,
emph = "**") {
x[which] %<>% paste0(emph, ., emph)
x
}
#' `r this_pkg` package configuration metadata
#'
#' A [tibble][tibble::tbl_df] with metadata of all possible `r this_pkg` package configuration options. See [pal::pkg_config_val()] for more information.
#'
#' @format `r pkgsnip::return_lbl("tibble_cols", cols = colnames(pkg_config))`
#' @export
#'
#' @examples
#' fokus::pkg_config
"pkg_config"
zdaarau/fokus documentation built on Dec. 24, 2024, 10:47 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions raw_qstnr_suppl_proposal raw_qstnr_suppl_lvl_canton raw_qstnr_suppl_lvl raw_qstnr_suppl .onLoad
Documented in raw_qstnr_suppl raw_qstnr_suppl_lvl raw_qstnr_suppl_lvl_canton raw_qstnr_suppl_proposal
# DO NOT EDIT THIS FILE BY HAND! Instead edit the R Markdown source file `Rmd/fokus.Rmd` and run `pkgpurl::purl_rmd()`.
# See `README.md#r-markdown-format` for more information on the literate programming approach used applying the R Markdown format.
# fokus: Provides an API around the FOKUS Post-voting Surveys
# Copyright (C) 2024 Centre for Democracy Studies Aarau (ZDA)
#
# This program is free software: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License as published by the Free
# Software Foundation, either version 3 of the License, or any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
.onLoad <- function(libname, pkgname) {
# clear pkgpins cache
tryCatch(expr = pkgpins::clear_cache(board = pkgpins::board(pkg = pkgname),
max_age = pal::pkg_config_val(key = "global_max_cache_age",
pkg = pkgname)),
error = function(e) cli::cli_alert_warning(text = "Failed to clear pkgpins cache on load of {.pkg {pkgname}}. Error message: {e$message}"))
}
utils::globalVariables(names = c(".",
# tidyselect fns
"all_of",
"any_of",
"ends_with",
"everything",
"starts_with",
"where",
# other
"alignment",
"allowed_at",
"block",
"date_begin",
"date_end",
"enumerator",
"enumerator_base",
"full_expressions",
"Geschlecht",
"has_fallback",
"has_same_length",
"Haushaltsgr\u00f6sse Anzahl Personen Total",
"Haushaltsgr\u00f6sse Anzahl Personen \u00fcber 18 Jahren",
"household_size_official",
"i",
"id",
"ID-Nummer",
"is_likely_default",
"j",
"Jahrgang",
"length_response_options",
"length_value_labels",
"length_variable_values",
"lvl",
"marital_status_official",
"matches_length",
"max_age",
"min_age",
"n_adults_in_household_official",
"n_cantonal_majoritarian_elections",
"n_cantonal_proportional_elections",
"n_cantonal_proposals",
"n_char_short",
"n_federal_majoritarian_elections",
"n_federal_proportional_elections",
"n_federal_proposals",
"n_kids_in_household_official",
"name",
"name.de.qstnr",
"nr",
"question",
"question_full",
"question_intro_i",
"question_intro_j",
"receives_print",
"response_options",
"sep",
"sex_official",
"string",
"term",
"topic",
"value_labels",
"variable_label",
"variable_name",
"variable_values",
"who",
"width",
"year_of_birth_official",
"Zivilstand"))
#' Raw FOKUS questionnaire data
#'
#' A structured list of the raw questionnaire data of the FOKUS surveys.
#'
#' @format `r pkgsnip::return_lbl("strict_list")`
#' @docType data
#' @family qstnr_raw
#' @keywords internal
#'
#' @name raw_qstnr
NULL
#' Raw supplemental date-specific FOKUS questionnaire data
#'
#' A structured list of raw supplemental date-specific questionnaire data of the FOKUS surveys.
#'
#' @format `r pkgsnip::return_lbl("strict_list")`
#' @docType data
#' @family qstnr_raw
#' @keywords internal
#'
#' @name raw_qstnrs_suppl
#'
#' @examples
#' fokus:::raw_qstnrs_suppl[["2018-09-23"]]$mode
NULL
#' Get raw supplemental date-specific FOKUS questionnaire data
#'
#' Returns a structured list of the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnrs_suppl] for the specified ballot date.
#'
#' @inheritParams cantons
#'
#' @return `r pkgsnip::return_lbl("strict_list")`
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl(ballot_date = "2018-09-23") |> _$mode
raw_qstnr_suppl <- function(ballot_date = pal::pkg_config_val("ballot_date")) {
ballot_date %<>% as_ballot_date_chr()
raw_qstnrs_suppl[[ballot_date]]
}
#' Get a political level's raw supplemental date-specific FOKUS questionnaire data
#'
#' Returns a structured list of the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl] for the specified ballot date and political
#' level.
#'
#' @inheritParams cantons
#' @param lvl Political level. One of `r pal::enum_fn_param_defaults(param = "lvl", fn = raw_qstnr_suppl_lvl)`.
#'
#' @inherit raw_qstnr_suppl return seealso
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_lvl(ballot_date = "2018-09-23",
#' lvl = "cantonal") |>
#' names()
raw_qstnr_suppl_lvl <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls) {
lvl <- rlang::arg_match(lvl)
result <- raw_qstnr_suppl(ballot_date = ballot_date) |> purrr::pluck(lvl)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
cli::cli_abort("No {.val {lvl}} level present in the supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result
}
#' Get a canton's political-level-specific raw supplemental date-specific FOKUS questionnaire data
#'
#' Returns a structured list of the [raw supplemental date-specific FOKUS questionnaire data for the specified ballot date and political
#' level][raw_qstnr_suppl_lvl] that applies for the specified canton only.
#'
#' @inheritParams raw_qstnr_suppl_lvl
#' @inheritParams lvls
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_lvl_canton(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau") |>
#' names()
raw_qstnr_suppl_lvl_canton <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton")) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <-
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = lvl) |>
purrr::pluck(canton)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
cli::cli_abort("No {.val {lvl}} supplemental {.val {ballot_date}} FOKUS questionnaire data present for canton {.val {canton}}.")
}
result
}
#' Get raw proposal supplemental questionnaire data
#'
#' Returns a structured list of a proposal's data from the [supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @param proposal_nr Proposal number. A positive integerish scalar.
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_proposal(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1) |>
#' _$name
raw_qstnr_suppl_proposal <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
lvl <- rlang::arg_match(lvl)
checkmate::assert_count(proposal_nr,
positive = TRUE)
proposals <-
lvl |>
pal::when(. == "federal" ~
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = .),
~ raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = .,
canton = canton)) |>
purrr::pluck("proposal")
if (is.null(proposals)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} proposals present",
" for {.val {canton}}"[lvl == "cantonal"],
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
proposal <- proposals |> purrr::pluck(as.character(proposal_nr))
if (is.null(proposal)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} proposal {.val {proposal_nr}} present",
" for {.val {canton}}"[lvl == "cantonal"],
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
proposal
}
#' Safely get raw proposal supplemental questionnaire data
#'
#' Returns a structured list of a proposal's data from the [supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl], or `NULL` if no referendums
#' proposals were covered.
#'
#' @inheritParams raw_qstnr_suppl_proposal
#' @param proposal_nr Proposal number. Either a positive integerish scalar or `NULL` to return the data for all proposals.
#'
#' @return A [strict list][xfun::strict_list()], or `NULL` if no referendums proposals were covered.
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_proposal_safe(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
raw_qstnr_suppl_proposal_safe <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = NULL) {
lvl <- rlang::arg_match(lvl)
checkmate::assert_count(proposal_nr,
positive = TRUE,
null.ok = TRUE)
if (lvl == "cantonal") {
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
}
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck(lvl) |>
pal::when(lvl == "cantonal" ~ purrr::pluck(., canton),
~ .) |>
purrr::pluck("proposal") |>
pal::when(is.null(proposal_nr) ~ .,
~ purrr::pluck(., proposal_nr))
}
#' Get a proposal's raw name supplemental questionnaire data
#'
#' Returns a structured list of proposal name data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_proposal_name(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2)
raw_qstnr_suppl_proposal_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
result <-
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("name")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No names present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a proposal's raw argument supplemental questionnaire data
#'
#' Returns a structured list of argument data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_arguments(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2)
raw_qstnr_suppl_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
result <-
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("argument")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No arguments present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a proposal argument's raw supplemental questionnaire data
#'
#' Returns a structured list of a proposal argument's data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_arguments
#' @inheritParams proposal_argument
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_argument(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2,
#' side = "pro",
#' argument_nr = 2)
raw_qstnr_suppl_argument <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L,
side = all_argument_sides,
argument_nr = 1L) {
side <- rlang::arg_match(side)
checkmate::assert_count(argument_nr,
positive = TRUE)
result <-
raw_qstnr_suppl_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::keep(\(x) x$side %in% side && x$nr %in% argument_nr) |>
dplyr::first()
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {side}} argument {.val {argument_nr}} present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a proposal's raw main motive supplemental questionnaire data
#'
#' Returns a structured list of main motive data from the [proposal-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_proposal].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_main_motives(ballot_date = "2018-11-25",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 2)
raw_qstnr_suppl_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = 1L) {
result <-
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("main_motive")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No main motives present for {.val {lvl}} proposal {.val {proposal_nr}} ",
"in {.val {canton}} "[lvl == "cantonal"],
"in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get raw supplemental election questionnaire data
#'
#' Returns a structured list of election data from the [canton's political-level-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_lvl_canton].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_elections(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau") |>
#' _$skill_questions_source
raw_qstnr_suppl_elections <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton")) {
result <-
raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::pluck("election")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort("No {.val {lvl}} elections for canton {.val {canton}} present in the supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result
}
#' Get an election's raw supplemental questionnaire data
#'
#' Returns a structured list of an election's data from the [canton's political-level-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_lvl_canton].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @inheritParams election_name
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_election(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "majoritarian") |>
#' _$n_seats
raw_qstnr_suppl_election <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
prcd = all_prcds,
election_nr = 1L) {
prcd <- rlang::arg_match(prcd)
checkmate::assert_count(election_nr,
positive = TRUE)
result <-
raw_qstnr_suppl_elections(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::pluck(prcd)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} {.val {prcd}} elections for canton {.val {canton}} present in the supplemental {.val {ballot_date}} FOKUS ",
"questionnaire data."))
}
result %<>% purrr::pluck(as.character(election_nr))
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No {.val {lvl}} {.val {prcd}} election {.val {election_nr}} for canton {.val {canton}} present in the supplemental ",
"{.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get raw supplemental election name questionnaire data
#'
#' Returns a structured list of an election's name data from the [political-level-specific raw supplemental date-specific FOKUS questionnaire
#' data][raw_qstnr_suppl_lvl].
#'
#' @inheritParams raw_qstnr_suppl_election
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_election_name(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "majoritarian")
raw_qstnr_suppl_election_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
prcd = all_prcds,
election_nr = 1L) {
lvl <- rlang::arg_match(lvl)
prcd <- rlang::arg_match(prcd)
checkmate::assert_count(election_nr,
positive = TRUE)
# federal proportional election names are defined once for all cantons together
if (lvl == "federal" && prcd == "proportional") {
result <-
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = lvl) |>
purrr::chuck("election", prcd, as.character(election_nr))
} else {
result <- raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd,
election_nr = election_nr)
}
result %<>% purrr::pluck("name")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No names present for {.val {lvl}} {.val {prcd}} election {.val {election_nr}} in canton {.val {canton}} in the supplemental ",
"{.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get raw supplemental survey mode questionnaire data
#'
#' Returns a structured list of survey mode data from the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_mode(ballot_date = "2018-09-23",
#' canton = "aargau")
raw_qstnr_suppl_mode <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = pal::pkg_config_val("canton")) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <-
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck("mode", canton)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
cli::cli_abort("No survey mode data present for canton {.val {canton}} in supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result
}
#' Get raw supplemental skill question questionnaire data
#'
#' Returns a structured list of skill question data from the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_proposal
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, non-proposal-specific skill question data is returned.
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_skill_questions(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1) |>
#' purrr::map_depth(1L, "de") |>
#' purrr::list_c(ptype = character())
raw_qstnr_suppl_skill_questions <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = NULL) {
lvl <- rlang::arg_match(lvl)
result <-
lvl |>
pal::when(
# federal non-proposal-specific skill questions (e.g. at federal elections)
length(proposal_nr) == 0L && . == "federal" ~
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = .),
# cantonal non-proposal-specific skill questions (e.g. at cantonal elections)
length(proposal_nr) == 0L && . == "cantonal" ~
raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = .,
canton = canton),
# federal or cantonal proposal-specific skill questions
~ raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = .,
canton = canton,
proposal_nr = proposal_nr)) |>
purrr::pluck("skill_question")
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No skill questions present",
ifelse(length(proposal_nr) == 0L,
paste0(" on the {.val {lvl}} level",
" for {.val {canton}}"[lvl == "cantonal"]),
" for {.val {lvl}} proposal {.val {proposal_nr}}"),
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data."))
}
result
}
#' Get a single skill question's raw supplemental questionnaire data
#'
#' Returns a structured list of a single skill question's data from the [raw supplemental date-specific FOKUS questionnaire data][raw_qstnr_suppl].
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @inheritParams skill_question
#'
#' @inherit raw_qstnr_suppl return
#' @family qstnr_raw
#' @keywords internal
#'
#' @examples
#' fokus:::raw_qstnr_suppl_skill_question(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 1)
raw_qstnr_suppl_skill_question <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = pal::pkg_config_val("canton"),
proposal_nr = NULL,
skill_question_nr = 1L) {
checkmate::assert_count(skill_question_nr,
positive = TRUE)
result <-
raw_qstnr_suppl_skill_questions(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck(skill_question_nr)
if (is.null(result)) {
# reduce to proper arg values for error msg
ballot_date %<>% as_ballot_date()
lvl <- rlang::arg_match(lvl)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
cli::cli_abort(paste0("No skill question {.val {skill_question_nr}} present",
ifelse(length(proposal_nr) == 0L,
paste0(" on the {.val {lvl}} level", " for {.val {canton}}"[lvl == "cantonal"]),
" for {.val {lvl}} proposal {.val {proposal_nr}}"),
" in the supplemental {.val {ballot_date}} FOKUS questionnaire data. Only {length(skill_questions)} skill questions included."))
}
result
}
#' Pick right raw questionnaire value
#'
#' Picks the right value of a certain raw questionnaire key based on ballot date and canton (recursively).
#'
#' @inheritParams raw_qstnr_suppl_lvl_canton
#' @param x Questionnaire key. A list object.
#' @param key Questionnaire key name, used to determine the correct default value fallback. A character scalar or `NULL`. If `NULL`, no fallback is used (and an
#' error is thrown in case none of the subkeys matches).
#'
#' @return Value of `x` that corresponds to `canton` and `ballot_date`.
#' @family qstnr_raw
#' @keywords internal
raw_pick_right <- function(x,
key = NULL,
ballot_date,
canton) {
# force evaluation of `ballot_date`, `canton` and `key` to ensure immediate error (with better msg) in case they are missing
ballot_date %<>% as_ballot_date_chr()
canton
key
if (purrr::pluck_depth(x) > 1L) {
x <-
pick_right_helper(x = x,
key = key,
ballot_date = ballot_date,
canton = canton) |>
raw_pick_right(key = key,
ballot_date = ballot_date,
canton = canton)
}
x
}
pick_right_helper <- function(x,
ballot_date,
canton,
key) {
if (purrr::is_list(x) && (length(x) > 1L || purrr::pluck_depth(x) > 1L)) {
# create plain ballot date as in subkeys
ballot_date_squeezed <- stringr::str_remove_all(string = ballot_date,
pattern = stringr::fixed("-"))
# convert ballot date to type date
ballot_date %<>% clock::date_parse()
# handle begin-end date subkeys
begin_end_subkeys <-
names(x) |>
stringr::str_subset(pattern = "^\\d+_\\d+$")
matches_begin_end_subkeys <-
begin_end_subkeys |>
purrr::map_lgl(function(x) {
begin <- x |> stringr::str_extract(pattern = "^\\d+") |> lubridate::as_date()
end <- x |> stringr::str_extract(pattern = "\\d+$") |> lubridate::as_date()
begin <= ballot_date && ballot_date <= end
})
# integrity check: ensure there aren't any overlapping intervals
if (length(which(matches_begin_end_subkeys)) > 1L) {
cli::cli_abort(c("Illegal overlapping interval subkeys found: {.var {begin_end_subkeys[matches_begin_end_subkeys]}}",
">" = "Please fix this and run again."),
.internal = TRUE)
}
ballot_types <- ballot_types(ballot_date = ballot_date,
canton = canton)
x <- names(x) |> pal::when(
# canton and ballot date
## consider overrides for binary keys
canton %in% x[["false"]] || ballot_date %in% x[["false"]] ~ FALSE,
canton %in% x[["true"]] || ballot_date %in% x[["true"]] ~ TRUE,
## consider overrides for non-binary keys
### single canton subkey
canton %in% . ~ x[[canton]],
### single date subkey
ballot_date_squeezed %in% . ~ x[[ballot_date_squeezed]],
### begin-end date subkey
any(matches_begin_end_subkeys) ~ x[[begin_end_subkeys[matches_begin_end_subkeys]]],
# consider overrides for ballot types (we take the first one in case of ambiguity)
any(ballot_types %in% .) ~ x[[intersect(., ballot_types)[1L]]],
# return default value if defined
"default" %in% . ~ x[["default"]],
# fall back on key's default value if no subkey matches canton and ballot date
key %in% qstnr_item_keys$key ~ unlist(qstnr_item_keys$default_val[qstnr_item_keys$key == key]),
# abort in any remaining case
~ cli::cli_abort("Undefined behavior, please debug. {.arg {key}} is {.val {key}}, {.arg {x}} is {.field {x}}.",
.internal = TRUE)
)
}
x
}
init_heritable_map <- function(block) {
xfun::strict_list(lvl = "?",
i = NA_integer_,
j = NA_integer_,
block = block,
variable_name = "???",
topic = NULL,
who = "alle",
question_intro_i = NULL,
question_intro_j = NULL,
question = NULL,
question_full = NULL,
question_common = NULL,
allow_multiple_answers = FALSE,
variable_label = "???",
variable_label_common = NULL,
response_options = NULL,
variable_values = NULL,
value_labels = NULL,
value_scale = "nominal",
randomize_response_options = FALSE,
is_mandatory = FALSE,
ballot_types = all_ballot_types,
include = TRUE)
}
resolve_qstnr_val <- function(x,
ballot_date,
canton,
key,
lvl,
i,
j,
...) {
ballot_date %<>% as_ballot_date_chr()
checkmate::assert_string(lvl,
na.ok = TRUE,
null.ok = TRUE)
checkmate::assert_count(i,
na.ok = TRUE,
null.ok = TRUE)
checkmate::assert_count(j,
na.ok = TRUE,
null.ok = TRUE)
x |>
raw_pick_right(key = key,
ballot_date = ballot_date,
canton = canton) |>
pal::when(is.character(.) ~ interpolate_qstnr_val(.,
ballot_date = ballot_date,
canton = canton,
key = key,
lvl = lvl,
i = i,
j = j,
... = ...),
~ .) |>
# convert to proper type
pal::when(
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "character"] ~
as.character(.),
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "logical"] ~
as.logical(.),
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "integer"] ~
as.integer(.),
key %in% qstnr_item_keys$key[qstnr_item_keys$type == "double"] ~
as.double(.),
# undefined behaviour
~ cli::cli_abort("Undefined behaviour in {.fun resolve_qstnr_val}. Please debug.",
.internal = TRUE)
)
}
interpolate_qstnr_val <- function(x,
ballot_date,
canton,
key,
lvl,
i,
j,
...) {
# assign objects in dots to current env ensuring glue/cli fns respect them
rlang::env_bind(.env = rlang::current_env(),
...)
if (key %in% qstnr_item_keys$key[qstnr_item_keys$is_scalar]) {
result <- cli::pluralize(x,
.na = NULL,
.null = NA_character_,
.trim = FALSE)
} else {
result <-
x |>
purrr::map(\(x) glue::glue(x,
.envir = rlang::current_env(),
.na = NULL,
.null = NA_character_,
.trim = FALSE)) |>
unlist()
}
result
}
#' Generate questionnaire tibble
#'
#' @inheritParams ballot_title
#' @param verbose Whether or not to print detailed progress information during questionnaire generation. Note that it will take considerably more time when this
#' is set to `TRUE`.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_gen
#' @keywords internal
gen_qstnr_tibble <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(verbose)
cli::start_app(theme = cli_theme)
pal::cli_progress_step_quick(msg = "Generating {.val {canton}} @ {.val {ballot_date}} questionnaire tibble")
purrr::map2_dfr(.x = raw_qstnr,
.y = names(raw_qstnr),
.f = ~ {
if (verbose && !(.y %in% qstnr_non_item_lvls)) cli::cli_h1("BLOCK: {.val {.y}}")
assemble_qstnr_tibble(ballot_date = ballot_date,
canton = canton,
raw_qstnr_branch = .x,
qstnr_lvl = .y,
heritable_map = init_heritable_map(block = .y),
verbose = verbose)
}) |>
# add ballot date and canton
dplyr::mutate(ballot_date = !!ballot_date,
canton = !!canton,
.before = 1L)
}
assemble_qstnr_tibble <- function(ballot_date,
canton,
raw_qstnr_branch,
qstnr_lvl,
heritable_map,
verbose) {
if (verbose && stringr::str_detect(qstnr_lvl, "\\..+\\.item$")) {
cli::cli_h2("BRANCH PATH: {.val {stringr::str_remove(qstnr_lvl, '\\\\.item$')}}")
}
map <- heritable_map
# only complement with non-table-array qstnr lvls (would be completely wrong to complement with the `item` table arrays, which are also *unnamed* lists)
if (rlang::is_named(raw_qstnr_branch)) {
map %<>%
purrr::list_modify(!!!raw_qstnr_branch) %>%
purrr::keep_at(at = qstnr_item_keys$key)
}
result <- NULL
if ("variable_name" %in% names(raw_qstnr_branch)) {
result <- assemble_qstnr_item_tibble(ballot_date = ballot_date,
canton = canton,
item_map = map,
verbose = verbose)
} else if (purrr::pluck_depth(raw_qstnr_branch) > 2L) {
result <- purrr::map2_dfr(.x = raw_qstnr_branch,
.y = names(raw_qstnr_branch) %||% seq_along(raw_qstnr_branch),
.f = ~ assemble_qstnr_tibble(ballot_date = ballot_date,
canton = canton,
raw_qstnr_branch = .x,
qstnr_lvl = paste(qstnr_lvl, .y,
sep = "."),
heritable_map = map,
verbose = verbose))
}
result
}
assemble_qstnr_item_tibble <- function(ballot_date,
canton,
item_map,
verbose) {
# iterate over `lvl`...
resolve_qstnr_val(x = item_map$lvl,
ballot_date = ballot_date,
canton = canton,
key = "lvl",
lvl = "",
i = NA_integer_,
j = NA_integer_) |>
purrr::map(
.f = function(lvl) {
# ...`i`...
resolve_qstnr_val(x = item_map$i,
ballot_date = ballot_date,
canton = canton,
key = "i",
lvl = lvl,
i = NA_integer_,
j = NA_integer_) |>
purrr::map(
lvl = lvl,
.f = function(i,
lvl) {
# ...and `j`
resolve_qstnr_val(x = item_map$j,
ballot_date = ballot_date,
canton = canton,
key = "j",
lvl = lvl,
i = i,
j = NA_integer_) |>
purrr::map(
i = i,
lvl = lvl,
.f = function(j,
i,
lvl) {
# respect keys `include` and `ballot_types`
is_incl <- resolve_qstnr_val(x = item_map$include,
ballot_date = ballot_date,
canton = canton,
key = "include",
lvl = lvl,
i = i,
j = j)
has_ballot_type <-
resolve_qstnr_val(x = item_map$ballot_types,
ballot_date = ballot_date,
canton = canton,
key = "ballot_types",
lvl = lvl,
i = i,
j = j) |>
intersect(ballot_types(ballot_date = ballot_date,
canton = canton)) |>
rlang::is_empty() |>
magrittr::not()
result <- NULL
if (is_incl && has_ballot_type) {
if (verbose) cli::cli_h3("ITEM: {.var {item_map$variable_name}}")
# resolve all keys in item map
result <-
names(item_map) |>
setdiff(c("lvl",
"i",
"j",
"ballot_types",
"include")) %>%
magrittr::set_names(x = .,
value = .) |>
purrr::map(~ {
if (verbose) cli::cli_progress_step("KEY: {.field {.x}}")
# pre-resolve `question` for dependent `question_full` resolution
if (.x == "question_full") {
question <- resolve_qstnr_val(x = item_map[["question"]],
ballot_date = ballot_date,
canton = canton,
key = "question",
lvl = lvl,
i = i,
j = j)
} else {
question <- NA_character_
}
resolve_qstnr_val(x = item_map[[.x]],
ballot_date = ballot_date,
canton = canton,
key = .x,
lvl = lvl,
i = i,
j = j,
question = question) |>
pal::when(
# replace empty scalars with NA
length(.) == 0L && .x %in% qstnr_item_keys$key[qstnr_item_keys$is_scalar] ~
.[NA],
# wrap vectors in list
.x %in% qstnr_item_keys$key[!qstnr_item_keys$is_scalar] ~
list(.),
~ .
)
}) |>
# add iterators
c(lvl = lvl,
i = i,
j = j)
# handle special cases
## 1: fill empty non-iterator multi-value keys with NA(s) if all other non-empty multi-value keys have the same length
lengths_multi_val_keys <-
qstnr_item_keys_multival %>%
magrittr::set_names(., .) |>
purrr::map_int(\(x) length(result[[x]][[1L]]))
positive_lengths_multi_val_keys <-
lengths_multi_val_keys %>%
magrittr::extract(. > 0L)
if (any(lengths_multi_val_keys == 0L) && length(unique(positive_lengths_multi_val_keys)) == 1L) {
for (k in (lengths_multi_val_keys %>%
magrittr::extract(. == 0L) |>
names())) {
result[[k]] <- list(rep(result[[k]][[1L]][NA],
times = length(result[[names(positive_lengths_multi_val_keys)[1L]]][[1L]])))
}
}
## 2: if no `question_common` is defined, fall back on
## a) `question_full.default`
## b) `question.default`
## c) `question_full`
## if either exists and actually differs from `question`
if (is.null(result$question_common)) {
question_common_fallback <-
item_map |>
pal::when("default" %in% names(.$question_full) ~
resolve_qstnr_val(x = item_map$question_full$default,
ballot_date = ballot_date,
canton = canton,
key = "question_full",
lvl = lvl,
i = i,
j = j),
"default" %in% names(.$question) ~
resolve_qstnr_val(x = item_map$question$default,
ballot_date = ballot_date,
canton = canton,
key = "question",
lvl = lvl,
i = i,
j = j),
~ result$question_full)
if (isTRUE(question_common_fallback != result$question)) {
result$question_common <- question_common_fallback
}
}
## 3: if no `variable_label_common` is defined, fall back on `variable_label.default` if it exists and actually differs from
## variable_label`
if (is.null(result$variable_label_common) && "default" %in% names(item_map$variable_label)) {
default_variable_label <- resolve_qstnr_val(x = item_map$variable_label$default,
ballot_date = ballot_date,
canton = canton,
key = "variable_label",
lvl = lvl,
i = i,
j = j)
if (isTRUE(default_variable_label != result$variable_label)) {
result$variable_label_common <- default_variable_label
}
}
## 4: add `who`-constraint to `variable_label` and `variable_label_common`
### get English `who` value
who_en <-
raw_qstnr$who |>
purrr::detect(\(x) result$who == cli::pluralize(x$value$de,
.null = NA_character_,
.trim = FALSE)) |>
purrr::chuck("value", "en") |>
cli::pluralize(.null = NA_character_,
.trim = FALSE)
### add who-constraints
if (!is.null(result$variable_label_common)
&& !is.na(result$variable_label_common)
&& !has_who_constraint(result$variable_label_common)) {
# ensure `who` doesn't vary over time
if (length(item_map$who) > 1L) {
cli::cli_abort(paste0("{.field who} of variable {.var {result$variable_name}} has changed over time. Thus an explicit {.field who}-",
"constraint has to be specified at the end of {.field variable_label_common} in the raw ",
"{.file questionnaire.toml}."),
.internal = TRUE)
}
result$variable_label_common %<>% add_who_constraint(who = who_en)
}
result$variable_label %<>% add_who_constraint(who = who_en)
}
# convert result to tibble
tibble::as_tibble(result)
}) |>
purrr::list_rbind()
}) |>
purrr::list_rbind()
}) |>
purrr::list_rbind()
}
#' Expand questionnaire tibble to long format
#'
#' Expands a [questionnaire tibble][gen_qstnr_tibble] to [long format](https://en.wikipedia.org/wiki/Wide_and_narrow_data).
#'
#' @param qstnr_tibble Questionnaire tibble as returned by [gen_qstnr_tibble()].
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_gen
#' @keywords internal
expand_qstnr_tibble <- function(qstnr_tibble) {
# run integrity checks...
validate_qstnr_tibble(qstnr_tibble) |>
# ...expand questionnaire data to long format...
tidyr::unnest(cols = any_of(qstnr_item_keys_multival))
}
clean_qstnr_tibble <- function(qstnr_tibble) {
qstnr_tibble |>
# remove (single) placeholders
dplyr::mutate(dplyr::across(any_of(qstnr_item_keys_multival) & where(\(x) is.character(x[[1L]])),
\(col) purrr::map(col,
\(x) {
if (length(x) == 1L && isTRUE(stringr::str_detect(x, "^_.+_$"))) {
character()
} else {
x
}
}))) |>
# strip MD
dplyr::mutate(dplyr::across(where(is.character),
pal::strip_md),
dplyr::across(where(is.list) & where(\(x) is.character(x[[1L]])),
\(x) purrr::map(x,
pal::strip_md)))
}
validate_qstnr_tibble <- function(qstnr_tibble) {
# integrity check 1: ensure there are no duplicated topics, variable names and variable labels
c("topic",
"variable_name",
"variable_label") |>
purrr::walk(.f = function(var) {
is_dup <- duplicated(qstnr_tibble[[var]])
if (any(is_dup)) {
dup_indices <- which(is_dup)
for (i in dup_indices) {
dup_var <- qstnr_tibble[[var]][i]
cli::cli_alert_warning(paste0("{.var {var}} {.val {dup_var}} is included more than once in the questionnaire."))
}
}
})
# integrity check 2: ensure all multi-value columns have the same length or alternatively are empty, and if not, tell which ones don't
multi_val_var_lengths <-
qstnr_tibble |>
dplyr::mutate(dplyr::across(where(is.list),
lengths),
.keep = "none") |>
dplyr::rename_with(\(x) paste0("length_", x)) |>
dplyr::mutate(matches_length = length_variable_values == 0L | length_value_labels == 0L | length_variable_values == length_value_labels) |>
dplyr::mutate(matches_length =
matches_length & (length_response_options == 0L | length_value_labels == 0L | length_response_options == length_value_labels),
matches_length =
matches_length & (length_response_options == 0L | length_variable_values == 0L | length_response_options == length_variable_values))
i_violated <- which(!multi_val_var_lengths$matches_length)
if (length(i_violated)) {
multi_val_var_names <-
qstnr_tibble |>
dplyr::select(where(is.list)) |>
colnames()
# print affected variable names first since long error msg gets truncated
cli::cli({
cli::cli_alert_danger("Affected variable names:")
cli::cli_ul(items = qstnr_tibble$variable_name[i_violated])
})
bullets <-
qstnr_tibble$variable_name[i_violated] |>
purrr::map_chr(\(x) glue::glue("{{.var {x}}}")) |>
rlang::set_names("*")
cli::cli_abort(c("The number of {.var {multi_val_var_names}} differs for the following variable names:",
bullets),
.internal = TRUE)
}
invisible(qstnr_tibble)
}
has_who_constraint <- function(x) {
isTRUE(stringr::str_detect(string = x,
pattern = "(\\(|; )(\\d{4}-\\d{2}-\\d{2} )?only [^\\)]+\\)$"))
}
add_who_constraint <- function(x,
who) {
if (who != "all") {
result <- who %>% pal::when(endsWith(x, ")") ~ stringr::str_replace(string = x,
pattern = "\\)$",
replacement = paste0("; only *", ., "*)")),
~ paste0(x, " (only *", ., "*)"))
} else {
result <- x
}
result
}
#' Generate Markdown questionnaire
#'
#' @inheritParams expand_qstnr_tibble
#' @param incl_title Whether or not to generate an `<h1>` questionnaire title at the beginning of the document. If the result is intended to be fed to Pandoc,
#' it's recommended to set this to `FALSE` and provide the title via [Pandoc's `--metadata` option](https://pandoc.org/MANUAL.html#option--metadata) instead.
#'
#' @return A character vector.
#' @family qstnr_gen
#' @keywords internal
gen_qstnr_md <- function(qstnr_tibble,
incl_title = FALSE) {
# ensure we have a single ballot date and canton
ballot_date <-
qstnr_tibble |>
dplyr::pull("ballot_date") |>
unique() |>
as_ballot_date()
canton <-
qstnr_tibble |>
dplyr::pull("canton") |>
unique() |>
rlang::arg_match0(values = all_cantons,
arg_nm = "unique(qstnr_tibble$canton)")
pal::cli_progress_step_quick(msg = "Generating {.val {canton}} @ {.val {ballot_date}} Markdown questionnaire")
block_lines <-
qstnr_tibble |>
# add block title and across-block item enumerator base/group
dplyr::mutate(enumerator_base =
block |>
purrr::map_int(\(x) raw_qstnr |> purrr::pluck(x, "prefix",
.default = 0L))) |>
# add across-block item enumerator
dplyr::group_by(enumerator_base) |>
dplyr::group_modify(\(d, k) tibble::rowid_to_column(d,
var = "enumerator")) |>
dplyr::ungroup() |>
dplyr::mutate(enumerator = enumerator_base + enumerator) |>
dplyr::arrange(block, enumerator) |>
# iterate over every block and generate block header plus table
dplyr::group_by(block) |>
dplyr::group_map(~ {
block <- .y$block
block_nr <- block_name_to_nr(block)
block_title <- raw_qstnr |> purrr::chuck(block, "title")
block_intro <-
raw_qstnr |>
purrr::pluck(block, "intro") |>
raw_pick_right(key = "intro",
ballot_date = ballot_date,
canton = canton) |>
cli::pluralize(.trim = FALSE)
c(glue::glue("## Block {block_nr}: {block_title}",
.null = NA_character_),
"",
block_intro,
""[length(block_intro)],
qstnr_md_table_header,
qstnr_md_table_body(qstnr_tibble_block = .x,
block = block),
"",
"")
}) |>
purrr::list_c(ptype = character())
# add title, technical notes, introduction, footnotes and link references
title <- glue::glue("# FOKUS-{ stringr::str_to_sentence(canton) }-Fragebogen f\u00fcr den ",
ballot_title(ballot_date = ballot_date,
canton = canton),
"\n",
.trim = FALSE)
technical_notes <-
raw_qstnr$who |>
# assemble who lines
purrr::map_depth(.depth = 1L,
.f = function(who_map) {
lvl <- resolve_qstnr_val(x = who_map$lvl %||% "",
ballot_date = ballot_date,
canton = canton,
key = "lvl",
lvl = "",
i = 1L,
j = 1L)
i <- resolve_qstnr_val(x = who_map$i %||% 1L,
ballot_date = ballot_date,
canton = canton,
key = "i",
lvl = "",
i = 1L,
j = 1L)
j <- resolve_qstnr_val(x = who_map$j %||% 1L,
ballot_date = ballot_date,
canton = canton,
key = "j",
lvl = "",
i = 1L,
j = 1L)
value <-
lvl |>
purrr::map(\(lvl) {
i |>
purrr::map(lvl = lvl,
\(lvl, i) {
j |>
purrr::map_chr(lvl = lvl,
i = i,
.f = \(lvl, i, j) {
glue::glue(who_map$value$de,
.null = NA_character_,
.trim = FALSE)
})
})
}) |>
purrr::flatten() |>
purrr::list_c(ptype = character())
description <-
lvl |>
purrr::map(\(lvl) {
i |>
purrr::map(lvl = lvl,
\(lvl, i) {
j |>
purrr::map_chr(lvl = lvl,
i = i,
.f = \(lvl, i, j) {
# hack to support desc variation @ 2024-10-20
if ("de" %in% names(who_map$description)) {
result <- glue::glue(who_map$description$de,
.null = NA_character_,
.trim = FALSE)
} else {
result <-
who_map$description[[stringr::str_remove_all(ballot_date, "-")]] %||%
who_map$description$default |>
purrr::chuck("de") |>
glue::glue(.null = NA_character_,
.trim = FALSE)
}
result
})
})
}) |>
purrr::flatten() |>
purrr::list_c(ptype = character())
# reduce to who's that actually occur in data
ix_keep <- which(value %in% qstnr_tibble$who)
value %<>% magrittr::extract(ix_keep)
description %<>% magrittr::extract(ix_keep)
glue::glue("- { md_emphasize(value) }: { description }")
}) |>
purrr::list_c(ptype = character()) %>%
c("## Technische Vorbemerkungen",
"",
"### `Wer`",
"",
"Die Spalte `Wer` dient dem Fragebogen-Routing. Sie kennt folgende Werte:",
"",
.,
"",
md_snippets$qstnr_technical_notes_multiple_responses,
md_snippets$qstnr_technical_notes_free_text_fields)
footnotes <-
raw_qstnr$footnote |>
# reduce to footnotes that actually occur in table body
purrr::keep(~ any(stringr::str_detect(block_lines, glue::glue("\\[\\^{.x$id}\\]",
.null = NA_character_)))) |>
purrr::map(~ c(glue::glue("[^{.x$id}]: ", glue::glue(.x$text,
.null = NA_character_,
.trim = FALSE),
.null = NA_character_,
.trim = FALSE),
"")) |>
purrr::list_c(ptype = character())
link_refs <-
raw_qstnr$link |>
# reduce to link references that actually occur in table body
purrr::keep(~ any(stringr::str_detect(block_lines, glue::glue("\\[[^]]+\\]\\[{.x$id}\\]",
.null = NA_character_)))) |>
purrr::map(~ c(glue::glue("[{.x$id}]: {.x$url}",
.null = NA_character_),
"")) |>
purrr::list_c(ptype = character())
c(title[incl_title],
technical_notes,
paste0(glue::glue(md_snippets$qstnr_introduction,
.envir = rlang::current_env(),
.na = NULL,
.null = NA_character_,
.trim = TRUE),
"\n"),
block_lines,
footnotes,
link_refs)
}
qstnr_md_table_body <- function(qstnr_tibble_block,
block) {
qstnr_tibble_block |>
# replace logicals by German ja/nein
dplyr::mutate(dplyr::across(where(is.logical),
\(x) ifelse(x,
"ja",
"nein"))) |>
purrr::pmap_chr(function(ballot_date,
canton,
enumerator,
variable_name,
topic,
who,
question_intro_i,
question_intro_j,
question,
allow_multiple_answers,
variable_label,
response_options,
variable_values,
value_labels,
randomize_response_options,
is_mandatory,
i,
j,
...) {
paste(enumerator,
tidyr::replace_na(topic,
"-"),
who,
question |> pal::when(is.na(.) ~ "-",
~ c(c(question_intro_i[isTRUE(i == 1L && j %in% c(1L, NA_integer_))],
question_intro_j[isTRUE(j == 1L)]) %>%
magrittr::extract(!is.na(.)) |>
pal::as_str(),
.) %>%
magrittr::extract(!is.na(.)) |>
pal::as_str(sep = " <br><br>")),
allow_multiple_answers,
pal::wrap_chr(variable_name,
wrap = "`"),
shorten_var_names(var_names = variable_name,
max_n_char = ifelse(block %in% c("x_polling_agency", "y_generated", "z_generated")
|| stringr::str_detect(string = variable_name,
pattern = paste0("^", pal::fuse_regex(c("agreement_contra_argument_",
"information_source_",
"reason_non_participation_",
"political_occasions_")))),
32L,
30L)) |>
pal::wrap_chr("`"),
variable_label,
response_options |>
pal::when(is_skill_question_var(variable_name) ~
format_md_multival_col(x = .,
collapse_break = FALSE) |>
md_emphasize(which = skill_question_answer_nr(ballot_date = ballot_date,
lvl = var_lvls(var_names = variable_name),
canton = canton,
proposal_nr =
var_proposal_nr(variable_name) |>
pal::when(is.na(.) ~ NULL,
~ .),
skill_question_nr = var_skill_question_nr(variable_name))) |>
collapse_break(),
~ format_md_multival_col(.)),
format_md_multival_col(variable_values),
format_md_multival_col(value_labels),
randomize_response_options,
is_mandatory,
sep = " | ")
})
}
format_md_multival_col <- function(x,
collapse_break = TRUE) {
result <- x
if (all(is.na(x))) {
result <- "-"
} else if (length(x) > 1L
&& all(stringr::str_detect(string = x,
pattern = "^_.+_$",
negate = TRUE),
na.rm = TRUE)) {
result <-
x |>
pal::wrap_chr(wrap = "`") |>
pal::when(collapse_break ~ collapse_break(.),
~ .)
}
result
}
block_name_to_nr <- function(x) {
x |>
stringr::str_extract("^.[^_]?(_\\d)?") |>
stringr::str_replace("_(\\d)", "-\\1") |>
stringr::str_remove("^0") |>
stringr::str_to_upper()
}
#' Extract questionnaire item field value
#'
#' Extracts a single questionnaire item field value for every first- for every second-level iterator from the [raw FOKUS questionnaire data][raw_qstnr] based on
#' the specified variable name and branch path.
#'
#' When used in questionnaire item field values via [string interpolation][glue::glue], be careful to not create infinite loops via circular references.
#'
#' @inheritParams ballot_title
#' @param var_name Variable name, without resolved string interpolation, i.e. 1:1 as stated in the raw FOKUS questionnaire data. A character scalar.
#' @param branch_path Sequence of questionnaire table levels that lead to the `item` leaf node where `var_name` is defined. A character vector.
#' @param key Questionnaire item key. One of
#' `r pal::as_md_val_list(qstnr_item_keys$key)`
#' @param lvl Political-level loop iterator that can be referred to in field value via [string interpolation][glue::glue]. A character vector.
#' @param i Second-level loop iterator that can be referred to in field value via [string interpolation][glue::glue]. An integerish vector.
#' @param j Third-level loop iterator that can be referred to in field value via [string interpolation][glue::glue]. An integerish vector.
#'
#' @return A vector of the resolved item field values. Type and length of resolved values depend on `key`.
#' @family qstnr_internal
#' @keywords internal
#'
#' @examples
#' fokus:::qstnr_item_val(ballot_date = "2018-09-23",
#' canton = "aargau",
#' branch_path = c("03_proposal_specific", "004_participants"),
#' var_name = "appeal_federal_proposals",
#' key = "include")
#'
#' fokus:::qstnr_item_val(
#' ballot_date = "2019-10-20",
#' canton = "aargau",
#' branch_path = c("02_political_start", "002_non_participation",
#' "003_election", "z01_hypothetical"),
#' var_name = "hypothetical_voting_decision_federal_majoritarian_election_{i}_seat_{j}",
#' key = "topic",
#' i = 1:2,
#' j = 1:3
#' )
qstnr_item_val <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
branch_path,
var_name,
key = qstnr_item_keys$key,
lvl = "?",
i = NA_integer_,
j = NA_integer_) {
ballot_date %<>% as_ballot_date_chr()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_character(branch_path,
any.missing = FALSE,
min.len = 1L)
if ("item" %in% branch_path) {
cli::cli_abort("{.arg branch_path} must be specified {.emph without} the {.val item} leaf node.")
}
checkmate::assert_string(var_name)
key <- rlang::arg_match(key)
item_map <-
raw_qstnr |>
purrr::chuck(!!!branch_path, "item") |>
purrr::keep(.p = \(x) isTRUE(x$variable_name == var_name)) |>
purrr::list_flatten()
if (!rlang::has_name(x = item_map, name = "variable_name")) {
cli::cli_abort(paste0("There is no item with {.arg variable_name} {.val {var_name}} defined under the questionnaire branch path {.field ",
cli::ansi_collapse(x = branch_path,
x = branch_path,
sep = " -> ",
sep2 = " -> ",
last = " -> "),
"}."))
}
# traverse questionnaire branch path and complement heritable map
parent_map <- init_heritable_map(block = branch_path[1L])
for (branch_depth in purrr::accumulate(branch_path, c)) {
parent_map <-
raw_qstnr |>
purrr::chuck(!!!branch_depth) %>%
purrr::list_modify(.x = parent_map,
!!!.) |>
purrr::keep_at(at = qstnr_item_keys$key)
}
# evaluate requested item value
raw_val <-
parent_map |>
purrr::list_modify(!!!item_map) |>
purrr::chuck(key)
lvl |>
purrr::map(function(lvl) {
i |>
purrr::map(lvl = lvl,
.f = function(i,
lvl) {
j |>
purrr::map(i = i,
lvl = lvl,
.f = function(j,
i,
lvl) {
resolve_qstnr_val(x = raw_val,
ballot_date = ballot_date,
canton = canton,
key = key,
lvl = lvl,
i = i,
j = j)
})
})
}) |>
unlist()
}
#' Get political parties
#'
#' Returns a tibble of ballot-date-specific political party metadata defined in the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_internal
#' @keywords internal
qstnr_parties <- function(ballot_date = pal::pkg_config_val("ballot_date")) {
ballot_date <- as_ballot_date(ballot_date)
raw_qstnr |>
purrr::chuck("party") |>
purrr::map(~ {
tibble::tibble_row(code = .x$code,
de.long = .x$de$long,
de.short = .x$de$short,
en.short = .x$en$short %||% .x$de$short,
date_begin = .x$date_begin %||% clock::date_build(year = 1970L,
month = 1L,
day = 1L),
date_end = .x$date_end %||% as.Date(Inf))
}) |>
purrr::list_rbind() |>
dplyr::filter(date_begin <= ballot_date & date_end >= ballot_date)
}
#' Get response option codes
#'
#' Extracts response option codes of the specified type(s) from the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' Note that only codes of recurring response options are returned which are defined under the `response_options` top-level key in the file
#' `data-raw/questionnaire/questionnaire.toml`.
#'
#' @param types Response option types. One or more of
#' `r pal::as_md_val_list(all_response_option_types)`
#'
#' @return An integer vector.
#' @family qstnr_internal
#' @keywords internal
#'
#' @examples
#' fokus:::qstnr_response_option_codes(types = "abstain")
#'
#' fokus:::qstnr_response_option_codes(types = c("dunno",
#' "custom",
#' "abstain"))
qstnr_response_option_codes <- function(types = all_response_option_types) {
types <- rlang::arg_match(arg = types,
multiple = TRUE)
types |> purrr::map_int(\(x) raw_qstnr |> purrr::chuck("response_options", x, "code"))
}
#' Determine questionnaire data's value label column
#'
#' Determines the [questionnaire data][qstnrs] column that holds variable value labels, returned as a [symbol][as.symbol].
#'
#' The questionnaire data column that holds variable value labels is language-dependent. While the column
#' `r qstnr_lbl_col_sym("de") |> as.character() |> pal::wrap_chr("\x60")` holds the German value labels, their English counterpars are found in the column
#' `r qstnr_lbl_col_sym("en") |> as.character() |> pal::wrap_chr("\x60")`. `qstnr_lbl_col_sym()` is intended to ease language-agnostic questionnaire data
#' programming.
#'
#' @inheritParams lang_to_locale
#'
#' @return `r pkgsnip::return_lbl("sym")`
#' @family qstnr_predicate
#' @keywords internal
#'
#' @examples
#' fokus:::qstnr_lbl_col_sym(lang = "de")
#'
#' fokus:::qstnr_lbl_col_sym(lang = "en")
qstnr_lbl_col_sym <- function(lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
as.symbol(ifelse(lang == "de",
"response_options",
"value_labels"))
}
#' Print structure of the private FOKUS repository
#'
#' Returns a textual representation of the structure of the private FOKUS repository, formatted as a Markdown [fenced code
#' block](https://pandoc.org/MANUAL.html#extension-fenced_code_blocks).
#'
#' @includeRmd data-raw/snippets/fokus_private_description.Rmd
#'
#' @return A character scalar.
#' @family private
#' @keywords internal
print_private_repo_structure <- function() {
pal::cat_lines("``` default")
fokus_private_structure |> pal::flatten_path_tree() |> pal::draw_path_tree()
pal::cat_lines("```",
"",
"The following placeholders are used in the schema above:",
"",
"- `...` for further files and/or folders",
"- `*` for a variable character sequence",
"- `#` for a count starting with `1`",
"- `{canton}` for the name of the FOKUS-covered canton (in lower case), e.g. `aargau`",
"- `{ballot_date}` for the FOKUS-covered ballot date (in the format `YYYY-MM-DD`), e.g. `2018-09-23`",
paste0("- `{date_delivery_statistical_office}` for the delivery date of the voting register data provided by the cantonal statistical ",
"office (in the format `YYYY-MM-DD`), e.g. `2019-09-11`"))
}
private_file_hash <- function(path,
auth_token = pal::pkg_config_val("token_repo_private")) {
req_private_file(path = path,
method = "HEAD",
auth_token = auth_token) |>
httr2::req_perform() |>
httr2::resp_header(header = "X-Gitlab-Content-Sha256")
}
req_private_file <- function(path,
method,
max_tries = 3L,
auth_token = pal::pkg_config_val("token_repo_private")) {
checkmate::assert_string(auth_token)
httr2::request(base_url = glue::glue("https://gitlab.com/api/v4/projects/{repo_private_proj_id}/repository/files/", utils::URLencode(path,
reserved = TRUE))) |>
httr2::req_url_query(ref = repo_private_default_branch) |>
httr2::req_method(method = method) |>
httr2::req_headers(`PRIVATE-TOKEN` = auth_token,
.redact = "PRIVATE-TOKEN") |>
httr2::req_retry(max_tries = max_tries) |>
httr2::req_error(body = \(resp) {
if (httr2::resp_has_body(resp)) {
return(httr2::resp_body_json(resp)$message)
}
NULL
})
}
#' Assemble private FOKUS repository URL
#'
#' @param ... Optional path components added to the base URL.
#' @param .branch Git branch name to use in URL. A character scalar. Only relevant if `...` is non-empty.
#'
#' @return A character scalar.
#' @family private
#' @keywords internal
#'
#' @examples
#' fokus:::url_repo_private("generated")
url_repo_private <- function(...,
.branch = repo_private_default_branch) {
result <- "https://gitlab.com/zdaarau/private/fokus_private/"
if (...length() > 0L) {
checkmate::assert_string(.branch)
result <- paste0(result, fs::path("-/tree", .branch, ..., "?ref_type=heads"))
}
result
}
assert_countish <- function(x,
positive = TRUE,
null_ok = FALSE) {
if (null_ok && is.null(x)) {
x
} else {
checkmate::assert_count(as.integer(x),
positive = positive)
}
}
assert_integerish <- function(x,
lower = -Inf,
upper = Inf,
any_missing = FALSE,
all_missing = FALSE,
null_ok = FALSE) {
if (null_ok && is.null(x)) {
x
} else {
checkmate::assert_integerish(as.integer(x),
lower = lower,
upper = upper,
any.missing = any_missing,
all.missing = all_missing,
coerce = TRUE)
}
}
assert_var_names_present <- function(data,
var_names) {
checkmate::assert_data_frame(data)
var_names |> purrr::walk(\(var_name) {
if (!(var_name %in% colnames(data))) {
cli::cli_abort("{.arg data} must contain a column {.var {var_name}}")
}
})
invisible(data)
}
assert_var_names_valid <- function(var_names,
as_scalar = FALSE,
null_ok = FALSE) {
checkmate::assert_flag(as_scalar)
if (as_scalar) {
checkmate::assert_choice(var_names,
choices = unique(fokus::qstnrs$variable_name),
null.ok = null_ok)
} else {
purrr::map_chr(var_names,
checkmate::assert_choice,
choices = unique(fokus::qstnrs$variable_name),
null.ok = null_ok)
}
}
#' Abbreviations used in the **fokus** package
#'
#' Returns a [tibble][tibble::tbl_df] listing an opinionated set of abbreviations used in the \R code and documentation of the **fokus** package.
#'
#' @inheritParams pkgsnip::abbrs
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @keywords internal
abbrs <- function(unnest = FALSE) {
rlang::check_installed("pkgsnip",
reason = pal::reason_pkg_required())
tibble::tibble(full_expressions = list("google"),
abbreviation = "g") |>
dplyr::bind_rows(pkgsnip::abbrs()) |>
dplyr::arrange(purrr::map_chr(full_expressions,
\(x) stringr::str_to_lower(dplyr::first(x)))) |>
pal::when(unnest ~ tidyr::unnest_longer(data = .,
col = full_expressions,
values_to = "full_expression"),
~ .)
}
as_ballot_date <- function(ballot_date,
error_call = rlang::caller_env()) {
result <- ballot_date[1L]
if (lubridate::is.Date(result)) {
if (!(result %in% all_ballot_dates)) {
cli::cli_abort("{.arg ballot_date} must be one of {.val all_ballot_dates}, not {.val {ballot_date}}.")
}
} else {
result %<>%
as_ballot_date_chr(error_call = error_call) %>%
clock::date_parse()
}
result
}
as_ballot_date_chr <- function(ballot_date,
error_call = rlang::caller_env()) {
checkmate::assert_atomic(ballot_date,
len = 1L)
rlang::arg_match0(arg = as.character(ballot_date),
values = as.character(all_ballot_dates),
arg_nm = "ballot_date",
error_call = error_call)
}
as_ballot_dates <- function(ballot_dates,
error_call = rlang::caller_env()) {
ballot_dates |>
purrr::map(\(x) as_ballot_date(ballot_date = x,
error_call = error_call)) |>
purrr::list_c(ptype = as.Date(NULL))
}
as_flat_list <- function(x) {
result <- x
depth <- purrr::pluck_depth(result)
# unlist until only a single list level remains
while (depth > 2L) {
result %<>% unlist(recursive = FALSE)
depth <- purrr::pluck_depth(result)
}
# wrap in list if necessary
if (depth < 2L && !is.list(x)) {
result <- list(x)
}
result
}
as_sym_part_regex <- function(x) {
paste0(sym_part_regex_start, x, sym_part_regex_end)
}
collapse_break <- function(s) {
paste0(s, collapse = "<br>")
}
#' Convert language code to country-specific locale ID
#'
#' Converts a language code as used in many of this package's functions to a country-specific locale identifier.
#'
#' @param lang Language. One of `r all_langs |> pal::as_md_vals() |> pal::enum_str(sep2 = " or ")`.
#'
#' @return A character scalar.
#' @keywords internal
#'
#' @examples
#' fokus:::lang_to_locale("de")
#' fokus:::lang_to_locale("en")
lang_to_locale <- function(lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
switch(lang,
de = "de-CH",
en = "en-US")
}
var_predicate <- function(predicate,
var_name,
ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
predicate <- rlang::arg_match(predicate,
values = setdiff(colnames(fokus::qstnrs),
c("ballot_date",
"canton",
"variable_name")))
assert_var_names_valid(var_names = var_name,
as_scalar = TRUE)
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
fokus::qstnrs |>
dplyr::filter(canton == !!canton
& ballot_date == !!ballot_date
& variable_name == !!var_name) %$%
eval(as.symbol(predicate)) |>
unique()
}
wrap_backtick <- function(x) {
dplyr::if_else(x == "-" | stringr::str_detect(string = x,
pattern = "^(_.*_|\\*.*\\*)$"),
as.character(x),
paste0("`", x, "`"))
}
this_pkg <- utils::packageName()
cli_theme <-
cli::builtin_theme() |>
purrr::list_modify(h2 = list("margin-bottom" = 0.0),
h3 = list("margin-top" = 0.0))
global_max_cache_age <- "30 days"
#' Questionnaire item keys
#'
#' A tibble of item keys supported in the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @docType data
#' @family metadata
#' @keywords internal
#'
#' @name qstnr_item_keys
#'
#' @examples
#' fokus:::qstnr_item_keys
NULL
qstnr_md_table_header <-
tibble::tribble(
~name, ~width, ~alignment,
"\\#", 2L, "left",
"Thema", 5L, "left",
"Wer", 3L, "left",
"Frage", 15L, "left",
"Mehrfachnennungen", 3L, "left",
"Variablenname", 5L, "left",
"Variablenname (gek\u00fcrzt auf 32 Zeichen)", 5L, "left",
"Variablenlabel", 15L, "left",
"Antwortoptionen", 5L, "left",
"Variablenauspr\u00e4gungen", 5L, "left",
"Auspr\u00e4gungslabels", 5L, "left",
"Antwortoptionen in Zufallsreihenfolge", 3L, "left",
"Antwort obligatorisch", 3L, "left"
) |>
dplyr::mutate(sep = purrr::map2_chr(.x = width,
.y = alignment,
.f = ~
rep(x = "-",
times = .x) |>
paste0(collapse = "") |>
pal::when(.y == "left" ~ stringr::str_replace(string = .,
pattern = "^.",
replacement = ":"),
.y == "right" ~ stringr::str_replace(string = .,
pattern = ".$",
replacement = ":"),
.y == "center" ~ stringr::str_replace_all(string = .,
pattern = "(^.|.$)",
replacement = ":"),
~ .))) %$%
c(paste0(name, collapse = " | "),
paste0(sep, collapse = " | "))
repo_private_proj_id <- 21325371L
sym_part_regex_start <- "(^|_|\\b)"
sym_part_regex_end <- "(\\b|_|$)"
unicode_checkmark <- "\u2705"
unicode_crossmark <- "\u274C"
unicode_ellipsis <- "\u2026"
url_qstnr <- list(aargau = "https://qstnr.fokus.ag")
url_survey_host <- list(aargau = "https://umfrage.fokus.ag")
url_parameter_survey <- list(aargau = "pw")
#' FOKUS-covered ballot dates
#'
#' A vector of ballot dates covered by FOKUS surveys up until `r max(all_ballot_dates)`.
#'
#' @format `r pkgsnip::return_lbl("dates")`
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_ballot_dates
"all_ballot_dates"
#' FOKUS-covered cantons
#'
#' A vector of all [cantons][cantons] covered by FOKUS surveys.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_cantons
"all_cantons"
#' Ballot types
#'
#' A vector of all possible [ballot types][ballot_types].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_ballot_types
"all_ballot_types"
#' Political levels
#'
#' A vector of all possible [political levels][lvls].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_lvls
"all_lvls"
#' Election procedures
#'
#' A vector of all possible [election procedures][prcds].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_prcds
"all_prcds"
#' Referendum proposal types
#'
#' A vector of all possible [referendum proposal types][proposal_type].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_proposal_types
"all_proposal_types"
#' Standardized referendum proposal question groups
#'
#' A vector of all possible referendum [proposal question groups][proposal_qstn_groups].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_qstn_groups
"all_qstn_groups"
#' Referendum proposal argument sides
#'
#' A vector of all possible referendum proposal argument sides.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_argument_sides
"all_argument_sides"
#' Referendum proposal main motive types
#'
#' A vector of all possible referendum proposal main motive types.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_main_motive_types
"all_main_motive_types"
#' Election seat types
#'
#' A vector of all possible election seat types.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_election_seat_types
"all_election_seat_types"
#' Response option types
#'
#' A vector of all possible response option types defined in the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_response_option_types
"all_response_option_types"
#' Postal dispatch types
#'
#' A vector of all possible postal dispatch types.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_postal_dispatch_types
"all_postal_dispatch_types"
#' Postal dispatch ways
#'
#' A vector of all possible [postal dispatch ways][postal_dispatch_way].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_postal_dispatch_ways
"all_postal_dispatch_ways"
#' Languages
#'
#' A vector of all possible survey metadata languages.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_langs
"all_langs"
#' Name types
#'
#' A vector of all possible name types for various entities.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_name_types
"all_name_types"
#' Get cantons covered by FOKUS survey
#'
#' Determines the cantons covered by the FOKUS survey at the specified ballot date.
#'
#' @param ballot_date FOKUS-covered ballot date. One of
#' `r pal::as_md_val_list(as.character(all_ballot_dates))`
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::cantons(ballot_date = "2018-09-23")
#'
#' # determine all cantons covered per ballot date
#' library(magrittr)
#'
#' fokus::all_ballot_dates %>%
#' magrittr::set_names(., .) |>
#' purrr::map_chr(fokus::cantons)
cantons <- function(ballot_date = pal::pkg_config_val("ballot_date")) {
ballot_date %<>% as_ballot_date_chr()
cantons_at[[ballot_date]]
}
#' Get ballot's political levels
#'
#' Determines the [political levels][all_lvls] covered by the FOKUS survey for the specified canton of the specified ballot type at the specified ballot date.
#'
#' @inheritParams cantons
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#' @param ballot_type Ballot type. One of `r all_ballot_types |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#' @param prcds Election procedure(s). One or more of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' Only relevant if `ballot_type = "election"`.
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::lvls(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::lvls(ballot_date = "2018-09-23",
#' canton = "aargau",
#' ballot_type = "election")
#'
#' fokus::lvls(ballot_date = "2019-10-20",
#' canton = "aargau",
#' ballot_type = "election")
#'
#' fokus::lvls(ballot_date = "2019-10-20",
#' canton = "aargau",
#' ballot_type = "election",
#' prcds = "proportional")
lvls <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
ballot_type = ballot_types(ballot_date = ballot_date,
canton = canton),
prcds = all_prcds) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
ballot_type <- rlang::arg_match(arg = ballot_type,
values = all_ballot_types)
prcds <- unique(rlang::arg_match(arg = prcds,
multiple = TRUE))
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if (ballot_type == "referendum") {
result <- c("cantonal"[length(raw$cantonal[[canton]]$proposal) > 0L],
"federal"[length(raw$federal$proposal) > 0L])
} else {
result <- c("cantonal"[any(purrr::map_lgl(prcds,
~ length(raw$cantonal[[canton]]$election[[.x]]) > 0L))],
"federal"[any(purrr::map_lgl(prcds,
~ length(raw$federal[[canton]]$election[[.x]]) > 0L))])
}
result
}
#' Get ballot types
#'
#' Determines the [types of the ballot][all_ballot_types] covered by the FOKUS survey for the specified canton on the specified political level(s) at the
#' specified ballot date.
#'
#' @inheritParams lvls
#' @param lvls Political level(s). One or more of `r all_lvls |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::ballot_types(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' # in case of no ballot types at lvl, an empty character vector is returned
#' fokus::ballot_types(ballot_date = "2020-10-18",
#' lvls = "federal",
#' canton = "aargau")
ballot_types <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date)) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- character()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if ("federal" %in% lvls) {
result <- c("referendum"[length(raw$federal$proposal) > 0L],
"election"[any(purrr::map_lgl(all_prcds,
~ length(raw$federal[[canton]]$election[[.x]]) > 0L))])
}
if ("cantonal" %in% lvls) {
result %<>% c("referendum"[length(raw$cantonal[[canton]]$proposal) > 0L],
"election"[any(purrr::map_lgl(all_prcds,
~ length(raw$cantonal[[canton]]$election[[.x]]) > 0L))])
}
unique(result)
}
#' Get ballot's election procedures
#'
#' Determines the [election procedures][all_prcds] covered by the FOKUS survey for the specified canton on the specified political level at the specified ballot
#' date.
#'
#' @inheritParams lvls
#' @param lvl Political level. One of `r all_lvls |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::prcds(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::prcds(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
#'
#' # in case of no elections, an empty character vector is returned
#' fokus::prcds(ballot_date = "2020-10-18",
#' lvl = "federal",
#' canton = "aargau")
prcds <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date)) {
if (length(lvl)) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- character()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if (isTRUE(lvl == "federal")) {
result <-
names(raw$federal[[canton]]$election) |>
intersect(all_prcds) |>
as.character()
} else if (isTRUE(lvl == "cantonal")) {
result <-
names(raw$cantonal[[canton]]$election) |>
intersect(all_prcds) |>
as.character()
}
result
}
#' Get ballot's referendum proposal numbers
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level.
#'
#' @inheritParams prcds
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvl = "cantonal"`.
#'
#' @return An integer vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::proposal_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::proposal_nrs(ballot_date = "2018-09-23",
#' lvl = "federal",
#' canton = "aargau")
#'
#' # in case of no referendum proposals, an empty integer vector is returned
#' fokus::proposal_nrs(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
if (length(lvl) > 0L) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
result <- integer()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if (isTRUE(lvl == "federal")) {
result <-
raw$federal$proposal |>
names() |>
as.integer()
} else if (isTRUE(lvl == "cantonal")) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <-
raw$cantonal[[canton]]$proposal |>
names() |>
as.integer()
}
result
}
#' Get ballot's election numbers
#'
#' Determines the election numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political level and of the
#' specified election procedure(s).
#'
#' @inheritParams prcds
#' @param prcd Election procedure. One of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#'
#' @return An integer vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::election_nrs(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau",
#' prcd = "majoritarian")
#'
#' # in case of no (matching) elections, an empty integer vector is returned
#' fokus::election_nrs(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "proportional")
election_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
prcd = prcds(ballot_date = ballot_date,
lvl = lvl,
canton = canton)) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- integer()
if (length(prcd) > 0L) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
prcd <- rlang::arg_match(arg = prcd,
values = all_prcds)
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
result <- as.integer(names(raw[[lvl]][[canton]]$election[[prcd]]))
}
result
}
#' Get ballot's election procedures
#'
#' Determines the election procedures covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political level.
#'
#' @inheritParams prcds
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::election_prcds(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
#'
#' # in case of no (matching) elections, an empty integer vector is returned
#' fokus::election_prcds(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
election_prcds <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date)) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- character()
if (length(lvl) > 0L) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
result <-
names(raw[[lvl]][[canton]]$election) |>
intersect(y = all_prcds)
}
result
}
#' Get referendum proposal question groups
#'
#' Determines the referendum proposal [question groups][all_qstn_groups] covered by the FOKUS survey for the specified canton on the specified political level
#' at the specified ballot date.
#'
#' @inheritParams proposal_nrs
#' @inheritParams raw_qstnr_suppl_proposal
#'
#' @return A character vector of question group identifiers.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::proposal_qstn_groups(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' fokus::proposal_qstn_groups(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 2)
proposal_qstn_groups <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = cantons(ballot_date),
proposal_nr = 1L) {
raw_qstnr_suppl_proposal_safe(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
names() |>
intersect(all_qstn_groups) %||%
character()
}
#' Get referendum proposal numbers with question group
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level for which at least one question of each of the specified standardized question groups has been asked.
#'
#' @inheritParams proposal_nrs
#' @param qstn_groups One or more of the standardized question groups `r pal::enum_fn_param_defaults(param = "qstn_groups", fn = qstn_groups_proposal_nrs)`.
#'
#' @return An integer vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::qstn_groups_proposal_nrs(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
qstn_groups_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = all_lvls,
canton = cantons(ballot_date),
qstn_groups = all_qstn_groups) {
raw_qstnr_suppl_proposal_safe(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::keep(\(x) all(qstn_groups %in% names(x))) |>
names() |>
as.integer()
}
#' Get survey channels
#'
#' Determines the channels the surevy was conducted over.
#'
#' @inheritParams lvls
#'
#' @return A character vector.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::survey_channels(ballot_date = "2023-06-18",
#' canton = "aargau")
survey_channels <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::chuck("channels")
}
#' Determine whether survey is based on representative sample
#'
#' Determines whether or not the survey was conducted among a representative sample of the electorate (i.e. drawn randomly).
#'
#' @inheritParams lvls
#'
#' @return A logical scalar.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::is_representative(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::is_representative(ballot_date = "2024-10-20",
#' canton = "aargau")
is_representative <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::chuck("is_representative")
}
#' Get number of referendum proposals
#'
#' Determines the number of referendum proposals covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level(s).
#'
#' The number of *federal* proposals is independent from the canton, i.e. the returned number of *federal* proposals at a specific ballot date is always the
#' same, thus `canton` is ignored if `!("cantonal" %in% lvls)`.
#'
#' @inheritParams ballot_types
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvls` includes `"cantonal"`.
#'
#' @return An integer vector of the same length as and named after `lvls`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::n_proposals(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::n_proposals(ballot_date = "2018-09-23",
#' lvls = "cantonal",
#' canton = "aargau")
#'
#' fokus::n_proposals(ballot_date = "2019-10-20")
n_proposals <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date)) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
result <- integer()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if ("cantonal" %in% lvls) {
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
result <- c(cantonal = length(raw$cantonal[[canton]]$proposal))
}
if ("federal" %in% lvls) {
result %<>% c(federal = length(raw$federal$proposal))
}
result
}
#' Get number of elections
#'
#' Determines the number of elections covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) and
#' of the specified election procedure(s).
#'
#' @inheritParams ballot_types
#' @param prcds Election procedure(s). One or more of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' @return An integer vector of length `lvls` × `prcds`, named after `lvls.prcds`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::n_elections(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::n_elections(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::n_elections(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau",
#' prcds = "majoritarian")
n_elections <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
prcds = all_prcds) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
prcds <- unique(rlang::arg_match(arg = prcds,
multiple = TRUE))
result <- integer()
raw <- raw_qstnr_suppl(ballot_date = ballot_date)
if ("federal" %in% lvls) {
result <-
prcds %>%
magrittr::set_names(., .) |>
purrr::map_int(\(x) length(raw$federal[[canton]]$election[[x]])) |>
list(federal = _) |>
unlist()
}
if ("cantonal" %in% lvls) {
result <-
prcds %>%
magrittr::set_names(., .) |>
purrr::map_int(\(x) length(raw$cantonal[[canton]]$election[[x]])) |>
list(cantonal = _) |>
unlist() |>
c(result)
}
result
}
#' Determine whether ballot includes a referendum
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) covered a referendum.
#'
#' @inheritParams n_proposals
#'
#' @return A logical vector of the same length as and named after `lvls`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_referendum(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_referendum(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau")
has_referendum <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date)) {
n_proposals(ballot_date = ballot_date,
lvls = lvls,
canton = canton) > 0L
}
#' Determine whether ballot includes an election
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) covered an election of
#' the specified election procedure(s).
#'
#' @inheritParams n_elections
#'
#' @return A logical vector of length `lvls` × `prcds`, named after `lvls.prcds`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_election(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::has_election(ballot_date = "2019-10-20",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::has_election(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau",
#' prcds = "proportional")
has_election <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
prcds = all_prcds) {
n_elections(ballot_date = ballot_date,
lvls = lvls,
canton = canton,
prcds = prcds) > 0L
}
#' Determine whether ballot includes type
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political level(s) covered the specified
#' [ballot types][ballot_types].
#'
#' @inheritParams lvls
#' @inheritParams n_elections
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvls` includes `"cantonal"` or `ballot_type = "election"`.
#'
#' @return A logical vector of the same length as `lvl` (× `prcds`), named after `lvls(.prcds).ballot_type`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_ballot_type(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_ballot_type(ballot_date = "2018-09-23",
#' canton = "aargau",
#' ballot_type = "election")
#'
#' fokus::has_ballot_type(ballot_date = "2019-10-20",
#' canton = "aargau",
#' ballot_type = "election",
#' prcds = "proportional")
has_ballot_type <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
ballot_type = ballot_types(ballot_date = ballot_date,
lvls = lvls,
canton = canton),
prcds = all_prcds) {
ballot_type <- rlang::arg_match(arg = ballot_type,
values = all_ballot_types)
if (isTRUE(ballot_type == "election")) {
result <-
has_election(ballot_date = ballot_date,
lvls = lvls,
canton = canton,
prcds = prcds) %>%
magrittr::set_names(paste(names(.), "election",
sep = "."))
} else if (isTRUE(ballot_type == "referendum")) {
result <-
has_referendum(ballot_date = ballot_date,
lvls = lvls,
canton = canton) %>%
magrittr::set_names(paste(names(.), "referendum",
sep = "."))
}
result
}
#' Determine whether ballot includes a political level
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date covered the specified political level.
#'
#' @inheritParams cantons
#' @param lvl Political level to test for. One of `r all_lvls |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#' @param canton FOKUS-covered canton name. One of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' Only relevant if `lvl = "cantonal"` or `ballot_types` includes `"election"`.
#' @param ballot_types Ballot type(s). One or more of `r pal::enum_fn_param_defaults(param = "ballot_types", fn = has_lvl)`
#' @param prcds Election procedure(s). One or more of `r all_prcds |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' Only relevant if `ballot_types` includes `"election"`.
#'
#' @return A logical vector of the same length as (`prcds` ×) `ballot_types`, named after `lvl(.prcds).ballot_types`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_lvl(ballot_date = "2018-09-23",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::has_lvl(ballot_date = "2018-09-23",
#' lvl = "federal",
#' canton = "aargau",
#' ballot_types = "election")
#'
#' fokus::has_lvl(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau",
#' ballot_types = "election")
has_lvl <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
ballot_types = all_ballot_types,
prcds = all_prcds) {
if (length(lvl)) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
ballot_types <- rlang::arg_match(arg = ballot_types,
multiple = TRUE)
result <- logical()
if ("election" %in% ballot_types) {
result <-
has_election(ballot_date = ballot_date,
lvls = lvl,
canton = canton,
prcds = prcds) %>%
magrittr::set_names(paste(names(.), "election",
sep = "."))
}
if ("referendum" %in% ballot_types) {
result <-
has_referendum(ballot_date = ballot_date,
lvls = lvl,
canton = canton) %>%
magrittr::set_names(paste(names(.), "referendum",
sep = ".")) |>
c(result)
}
result
}
#' Determine whether ballot includes referendum proposals
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political levels covered the specified
#' referendum proposal numbers.
#'
#' @inheritParams n_proposals
#' @param proposal_nrs Proposals number(s) to test for. An integerish vector or `NULL`. If `NULL`, falls back to [`1:n_proposals()`][n_proposals] present
#' matching the specified parameters.
#'
#' @return Either
#' - **an unnamed logical scalar** if `proposal_nrs` is `NULL` and there was no FOKUS-covered referendum at `ballot_date` on any `lvls`, or
#' - **a logical vector** of the same length as `lvls` × `proposal_nrs`, **named** after `lvls.proposal_nrs`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_proposal_nrs(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_proposal_nrs(ballot_date = "2018-09-23",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::has_proposal_nrs(ballot_date = "2018-09-23",
#' canton = "aargau",
#' proposal_nrs = 1:5)
#'
#' fokus::has_proposal_nrs(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::has_proposal_nrs(ballot_date = "2021-11-28",
#' lvls = "cantonal",
#' canton = "aargau")
has_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
proposal_nrs = NULL) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
checkmate::assert_integerish(proposal_nrs,
lower = 1L,
any.missing = FALSE,
null.ok = TRUE)
lvls %>%
magrittr::set_names(., .) |>
purrr::map(~ {
present_proposal_nrs <- proposal_nrs(ballot_date = ballot_date,
lvl = .x,
canton = canton)
if (is.null(proposal_nrs)) {
proposal_nrs <- present_proposal_nrs
}
proposal_nrs %>%
magrittr::set_names(., .) |>
purrr::map(\(x) x %in% present_proposal_nrs)
}) |>
unlist() |>
pal::when(is.null(.) ~ FALSE,
~ .)
}
#' Determine whether ballot includes elections
#'
#' Determines whether or not the FOKUS survey for the specified canton at the specified ballot date on the specified political levels covered the specified
#' election numbers of the specified procedures.
#'
#' @inheritParams n_elections
#' @param election_nrs Election number(s) to test for. An integerish vector or `NULL`. If `NULL`, falls back to [`1:n_elections()`][n_elections] present
#' matching the specified parameters.
#'
#' @return Either
#' - **an unnamed logical scalar** if `election_nrs` is `NULL` and there was no FOKUS-covered election of any `prcds` at `ballot_date` on any `lvls`, or
#' - **a logical vector** of the same length as `lvls` × `prcds` × `election_nrs`, **named** after `lvls.prcds.election_nrs`.
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' fokus::has_election_nrs(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::has_election_nrs(ballot_date = "2019-10-20",
#' lvls = "federal",
#' canton = "aargau",
#' prcds = "proportional")
#'
#' fokus::has_election_nrs(ballot_date = "2019-10-20",
#' canton = "aargau",
#' election_nrs = 1:2)
#'
#' fokus::has_election_nrs(ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::has_election_nrs(ballot_date = "2020-10-18",
#' lvls = "federal",
#' canton = "aargau")
has_election_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
prcds = all_prcds,
election_nrs = NULL) {
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
checkmate::assert_integerish(election_nrs,
lower = 1L,
any.missing = FALSE,
null.ok = TRUE)
lvls %>%
magrittr::set_names(., .) |>
purrr::map(function(lvl) {
prcds %>%
magrittr::set_names(., .) |>
purrr::map(lvl = lvl,
.f = function(prcd,
lvl) {
present_election_nrs <- election_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd)
if (is.null(election_nrs)) {
election_nrs <- present_election_nrs
}
election_nrs %>%
magrittr::set_names(., .) |>
purrr::map(\(x) x %in% present_election_nrs)
})
}) |>
unlist() |>
pal::when(is.null(.) ~ FALSE,
~ .)
}
#' Get ballot type combinations
#'
#' Returns a list with a metadata item per ballot type, ballot date, canton and optionally political level.
#'
#' @inheritParams ballot_types
#' @inheritParams has_lvl
#' @param ballot_dates FOKUS-covered ballot date(s). One or more of
#' `r pal::as_md_val_list(as.character(all_ballot_dates))`
#' @param cantons FOKUS-covered canton name(s). One or more of
#' `r pal::as_md_val_list(all_cantons)`
#' @param incl_lvl Whether or not to include the political levels in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#'
#' @return A list with an element per ballot-type and optionally -political-level combination.
#' @family combo
#' @family predicate_fundamental
#' @export
#'
#' @examples
#' # of all covered ballots
#' fokus::combos_ballot_types()
#'
#' # only of 2023-06-18 ballot in aargau
#' fokus::combos_ballot_types(ballot_dates = "2023-06-18",
#' cantons = "aargau")
combos_ballot_types <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
ballot_types = all_ballot_types,
incl_lvl = TRUE) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
ballot_types <- rlang::arg_match(arg = ballot_types,
multiple = TRUE)
checkmate::assert_flag(incl_lvl)
result <-
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
if (incl_lvl) {
sub_result <-
lvls |>
purrr::map(\(lvl) {
ballot_types(ballot_date = ballot_date,
lvls = lvl,
canton = canton) |>
intersect(y = ballot_types) |>
purrr::map(\(x) list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
ballot_type = x))
}) |>
purrr::list_flatten()
} else {
sub_result <-
ballot_types(ballot_date = ballot_date,
lvls = lvls,
canton = canton) |>
intersect(y = ballot_types) |>
purrr::map(\(x) list(ballot_date = ballot_date,
canton = canton,
ballot_type = x))
}
sub_result
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
result
}
#' Get referendum proposal type
#'
#' Returns the [type][all_proposal_types] of the specified referendum proposal.
#'
#' @inheritParams proposal_name
#'
#' @return Proposal type. One of
#' `r pal::as_md_val_list(all_proposal_types)`
#'
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_type(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
proposal_type <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L) {
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck("type")
}
#' Get referendum proposal name
#'
#' Returns the name of the specified referendum proposal in the specified language.
#'
#' @inheritParams proposal_nrs
#' @inheritParams raw_qstnr_suppl_proposal
#' @inheritParams lang_to_locale
#' @param type Name type. One of `r all_name_types |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#'
#' @return A character scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_name(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "long")
proposal_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
lang = pal::pkg_config_val("lang"),
type = all_name_types) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
type <- rlang::arg_match(type)
raw_qstnr_suppl_proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck(lang, type, "text")
}
#' Get German referendum proposal name's grammatical gender
#'
#' Returns the grammatical gender of the German name of the specified referendum proposal.
#'
#' @inheritParams proposal_name
#'
#' @return A character scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_name_gender(ballot_date = "2018-09-23",
#' lvl = "federal",
#' proposal_nr = 1,
#' type = "short")
#'
#' fokus::proposal_name_gender(ballot_date = "2018-09-23",
#' lvl = "federal",
#' proposal_nr = 1,
#' type = "long")
proposal_name_gender <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_name_types) {
type <- rlang::arg_match(type)
raw_qstnr_suppl_proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck("de", type, "gender")
}
#' Determine whether German referendum proposal name is plural
#'
#' Determines whether or not the German name of the specified referendum proposal is a plural.
#'
#' @inheritParams proposal_name
#'
#' @return A logical scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::is_proposal_name_plural(ballot_date = "2020-09-27",
#' lvl = "federal",
#' proposal_nr = 3,
#' type = "short")
is_proposal_name_plural <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_name_types) {
type <- rlang::arg_match(type)
raw_qstnr_suppl_proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("de", type, "is_plural",
.default = FALSE)
}
#' Get referendum proposal's arguments
#'
#' Returns text, side and number of all referendum arguments on the specified proposal.
#'
#' @inheritParams proposal_name
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_arguments(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
proposal_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L) {
raw_qstnr_suppl_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::map(as_flat_list) |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind() |>
dplyr::relocate(any_of(c("side", "nr")),
any_of("de.short"),
starts_with("de."),
any_of("en.short"),
starts_with("en."))
}
#' Get referendum proposal argument
#'
#' Returns the specified referendum proposal argument's text of the specified type in the specified language.
#'
#' @inheritParams proposal_name
#' @param side Proposal argument side. One of `r all_argument_sides |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " or ", last = " or ")`.
#' @param argument_nr Proposal argument number. A positive integerish scalar.
#'
#' @return A character scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_argument(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' side = "contra",
#' argument_nr = 3,
#' type = "long")
proposal_argument <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
side = all_argument_sides,
argument_nr = 1L,
lang = pal::pkg_config_val("lang"),
type = all_name_types) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
type <- rlang::arg_match(type)
raw_qstnr_suppl_argument(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
side = side,
argument_nr = argument_nr) |>
purrr::chuck(lang, type)
}
#' Get referendum proposal's main motives
#'
#' Returns text and code number of all main motives of the specified `type` for the specified referendum proposal.
#'
#' @inheritParams proposal_name
#' @param type Main motive type. One of `r pal::enum_fn_param_defaults(param = "type", fn = proposal_main_motives)`.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::proposal_main_motives(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "no")
proposal_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_main_motive_types) {
type <- rlang::arg_match(type)
raw_qstnr_suppl_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::chuck(type) |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get referendum proposal's number of arguments
#'
#' Determines the number of arguments on the specified referendum proposal of the specified sides.
#'
#' @inheritParams proposal_name
#' @param sides Proposal argument side(s). One or more of `r all_argument_sides |> pal::as_md_vals() |> cli::ansi_collapse(sep2 = " and ", last = " and ")`.
#'
#' @return An integer scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::n_proposal_arguments(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' fokus::n_proposal_arguments(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' sides = "pro")
n_proposal_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
sides = all_argument_sides) {
sides <- rlang::arg_match(arg = sides,
multiple = TRUE)
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("argument") |>
purrr::keep(\(x) x$side %in% sides) |>
length()
}
#' Get referendum proposal's number of main motives
#'
#' Determines the number of main motives for the specified proposal and motive type.
#'
#' @inheritParams proposal_main_motives
#' @param types Main motive type(s). One or more of `r pal::enum_fn_param_defaults(param = "type", fn = proposal_main_motives, sep2 = " and ")`.
#'
#' @return An integer scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' # count all motive types
#' fokus::n_proposal_main_motives(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' # count only motives of type "no"
#' fokus::n_proposal_main_motives(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' types = "no")
n_proposal_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
types = all_main_motive_types) {
types <- rlang::arg_match(types,
multiple = TRUE)
raw_qstnr_suppl_proposal(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::pluck("main_motive") |>
purrr::keep_at(at = types) |>
pal::when(length(.) > 0L ~
purrr::map_depth(.,
.depth = 1L,
length) |>
purrr::list_c(ptype = integer()),
~ 0L) |>
sum()
}
#' Determine whether arguments have been queried for referendum proposal
#'
#' Determines whether or not arguments have been queried for the specified referendum proposal.
#'
#' @inheritParams n_proposal_arguments
#'
#' @return A logical scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::has_proposal_arguments(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::has_proposal_arguments(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 2)
has_proposal_arguments <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
sides = all_argument_sides) {
n_proposal_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
sides = sides) > 0L
}
#' Determine whether main motives have been queried for referendum proposal
#'
#' Determines whether or not main motives have been queried for the specified referendum proposal.
#'
#' @inheritParams n_proposal_main_motives
#'
#' @return A logical scalar.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::has_proposal_main_motives(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::has_proposal_main_motives(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau",
#' proposal_nr = 2)
has_proposal_main_motives <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
types = all_main_motive_types) {
n_proposal_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
types = types) > 0L
}
#' Get referendum proposal numbers with arguments
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level for which at least one pro/contra argument has been queried.
#'
#' @inheritParams proposal_nrs
#'
#' @return An integer vector.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::argument_proposal_nrs(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
argument_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
qstn_groups_proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
qstn_groups = "argument")
}
#' Get referendum proposal numbers with arguments
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level for which at least one pro/contra argument has been queried.
#'
#' @inheritParams proposal_nrs
#'
#' @return An integer vector.
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::main_motive_proposal_nrs(ballot_date = "2023-06-18",
#' lvl = "federal",
#' canton = "aargau")
main_motive_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
qstn_groups_proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
qstn_groups = "main_motive")
}
#' Get referendum proposal combinations
#'
#' Returns a list with a metadata item per ballot date, political level, canton and optionally proposal number.
#'
#' @inheritParams combos_ballot_types
#' @param incl_nr Whether or not to include proposal numbers in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#'
#' @return A list with an element per political-level and optionally -proposal-number combination.
#' @family combo
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::combos_proposals(ballot_dates = "2023-06-18",
#' cantons = "aargau")
#'
#' # without proposal numbers
#' fokus::combos_proposals(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_nr = FALSE)
combos_proposals <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
incl_nr = TRUE) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
checkmate::assert_flag(incl_nr)
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
if (incl_nr) {
result <-
proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::map(\(nr) list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = nr))
} else if (has_lvl(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
ballot_types = "referendum")) {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton)
} else {
result <- NULL
}
result
}) |>
pal::when(incl_nr ~ purrr::list_flatten(.),
~ .) |>
purrr::compact()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get referendum proposal combinations for which arguments have been queried
#'
#' Returns a list with a metadata item per ballot date, political level, canton, proposal number and optionally proposal argument side (pro/contra) and number.
#'
#' @inheritParams combos_ballot_types
#' @param incl_side Whether or not to include argument sides (pro/contra) in the resulting list. Setting this to `FALSE` potentially results in fewer
#' combinations.
#' @param incl_argument_nr Whether or not to include argument numbers in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#' Setting this to `TRUE` implies `incl_side = TRUE`.
#'
#' @return A list with an element per political-level-proposal-number and optionally -argument-side and -argument-number combination.
#' @family combo
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::combos_proposal_arguments(ballot_dates = "2023-06-18",
#' cantons = "aargau")
#' # without argument numbers
#' fokus::combos_proposal_arguments(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_argument_nr = FALSE)
#' # without argument sides and numbers
#' fokus::combos_proposal_arguments(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_side = FALSE,
#' incl_argument_nr = FALSE)
combos_proposal_arguments <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
incl_side = TRUE,
incl_argument_nr = incl_side) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
checkmate::assert_flag(incl_side)
checkmate::assert_flag(incl_argument_nr)
# ensure `incl_argument_nr` and `incl_side` do not conflict
if (incl_argument_nr && !incl_side) {
cli::cli_abort("{.arg incl_argument_nr} cannot be {.val {TRUE}} when {.arg incl_side} is {.val {FALSE}}.")
}
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::map(\(proposal_nr) {
if (has_proposal_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)) {
if (incl_side) {
result <-
raw_qstnr_suppl_arguments(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr) |>
purrr::map(\(arg) {
if (incl_argument_nr) {
return(list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
side = arg$side,
argument_nr = arg$nr))
} else {
return(list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
side = arg$side))
}
}) |>
unique()
} else {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)
}
} else {
result <- NULL
}
result
}) |>
purrr::compact() |>
pal::when(incl_side ~ purrr::list_flatten(.),
~ .)
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get referendum proposal combinations for which main motives have been queried
#'
#' Returns a list with a metadata item per ballot date, political level, canton, proposal number and optionally motive type for which [main
#' motives][proposal_main_motives] have been queried in the respective post-voting survey.
#'
#' @inheritParams combos_ballot_types
#' @param incl_type Whether or not to include motive types (yes/no) in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#'
#' @return A list with an element per political-level-proposal-number and optionally -type combination.
#' @family combo
#' @family predicate_proposal
#' @export
#'
#' @examples
#' fokus::combos_proposal_main_motives(ballot_dates = "2023-06-18",
#' cantons = "aargau")
#' # without types
#' fokus::combos_proposal_main_motives(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_type = FALSE)
combos_proposal_main_motives <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
incl_type = TRUE) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
checkmate::assert_flag(incl_type)
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
purrr::map(\(proposal_nr) {
if (incl_type) {
result <-
all_main_motive_types |>
purrr::map(\(type) {
if (has_proposal_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
types = type)) {
list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
type = type)
} else {
NULL
}
}) |>
purrr::compact()
} else if (has_proposal_main_motives(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)) {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr)
} else {
result <- NULL
}
result
}) |>
purrr::compact() |>
pal::when(incl_type ~ purrr::list_flatten(.),
~ .)
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get election name
#'
#' Returns the name of the specified election in the specified language.
#'
#' @inheritParams election_nrs
#' @inheritParams proposal_name
#' @param election_nr Election number. A positive integerish scalar.
#' @param type Name type. One of `r pal::enum_fn_param_defaults(param = "type", fn = election_name)`.
#'
#' @return A character scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_name(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' prcd = "majoritarian",
#' election_nr = 1,
#' type = "body")
election_name <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
prcd = prcds(ballot_date,
lvl,
canton),
election_nr = 1L,
lang = pal::pkg_config_val("lang"),
type = c("short", "long", "body", "body_alt")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
type <- rlang::arg_match(type)
# this is required to trigger a proper error message in case `prcds` is not explicitly set and there are no elections (`prcd = character()`)
if (!length(prcd)) {
cli::cli_abort(paste0("{.arg prcd} must be one of ", cli::ansi_collapse(paste0("{.val ", all_prcds, "}"), sep2 = " or ", last = " or "), "."))
}
raw_qstnr_suppl_election_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd,
election_nr = election_nr) |>
purrr::chuck(lang, type, "text")
}
#' Get combined elections name
#'
#' Returns the combined name of all elections at the specified date on the specified level(s) for the specified canton in the specified language.
#'
#' @inheritParams n_elections
#' @inheritParams lang_to_locale
#' @param federal_first Whether or not to list federal elections before cantonal ones. Only has an effect if `"federal" %in% lvls`.
#'
#' @return A character scalar, empty if no elections were held.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_names_combined(ballot_date = "2019-10-20",
#' lvls = "federal",
#' canton = "aargau")
#'
#' fokus::election_names_combined(ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::election_names_combined(ballot_date = "2019-10-20",
#' canton = "aargau",
#' federal_first = FALSE)
election_names_combined <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvls = all_lvls,
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang"),
federal_first = TRUE) {
lvls <- unique(rlang::arg_match(arg = lvls,
multiple = TRUE))
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_flag(federal_first)
sep <- switch(EXPR = lang,
de = " sowie ",
en = " as well as ")
lvls |>
intersect(lvls(ballot_date = ballot_date,
canton = canton,
ballot_type = "election")) |>
purrr::map_chr(\(x) {
raw_qstnr_suppl_elections(ballot_date = ballot_date,
lvl = x,
canton = canton) |>
purrr::chuck("names_combined", lang, "short")
}) |>
pal::when(federal_first ~ .[sort(x = seq_along(.),
decreasing = TRUE)],
~ .) |>
cli::ansi_collapse(sep2 = sep,
last = sep)
}
#' Get majoritarian election's candidates
#'
#' Returns the name and party of all candidates running for the specified majoritarian election.
#'
#' @inheritParams n_election_seats
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_candidates(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
election_candidates <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("candidate") |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get proportional election's political parties
#'
#' Returns the questionnaire code as well as different versions of the name of all parties for the specified proportional election.
#'
#' @inheritParams n_election_seats
#' @param past Whether to process the current or the predecessor election's parties.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @seealso [fct_relabel_election_parties()]
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_parties(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
#'
#' fokus::election_parties(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau",
#' past = TRUE)
election_parties <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election",
prcds = "proportional"),
canton = cantons(ballot_date),
election_nr = 1L,
past = FALSE) {
checkmate::assert_flag(past)
if (past) {
# priority 1: from current election's metadata (past election was *not* covered by FOKUS survey)
result <-
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::pluck("past_party")
# priority 2: from past election's metadata (past election was covered by FOKUS survey)
if (is.null(result)) {
result <-
raw_qstnr_suppl_election(ballot_date = past_election_date(ballot_date = ballot_date,
lvl = lvl,
canton = canton),
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::chuck("party")
}
} else {
result <-
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::chuck("party")
}
result |>
purrr::map(as_flat_list) |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get proportional election's tickets
#'
#' Returns the name, number and party of all tickets for the specified proportional election.
#'
#' @inheritParams n_election_seats
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::election_tickets(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
election_tickets <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "proportional",
election_nr = election_nr) |>
purrr::chuck("ticket") |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get election's past date
#'
#' Determines the ordinary date (i.e. 1st round of voting) on which the specified election was *last* held (i.e. 4 years earlier than `ballot_date`).
#'
#' @inheritParams election_name
#'
#' @return `r pkgsnip::return_lbl("date")`
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::past_election_date(ballot_date = "2019-10-20")
#' fokus::past_election_date(ballot_date = "2020-10-18")
#' fokus::past_election_date(ballot_date = "2024-10-20")
#' fokus::past_election_date(ballot_date = "2019-10-20",
#' lvl = "federal")
past_election_date <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date)) {
ballot_date %<>% as_ballot_date()
if (length(lvl)) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
}
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
# priority 1: from current election's metadata (past election was *not* covered by FOKUS survey)
result <-
lvl |>
pal::when(. == "federal" ~
raw_qstnr_suppl_lvl(ballot_date = ballot_date,
lvl = .),
~ raw_qstnr_suppl_lvl_canton(ballot_date = ballot_date,
lvl = .,
canton = canton)) |>
purrr::pluck("election", "past_ballot_date") |>
checkmate::assert_date(any.missing = FALSE,
null.ok = TRUE)
# priority 2: from past election's metadata (past election was covered by FOKUS survey)
if (is.null(result)) {
# NOTE: we assume the past election must be *4* years before `ballot_date`
past_election_year <- clock::get_year(ballot_date) - 4L
result <-
combos_elections(ballot_dates = all_ballot_dates,
lvls = lvl,
cantons = canton,
incl_prcd = FALSE,
incl_nr = FALSE) |>
purrr::keep(.p = \(x) {
clock::get_year(x$ballot_date) == past_election_year
}) |>
purrr::map_depth(.depth = 1L,
.f = \(x) x$ballot_date) |>
purrr::list_c(ptype = as.Date(NULL)) |>
pal::safe_min()
}
if (length(result) == 0L) {
cli::cli_abort(paste0("Past election date couldn't be determined. Please set `past_ballot_date` explicitly in the supplemental {.val {ballot_date}} FOKUS ",
"questionnaire data."))
}
result
}
#' Get number of majoritarian election seats
#'
#' Determines the number of election seats of the specified type for the specified majority election.
#'
#' @inheritParams ballot_types
#' @inheritParams election_name
#' @param seat_type Seat type. One of `r pal::enum_fn_param_defaults(param = "seat_type", fn = n_election_seats)`.
#'
#' @return An integer scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::n_election_seats(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' seat_type = "total")
n_election_seats <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L,
seat_type = all_election_seat_types) {
seat_type <- rlang::arg_match(seat_type)
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("n_seats", seat_type)
}
#' Get number of (officially registered) majoritarian election candidates
#'
#' Determines the number of (officially registered) candidates of a majority election at the specified ballot date on the specified political level.
#'
#' @inheritParams n_election_seats
#'
#' @return An integer scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::n_election_candidates(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
n_election_candidates <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("candidate") |>
length()
}
#' Determine whether majoritarian election requires candidate registration
#'
#' Determines whether or not candidates must be officially registered prior to the specified majority election.
#'
#' The absence of a candidate registration requirement usually means that every eligible citizen can be elected, i.e. receive valid votes.
#'
#' @inheritParams n_election_seats
#'
#' @return A logical scalar.
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::requires_candidate_registration(ballot_date = "2019-10-20",
#' lvl = "federal",
#' canton = "aargau")
requires_candidate_registration <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L) {
raw_qstnr_suppl_election(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = "majoritarian",
election_nr = election_nr) |>
purrr::chuck("requires_candidate_registration")
}
#' Get election combinations
#'
#' Returns a list with a metadata item per ballot date, political level and optionally election procedure and number.
#'
#' @inheritParams combos_ballot_types
#' @inheritParams n_elections
#' @param incl_prcd Whether or not to include election procedures in the resulting list. Setting this to `FALSE` potentially results in fewer combinations.
#' @param incl_nr Whether or not to include election numbers in the resulting list. Setting this to `FALSE` potentially results in fewer combinations. Only
#' relevant if `incl_prcd = TRUE`.
#'
#' @return A list with an element per political-level and optionally -election-procedure and -election-number combination.
#' @family combo
#' @family predicate_election
#' @export
#'
#' @examples
#' fokus::combos_elections(ballot_dates = "2019-10-20",
#' cantons = "aargau")
#'
#' # without election numbers
#' fokus::combos_elections(ballot_dates = "2019-10-20",
#' cantons = "aargau",
#' incl_prcd = TRUE,
#' incl_nr = FALSE)
#'
#' # without election procedures and numbers
#' fokus::combos_elections(ballot_dates = "2019-10-20",
#' cantons = "aargau",
#' incl_prcd = FALSE,
#' incl_nr = FALSE)
combos_elections <- function(ballot_dates = all_ballot_dates,
lvls = all_lvls,
cantons = all_cantons,
prcds = all_prcds,
incl_prcd = TRUE,
incl_nr = incl_prcd) {
ballot_dates %<>% as_ballot_dates()
lvls <- rlang::arg_match(arg = lvls,
multiple = TRUE)
cantons <- rlang::arg_match(arg = cantons,
multiple = TRUE)
prcds <- rlang::arg_match(arg = prcds,
multiple = TRUE)
checkmate::assert_flag(incl_prcd)
checkmate::assert_flag(incl_nr)
ballot_dates |>
purrr::map(\(ballot_date) {
cantons(ballot_date = ballot_date) |>
intersect(y = cantons) |>
purrr::map(\(canton) {
lvls |>
purrr::map(\(lvl) {
if (incl_prcd) {
result <-
election_prcds(ballot_date = ballot_date,
lvl = lvl,
canton = canton) |>
intersect(y = prcds) |>
purrr::map(\(prcd) {
if (incl_nr) {
return(election_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd) |>
purrr::map(\(nr) list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd,
election_nr = nr)))
} else {
return(list(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
prcd = prcd))
}
}) |>
pal::when(incl_nr ~ purrr::list_flatten(.),
~ .)
} else if (any(has_lvl(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
ballot_types = "election"))) {
result <- list(ballot_date = ballot_date,
lvl = lvl,
canton = canton)
} else {
result <- NULL
}
result
}) |>
pal::when(incl_prcd ~ purrr::list_flatten(.),
~ .) |>
purrr::compact()
}) |>
purrr::list_flatten()
}) |>
purrr::list_flatten()
}
#' Get skill question numbers
#'
#' Determines the skill questions numbers at the specified ballot date on the specified political level. Note that by default (`proposal_nr = NULL`),
#' non-proposal-specific skill question numbers are returned.
#'
#' @inheritParams proposal_nrs
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, the numbers of non-proposal-specific skill questions are returned.
#'
#' @return An integer vector.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' # note that by default, non-proposal-specific skill question numbers are returned
#' fokus::skill_question_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::skill_question_nrs(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
skill_question_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL) {
pal::safe_seq_len(n_skill_questions(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr))
}
#' Get number of skill questions
#'
#' Determines the number of skill questions at the specified ballot date on the specified political level. Note that by default (`proposal_nr = NULL`), the
#' number of non-proposal-specific skill questions is returned.
#'
#' @inheritParams proposal_nrs
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, the number of non-proposal-specific skill questions is returned.
#'
#' @return An integer scalar.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::n_skill_questions(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1)
#'
#' # note that by default, the number of non-proposal-specific skill questions is returned
#' fokus::n_skill_questions(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
#'
#' fokus::n_skill_questions(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau")
n_skill_questions <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL) {
lvl <- rlang::arg_match(arg = lvl,
values = all_lvls)
if (lvl == "cantonal") {
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
}
checkmate::assert_count(proposal_nr,
positive = TRUE,
null.ok = TRUE)
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck(lvl) |>
pal::when(lvl == "cantonal" ~ purrr::pluck(., canton),
~ .) |>
# get non-proposal-specific skill questions if `proposal_nr = NULL`
pal::when(length(proposal_nr) > 0L ~ purrr::pluck(., "proposal", proposal_nr),
~ .) |>
purrr::pluck("skill_question") |>
length()
}
#' Get skill question
#'
#' Returns the skill question text in the specified language. Note that by default (`proposal_nr = NULL`), only non-proposal-specific skill questions are
#' returned.
#'
#' @inheritParams proposal_name
#' @param proposal_nr Proposal number. A positive integerish scalar or `NULL`. If `NULL`, it is considered to be a non-proposal-specific skill question
#' (the case at elections).
#' @param skill_question_nr Skill question number. A positive integerish scalar.
#'
#' @return A character scalar.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 2,
#' lang = "en")
skill_question <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL,
skill_question_nr = 1L,
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
raw_qstnr_suppl_skill_question(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
skill_question_nr = skill_question_nr) |>
purrr::chuck(lang)
}
#' Get skill question response options
#'
#' Returns the response options of the specified skill question together with the information whether they are correct or not.
#'
#' @inheritParams skill_question
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_response_options(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 2)
skill_question_response_options <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL,
skill_question_nr = 1L) {
raw_qstnr_suppl_skill_question(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
skill_question_nr = skill_question_nr) |>
purrr::chuck("response_option") |>
purrr::map(tibble::as_tibble) |>
purrr::list_rbind()
}
#' Get correct skill question answer number
#'
#' Returns the sequential number of the correct answer for the specified skill question.
#'
#' @inheritParams skill_question
#'
#' @return An integer scalar.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_answer_nr(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' skill_question_nr = 2)
skill_question_answer_nr <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton),
canton = cantons(ballot_date),
proposal_nr = NULL,
skill_question_nr = 1L) {
raw_qstnr_suppl_skill_question(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
skill_question_nr = skill_question_nr) |>
purrr::chuck("response_option") |>
purrr::map_depth(.depth = 1L,
.f = \(x) x$is_correct) |>
purrr::list_c(ptype = logical()) |>
which()
}
#' Get referendum proposal numbers with skill questions
#'
#' Determines the referendum proposal numbers covered by the FOKUS survey for the specified canton at the specified ballot date on the specified political
#' level that have at least one skill question.
#'
#' @inheritParams proposal_nrs
#'
#' @return An integer vector.
#' @family predicate_skill_question
#' @export
#'
#' @examples
#' fokus::skill_question_proposal_nrs(ballot_date = "2018-09-23",
#' lvl = "cantonal",
#' canton = "aargau")
skill_question_proposal_nrs <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date)) {
qstn_groups_proposal_nrs(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
qstn_groups = "skill_question")
}
#' Get ballot title
#'
#' Returns the ballot title consisting of the [ballot type][ballot_types()] and the ballot date, phrased in German.
#'
#' @inheritParams lvls
#' @inheritParams lang_to_locale
#'
#' @return A character scalar.
#' @family predicate_other
#' @export
#'
#' @examples
#' fokus::ballot_title(ballot_date = "2019-10-20",
#' canton = "aargau")
ballot_title <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang")) {
ballot_date %<>% as_ballot_date()
lang <- rlang::arg_match(arg = lang,
values = all_langs)
ballot_types <- ballot_types(ballot_date = ballot_date,
canton = canton)
if (!length(ballot_types)) {
cli::cli_abort("No ballot type could be determined. Please debug.",
.internal = TRUE)
}
if (lang == "de") {
result <-
ballot_types |>
pal::when(length(.) > 1L ~ "Abstimmungs- und Wahl",
. == "referendum" ~ "Abstimmungs",
. == "election" ~ "Wahl") |>
paste0("termin vom ", stringi::stri_datetime_format(time = ballot_date,
format = "date_long",
locale = lang_to_locale(lang)))
} else if (lang == "en") {
result <-
ballot_types |>
pal::when(length(.) > 1L ~ "Referendum and election",
~ stringr::str_to_sentence(.)) |>
paste0(" date of ", stringi::stri_datetime_format(time = ballot_date,
format = "date_long",
locale = lang_to_locale(lang)))
}
result
}
#' Get political issues
#'
#' Returns the political issues in the specified language at the specified ballot date.
#'
#' @inheritParams proposal_name
#'
#' @return A character vector.
#' @family predicate_other
#' @export
#'
#' @examples
#' fokus::political_issues(ballot_date = "2019-10-20",
#' lang = "en")
political_issues <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
result <-
raw_qstnr_suppl(ballot_date = ballot_date) |>
purrr::pluck("political_issues")
if (is.null(result)) {
# reduce to proper arg value for error msg
ballot_date %<>% as_ballot_date()
cli::cli_abort("No political issues present in the supplemental {.val {ballot_date}} FOKUS questionnaire data.")
}
result |>
purrr::chuck("issue") |>
purrr::map_depth(.depth = 1L,
.f = \(x) purrr::chuck(x, lang)) |>
purrr::list_c(ptype = character())
}
#' Get postal dispatch way
#'
#' Returns the FOKUS survey's postal dispatch way of the specified type for the specified canton at the specified ballot date.
#'
#' @inheritParams lvls
#' @param dispatch_type Postal dispatch type. One of `r pal::enum_fn_param_defaults(param = "dispatch_type", fn = postal_dispatch_way)`.
#'
#' @return A character scalar.
#' @family predicate_other
#' @family postal_dispatch
#' @export
#'
#' @examples
#' fokus::postal_dispatch_way(ballot_date = "2018-09-23",
#' canton = "aargau",
#' dispatch_type = "invitation")
postal_dispatch_way <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
dispatch_type = all_postal_dispatch_types) {
dispatch_type <- rlang::arg_match(dispatch_type)
raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::chuck("postal_dispatch", "type", dispatch_type)
}
#' Get response options
#'
#' Returns response options of the specified type and optionally subtype(s) from the [raw FOKUS questionnaire data][raw_qstnr].
#'
#' Note that only recurring response options are returned which are defined under the `response_options` top-level key in the file
#' `data-raw/questionnaire/questionnaire.toml`.
#'
#' @inheritParams lang_to_locale
#' @param type Response option type. One of
#' `r pal::as_md_val_list(all_response_option_types)`
#' @param subtypes Hierarchical response option subtypes as a character vector, or `NULL`. If `NULL`, all subtypes are returned.
#'
#' @return A character vector.
#' @family predicate_other
#' @export
#'
#' @examples
#' fokus:::response_options(type = "abstain",
#' lang = "de")
#'
#' fokus:::response_options(type = "abstain",
#' lang = "de",
#' subtypes = "election")
#'
#' fokus:::response_options(type = "abstain",
#' lang = "de",
#' subtypes = c("election", "proportional"))
response_options <- function(type = all_response_option_types,
lang = pal::pkg_config_val("lang"),
subtypes = NULL) {
type <- rlang::arg_match(type)
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_character(subtypes,
any.missing = FALSE,
min.len = 1L,
null.ok = TRUE)
raw_qstnr |>
purrr::chuck("response_options", type, lang, !!!subtypes) |>
pal::as_chr()
}
#' Questionnaire data
#'
#' A tibble containing all FOKUS questionnaires as structured data.
#'
#' `qstnrs` was generated based on the following steps:
#'
#' 1. [gen_qstnr_tibble()] was run for all valid combinations of `canton` and `ballot_date`, some validation checks were performed, and the results were merged
#' into a single tibble.
#' 2. List columns were [expanded][expand_qstnr_tibble] to [long format](https://en.wikipedia.org/wiki/Wide_and_narrow_data).
#' 3. Columns [`question_intro_i` and `question_intro_j`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) were merged into the single
#' column `question_intro`.
#' 4. Column [`question_full`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) was complemented, i.e. made to fall back on `question` if
#' `NA`.
#' 5. Columns [`question_common`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) and
#' [`variable_label_common`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) were complemented, i.e. made to fall back on
#' `question_full` and `variable_label` respectively if `NA`.
#' 6. Markdown formatting was [stripped][pal::strip_md] from all character columns.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::qstnrs
"qstnrs"
#' Proposal data
#'
#' A tibble containing basic referendum proposal data of all FOKUS questionnaires.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::proposals
"proposals"
#' Election data
#'
#' A tibble containing basic election data of all FOKUS questionnaires.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::elections
"elections"
#' Ballot data
#'
#' A list of tibbles containing official statistical data about all FOKUS-covered ballots. The data includes i.a. the total electorate as well as participation
#' numbers per voting channel and per voting decision.
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @family qstnr_data
#'
#' @examples
#' fokus::ballots
"ballots"
#' Read in easyvote municipality data
#'
#' Reads in the latest dataset of easyvote municipality information provided to us not earlier than 90 days before and up until 20 days after the `ballot_date`.
#'
#' If both columns `min_age` and `max_age` are `NA` in the data returned, it means that
#'
#' - the municipality did not provide easyvote with specific information on the target age range, and
#' - the municipality has subscribed to parcel mailing (instead of direct delivery to households) and delivers the brochures itself -- very likely to young
#' adults between 18--25 years.
#'
#' @inheritParams lvls
#' @inheritParams read_private_file
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_easyvote_municipalities(ballot_date = "2020-09-27",
#' canton = "aargau") |>
#' colnames()
#' )
read_easyvote_municipalities <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
# get date of latest dataset delivered *not earlier than 90 days before ballot date* and *up until 20 days after ballot date*
date_boundary_lower <- ballot_date - 90L
date_boundary_upper <- ballot_date + 20L
date_data <-
gitlab::dir_ls(ref = repo_private_default_branch,
path = "raw",
id_project = repo_private_proj_id,
token = auth_token) |>
dplyr::pull("path") |>
stringr::str_subset(pattern = stringr::fixed("raw/easyvote_municipalities_")) |>
stringr::str_extract(glue::glue("\\d{{4}}-\\d{{2}}-\\d{{2}}(?=_{canton}\\.csv$)")) |>
clock::date_parse() %>%
magrittr::extract(. >= date_boundary_lower & . <= date_boundary_upper) |>
pal::safe_max()
if (length(date_data) == 0L) {
cli::cli_abort(paste0("No easyvote municipality data present for canton {.val {canton}} with effective date at minimum 90 days before and at maximum 20 ",
"days after the ballot date {.val {ballot_date}}."))
}
read_private_file(path = glue::glue("raw/easyvote_municipalities_{date_data}_{canton}.csv"),
use_cache = use_cache,
auth_token = auth_token) |>
readr::read_csv(col_types = "ciii")
}
#' Read in online participation codes
#'
#' Reads in the online participation codes externally generated by the survey institute that are necessary to [generate QR codes with personalized survey
#' URLs][export_qr_codes].
#'
#' @inheritParams read_easyvote_municipalities
#'
#' @return A character vector.
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_online_participation_codes(ballot_date = "2018-11-25",
#' canton = "aargau") |>
#' length()
#' )
read_online_participation_codes <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
path <- glue::glue("raw/online_participation_codes_{ballot_date}_{canton}.txt")
if (!gitlab::file_exists(path = path,
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token)) {
cli::cli_abort("No online participation codes present for canton {.val {canton}} @ {.val {ballot_date}}.")
}
read_private_file(path = path,
use_cache = use_cache,
auth_token = auth_token) |>
stringr::str_split_1(pattern = stringr::fixed("\n"))
}
#' Read in generated survey data
#'
#' @description
#' Reads in the FOKUS survey dataset exported by [export_survey_data()] for the specified ballot date in the specified canton and language, optionally merged
#' with all prior survey datasets for that canton and language.
#'
#' @includeRmd data-raw/snippets/merged_data.Rmd
#'
#' @inheritParams ballot_title
#' @inheritParams read_private_file
#' @param merged Whether or not to read in the *merged* dataset that includes the data from **all** ballot dates up until `ballot_date` that were covered by
#' FOKUS surveys in the specified `canton`. See section *Merged data* below for details. If `FALSE`, only the data for `ballot_date` itself is returned.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_survey_data(ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "en") |>
#' nrow()
#' )
#'
#' try(
#' fokus::read_survey_data(ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "en",
#' merged = TRUE) |>
#' nrow()
#' )
read_survey_data <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang"),
merged = FALSE,
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_flag(merged)
read_private_file(path = glue::glue("generated/survey_data_", ifelse(merged, "merged_", ""), "{lang}_{ballot_date}_{canton}.rds"),
use_cache = use_cache,
auth_token = auth_token) |>
memDecompress() |>
unserialize()
}
#' Read in extra voting register data
#'
#' Reads in the raw extra voting register data provided by the statistical office, performs various integrity checks and returns it in tidy shape.
#'
#' @inheritParams read_easyvote_municipalities
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_voting_register_data_extra(ballot_date = "2019-10-20",
#' canton = "aargau") |>
#' colnames()
#' )
read_voting_register_data_extra <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
rlang::check_installed("readxl",
reason = pal::reason_pkg_required())
# get date of latest dataset delivered *before* ballot date
date_data <-
gitlab::dir_ls(ref = repo_private_default_branch,
path = "raw",
id_project = repo_private_proj_id,
token = auth_token) |>
dplyr::pull("path") |>
stringr::str_subset(pattern = stringr::fixed("raw/voting_register_data_extra_")) |>
stringr::str_extract(glue::glue("\\d{{4}}-\\d{{2}}-\\d{{2}}(?=_{canton}\\.xlsx$)")) |>
clock::date_parse() %>%
magrittr::extract(. < ballot_date) |>
pal::safe_max()
if (length(date_data) == 0L) {
cli::cli_abort("No voting register data present for canton {.val {canton}} with effective date before the ballot on {.val {ballot_date}}.")
}
# NOTE: `readxl::read_xlsx()` can only read from file, so we have to temporarily write the file to disk
tmp_file <- fs::file_temp(pattern = glue::glue("voting_register_data_extra_{date_data}_{canton}"),
ext = "xlsx")
read_private_file(path = glue::glue("raw/voting_register_data_extra_{date_data}_{canton}.xlsx"),
use_cache = use_cache,
auth_token = auth_token) |>
brio::write_file_raw(path = tmp_file)
data <-
readxl::read_xlsx(path = tmp_file,
col_types = "text") |>
# rename variables to our scheme
dplyr::rename(id = `ID-Nummer`,
sex_official = Geschlecht,
year_of_birth_official = Jahrgang,
marital_status_official = Zivilstand,
household_size_official = "Haushaltsgr\u00f6sse Anzahl Personen Total",
n_adults_in_household_official = "Haushaltsgr\u00f6sse Anzahl Personen \u00fcber 18 Jahren",
n_kids_in_household_official = "Haushaltsgr\u00f6sse Anzahl Personen unter 18 Jahren") |>
# convert numeric columns to type integer
dplyr::mutate(dplyr::across(c(id,
year_of_birth_official,
household_size_official,
n_adults_in_household_official,
n_kids_in_household_official),
as.integer)) |>
# transform variable values to our scheme
dplyr::mutate(dplyr::across(c(sex_official, marital_status_official),
stringr::str_to_lower)) |>
dplyr::mutate(marital_status_official = dplyr::case_match(.x = marital_status_official,
"eingetragene partnerschaft" ~ "in eingetragener Partnerschaft",
"aufgel\u00f6ste partnerschaft" ~ "aufgel\u00f6ste Partnerschaft",
"unverheiratet" ~ "ledig",
.default = marital_status_official))
# integrity check 1: ensure no unexpected columns occur
if (ncol(data) > 7L) {
unknown_colnames <-
colnames(data) |>
setdiff(c(id,
sex_official,
year_of_birth_official,
marital_status_official,
household_size_official,
n_adults_in_household_official,
n_kids_in_household_official))
cli::cli_abort("Unexpected column(s) detected in private file {.file raw/voting_register_data_extra_{date_data}_{canton}.xlsx}: {.val unknown_colnames}",
.internal = TRUE)
}
# integrity check 2: ensure no unexpected values occur
## in `sex_official`
unknown_sex_official_i <-
data$sex_official |>
magrittr::is_in(var_val_set(var_name = "sex_official",
ballot_date = ballot_date,
canton = canton,
lang = "de")) |>
magrittr::not() |>
which()
if (length(unknown_sex_official_i) > 0L) {
cli::cli_abort("{.var sex_official} in raw extra voting register data has unknown values: {.val {unique(data$sex_official[unknown_sex_official_i])}}")
}
## in `marital_status_official`
unknown_marital_status_official_i <-
data$marital_status_official |>
magrittr::is_in(var_val_set(var_name = "marital_status_official",
ballot_date = ballot_date,
canton = canton,
lang = "de")) |>
magrittr::not() |>
which()
if (length(unknown_marital_status_official_i)) {
cli::cli_abort(paste0("{.var marital_status_official} in raw extra voting register data has unknown values: ",
"{.val {unique(data$sex_official[unknown_marital_status_official_i])}}"))
}
data
}
#' Read in voting register identifiers
#'
#' Reads in the voting register identifiers of the population that was invited to participate in the FOKUS survey at the specified ballot date in the specified
#' canton.
#'
#' Note that this data is not available for all FOKUS surveys.
#'
#' @inheritParams read_easyvote_municipalities
#'
#' @return `r pkgsnip::return_lbl("tibble_cols", cols = "id_voting_register")`
#' @family data_import
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_voting_register_ids(ballot_date = "2019-10-20",
#' canton = "aargau") |>
#' nrow()
#' )
read_voting_register_ids <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = all_cantons)
path <- glue::glue("raw/voting_register_ids_{ballot_date}_{canton}.csv")
if (!gitlab::file_exists(path = path,
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token)) {
cli::cli_abort("No voting register ID data present for canton {.val {canton}} @ {.val {ballot_date}}.")
}
read_private_file(path = glue::glue("raw/voting_register_ids_{ballot_date}_{canton}.csv"),
use_cache = use_cache,
auth_token = auth_token) |>
readr::read_csv(col_types = "i") |>
# integrity check
pal::when(ncol(.) > 1L ~ cli::cli_abort("More than one column present in {.file {path}}. Please debug.",
.internal = TRUE),
~ .) |>
dplyr::rename(id_voting_register = 1L)
}
#' Read in file from private FOKUS repository
#'
#' Downloads a file from the [private FOKUS repository](`r url_repo_private()`) and returns it as a character scalar in case of a text file, or a [raw] vector
#' otherwise.
#'
#' Files are downloaded via [GitLab's RESTful API (v4)](https://docs.gitlab.com/ee/api/rest/). If `use_cache = TRUE` (the default), a downloaded file is cached
#' on disk in this package's [user-cache pins board][pkgpins::board] and only newly fetched from the private FOKUS repository GitLab remote if is has changed
#' since being downloaded the last time. Caching saves a bit of time and (potentially) a lot of bandwidth.
#'
#' @param path File path relative to the repository root.
#' @param use_cache Whether or not to return cached results if possible. Caching is done based on file content hashing, so the file is only newly fetched if it
#' actually changed since the last download. If `FALSE`, the file is always newly fetched.
#' @param auth_token [Personal access token of a gitlab.com account](https://gitlab.com/-/user_settings/personal_access_tokens) with access to the [private
#' FOKUS repository](`r url_repo_private()`).
#'
#' @return The file content, as character scalar for text files, otherwise as a [raw vector][raw].
#' @family data_import
#' @family private
#' @export
#'
#' @examples
#' # GitLab PAT with access to the private FOKUS repository is required for this function to work
#' try(
#' fokus::read_private_file("raw/survey_data_2018-09-23_aargau.xlsx") |>
#' length()
#' )
read_private_file <- function(path,
use_cache = TRUE,
auth_token = pal::pkg_config_val("token_repo_private")) {
checkmate::assert_string(path)
pkgpins::with_cache(expr = gitlab::file_content(path = path,
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token),
pkg = this_pkg,
from_fn = "read_private_file",
gitlab::file_meta(path = path,
attribute = "content_sha256",
id_project = repo_private_proj_id,
ref = repo_private_default_branch,
token = auth_token),
use_cache = use_cache,
max_cache_age = Inf)
}
#' Tidy columns
#'
#' Renames a data frame's columns and converts them to their proper types. Aimed at datasets published by cantonal statistical offices.
#'
#' @param data Data frame whose columns are to be converted.
#' @param default_type [readr column type][readr::col_character] to which columns are to be converted for which no explicit type is predefined.
#'
#' @return `data`
#' @family data_import
#' @export
tidy_cols <- function(data,
default_type = readr::col_character()) {
data |>
# rename cols
pal::rename_from(dict = dicts$colnames$ballots) |>
# remove `.0` suffix from numbers to avoid warnings from `readr::type_convert()` below
dplyr::mutate(dplyr::across(.cols = where(is.character),
.fns = \(x) stringr::str_replace(string = x,
pattern = "^(\\d+)\\.0$",
replacement = "\\1"))) %>%
# tidy col types
# NOTE: we must reduce `col_types` to the ones actually present in `data` to avoid warnings
readr::type_convert(col_types = readr::cols(!!!col_types[intersect(names(col_types),
colnames(.))],
.default = default_type))
}
#' Export questionnaire data
#'
#' Generates the [questionnaire tibble][gen_qstnr_tibble], the [Markdown questionnaire][gen_qstnr_md] and optionally a CSV, an HTML and an XLSX version of it,
#' and writes all of them to `path` and optionally uploads them to a Google Drive folder.
#'
#' The generated files are named according to the scheme `{ballot_date}_{canton}.{ext}`, so if the `qstnr_tibble` of the 2018-09-23 survey in the canton of
#' Aargau is input, the following files will be written to `path` by default:
#'
#' - `2018-09-23_aargau.csv`
#' - `2018-09-23_aargau.html`
#' - `2018-09-23_aargau.md`
#' - `2018-09-23_aargau.xlsx`
#'
#' @inheritParams expand_qstnr_tibble
#' @param path Path to the directory to write the generated questionnaire files to. A character scalar.
#' @param verbose Whether or not to print detailed progress information during questionnaire generation and Google Drive file upload. Note that questionnaire
#' generation takes considerably more time when this is set to `TRUE`.
#' @param incl_csv Whether or not to also generate and export a CSV version of the questionnaire.
#' @param incl_html Whether or not to also generate and export an HTML version of the questionnaire.
#' @param incl_xlsx Whether or not to also generate and export an XLSX version of the questionnaire.
#' @param upload_to_g_drive Whether or not to upload the generated files to the Google Drive folder `g_drive_folder`.
#' @param g_drive_folder Google Drive folder to upload the generated files to. Ignored if `upload_to_g_drive = FALSE`.
#'
#' @return `path`, invisibly.
#' @family data_export
#' @export
export_qstnr <- function(qstnr_tibble,
path,
verbose = FALSE,
incl_csv = TRUE,
incl_html = TRUE,
incl_xlsx = incl_html,
upload_to_g_drive = FALSE,
g_drive_folder = "fokus/aargau/Umfragen/Dateien f\u00fcr Umfrageinstitut/Fragebogen/") {
path <- fs::path_abs(path)
fs::dir_create(path)
checkmate::assert_flag(incl_csv)
checkmate::assert_flag(incl_html)
checkmate::assert_flag(incl_xlsx)
if (incl_xlsx && !incl_html) {
cli::cli_abort("{.arg incl_html} must be set to {.val TRUE} when {.code incl_xlsx = TRUE} because the XLSX file is generated from the HTML file.")
}
checkmate::assert_flag(upload_to_g_drive)
rlang::check_installed("rmarkdown",
reason = pal::reason_pkg_required())
rlang::check_installed("yay",
reason = pal::reason_pkg_required())
# extract ballot date and canton from `qstnr_tibble`
ballot_date <- as_ballot_date(unique(qstnr_tibble$ballot_date))
canton <- rlang::arg_match0(arg = unique(qstnr_tibble$canton),
values = all_cantons,
arg_nm = "unique(qstnr_tibble$canton)")
# Generate Markdown version
md_path <- fs::path(path, glue::glue("{ballot_date}_{canton}.md"))
qstnr_tibble |>
gen_qstnr_md() |>
brio::write_lines(path = md_path)
# create CSV version from tibble if requested
if (incl_csv) {
pal::cli_progress_step_quick(msg = "Converting {.val {canton}} @ {.val {ballot_date}} questionnaire tibble to CSV")
csv_path <- fs::path_ext_set(path = md_path,
ext = "csv")
qstnr_tibble |>
clean_qstnr_tibble() |>
dplyr::mutate(variable_name_32 =
purrr::map2_chr(.x = variable_name,
.y = dplyr::if_else(block %in% c("x_polling_agency", "y_generated", "z_generated")
| stringr::str_detect(string = variable_name,
pattern = paste0("^", pal::fuse_regex(c("agreement_contra_argument_",
"information_source_",
"reason_non_participation_",
"political_occasions_")))),
32L,
30L),
.f = ~ shorten_var_names(var_names = .x,
max_n_char = .y)),
.after = variable_name) |>
dplyr::select(-ends_with("_common"),
-c(lvl,
i,
j,
question_intro_i,
question_intro_j,
question_full)) |>
expand_qstnr_tibble() |>
readr::write_csv(file = csv_path,
na = "")
cli::cli_progress_done()
}
# create HTML version from Markdown questionnaire if requested
if (incl_html) {
html_path <- fs::path_ext_set(path = md_path,
ext = "html")
pal::cli_progress_step_quick(msg = "Converting {.val {canton}} @ {.val {ballot_date}} Markdown questionnaire to HTML using Pandoc")
rmarkdown::pandoc_convert(input = md_path,
to = "html5",
from = "markdown",
output = html_path,
options = c("--standalone",
"--css=github-pandoc.css",
glue::glue('--metadata=title:FOKUS-{ stringr::str_to_sentence(canton) }-Fragebogen f\u00fcr den ',
ballot_title(ballot_date = ballot_date,
canton = canton))),
verbose = FALSE)
cli::cli_progress_done()
}
# create XLSX version from HTML questionnaire if requested
if (incl_xlsx) {
pal::cli_progress_step_quick(msg = "Converting {.val {canton}} @ {.val {ballot_date}} HTML questionnaire to XLSX using LibreOffice")
system2(command = "flatpak",
args = glue::glue("run --command=libreoffice",
"org.libreoffice.LibreOffice",
"--calc",
"--headless",
"--convert-to xlsx",
"--outdir \"{path}\"",
"\"{html_path}\"",
.sep = " "),
stdout = ifelse(verbose, "", FALSE))
cli::cli_progress_done()
}
# upload files to Google Drive for polling agency if requested
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = c(md_path,
csv_path[incl_csv],
html_path[incl_html],
fs::path(path, "github-pandoc.css")[incl_html],
fs::path_ext_set(path = html_path,
ext = "xlsx")[incl_xlsx]),
g_drive_folder = g_drive_folder,
quiet = !verbose)
}
invisible(path)
}
#' Export QR codes with personalized survey URL
#'
#' Exports a ZIP file, that contains a [QR code](https://en.wikipedia.org/wiki/QR_code) in SVG and in EPS format for each survey participant storing the
#' personalized survey URL, to the [private FOKUS repository][print_private_repo_structure].
#'
#' @inheritParams lvls
#' @inheritParams export_qstnr
#' @inheritParams upload_to_g_drive
#' @inheritParams read_online_participation_codes
#' @param quiet `r pkgsnip::param_lbl("quiet")`
#' @param verbose Whether or not to print detailed status output from [Google Drive file upload][upload_to_g_drive].
#'
#' @return A [tibble][tibble::tbl_df] containing metadata about the contents of the created ZIP archive, invisibly.
#' @family data_export
#' @export
export_qr_codes <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
upload_to_g_drive = TRUE,
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/QR-Codes/"),
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE,
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(upload_to_g_drive)
checkmate::assert_flag(quiet)
checkmate::assert_flag(verbose)
rlang::check_installed("archive",
reason = pal::reason_pkg_required())
rlang::check_installed("qrencoder",
reason = pal::reason_pkg_required())
rlang::check_installed("rsvg",
reason = pal::reason_pkg_required())
participation_codes <- read_online_participation_codes(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token)
tmp_dir <-
glue::glue("fokus_qr_codes_{ballot_date}_{canton}") |>
fs::path_temp() |>
fs::dir_create()
on.exit(fs::dir_delete(tmp_dir),
add = TRUE,
after = FALSE)
tmp_dir_svg <-
fs::path(tmp_dir, "svg") |>
fs::dir_create()
tmp_dir_eps <-
fs::path(tmp_dir, "eps") |>
fs::dir_create()
# create SVG and EPS image files
if (!quiet) {
cli_id <- pal::cli_progress_step_quick(
msg = "Generating {length(participation_codes)} personalized QR code{?s} in SVG and EPS format for canton {.val {canton}} @ {.val {ballot_date}}"
)
}
participation_codes |>
purrr::walk2(.progress = !quiet,
.x = participation_codes,
.y = _,
.f = ~ {
path_svg <- fs::path(tmp_dir_svg, .x,
ext = "svg")
# create SVG file
url <- url_survey_host |> purrr::chuck(canton)
url_parameter <- url_parameter_survey |> purrr::chuck(canton)
qrencoder::qrencode_svg(to_encode = glue::glue("{url}?{url_parameter}={.x}"),
level = 3L) |>
brio::write_file(path = path_svg)
# create EPS file from SVG file
rsvg::rsvg_eps(svg = path_svg,
file = fs::path(tmp_dir_eps, .x,
ext = "eps"))
})
if (!quiet) {
cli::cli_progress_done(id = cli_id)
}
# create ZIP archive of SVG and EPS files
if (!quiet) {
cli_id <- pal::cli_progress_step_quick(msg = "Compressing SVG and EPS QR code files to ZIP archive")
}
filename_zip <- glue::glue("{ballot_date}_{canton}_qr_codes.zip")
tmp_path_zip <- fs::path(tmp_dir, filename_zip)
result <- archive::archive_write_dir(archive = tmp_path_zip,
dir = tmp_dir,
format = "zip")
if (!quiet) {
cli::cli_progress_done(id = cli_id)
}
# upload ZIP archive to private repo
write_private_file(path = fs::path("generated/for-polling-agency", filename_zip),
content = tmp_path_zip,
from_file = TRUE,
auth_token = auth_token,
quiet = quiet)
# upload ZIP archive to Google Drive for polling agency if requested
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = tmp_path_zip,
g_drive_folder = g_drive_folder,
quiet = quiet || !verbose)
}
invisible(result)
}
#' Export print recipients data
#'
#' Exports a CSV dataset containing the two columns `id` and `receives_print` to the [private FOKUS repository][print_private_repo_structure].
#'
#' @inheritParams export_qr_codes
#'
#' @return `NULL` if no export for the specified ballot date is possible, otherwise a [tibble][tibble::tbl_df] of the exported data, invisibly.
#' @family data_export
#' @export
export_print_recipients <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
upload_to_g_drive = TRUE,
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/Print-Zielgruppen/"),
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE,
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(upload_to_g_drive)
checkmate::assert_flag(quiet)
checkmate::assert_flag(verbose)
# only export if `reminder_print_*` constraint present
if (raw_qstnr_suppl_mode(ballot_date = ballot_date,
canton = canton) |>
purrr::pluck("constraints") |>
stringr::str_detect("^reminder_print_.+") |>
any()) {
pal::cli_progress_step_quick(msg = "Exporting print recipients data for canton {.val {canton}} @ {.val {ballot_date}}")
# read in statistical office IDs used for current survey
ids <-
read_voting_register_ids(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token) |>
dplyr::pull("id_voting_register")
# ensure output folder exists
filename <- glue::glue("{ballot_date}_{canton}_print_recipients.csv")
tmp_path <- fs::path_temp(filename)
on.exit(fs::file_delete(tmp_path),
add = TRUE,
after = FALSE)
# export data
result <-
read_voting_register_data_extra(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token) |>
dplyr::filter(id %in% !!ids) |>
dplyr::mutate(receives_print = year_of_birth_official < 1970L) |>
dplyr::select(id, receives_print) |>
readr::write_csv(file = tmp_path)
gitlab::file_write(content = tmp_path,
path = fs::path("generated/for-polling-agency", filename),
id_project = repo_private_proj_id,
start_branch = repo_private_default_branch)
write_private_file(path = fs::path("generated/for-polling-agency", filename),
content = tmp_path,
from_file = TRUE,
auth_token = auth_token,
quiet = quiet)
# upload data to Google Drive for polling agency if requested
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = tmp_path,
g_drive_folder = g_drive_folder,
quiet = quiet || !verbose)
}
} else {
cli::cli_alert_info("No print recipients data export sensible or possible for canton {.val {canton}} @ {.val {ballot_date}}.")
result <- NULL
}
invisible(result)
}
#' Export easyvote municipality details
#'
#' Exports a CSV dataset containing the columns `municipality`, `municipality_id`, `min_age` and `max_age` to the [private FOKUS
#' repository][print_private_repo_structure].
#'
#' The meaning of the individual columns is as follows:
#'
#' | **column name** | **description** |
#' | --------------- | --------------- |
#' | `municipality` | official name of the municipality |
#' | `municipality_id` | [official Swiss community identification number](https://en.wikipedia.org/wiki/Community_Identification_Number#Switzerland) (also called "GEOSTAT"/"BFS" number, see the [corresponding German Wikipedia article](https://de.wikipedia.org/wiki/Gemeindenummer)) |
#' | `min_age` | `r var_lbl("easyvote_municipality_min_age")` |
#' | `max_age` | `r var_lbl("easyvote_municipality_max_age")` |
#'
#' @inheritParams export_qr_codes
#'
#' @return A [tibble][tibble::tbl_df] of the exported data, invisibly.
#' @family data_export
#' @export
export_easyvote_municipalities <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
upload_to_g_drive = TRUE,
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/easyvote-Gemeinden/"),
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE,
verbose = FALSE) {
ballot_date %<>% as_ballot_date()
canton <- rlang::arg_match(arg = canton,
values = cantons(ballot_date))
checkmate::assert_flag(upload_to_g_drive)
checkmate::assert_flag(quiet)
checkmate::assert_flag(verbose)
file_basename <- glue::glue("{ballot_date}_{canton}_easyvote_municipalities")
tmp_path <- fs::file_temp(pattern = file_basename,
ext = "csv")
on.exit(fs::file_delete(tmp_path),
add = TRUE,
after = FALSE)
result <-
read_easyvote_municipalities(ballot_date = ballot_date,
canton = canton,
auth_token = auth_token) |>
# assume 18-25 age range if both min/max age are NA
dplyr::mutate(is_likely_default = is.na(min_age) & is.na(max_age),
min_age = dplyr::if_else(is_likely_default,
18L,
min_age),
max_age = dplyr::if_else(is_likely_default,
25L,
max_age)) |>
dplyr::select(-is_likely_default) |>
readr::write_csv(file = tmp_path)
write_private_file(path = fs::path("generated/for-polling-agency", file_basename,
ext = "csv"),
content = tmp_path,
from_file = TRUE,
auth_token = auth_token,
quiet = quiet)
if (upload_to_g_drive) {
upload_to_g_drive(filepaths = tmp_path,
g_drive_folder = g_drive_folder,
quiet = quiet || !verbose)
}
invisible(result)
}
#' Export generated survey data
#'
#' @description
#' Exports a FOKUS survey dataset generated via *TODO* to the [private FOKUS repository][print_private_repo_structure].
#'
#' @includeRmd data-raw/snippets/merged_data.Rmd
#'
#' @inheritParams write_private_file
#' @param data FOKUS survey dataset. `r pkgsnip::param_lbl("tibble")`
#' @param lang Language. Either `NULL` to read the language from `data`'s `fokus_lang` attribute or one of
#' `r all_langs |> pal::as_md_vals() |> pal::enum_str(sep2 = " or ")`.
#' @param merged Whether or not `data` is a *merged* dataset, i.e. one that includes the data from **all** ballot dates that were covered by FOKUS surveys up
#' until the most recent `ballot_date` contained in `data`. See section *Merged data* below for details.
#'
#' If `NULL`, a merged dataset is assumed if `data` covers multiple `ballot_date`s.
#'
#' @return `data`, invisibly.
#' @family data_export
#' @export
export_survey_data <- function(data,
lang = NULL,
merged = NULL,
auth_token = pal::pkg_config_val("token_repo_private")) {
lang <-
lang %||%
attr(data, "fokus_lang") %||%
cli::cli_abort("{.arg lang} must be explicitly specified since {.arg data} lacks a {.field fokus_lang} attribute to detect the language from.")
lang <- rlang::arg_match(arg = lang,
values = all_langs)
checkmate::assert_flag(merged,
null.ok = TRUE)
assert_var_names_present(data = data,
var_names = c("ballot_date", "canton"))
if (is.null(merged)) {
merged <- length(unique(data$ballot_date)) > 1L
}
ballot_date <- checkmate::assert_date(unique(data$ballot_date),
any.missing = FALSE,
min.len = 1L)
canton <- checkmate::assert_character(unique(data$canton),
any.missing = FALSE,
min.len = 1L)
# assemble target path
path <- "generated/survey_data_"
if (!merged) {
if (!checkmate::test_scalar(ballot_date)) {
cli::cli_abort("Column {.var ballot_date} mustn't contain different dates when {.code merged = FALSE}.")
}
if (!checkmate::test_scalar(canton)) {
cli::cli_abort("Column {.var canton} mustn't contain different cantons when {.code merged = FALSE}.")
}
path %<>% paste0("{lang}_{ballot_date}_{canton}")
} else {
if (length(ballot_date) > 1L) {
ballot_date %<>% max()
}
if (length(canton) > 1L) {
path %<>% paste0("merged_{lang}_{ballot_date}")
} else {
path %<>% paste0("merged_{lang}_{ballot_date}_{canton}")
}
}
# write data
data |>
serialize(connection = NULL,
xdr = FALSE) |>
memCompress(type = "xz") |>
write_private_file(path = glue::glue(path, ".rds"),
auth_token = auth_token)
invisible(data)
}
#' Write file to private FOKUS repository
#'
#' Uploads a file to the [private FOKUS repository](`r url_repo_private()`) via [GitLab's RESTful API (v4)](https://docs.gitlab.com/ee/api/rest/).
#'
#' @inheritParams read_private_file
#' @param content File content, as a character scalar for text files, or a [raw vector][raw] for binary files. Or the path to a local file as a character scalar
#' if `from_file = TRUE`.
#' @param from_file Whether or not `content` indicates the path to a local file instead of the actual file content.
#' @param overwrite Whether or not to overwrite an already existing file.
#' @param commit_message Git commit message for file creation/update.
#' @param branch Git branch name to upload the file to.
#' @param quiet `r pkgsnip::param_lbl("quiet")`
#'
#' @return `path`, invisibly.
#' @family data_export
#' @family private
#' @export
write_private_file <- function(path,
content,
from_file = FALSE,
overwrite = TRUE,
commit_message = "auto: update file via fokus R pkg",
branch = repo_private_default_branch,
auth_token = pal::pkg_config_val("token_repo_private"),
quiet = FALSE) {
gitlab::file_write(content = content,
path = path,
id_project = repo_private_proj_id,
start_branch = branch,
from_file = from_file,
overwrite = overwrite,
commit_message = commit_message,
token = auth_token,
quiet = quiet)
}
#' Get variable description
#'
#' Extracts a variable's (common) description from the [questionnaire data][qstnrs].
#'
#' If no `ballot_date` and `canton` are specified or `var_name` is not included at `ballot_date`,
#' [`variable_label_common`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys) is returned, otherwise
#' [`variable_label`](https://fokus.rpkg.dev/articles/raw_qstnr_schema.html#supported-keys). Note that `ballot_date` and `canton` either must both be `NULL` or
#' set to a valid canton name and ballot date respectively.
#'
#' @param var_name Variable name. A character scalar.
#' @param ballot_date `NULL` or a FOKUS-covered ballot date, i.e. one of
#' `r pal::as_md_val_list(as.character(all_ballot_dates))`
#' @param canton `NULL` or a FOKUS-covered canton name, i.e. one of
#' `r pal::as_md_val_list(all_cantons)`
#'
#' @return A character scalar.
#' @family vars
#' @export
#'
#' @examples
#' # if `ballot_date` and `canton` are not supplied, `variable_label_common` is returned:
#' fokus::var_lbl("participation_federal")
#'
#' # otherwise `variable_label`:
#' fokus::var_lbl(var_name = "participation_federal",
#' ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::var_lbl(var_name = "participation_federal",
#' ballot_date = "2019-10-20",
#' canton = "aargau")
var_lbl <- function(var_name,
ballot_date = NULL,
canton = NULL) {
is_common <- is.null(ballot_date) && is.null(canton)
if (!is_common) {
is_arg_invalid <- purrr::map_lgl(list(ballot_date, canton),
is.null)
arg_names <- c("ballot_date", "canton")
if (any(is_arg_invalid)) {
cli::cli_abort(paste0("Either {.arg ballot_date} and {.arg canton} must both be {.val NULL} or set to a valid canton name and ballot date, but ",
"{.arg {arg_names[is_arg_invalid]}} is {.val NULL} while {.arg {arg_names[!is_arg_invalid]}} is ",
"{.val {get(arg_names[!is_arg_invalid])}}."))
}
result <- var_predicate(predicate = "variable_label",
var_name = var_name,
ballot_date = ballot_date,
canton = canton)
is_common <- length(result) == 0L
}
if (is_common) {
result <-
fokus::qstnrs |>
dplyr::filter(variable_name == !!var_name) |>
dplyr::pull("variable_label_common") |>
unique()
}
result
}
#' Determine variable's political level(s)
#'
#' Determines political level(s) of one or more variables.
#'
#' Note that the political levels are determined by simply parsing `var_names`.
#'
#' @inheritParams is_skill_question_var
#'
#' @return A character vector of political levels, of length 0 if no specific levels could be determined.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(lvls = purrr::map(variable_name,
#' fokus::var_lvls)) |>
#' dplyr::filter(purrr::map_lgl(lvls,
#' \(x) length(x) > 0)) |>
#' dplyr::select(variable_name, lvls) |>
#' tidyr::unnest_longer(col = lvls,
#' values_to = "lvl") |>
#' unique()
var_lvls <- function(var_names) {
checkmate::assert_character(var_names)
is_cantonal <- var_names |> stringr::str_detect(pattern = as_sym_part_regex("cantonal")) |> any()
is_federal <- var_names |> stringr::str_detect(pattern = as_sym_part_regex("federal")) |> any()
c("cantonal"[is_cantonal], "federal"[is_federal])
}
#' Determine variable's election procedure
#'
#' Determines the election procedure each variable corresponds to. In case no election procedure could be determined for a variable, `NA_character` is returned.
#'
#' @inherit is_skill_question_var details
#'
#' @inheritParams is_skill_question_var
#'
#' @return A character vector of the same length as `var_names`.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(prcd = fokus::var_prcd(variable_name)) |>
#' dplyr::filter(!is.na(prcd)) |>
#' dplyr::select(variable_name, prcd) |>
#' unique()
var_prcd <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(pattern = paste0(pal::fuse_regex(all_prcds), glue::glue("(?=_election{sym_part_regex_end})")))
}
#' Determine variable's election number
#'
#' Determines the election number each variable corresponds to. In case no election number could be determined for a variable, `NA_character` is returned.
#'
#' @inherit is_skill_question_var details
#'
#' @inheritParams is_skill_question_var
#'
#' @return An integer vector of the same length as `var_names`.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(election_nr = fokus::var_election_nr(variable_name)) |>
#' dplyr::filter(!is.na(election_nr)) |>
#' dplyr::select(variable_name, election_nr) |>
#' unique()
var_election_nr <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(glue::glue("(?<={sym_part_regex_start}election_)\\d+")) |>
as.integer()
}
#' Determine variable's proposal number
#'
#' Determines the proposal number each variable corresponds to. In case no proposal number could be determined for a variable, `NA_character` is returned.
#'
#' @inherit is_skill_question_var details
#'
#' @inheritParams is_skill_question_var
#'
#' @return An integer vector of the same length as `var_names`.
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(proposal_nr = fokus::var_proposal_nr(variable_name)) |>
#' dplyr::filter(!is.na(proposal_nr)) |>
#' dplyr::select(variable_name, proposal_nr) |>
#' unique()
var_proposal_nr <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(glue::glue("(?<={sym_part_regex_start}proposal_)\\d+")) |>
as.integer()
}
#' Determine variable's skill question number
#'
#' Determines the skill question number each variable corresponds to. In case no skill question number could be determined for a variable, `NA_character` is
#' returned.
#'
#' @inherit var_proposal_nr details return
#'
#' @inheritParams is_skill_question_var
#'
#' @family vars
#' @export
#'
#' @examples
#' fokus::qstnrs |>
#' dplyr::mutate(skill_question_nr = fokus::var_skill_question_nr(variable_name)) |>
#' dplyr::filter(!is.na(skill_question_nr)) |>
#' dplyr::select(variable_name, skill_question_nr) |>
#' unique()
var_skill_question_nr <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_extract(glue::glue("(?<={sym_part_regex_start}skill_question_)\\d+")) |>
as.integer()
}
#' Get variable title
#'
#' Extracts a variable's title from the [questionnaire data][qstnrs], adapted to the actual [election_name()] if applicable.
#'
#' @inheritParams lvls
#' @inheritParams var_lbl
#'
#' @return `NULL` if the variable is not present at the specified `ballot_date` and `canton`, otherwise a character scalar.
#' @family vars
#' @export
#'
#' @examples
#' fokus::var_title(var_name = "weight_decision",
#' ballot_date = "2018-11-25",
#' canton = "aargau")
#'
#' fokus::var_title(var_name = "weight_decision",
#' ballot_date = "2019-10-20",
#' canton = "aargau")
#'
#' fokus::var_title(var_name = "voting_decision_cantonal_proportional_election_1_party",
#' ballot_date = "2024-10-20",
#' canton = "aargau")
var_title <- function(var_name,
ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
ballot_date %<>% as_ballot_date()
lang <- "de"
result <- var_predicate(predicate = "topic",
var_name = var_name,
ballot_date = ballot_date,
canton = canton)
# replace generic with actual election name
prcd <- var_prcd(var_name)
if (!is.na(prcd)) {
lvl <- checkmate::assert_string(var_lvls(var_name))
election_nr <- var_election_nr(var_name)
regex_cut <-
phrased_terms |>
dplyr::filter(term == "lvl") |>
dplyr::pull(!!lang) |>
paste(collapse = "|") %>%
paste0("(?=", ., ")")
if (has_election(ballot_date = ballot_date,
lvls = lvl,
canton = canton,
prcds = prcd)) {
result %<>%
stringr::str_extract(pattern = paste0("^.+?", regex_cut)) %>%
paste0(election_name(ballot_date = ballot_date,
lvl = lvl, canton = canton,
prcd = prcd,
election_nr = election_nr,
lang = lang,
type = "short"),
"\u00a0",
clock::get_year(ballot_date))
}
}
# return `NULL` instead of empty chr vctr
if (length(result) == 0L) {
result <- NULL
}
result
}
#' Get variable's value set
#'
#' Extracts a variable's value set from the [questionnaire data][qstnrs] in the specified language (or its integer representation if `lang = "int"`).
#'
#' @inheritParams lvls
#' @inheritParams var_lbl
#' @param lang Language. One of `r c(all_langs, "int") |> pal::as_md_vals() |> pal::enum_str(sep2 = " or ")` for the value set's integer codes."
#'
#' @return A character scalar.
#' @family vars
#' @export
#'
#' @examples
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2018-09-23",
#' canton = "aargau")
#'
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2023-06-18",
#' canton = "aargau")
#'
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "en")
#'
#' fokus::var_val_set(var_name = "favored_party",
#' ballot_date = "2023-06-18",
#' canton = "aargau",
#' lang = "int")
var_val_set <- function(var_name,
ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date),
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = c(all_langs, "int"))
var_predicate(predicate = switch(EXPR = lang,
de = "response_options",
en = "value_labels",
int = "variable_values",
cli::cli_abort("Not implemented. Please debug.",
.internal = TRUE)),
var_name = var_name,
ballot_date = ballot_date,
canton = canton)
}
#' Add variable names to combination list
#'
#' Adds one or more `var_name`s to a combination list.
#'
#' @inheritParams shorten_var_names
#' @param list A list as returned by the `combos_*()` functions like [combos_ballot_types()].
#'
#' @return A list with `list` × `var_names` elements.
#' @family combo
#' @family vars
#' @export
#'
#' @examples
#' fokus::combos_proposals(ballot_dates = "2023-06-18",
#' cantons = "aargau",
#' incl_nr = FALSE) |>
#' fokus::add_vars_to_combos(var_names = c("age_group", "favored_party"))
add_vars_to_combos <- function(list,
var_names) {
checkmate::assert_list(list,
any.missing = FALSE)
checkmate::assert_character(var_names,
min.chars = 1L,
any.missing = FALSE)
list |>
purrr::map(\(x) {
purrr::map(var_names,
\(var_name) purrr::assign_in(x = x,
where = "var_name",
value = var_name))
}) |>
purrr::list_flatten()
}
#' Determine whether variable is skill question
#'
#' Determines for each variable whether or not it is a skill question.
#'
#' Note that the determination is performed by simply parsing `var_names`.
#'
#' @param var_names A character vector of FOKUS variable names.
#'
#' @return A logical vector of the same length as `var_names`.
#' @family vars
#' @export
is_skill_question_var <- function(var_names) {
var_names |>
checkmate::assert_character() |>
stringr::str_detect(pattern = "^skill_question_\\d+_(cantonal|federal)(_proposal_\\d+)?$")
}
#' Relabel factor of election parties
#'
#' Relabels a [factor] that contains election parties from/to the different FOKUS election party name types.
#'
#' @inheritParams election_parties
#' @param fct Factor to be relabelled.
#' @param from_type Name type to convert from. One of `r pal::enum_fn_param_defaults(param = "from_type", fn = fct_relabel_election_parties)`.
#' @param to_type Name type to convert to. One of `r pal::enum_fn_param_defaults(param = "to_type", fn = fct_relabel_election_parties)`.
#' @param strict Whether or not to strictly ensure that all of `fct` levels are matched by [known election parties][election_parties].
#'
#' @return A factor.
#' @seealso [election_parties()]
#' @family fcts
#' @export
#'
#' @examples
#' d <- fokus::read_survey_data(ballot_date = "2024-10-20",
#' canton = "aargau",
#' lang = "de")
#' # before
#' levels(d$voting_decision_cantonal_proportional_election_1_party)
#'
#' fct_new <- fct_relabel_election_parties(
#' fct = d$voting_decision_cantonal_proportional_election_1_party,
#' to_type = "short",
#' ballot_date = "2024-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' election_nr = 1L,
#' past = FALSE
#' )
#'
#' # after
#' levels(fct_new)
#'
#' # set `strict = FALSE` if your factor contains non-standard levels
#' d$voting_decision_cantonal_proportional_election_1_party |>
#' forcats::fct_lump_min(other_level = "Kleinparteien",
#' min = 5L) |>
#' fct_relabel_election_parties(to_type = "short",
#' ballot_date = "2024-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' election_nr = 1L,
#' past = FALSE,
#' strict = FALSE) |>
#' levels()
fct_relabel_election_parties <- function(fct,
from_type = c("qstnr", "run", "short"),
to_type = c("short", "run", "qstnr"),
ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election",
prcds = "proportional"),
canton = cantons(ballot_date),
election_nr = 1L,
past = FALSE,
strict = TRUE) {
from_type <- rlang::arg_match(from_type)
to_type <- rlang::arg_match(to_type)
checkmate::assert_flag(strict)
ref <-
election_parties(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
election_nr = election_nr,
past = past) |>
# TODO: determine below "none" val dynamically instead of hardcoding it
tibble::add_row(code = 0L,
name.de.qstnr = "keine (leer eingelegt oder nicht teilgenommen)",
name.de.run = name.de.qstnr,
name.de.short = "keine",
.before = 1L)
checkmate::assert_factor(fct,
levels = if (strict) ref[[paste0("name.de.", from_type)]])
forcats::fct_relabel(.f = fct,
.fun = \(fct_lvls) purrr::map_chr(fct_lvls,
\(old_val) {
new_val <-
ref |>
dplyr::filter(!!as.symbol(paste0("name.de.", from_type)) == old_val) |>
dplyr::pull(paste0("name.de.", to_type))
if (length(new_val) != 1L) {
new_val <- old_val
}
new_val
}))
}
#' Shorten variable names to a maximum length of 32 characters
#'
#' @param var_names A character vector of variable names.
#' @param reverse Whether to apply the inversion of the shortening logic, i.e. to restore original/unshortened variable names.
#' @param max_n_char Maximum allowed number of characters. It is ensured that the maximum resulting variable name length doesn't exceed this limit. Has no
#' influence on the applied shortening logic. An integerish scalar or `Inf` for no limit.
#'
#' @return A character vector of the same length as `var_names`.
#' @family var_name_shortening
#' @export
shorten_var_names <- function(var_names,
reverse = FALSE,
max_n_char = 32L) {
checkmate::assert_character(var_names,
any.missing = FALSE)
checkmate::assert_flag(reverse)
if (!isTRUE(is.infinite(max_n_char))) {
checkmate::assert_count(max_n_char)
}
rules <- shortening_rules
if (reverse) colnames(rules) %<>% .[c(2L, 1L, 3L)]
rules %<>% dplyr::mutate(pattern = purrr::map2_chr(
.x = string,
.y = allowed_at,
.f = ~ .y |> pal::when(. == "begin" ~
paste0("^", .x, "(?=_)"),
. == "middle" ~
paste0("(?<=_)", .x, "(?=_)"),
. == "end" ~
paste0("(?<=_)", .x, "$"),
. == "begin-middle" ~
paste0("(?<=(^|_))", .x, "(?=_)"),
. == "begin-end" ~
paste0("(^", .x, "(?=_)|(?<=_)", .x, "$)"),
. == "middle-end" ~
paste0("(?<=_)", .x, "(?=(_|$))"),
. == "begin-middle-end" ~
paste0("(?<=(^|_))", .x, "(?=(_|$))"),
~ cli::cli_abort("Unknown {.var allowed_at} type: {.val {.}}.",
.internal = TRUE))
))
pattern_replacement <- rules$replacement
names(pattern_replacement) <- rules$pattern
var_names_new <- var_names |> stringr::str_replace_all(pattern = pattern_replacement)
# ensure we did our job
if (!is.null(max_n_char) && !reverse && any(nchar(var_names_new) > max_n_char)) {
# NOTE: `cli::cli_abort()` doesn't properly print the output of `pal::capture_print()` because:
# - it just seems to ignore the output if it includes ANSI escape sequences (this can be worked around by an additional `cli::ansi_strip()`)
# - it normalizes whitespace chars **incl. tabs** to a single regular whitespace, thus breaking the formatting
rlang::abort(glue::glue("There are still variable names left of a length greater than {max_n_char} characters after applying `shorten_var_names()`. ",
"Affected are the following (shortened) variable names:\n\n",
tibble::tibble(var_name = var_names,
var_name_short = var_names_new,
n_char = nchar(var_names),
n_char_short = nchar(var_names_new)) |>
dplyr::filter(n_char_short > max_n_char) |>
pal::capture_print(collapse = "\n"),
.null = NA_character_,
.trim = FALSE))
}
var_names_new
}
#' Shorten column names to a maximum length of 32 characters
#'
#' This is useful for DTA export since Stata has a built-in variable name length limit of [32
#' characters](https://www.stata.com/manuals/r.pdf#rLimits) (see also
#' [here](https://www.statalist.org/forums/forum/general-stata-discussion/general/1452366-number-of-characters-in-variable-names)).
#'
#' @inheritParams shorten_var_names
#' @param x `r pkgsnip::param_lbl("tbl_data")`
#'
#' @return `x` with column names shortened to a maximum length of 32 characters.
#' @family var_name_shortening
#' @export
shorten_colnames <- function(x,
max_n_char = 32L) {
x |> magrittr::set_colnames(value = shorten_var_names(var_names = colnames(x),
max_n_char = max_n_char))
}
#' Restore original/unshortened column names
#'
#' Applies the inversion of [shorten_colnames()].
#'
#' @inheritParams shorten_colnames
#' @inheritParams shorten_var_names
#'
#' @return `x` with original/unshortened column names restored.
#' @family var_name_shortening
#' @export
restore_colnames <- function(x) {
x |> magrittr::set_colnames(value = shorten_var_names(var_names = colnames(x),
reverse = TRUE))
}
#' Phrase term
#'
#' Transforms a term's value into a phrased string representation.
#'
#' @inheritParams lang_to_locale
#' @param term Term to be phrased. A character scalar.
#' @param vals Value(s) of `term` to be phrased. A character vector.
#'
#' @return A character scalar.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase(term = "side",
#' vals = c("pro", "pro", "contra"),
#' lang = "de")
phrase <- function(term,
vals,
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
term <- rlang::arg_match(arg = term,
values = unique(phrased_terms_tidy$term))
data <- phrased_terms_tidy |> dplyr::filter(term == !!term & lang == !!lang)
vals <- rlang::arg_match(arg = vals,
values = unique(data$value),
multiple = TRUE)
vals |>
purrr::map_chr(\(val) {
data$phrase[data$value == val]
})
}
#' Phrase (ballot) date
#'
#' Phrases a date according to the specified `format` and `lang`.
#'
#' @inheritParams salim::phrase_datetime
#' @inheritParams lang_to_locale
#'
#' @return A character scalar.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase_date()
phrase_date <- function(x = pal::pkg_config_val("ballot_date"),
format = "date_long",
lang = pal::pkg_config_val("lang")) {
lang <- rlang::arg_match(arg = lang,
values = all_langs)
salim::phrase_datetime(x = x,
format = format,
locale = lang)
}
#' Phrase majoritarian election's candidate(s)
#'
#' Assembles one or more majoritarian election candidate strings consisting of the candidate's first name, last name and optionally political party (in
#' parentheses).
#'
#' @inheritParams n_election_seats
#' @param candidate_nrs Election candidate numbers to include. A vector of positive integers or `NULL`. If `NULL`, all candidates will be included.
#' @param incl_party Whether or not to include the candidate's political party in the resulting string (in parentheses).
#'
#' @return A character vector.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase_election_candidate(ballot_date = "2019-10-20",
#' lvl = "cantonal",
#' canton = "aargau",
#' candidate_nrs = 1:3)
phrase_election_candidate <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "election"),
canton = cantons(ballot_date),
election_nr = 1L,
candidate_nrs = NULL,
incl_party = TRUE) {
data_candidates <- election_candidates(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
election_nr = election_nr)
checkmate::assert_integerish(candidate_nrs,
lower = 1L,
upper = nrow(data_candidates),
any.missing = FALSE,
null.ok = TRUE)
checkmate::assert_flag(incl_party)
if (length(candidate_nrs)) {
data_candidates %<>% dplyr::filter(dplyr::row_number() %in% candidate_nrs)
}
data_candidates |> purrr::pmap_chr(\(first_name, last_name, party, ...) paste0(first_name, " ", last_name, paste0(" (", party, ")")[incl_party]))
}
#' Get declined German proposal name
#'
#' Declines a German [proposal name][proposal_name] to the specified grammatical `case`. Simple convenience function combining [proposal_name()],
#' [proposal_name_gender()] and [salim::decline_noun_de()].
#'
#' @inheritParams proposal_name
#' @inheritParams salim::decline_noun_de
#'
#' @return A character scalar.
#' @family phrase
#' @export
#'
#' @examples
#' fokus::phrase_proposal_name_de(ballot_date = "2023-06-18",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "short",
#' case = "dative")
#'
#' fokus::phrase_proposal_name_de(ballot_date = "2023-06-18",
#' lvl = "cantonal",
#' canton = "aargau",
#' proposal_nr = 1,
#' type = "short",
#' case = "genitive")
phrase_proposal_name_de <- function(ballot_date = pal::pkg_config_val("ballot_date"),
lvl = lvls(ballot_date,
canton,
ballot_type = "referendum"),
canton = cantons(ballot_date),
proposal_nr = 1L,
type = all_name_types,
case = c("nominative", "genitive", "dative", "accusative")) {
rlang::check_installed("salim",
reason = pal::reason_pkg_required())
proposal_name(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
lang = "de",
type = type) |>
salim::decline_noun_de(gender = proposal_name_gender(ballot_date = ballot_date,
lvl = lvl,
canton = canton,
proposal_nr = proposal_nr,
type = type),
case = case)
}
#' Authorize googledrive using GCP Service Account Key
#'
#' Authorizes the googledrive package to access and manage files on your Google Drive via a [Google Cloud Platform (GCP) Service
#' Account Key](https://cloud.google.com/iam/docs/creating-managing-service-account-keys) file (in JSON format). See the [relevant
#' documentation](https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly) for details.
#'
#' The recommended way to provide the filesystem path to the GCP Service Account Key file is to set the [environment
#' variable](https://en.wikipedia.org/wiki/Environment_variable) `PATH_GCP_KEY_ZDA` to that path, e.g. via the [`.Renviron`
#' file](https://rstats.wtf/r-startup.html#renviron).
#'
#' @param path_gcp_service_account_key Path to the GCP Service Account Key JSON file.
#'
#' @return `path_gcp_service_account_key`, invisibly.
#' @family g_apps
#' @keywords internal
auth_g_drive_gcp <- function(path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA")) {
rlang::check_installed("googledrive",
reason = pal::reason_pkg_required())
is_file <- checkmate::test_file_exists(path_gcp_service_account_key,
access = "r")
if (is_file) {
googledrive::drive_auth(path = path_gcp_service_account_key,
use_oob = TRUE)
} else {
cli::cli_abort(paste0("No Google Cloud Platform service account key found under {.path {path_gcp_service_account_key}}. ",
"Instructions to store such a key can be found here: ",
"{.url https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly}"))
}
invisible(path_gcp_service_account_key)
}
#' Authorize googlesheets4 using GCP Service Account Key
#'
#' Authorizes the googlesheets4 package to access and manage Google Sheets via a [Google Cloud Platform (GCP) Service
#' Account Key](https://cloud.google.com/iam/docs/creating-managing-service-account-keys) file (in JSON format). See the [relevant
#' documentation](https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly) for details.
#'
#' The recommended way to provide the filesystem path to the GCP Service Account Key file is to set the [environment
#' variable](https://en.wikipedia.org/wiki/Environment_variable) `PATH_GCP_KEY_ZDA` to that path, e.g. via the [`.Renviron`
#' file](https://rstats.wtf/r-startup.html#renviron).
#'
#' @param path_gcp_service_account_key Path to the GCP Service Account Key JSON file.
#'
#' @return `path_gcp_service_account_key`, invisibly.
#' @family g_apps
#' @keywords internal
auth_g_sheets_gcp <- function(path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA")) {
rlang::check_installed("googlesheets4",
reason = pal::reason_pkg_required())
is_file <- checkmate::test_file_exists(path_gcp_service_account_key,
access = "r")
if (is_file) {
googlesheets4::gs4_auth(path = path_gcp_service_account_key,
use_oob = TRUE)
} else {
cli::cli_abort(paste0("No Google Cloud Platform service account key found under {.path {path_gcp_service_account_key}} ",
"Instructions to store such a key can be found here: ",
"{.url https://gargle.r-lib.org/articles/non-interactive-auth.html#provide-a-service-account-token-directly}"))
}
invisible(path_gcp_service_account_key)
}
#' Backup Google Drive file locally
#'
#' Creates a local backup of a [Google Drive](https://en.wikipedia.org/wiki/Google_Drive) file.
#'
#' Essentially a convenience wrapper around [googledrive::drive_download()].
#'
#' If a [Google Sheet](https://en.wikipedia.org/wiki/Google_Sheets) that includes multiple worksheets is backed up to a file `type` that doesn't support
#' worksheets like `"csv"`, only the default (first) worksheet is written. In contrast, [backup_g_sheet()] allows to specify any worksheet to be backed up (but
#' always writes a single worksheet only regardless of the filetype).
#'
#' @inheritParams g_file_mod_time
#' @inheritParams upload_to_g_drive
#' @param path Path to the local file backup destination. A character scalar.
#' @param type Desired type of the Google Drive file to be backed up. Only consulted if `g_id` identifies a native Google Apps file. Will be processed via
#' [googledrive::drive_mime_type()], so it can either be a file extension like `"pdf"`, a full MIME type like `"application/pdf"`, or `NULL` to determine the
#' type based on the file extension of `path` (if none is specified, falls back on the default type determined by the [Google Drive
#' API](https://developers.google.com/drive/api/v3/)). Note that `type` takes precedence over a possible file extension of `path`, but specifying only the
#' latter should normally suffice.
#' @param overwrite Whether or not to overwrite an already existing file under `path`.
#' @param force Whether or not to force overwriting the file regardless whether it has changed since the last backup or not.
#'
#' @return An object of class [dribble][googledrive::dribble], a tibble with one row per file if local backup was (over)written, otherwise `NULL`, meaning
#' the remote file hasn't deviated from the local backup since the last run, invisibly.
#' @family g_apps
#' @export
backup_g_file <- function(g_id,
path,
type = NULL,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA"),
overwrite = TRUE,
force = FALSE,
quiet = TRUE) {
checkmate::assert_string(g_id)
checkmate::assert_path_for_output(path,
overwrite = TRUE)
checkmate::assert_flag(overwrite)
checkmate::assert_flag(force)
checkmate::assert_flag(quiet)
rlang::check_installed("googledrive",
reason = pal::reason_pkg_required())
if (quiet) {
googledrive::local_drive_quiet()
}
result <- NULL
remote_mod <- g_file_mod_time(g_id,
path_gcp_service_account_key = path_gcp_service_account_key)
local_mod <- ifelse(fs::file_exists(path),
pal::path_mod_time(path),
lubridate::as_datetime(0L))
if (local_mod < remote_mod || force) {
result <- googledrive::drive_download(file = googledrive::as_id(g_id),
path = path,
type = type,
overwrite = overwrite)
}
invisible(result)
}
#' Backup Google Sheet locally
#'
#' Creates a local backup of a [Google Sheet](https://en.wikipedia.org/wiki/Google_Sheets). It is accessed via [googlesheets4::read_sheet()] and written via
#' [readr::write_csv()] or [writexl::write_xlsx()], depending on the file extension of `path`.
#'
#' `backup_g_sheet()` only backs up a single worksheet at once (specified by the optional `sheet` argument). If you intend to backup multiple worksheets of the
#' same Google Sheet, consider using [backup_g_file()] in combination with a file `type` that supports multiple worksheets like `"ods"` or `"xlsx"`.
#'
#' @inheritParams backup_g_file
#' @inheritParams googlesheets4::read_sheet
#' @param ... Further arguments passed on to [googlesheets4::read_sheet()].
#' @param quiet Whether or not to [suppress printing status output from googledrive][googledrive::local_drive_quiet] and [googlesheets4
#' operations][googlesheets4::local_gs4_quiet].
#'
#' @return A [tibble][tibble::tbl_df] if the local backup was (over)written, otherwise `NULL`, meaning the remote file hasn't deviated from the local backup
#' since the last run, invisibly.
#' @family g_apps
#' @export
backup_g_sheet <- function(g_id,
path,
...,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA"),
overwrite = TRUE,
force = FALSE,
quiet = TRUE) {
checkmate::assert_string(g_id)
checkmate::assert_path_for_output(path,
overwrite = TRUE)
checkmate::assert_flag(overwrite)
checkmate::assert_flag(force)
checkmate::assert_flag(quiet)
rlang::check_installed("googledrive",
reason = pal::reason_pkg_required())
rlang::check_installed("googlesheets4",
reason = pal::reason_pkg_required())
pal::check_dots_named(...,
.fn = googlesheets4::read_sheet,
.forbidden = "ss")
if (quiet) {
googledrive::local_drive_quiet()
googlesheets4::local_gs4_quiet()
}
# authenticate Google account
auth_g_drive_gcp(path_gcp_service_account_key)
# ensure `g_id` refers to a spreadsheet
mime_type <-
googledrive::drive_get(id = g_id) |>
dplyr::pull("drive_resource") |>
dplyr::first() |>
purrr::chuck("mimeType")
if (mime_type != "application/vnd.google-apps.spreadsheet") {
cli::cli_abort("The supplied {.arg g_id} {.val {g_id}} doesn't seem to refer to a Google Sheet. Its Google Drive MIME type is {.val {mime_type}}.")
}
data <- NULL
remote_mod <- g_file_mod_time(g_id,
path_gcp_service_account_key = path_gcp_service_account_key)
local_mod <- ifelse(fs::file_exists(path),
pal::path_mod_time(path),
lubridate::as_datetime(0L))
if (local_mod < remote_mod || force) {
# authenticate Google account
auth_g_sheets_gcp(path_gcp_service_account_key)
filetype <- fs::path_ext(path)
data <- googlesheets4::read_sheet(ss = g_id,
...)
if (overwrite || !fs::file_exists(path)) {
filetype |>
pal::when(. == "csv" ~
readr::write_csv(x = data,
file = path,
na = ""),
. == "xlsx" ~ {
rlang::check_installed("writexl",
reason = pal::reason_pkg_required())
writexl::write_xlsx(x = data,
path = path)
},
. == "" ~
cli::cli_abort("{.arg path} must have a file extension ({.file .csv} or {.file .xlsx})."),
~ cli::cli_abort("Exporting filetype {.file {.}} is not yet implemented."))
} else {
cli::cli_alert_warning("A file already exists under {.arg path} {.file {path}} but {.arg overwrite} was set to {.val FALSE}. Nothing done.")
}
}
invisible(data)
}
#' Upload files to Google Drive
#'
#' Uploads one or more files to Google Drive.
#'
#' Essentially a convenience wrapper around [googledrive::drive_put()].
#'
#' @inheritParams g_file_mod_time
#' @param filepaths Local path(s) to the file(s) to be uploaded.
#' @param g_drive_folder Destination path on Google Drive where the files are to be uploaded to.
#' @param quiet Whether or not to [suppress printing status output from googledrive operations][googledrive::local_drive_quiet].
#'
#' @return `filepaths`, invisibly.
#' @family g_apps
#' @export
upload_to_g_drive <- function(filepaths,
g_drive_folder,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA"),
quiet = FALSE) {
checkmate::assert_character(filepaths,
any.missing = FALSE)
checkmate::assert_string(g_drive_folder)
checkmate::assert_flag(quiet)
# mute googledrive msgs if requested
if (quiet) googledrive::local_drive_quiet()
# extract filenames
filenames <- fs::path_file(filepaths)
# authenticate Google account
auth_g_drive_gcp(path_gcp_service_account_key)
# upload files
pal::cli_progress_step_quick(msg = "Uploading {length(filepaths)} file{?s} to Google Drive folder {.field {g_drive_folder}}")
purrr::walk2(.x = filenames,
.y = filepaths,
.f = ~ {
# overwrite existing file if possible or create new one otherwise
googledrive::drive_put(media = .y,
path = g_drive_folder,
name = .x)
})
invisible(filepaths)
}
#' Get Google Drive file modification timestamp
#'
#' @param g_id Google Drive file ID. A character scalar.
#' @param path_gcp_service_account_key Path to the GCP Service Account Key JSON file. See [auth_g_drive_gcp()] for details.
#'
#' @return `r pkgsnip::return_lbl("datetime")`
#' @family g_apps
#' @export
g_file_mod_time <- function(g_id,
path_gcp_service_account_key = Sys.getenv("PATH_GCP_KEY_ZDA")) {
auth_g_drive_gcp(path_gcp_service_account_key = path_gcp_service_account_key)
googledrive::drive_get(id = g_id) |>
dplyr::pull("drive_resource") |>
dplyr::first() |>
purrr::chuck("modifiedTime") |>
lubridate::as_datetime()
}
#' Convert logical vector to Unicode symbols `r unicode_checkmark` and `r unicode_crossmark`
#'
#' @param x A logical vector.
#'
#' @return A character vector.
#' @export
#'
#' @examples
#' fokus::lgl_to_unicode(c(TRUE, TRUE, FALSE, NA))
lgl_to_unicode <- function(x) {
checkmate::assert_logical(x)
dplyr::if_else(x,
unicode_checkmark,
unicode_crossmark)
}
#' Emphasize xth element of character vector (Markdown)
#'
#' @param x Input as a character vector.
#' @param which Indices of the elements to be emphasized.
#' @param emph Character sequence used for emphasis.
#'
#' @return A character vector of the same length as `x`.
#' @export
md_emphasize <- function(x,
which = TRUE,
emph = "**") {
x[which] %<>% paste0(emph, ., emph)
x
}
#' `r this_pkg` package configuration metadata
#'
#' A [tibble][tibble::tbl_df] with metadata of all possible `r this_pkg` package configuration options. See [pal::pkg_config_val()] for more information.
#'
#' @format `r pkgsnip::return_lbl("tibble_cols", cols = colnames(pkg_config))`
#' @export
#'
#' @examples
#' fokus::pkg_config
"pkg_config"
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.