In zdaarau/fokus: Provides an API around the FOKUS Post-voting Surveys
INTERNAL
Package load/unload
.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}"))
}
Avoid R CMD check notes about undefined global objects used in magrittr pipes
cf. https://github.com/tidyverse/magrittr/issues/29#issuecomment-74313262
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"))
Functions
Raw questionnaire data
DESCRIPTION
Functions to access the raw questionnaire data as defined in the TOML files found under
data-raw/questionnaire.
raw_qstnr
#' 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_qstnrs_suppl
#' 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
raw_qstnr_suppl
#' 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]]
}
raw_qstnr_suppl_lvl
#' 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
}
raw_qstnr_suppl_lvl_canton
#' 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
}
raw_qstnr_suppl_proposal
#' 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
}
raw_qstnr_suppl_proposal_safe
Version of raw_qstnr_suppl_proposal that doesn't fail when no referendum is held.
#' 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))
}
raw_qstnr_suppl_proposal_name
#' 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
}
raw_qstnr_suppl_arguments
#' 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
}
raw_qstnr_suppl_argument
#' 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
}
raw_qstnr_suppl_main_motives
#' 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
}
raw_qstnr_suppl_elections
#' 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
}
raw_qstnr_suppl_election
NOTES:
- Since federal elections in Switzerland are also organized per canton (the cantons are the electoral constituencies), the relevant data always stems from
raw_qstnr_suppl_lvl_canton() and never from raw_qstnr_suppl_lvl().
#' 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
}
raw_qstnr_suppl_election_name
#' 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
}
raw_qstnr_suppl_mode
#' 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
}
raw_qstnr_suppl_skill_questions
#' 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
}
raw_qstnr_suppl_skill_question
#' 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
}
raw_pick_right
NOTES:
- The recursion is performed because it's allowed to nest
.default, .true, false, .YYYYMMDD etc. subkeys under ballot-type-subkeys (.election,
.referendum etc.).
#' 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
}
Questionnaire generation
init_heritable_map
Initialize heritable map of key-value pairs that can be valid for multiple questions (set hierarchically)
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
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
NOTES:
cli::pluralize() collapses substituted vectors into a comma separated string, so we have to fall back to glue::glue() for arrays.
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
}
Questionnaire tibble
gen_qstnr_tibble
#' 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
Traverse questionnaire recursively and assemble questionnaire block tibble.
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
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_qstnr_tibble
#' 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
- Replaces placeholder values in multi-value columns with an empty vector.
- Removes all Markdown formatting from character columns.
NOTES:
- We assume each list column contains only a single type (e.g. character), so we only have to check the first value to determine the columns "subtype".
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
NOTES:
- Technically,
tidyr::unnest() used in expand_qstnr_tibble() also implicitly performs integrity check 2: it ensures that all of the simultaneously
expanded variables are of the same length (or otherwise throws an error); obviously, this isn't as useful since it doesn't tell which variable_names are
affected.
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
Determines whether or not a variable_label/variable_label_common already has a who-constraint at its end.
has_who_constraint <- function(x) {
isTRUE(stringr::str_detect(string = x,
pattern = "(\\(|; )(\\d{4}-\\d{2}-\\d{2} )?only [^\\)]+\\)$"))
}
add_who_constraint
Adds the who constraint wrapped in parentheses to the end of a string (e.g. a variable_label).
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
}
Markdown questionnaire
gen_qstnr_md
#' 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
Generate table body for Markdown questionnaire
NOTES:
- we set
shorten_var_names(max_n_char = 30L) to account for additional time_* variables which will be shortened to t_*, i.e. add 2 additional chars to
the original variable name (except the special-block variables which won't have time_* siblings and certain exceptions which will share a common time_*
variable).
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
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
block_name_to_nr <- function(x) {
x |>
stringr::str_extract("^.[^_]?(_\\d)?") |>
stringr::str_replace("_(\\d)", "-\\1") |>
stringr::str_remove("^0") |>
stringr::str_to_upper()
}
Questionnaire-internal
DESCRIPTION
Functions used only in embedded R code in the raw TOML questionnaire.
qstnr_item_val
#' 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()
}
qstnr_parties
#' 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)
}
qstnr_response_option_codes
#' 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"))
}
Questionnaire predicates
qstnr_lbl_col_sym
#' 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"))
}
Private repository
DESCRIPTION
Functions around the r glue::glue('[private FOKUS repository]({fokus:::url_repo_private()}).
print_private_repo_structure
#' 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
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
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
})
}
url_repo_private
NOTES:
- See gitlab-org/gitlab#424908 for background about the
ref_type=heads URL param.
#' 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
}
Validation
assert_countish
DEPRECATED
Assertion that
- allows a count as a character-scalar and converts its input to an integer scalar.
- checks for
positive = TRUE by default.
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
DEPRECATED
Assertion that
- allows integers as characters and converts its input to type integer.
- forbids missing values by default.
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
TODO:
-
Replace this fn with more sophisticated one that normalizes whole df based on vctrs::df_cast()? Error messages wouldn't be ideal for end-users, though...
e.g.:
r
vctrs::df_cast(x = mtcars,
to = mtcars |> dplyr::mutate(cyl = as.character(cyl)))
gives
! Can't convert `cyl` <double> to match type of `cyl` <character>.
Is there maybe already a data validation pkg that builds upon vctrs?
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
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)
}
}
Miscellaneous
abbrs
#' 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
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
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
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
NOTES:
- This differs substantially from
pal::as_flat_list(); it preserves all (sub)names by concatenating them but doesn't preserve any attributes, so data frames
& co. are destroyed.
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
as_sym_part_regex <- function(x) {
paste0(sym_part_regex_start, x, sym_part_regex_end)
}
collapse_break
Collapse char vector into single string separated by single HTML line breaks (<br> tags)
collapse_break <- function(s) {
paste0(s, collapse = "<br>")
}
lang_to_locale
#' 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
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
Wrap a vector in backticks
wrap_backtick <- function(x) {
dplyr::if_else(x == "-" | stringr::str_detect(string = x,
pattern = "^(_.*_|\\*.*\\*)$"),
as.character(x),
paste0("`", x, "`"))
}
Constants
this_pkg <- utils::packageName()
cli_theme
cli_theme <-
cli::builtin_theme() |>
purrr::list_modify(h2 = list("margin-bottom" = 0.0),
h3 = list("margin-top" = 0.0))
global_max_cache_age
global_max_cache_age <- "30 days"
qstnr_item_keys
#' 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
Table header for Markdown questionnaire. The tribble below allows easy tweaking of column widths and alignments.
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_*
repo_private_proj_id <- 21325371L
sym_part_regex_*
sym_part_regex_start <- "(^|_|\\b)"
sym_part_regex_end <- "(\\b|_|$)"
unicode_*
unicode_checkmark <- "\u2705"
unicode_crossmark <- "\u274C"
unicode_ellipsis <- "\u2026"
url_*
url_qstnr <- list(aargau = "https://qstnr.fokus.ag")
url_survey_host <- list(aargau = "https://umfrage.fokus.ag")
url_parameter_survey <- list(aargau = "pw")
EXPORTED
FOKUS metadata
DESCRIPTION
Metadata about the FOKUS surveys, generated from the raw supplemental date-specific questionnaire data files found under
data-raw/questionnaire/YYYY-MM-DD.toml that serve as a "source of truth" for
the r "[predicate functions](#predicates)".
all_ballot_dates
#' 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"
all_cantons
#' 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"
all_ballot_types
#' 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"
all_lvls
#' Political levels
#'
#' A vector of all possible [political levels][lvls].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_lvls
"all_lvls"
all_prcds
#' Election procedures
#'
#' A vector of all possible [election procedures][prcds].
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_prcds
"all_prcds"
all_proposal_types
#' 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"
all_qstn_groups
#' 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"
all_argument_sides
#' 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"
all_main_motive_types
#' 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"
all_election_seat_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"
all_response_option_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"
all_postal_dispatch_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"
all_postal_dispatch_ways
#' 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"
all_langs
#' Languages
#'
#' A vector of all possible survey metadata languages.
#'
#' @format A character vector.
#' @family metadata
#' @export
#'
#' @examples
#' fokus::all_langs
"all_langs"
all_name_types
#' 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"
Predicates
DESCRIPTION
Predicate functions based on the r "[metadata](#fokus-metadata)" and the raw questionnaire data.
Fundamental predicates
DESCRIPTION
Fundamental predicate functions never fail in case of incomplete raw questionnaire data (they do still fail in case of completely missing
questionnaire data for the specified ballot date and possibly canton).
cantons
#' 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]]
}
lvls
#' 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
}
ballot_types
NOTES:
- Federal elections are all
canton-dependent since FOKUS coverage in raw_qstnrs_suppl is, too.
#' 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)
}
prcds
#' 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
}
proposal_nrs
#' 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
}
election_nrs
#' 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
}
election_prcds
#' 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
}
proposal_qstn_groups
#' 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()
}
qstn_groups_proposal_nrs
#' 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()
}
survey_channels
#' 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")
}
is_representative
#' 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")
}
n_proposals
#' 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
}
n_elections
#' 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
}
has_referendum
#' 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
}
has_election
#' 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
}
has_ballot_type
#' 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
}
has_lvl
#' 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
}
has_proposal_nrs
#' 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,
~ .)
}
has_election_nrs
#' 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,
~ .)
}
combos_ballot_types
#' 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
}
Proposal predicates
proposal_type
#' 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")
}
proposal_name
#' 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")
}
proposal_name_gender
#' 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")
}
is_proposal_name_plural
#' 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)
}
proposal_arguments
#' 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."))
}
proposal_argument
#' 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)
}
proposal_main_motives
#' 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()
}
n_proposal_arguments
#' 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()
}
n_proposal_main_motives
#' 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()
}
has_proposal_arguments
#' 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
}
has_proposal_main_motives
#' 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
}
argument_proposal_nrs
#' 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")
}
main_motive_proposal_nrs
#' 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")
}
combos_proposals
#' 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()
}
combos_proposal_arguments
#' 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()
}
combos_proposal_main_motives
#' 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()
}
Election predicates
election_name
#' 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")
}
election_names_combined
#' 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)
}
election_candidates
#' 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()
}
election_parties
#' 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()
}
election_tickets
#' 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()
}
past_election_date
#' 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
}
n_election_seats
#' 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)
}
n_election_candidates
#' 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()
}
requires_candidate_registration
#' 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")
}
combos_elections
#' 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()
}
Skill question predicates
skill_question_nrs
NOTES:
- Skill questions are not named in the supplemental date-specific FOKUS questionnaire data but simply defined in an array of
skill_question
tables, so we can safely rely on n_skill_questions() internally.
#' 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))
}
n_skill_questions
TODO:
- Change param
lvl to lvls = all_lvls and return named values depending on lvls and proposal_nr, similar to n_proposals()?
#' 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()
}
skill_question
#' 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)
}
skill_question_response_options
#' 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()
}
skill_question_answer_nr
#' 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()
}
skill_question_proposal_nrs
#' 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")
}
Other predicates
ballot_title
TODO:
- Rename to
phrase_ballot_title.
#' 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
}
political_issues
#' 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())
}
postal_dispatch_way
#' 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)
}
response_options
#' 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 and survey
DESCRIPTION
Datasets and functions to conduct a FOKUS survey.
Datasets
DESCRIPTION
The FOKUS survey questionnaires and supplemental information as structured data.
qstnrs
#' 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"
proposals
#' 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"
elections
#' 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"
ballots
#' 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"
Data import
DESCRIPTION
Functions to access FOKUS data from the r glue::glue("[private FOKUS repository]({fokus:::url_repo_private()})").
read_easyvote_municipalities
#' 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_online_participation_codes
#' 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_survey_data
NOTES:
- RDS data as a raw vector cannot be fed to
readRDS(), but instead must be separately decompressed and then
unserialized.
#' 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_survey_data_raw
read_survey_data_raw <- function(ballot_date = pal::pkg_config_val("ballot_date"),
canton = cantons(ballot_date)) {
# TODO
}
read_voting_register_data_extra
#' 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_voting_register_ids
#' 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_private_file
#' 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_cols
#' 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))
}
Data export
DESCRIPTION
Functions to export data necessary to conduct a FOKUS survey and perform survey data analysis.
export_qstnr
TODO:
-
Actually, we want to set g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/Fragebogen/") as default arg, but a bug in
pkgdown 2.1.0 (wasn't there in 2.0.8, I think) prevents us from doing so -> fix that pkgdown bug!
-
Find way to mute Pandoc conversion output.
#' 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
NOTES:
- To generate high quality QR codes in SVG format, we use the R package qrencoder which is based on the C library
libqrencode.
#' 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
#' 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_municipalities
NOTES:
- See section Details in
?fokus:::read_easyvote_municipalities for specifics about the raw data.
#' 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_survey_data
#' 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_private_file
#' 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)
}
Variables
DESCRIPTION
Functions related to FOKUS questionnaire and survey data variables.
var_lbl
TODO:
- Rename to
var_desc to comply with terminology in pkg qstnr.
#' 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
}
var_lvls
#' 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])
}
var_prcd
#' 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})")))
}
var_election_nr
#' 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()
}
var_proposal_nr
#' 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()
}
var_skill_question_nr
#' 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()
}
var_title
TODO:
- Introduce param
lang once the FOKUS qstnr is ported to pkg qstnr.
#' 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
}
var_val_set
#' 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_vars_to_combos
#' 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()
}
is_skill_question_var
#' 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+)?$")
}
Factors
fct_relabel_election_parties
NOTES:
- This fn is not optmized for performance (e.g. uses a tibble as lookup tbl).
#' 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
}))
}
Variable name shortening
shorten_var_names
Remarks:
-
To display a comparison between original and shortened column names and their respective lengths after applying shorten_var_names(), use:
r
fa_data() |>
colnames() %>%
tibble::tibble(original = .,
shortened = shorten_var_names(var_names = .,
max_n_char = Inf)) |>
dplyr::mutate(n_char_original = nchar(original),
n_char_shortened = nchar(shortened)) |>
dplyr::arrange(-n_char_shortened) |>
print(n = Inf)
#' 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_colnames
#' 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_colnames
#' 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))
}
Text phrasing
phrase
#' 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_date
#' 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_election_candidate
#' 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]))
}
phrase_proposal_name_de
TODO:
-
Improve the underlying salim::decline_noun_de() fn. Cases where it currently fails include:
fokus::phrase_proposal_name_de(ballot_date = "2023-06-18", proposal_nr = 2, lvl = "federal", type = "long", case = "dative")
#' 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)
}
Google Apps
TODO: Move these fns to a separate pkg!
auth_g_drive_gcp INTERNAL
NOTES:
-
The GCP Service Account specified in the path_gcp_service_account_key file must have read access to private files accessed by or write access to files
modified by any googledrive fn relying on auth_g_drive_gcp(). Simply use the share functionality on Google Drive to grant such access. Note that e-mails
can't be delivered to the service account's address (e.g. c2d-zda@r-tidyverse.iam.gserviceaccount.com), so make sure to unset the "notify" checkmark when
sharing.
We've given our Service Account c2d-zda@r-tidyverse.iam.gserviceaccount.com write access to the whole fokus_aargau folder on Google
Drive, so we shouldn't have to bother with access rights in the scope of this
project.
#' 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)
}
auth_g_sheets_gcp INTERNAL
#' 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_g_file
#' 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_g_sheet
#' 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_to_g_drive
#' 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)
}
g_file_mod_time
#' 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()
}
Miscellaneous
lgl_to_unicode
#' 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)
}
md_emphasize
#' 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
}
pkg_config
#' `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.
INTERNAL
Package load/unload
.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}")) }
Avoid R CMD check notes about undefined global objects used in magrittr pipes
cf. https://github.com/tidyverse/magrittr/issues/29#issuecomment-74313262
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"))
Functions
Raw questionnaire data
DESCRIPTION
Functions to access the raw questionnaire data as defined in the TOML files found under
data-raw/questionnaire.
raw_qstnr
#' 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_qstnrs_suppl
#' 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
raw_qstnr_suppl
#' 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]] }
raw_qstnr_suppl_lvl
#' 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 }
raw_qstnr_suppl_lvl_canton
#' 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 }
raw_qstnr_suppl_proposal
#' 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 }
raw_qstnr_suppl_proposal_safe
Version of raw_qstnr_suppl_proposal that doesn't fail when no referendum is held.
#' 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)) }
raw_qstnr_suppl_proposal_name
#' 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 }
raw_qstnr_suppl_arguments
#' 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 }
raw_qstnr_suppl_argument
#' 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 }
raw_qstnr_suppl_main_motives
#' 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 }
raw_qstnr_suppl_elections
#' 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 }
raw_qstnr_suppl_election
NOTES:
- Since federal elections in Switzerland are also organized per canton (the cantons are the electoral constituencies), the relevant data always stems from
raw_qstnr_suppl_lvl_canton()and never fromraw_qstnr_suppl_lvl().
#' 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 }
raw_qstnr_suppl_election_name
#' 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 }
raw_qstnr_suppl_mode
#' 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 }
raw_qstnr_suppl_skill_questions
#' 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 }
raw_qstnr_suppl_skill_question
#' 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 }
raw_pick_right
NOTES:
- The recursion is performed because it's allowed to nest
.default,.true,false,.YYYYMMDDetc. subkeys under ballot-type-subkeys (.election,.referendumetc.).
#' 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 }
Questionnaire generation
init_heritable_map
Initialize heritable map of key-value pairs that can be valid for multiple questions (set hierarchically)
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
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
NOTES:
cli::pluralize()collapses substituted vectors into a comma separated string, so we have to fall back toglue::glue()for arrays.
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 }
Questionnaire tibble
gen_qstnr_tibble
#' 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
Traverse questionnaire recursively and assemble questionnaire block tibble.
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
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_qstnr_tibble
#' 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
- Replaces placeholder values in multi-value columns with an empty vector.
- Removes all Markdown formatting from character columns.
NOTES:
- We assume each list column contains only a single type (e.g. character), so we only have to check the first value to determine the columns "subtype".
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
NOTES:
- Technically,
tidyr::unnest()used inexpand_qstnr_tibble()also implicitly performs integrity check 2: it ensures that all of the simultaneously expanded variables are of the same length (or otherwise throws an error); obviously, this isn't as useful since it doesn't tell whichvariable_names are affected.
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
Determines whether or not a variable_label/variable_label_common already has a who-constraint at its end.
has_who_constraint <- function(x) { isTRUE(stringr::str_detect(string = x, pattern = "(\\(|; )(\\d{4}-\\d{2}-\\d{2} )?only [^\\)]+\\)$")) }
add_who_constraint
Adds the who constraint wrapped in parentheses to the end of a string (e.g. a variable_label).
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 }
Markdown questionnaire
gen_qstnr_md
#' 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
Generate table body for Markdown questionnaire
NOTES:
- we set
shorten_var_names(max_n_char = 30L)to account for additionaltime_*variables which will be shortened tot_*, i.e. add 2 additional chars to the original variable name (except the special-block variables which won't havetime_*siblings and certain exceptions which will share a commontime_*variable).
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
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
block_name_to_nr <- function(x) { x |> stringr::str_extract("^.[^_]?(_\\d)?") |> stringr::str_replace("_(\\d)", "-\\1") |> stringr::str_remove("^0") |> stringr::str_to_upper() }
Questionnaire-internal
DESCRIPTION
Functions used only in embedded R code in the raw TOML questionnaire.
qstnr_item_val
#' 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() }
qstnr_parties
#' 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) }
qstnr_response_option_codes
#' 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")) }
Questionnaire predicates
qstnr_lbl_col_sym
#' 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")) }
Private repository
DESCRIPTION
Functions around the r glue::glue('[private FOKUS repository]({fokus:::url_repo_private()}).
print_private_repo_structure
#' 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
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
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 }) }
url_repo_private
NOTES:
- See gitlab-org/gitlab#424908 for background about the
ref_type=headsURL param.
#' 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 }
Validation
assert_countish
DEPRECATED
Assertion that
- allows a count as a character-scalar and converts its input to an integer scalar.
- checks for
positive = TRUEby default.
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
DEPRECATED
Assertion that
- allows integers as characters and converts its input to type integer.
- forbids missing values by default.
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
TODO:
-
Replace this fn with more sophisticated one that normalizes whole df based on
vctrs::df_cast()? Error messages wouldn't be ideal for end-users, though... e.g.:r vctrs::df_cast(x = mtcars, to = mtcars |> dplyr::mutate(cyl = as.character(cyl)))gives
! Can't convert `cyl` <double> to match type of `cyl` <character>.Is there maybe already a data validation pkg that builds upon vctrs?
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
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) } }
Miscellaneous
abbrs
#' 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
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
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
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
NOTES:
- This differs substantially from
pal::as_flat_list(); it preserves all (sub)names by concatenating them but doesn't preserve any attributes, so data frames & co. are destroyed.
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
as_sym_part_regex <- function(x) { paste0(sym_part_regex_start, x, sym_part_regex_end) }
collapse_break
Collapse char vector into single string separated by single HTML line breaks (<br> tags)
collapse_break <- function(s) { paste0(s, collapse = "<br>") }
lang_to_locale
#' 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
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
Wrap a vector in backticks
wrap_backtick <- function(x) { dplyr::if_else(x == "-" | stringr::str_detect(string = x, pattern = "^(_.*_|\\*.*\\*)$"), as.character(x), paste0("`", x, "`")) }
Constants
this_pkg <- utils::packageName()
cli_theme
cli_theme <- cli::builtin_theme() |> purrr::list_modify(h2 = list("margin-bottom" = 0.0), h3 = list("margin-top" = 0.0))
global_max_cache_age
global_max_cache_age <- "30 days"
qstnr_item_keys
#' 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
Table header for Markdown questionnaire. The tribble below allows easy tweaking of column widths and alignments.
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_*
repo_private_proj_id <- 21325371L
sym_part_regex_*
sym_part_regex_start <- "(^|_|\\b)" sym_part_regex_end <- "(\\b|_|$)"
unicode_*
unicode_checkmark <- "\u2705" unicode_crossmark <- "\u274C" unicode_ellipsis <- "\u2026"
url_*
url_qstnr <- list(aargau = "https://qstnr.fokus.ag") url_survey_host <- list(aargau = "https://umfrage.fokus.ag") url_parameter_survey <- list(aargau = "pw")
EXPORTED
FOKUS metadata
DESCRIPTION
Metadata about the FOKUS surveys, generated from the raw supplemental date-specific questionnaire data files found under
data-raw/questionnaire/YYYY-MM-DD.toml that serve as a "source of truth" for
the r "[predicate functions](#predicates)".
all_ballot_dates
#' 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"
all_cantons
#' 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"
all_ballot_types
#' 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"
all_lvls
#' Political levels #' #' A vector of all possible [political levels][lvls]. #' #' @format A character vector. #' @family metadata #' @export #' #' @examples #' fokus::all_lvls "all_lvls"
all_prcds
#' Election procedures #' #' A vector of all possible [election procedures][prcds]. #' #' @format A character vector. #' @family metadata #' @export #' #' @examples #' fokus::all_prcds "all_prcds"
all_proposal_types
#' 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"
all_qstn_groups
#' 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"
all_argument_sides
#' 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"
all_main_motive_types
#' 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"
all_election_seat_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"
all_response_option_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"
all_postal_dispatch_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"
all_postal_dispatch_ways
#' 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"
all_langs
#' Languages #' #' A vector of all possible survey metadata languages. #' #' @format A character vector. #' @family metadata #' @export #' #' @examples #' fokus::all_langs "all_langs"
all_name_types
#' 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"
Predicates
DESCRIPTION
Predicate functions based on the r "[metadata](#fokus-metadata)" and the raw questionnaire data.
Fundamental predicates
DESCRIPTION
Fundamental predicate functions never fail in case of incomplete raw questionnaire data (they do still fail in case of completely missing questionnaire data for the specified ballot date and possibly canton).
cantons
#' 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]] }
lvls
#' 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 }
ballot_types
NOTES:
- Federal elections are all
canton-dependent since FOKUS coverage inraw_qstnrs_supplis, too.
#' 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) }
prcds
#' 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 }
proposal_nrs
#' 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 }
election_nrs
#' 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 }
election_prcds
#' 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 }
proposal_qstn_groups
#' 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() }
qstn_groups_proposal_nrs
#' 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() }
survey_channels
#' 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") }
is_representative
#' 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") }
n_proposals
#' 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 }
n_elections
#' 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 }
has_referendum
#' 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 }
has_election
#' 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 }
has_ballot_type
#' 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 }
has_lvl
#' 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 }
has_proposal_nrs
#' 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, ~ .) }
has_election_nrs
#' 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, ~ .) }
combos_ballot_types
#' 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 }
Proposal predicates
proposal_type
#' 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") }
proposal_name
#' 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") }
proposal_name_gender
#' 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") }
is_proposal_name_plural
#' 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) }
proposal_arguments
#' 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.")) }
proposal_argument
#' 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) }
proposal_main_motives
#' 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() }
n_proposal_arguments
#' 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() }
n_proposal_main_motives
#' 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() }
has_proposal_arguments
#' 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 }
has_proposal_main_motives
#' 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 }
argument_proposal_nrs
#' 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") }
main_motive_proposal_nrs
#' 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") }
combos_proposals
#' 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() }
combos_proposal_arguments
#' 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() }
combos_proposal_main_motives
#' 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() }
Election predicates
election_name
#' 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") }
election_names_combined
#' 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) }
election_candidates
#' 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() }
election_parties
#' 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() }
election_tickets
#' 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() }
past_election_date
#' 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 }
n_election_seats
#' 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) }
n_election_candidates
#' 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() }
requires_candidate_registration
#' 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") }
combos_elections
#' 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() }
Skill question predicates
skill_question_nrs
NOTES:
- Skill questions are not named in the supplemental date-specific FOKUS questionnaire data but simply defined in an array of
skill_questiontables, so we can safely rely onn_skill_questions()internally.
#' 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)) }
n_skill_questions
TODO:
- Change param
lvltolvls = all_lvlsand return named values depending onlvlsandproposal_nr, similar ton_proposals()?
#' 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() }
skill_question
#' 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) }
skill_question_response_options
#' 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() }
skill_question_answer_nr
#' 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() }
skill_question_proposal_nrs
#' 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") }
Other predicates
ballot_title
TODO:
- Rename to
phrase_ballot_title.
#' 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 }
political_issues
#' 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()) }
postal_dispatch_way
#' 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) }
response_options
#' 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 and survey
DESCRIPTION
Datasets and functions to conduct a FOKUS survey.
Datasets
DESCRIPTION
The FOKUS survey questionnaires and supplemental information as structured data.
qstnrs
#' 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"
proposals
#' 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"
elections
#' 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"
ballots
#' 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"
Data import
DESCRIPTION
Functions to access FOKUS data from the r glue::glue("[private FOKUS repository]({fokus:::url_repo_private()})").
read_easyvote_municipalities
#' 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_online_participation_codes
#' 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_survey_data
NOTES:
- RDS data as a raw vector cannot be fed to
readRDS(), but instead must be separately decompressed and then unserialized.
#' 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_survey_data_raw
read_survey_data_raw <- function(ballot_date = pal::pkg_config_val("ballot_date"), canton = cantons(ballot_date)) { # TODO }
read_voting_register_data_extra
#' 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_voting_register_ids
#' 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_private_file
#' 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_cols
#' 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)) }
Data export
DESCRIPTION
Functions to export data necessary to conduct a FOKUS survey and perform survey data analysis.
export_qstnr
TODO:
-
Actually, we want to set
g_drive_folder = glue::glue("fokus/{canton}/Umfragen/Dateien f\u00fcr Umfrageinstitut/Fragebogen/")as default arg, but a bug in pkgdown 2.1.0 (wasn't there in 2.0.8, I think) prevents us from doing so -> fix that pkgdown bug! -
Find way to mute Pandoc conversion output.
#' 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
NOTES:
- To generate high quality QR codes in SVG format, we use the R package qrencoder which is based on the C library libqrencode.
#' 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
#' 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_municipalities
NOTES:
- See section Details in
?fokus:::read_easyvote_municipalitiesfor specifics about the raw data.
#' 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_survey_data
#' 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_private_file
#' 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) }
Variables
DESCRIPTION
Functions related to FOKUS questionnaire and survey data variables.
var_lbl
TODO:
- Rename to
var_descto comply with terminology in pkg qstnr.
#' 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 }
var_lvls
#' 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]) }
var_prcd
#' 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})"))) }
var_election_nr
#' 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() }
var_proposal_nr
#' 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() }
var_skill_question_nr
#' 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() }
var_title
TODO:
- Introduce param
langonce the FOKUS qstnr is ported to pkg qstnr.
#' 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 }
var_val_set
#' 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_vars_to_combos
#' 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() }
is_skill_question_var
#' 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+)?$") }
Factors
fct_relabel_election_parties
NOTES:
- This fn is not optmized for performance (e.g. uses a tibble as lookup tbl).
#' 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 })) }
Variable name shortening
shorten_var_names
Remarks:
-
To display a comparison between original and shortened column names and their respective lengths after applying
shorten_var_names(), use:r fa_data() |> colnames() %>% tibble::tibble(original = ., shortened = shorten_var_names(var_names = ., max_n_char = Inf)) |> dplyr::mutate(n_char_original = nchar(original), n_char_shortened = nchar(shortened)) |> dplyr::arrange(-n_char_shortened) |> print(n = Inf)
#' 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_colnames
#' 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_colnames
#' 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)) }
Text phrasing
phrase
#' 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_date
#' 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_election_candidate
#' 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])) }
phrase_proposal_name_de
TODO:
-
Improve the underlying
salim::decline_noun_de()fn. Cases where it currently fails include:fokus::phrase_proposal_name_de(ballot_date = "2023-06-18", proposal_nr = 2, lvl = "federal", type = "long", case = "dative")
#' 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) }
Google Apps
TODO: Move these fns to a separate pkg!
auth_g_drive_gcp INTERNAL
NOTES:
-
The GCP Service Account specified in the
path_gcp_service_account_keyfile must have read access to private files accessed by or write access to files modified by any googledrive fn relying onauth_g_drive_gcp(). Simply use the share functionality on Google Drive to grant such access. Note that e-mails can't be delivered to the service account's address (e.g.c2d-zda@r-tidyverse.iam.gserviceaccount.com), so make sure to unset the "notify" checkmark when sharing.We've given our Service Account
c2d-zda@r-tidyverse.iam.gserviceaccount.comwrite access to the wholefokus_aargaufolder on Google Drive, so we shouldn't have to bother with access rights in the scope of this project.
#' 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) }
auth_g_sheets_gcp INTERNAL
#' 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_g_file
#' 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_g_sheet
#' 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_to_g_drive
#' 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) }
g_file_mod_time
#' 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() }
Miscellaneous
lgl_to_unicode
#' 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) }
md_emphasize
#' 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 }
pkg_config
#' `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.