#' Party nicheness measures
#'
#' Computes party nicheness measures suggested by Bischof 2015 and Meyer and Miller 2013.
#'
#' @references Bischof, D. (2015). Towards a Renewal of the Niche Party Concept Parties, Market Shares and Condensed Offers. Party Politics.
#' @references Meyer, T.M., & Miller, B. (2013). The Niche Party Concept and Its Measurement. Party Politics 21(2): 259-271.
#' @references Baeck, H., Debus, M., & Dumont, P. (2010). Who gets what in coalition governments? Predictors of portfolio
#' allocation in parliamentary democracies. European Journal of Political Research 50(4): 441-478.
#'
#' @param data a dataframe or matrix in format of Manifesto Project Main Dataset
#' @param method choose between bischof and meyermiller
#' @param ... parmaeters passed on to specialized functions for differnet methods
#' @export
mp_nicheness <- function(data,
method = "bischof",
... ) {
switch(method,
"bischof" = nicheness_bischof(data),
"meyermiller" = nicheness_meyer_miller(data),
stop(paste("Nicheness method", method, "not implemented!"))
)
}
meyer_miller_single_election <- function(election_data,
vars,
weights,
party_system_normalization = TRUE,
only_non_zero = TRUE) {
if (is.character(weights)) {
weights <- unlist(election_data[,weights])
}
if (only_non_zero) {
## kick out variables that are 0 for everyone
vars <- subset(vars, (election_data %>%
select(one_of(vars)) %>%
colSums()) > 0.0)
}
for (name in vars) {
election_data[,name] <- (election_data[,name] -
rival_mean(election_data[,name], weights = weights))^2
}
election_data %>%
select(one_of(vars)) %>%
rowSums() %>%
{ sqrt( . / length(vars)) } %>%
iff(party_system_normalization, function(.) { . - rival_mean(., weights = weights) } )
}
rival_mean <- function(x, weights = 1) {
if (length(weights) == 1) {
weights <- rep(weights, length(x))
}
(x*weights) %>%
{ sum(.) - . } %>%
{ . / (sum(weights) - weights)}
}
#'
#' @param groups groups of issues to determine niches/policy dimensions; formatted as named lists
#' variable names. For Meyer & Miller: Defaults to adapted version of Baeck et. al 2010 Policy dimensions
#' (without industry, as used in the original paper by Meyer & Miller). For Bischof: defaults
#' to issue groups used in the Bischof 2015 paper
#' @param transform transform to apply to each of the group indicators. Can be a function,
#' character "bischof" to apply log(x + 1), or NULL for no transformation.
#' @param smooth Smoothing of policy dimension values before nicheness computation, as suggested
#' and used by Bischof 2015
#' @param weights vector of the length nrow(data) or the name of a variable in data; is used to
#' weight mean party system position and nicheness; defaults to "pervote" as in Meyer & Miller 2013
#' @param party_system_normalization normalize nicheness result within election (substract weighted mean nicheness)
#' @param only_non_zero When dividing by the number of policy dimensions used for nicheness
#' estimation, ignore dimensions that are zero for all parties (election-wise)
#' @rdname mp_nicheness
#' @export
nicheness_meyer_miller <- function(data,
groups = meyer_miller_2013_policy_dimensions(),
transform = NULL,
smooth = FALSE,
weights = "pervote",
party_system_normalization = TRUE,
only_non_zero = TRUE) {
if (!is.null(transform) &&
is.character(transform) &&
transform == "bischof") {
transform <- function(x) { log(x + 1) }
}
data %>%
aggregate_pers(groups = groups,
keep = TRUE) %>%
iff(!is.null(transform), mutate_at, names(groups), .funs = funs(transform)) %>%
group_by(party) %>%
arrange(date) %>%
iff(smooth, mutate_at, names(groups), .funs = funs((. + lag(.))/2)) %>% ## TODO think about this
ungroup() %>%
{ split(., factor(paste0(.$country, .$date, sep = "_"))) } %>%
lapply(arrange_, "party") %>%
lapply(as.data.frame) %>% ## fix necessary due to split
lapply(function(data) {
data %>%
mutate(nicheness = meyer_miller_single_election(data,
vars = names(groups),
weights = weights,
party_system_normalization = party_system_normalization,
only_non_zero = only_non_zero))}) %>%
bind_rows() %>%
select(one_of(c("country", "party", "date", "nicheness"))) %>%
arrange(country, date, party)
}
diversification <- function(data, groups) {
data %>%
select(one_of(groups)) %>%
{ . / rowSums(.) } %>%
mutate_at(groups, .funs = funs( -. * log_0(.))) %>%
rowSums()
}
#'
#' @details
#' List of possible outputs of \code{nicheness_bischof}:
#'
#' diversification: Shannon's entropy $s_p$ in Bischof 2015
#'
#' max_divers: used maximum for diversification
#'
#' min_divers: used minimum for diversification
#'
#' specialization: inverted diversification
#'
#' specialization_stand: standardized specialization
#'
#' nicheness: nicheness according to Meyer & Miller 2013 without vote share weighting
#'
#' nicheness_stand: standardized nicheness
#'
#' nicheness_two: sum of nicheness_stand and specialization_stand as proposed by Bischof 2015
#'
#'
#' @param out_variables names of variables to return in data.frame. Can be any
#' from the input or that are generated during the computation of Bischof's nicheness
#' measure. See details for a list.
#' @param diversification_bounds Bounds of the range of the diversification measure
#' (Shannon's entropy $s_p$ in Bischof 2015), used for inversion and normalization;
#' default to the theoretical bounds of the entropy of a distribution on 5 discrete
#' elements. If "empirical", the empirical max and min of the diversification measure
#' are used
#' @rdname mp_nicheness
#' @export
nicheness_bischof <- function(data,
out_variables = c("party",
"date",
"specialization",
"nicheness",
"nicheness_two"),
groups = bischof_issue_groups(),
diversification_bounds = c(
0.0,
rep(1/length(groups), length(groups)) %>%
{ -(. * log(.)) } %>%
sum()),
smooth = function(x) {
(x + lag(x, default = first(first(x))))/2
}) {
data %>%
aggregate_pers(groups = groups,
keep = TRUE) %>%
mutate_at(names(groups), .funs = funs(log(. + 1))) %>%
# smooth with lag
group_by(party) %>%
arrange(date) %>%
iff(is.function(smooth), mutate_at, names(groups), .funs = funs(smooth)) %>%
ungroup() %>%
{ mutate(., diversification = diversification(., names(groups))) } %>%
mutate(
max_divers = ifelse(all(diversification_bounds == "empirical"),
max(diversification, na.rm=TRUE),
diversification_bounds[2]),
min_divers = ifelse(all(diversification_bounds == "empirical"),
min(diversification, na.rm=TRUE),
diversification_bounds[1]),
specialization = (min_divers + max_divers) - diversification
) %>%
{ split(., factor(paste0(.$country, .$date, sep = "_"))) } %>%
lapply(arrange_, "party") %>%
lapply(as.data.frame) %>% ## fix necessary due to split
lapply(function(x) {
mutate(x, nicheness = meyer_miller_single_election(x,
vars = names(groups),
weights = 1,
party_system_normalization = TRUE,
only_non_zero = TRUE))}) %>%
bind_rows() %>%
mutate(
max_nic = max(nicheness, na.rm=TRUE),
min_nic = min(nicheness, na.rm=TRUE),
nicheness_stand = (nicheness - min_nic)/(max_nic - min_nic),
max_spec = max(specialization, na.rm=TRUE),
min_spec = min(specialization, na.rm=TRUE),
specialization_stand = (specialization-min_spec)/(max_spec-min_spec),
specialization_stand_two = ifelse(is.na(specialization_stand),0,specialization_stand),
# nicheness two
nicheness_two = nicheness_stand + specialization_stand_two) %>%
select(one_of(out_variables))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.