Nothing
#' Derive flags for an aggregates using diffrent methods
#' @description The wrapper function to use the different method and provide a structured return value independently
#' from the method used.
#' @param flags A data.frame or a matrix containing the flags of the series (one column per period)
#' without row identifiers (e.g. country code).
#' @param method A string contains the method to to derive the flag for the aggregate. It can take the value,
#' "hierarchy", "frequency" or "weighted".
#' @param codelist A string or character vector defining the list of acceptable flags in case the method "hierarchy"
#' is chosen. In case of the string equals to "estat" or "sdmx" then the predefined standard Eurostat and SDMX codelist
#' is used, otherwise the characters in the sring will define the hierarchical order.
#' @param flag_weights A data.frame or a matrix containing the corresponding weights of the series (one column per
#' period) without row identifiers (e.g. country code). It has the same size and dimesion as the \code{flags} parameter.
#' @param threshold The threshold which above the should be the waights in order the aggregate to receive a flag.
#' Defalut value is 0.5, but can be changed to any value.
#' @return \code{propagate_flag} returns a list with the same size as the number of periods (columns) in the flags
#' parameter. In case of the methods is "hierarchy" or "frequency", then only the derived flag(s) is returned. In case
#' of weighted it returns the flag(s) and the sum of weights if it is above the threshold, otherwise the list contains
#' \code{NA} where the sum of weights are below the threshold.
#'
#' @seealso \code{\link{flag_hierarchy}}, \code{\link{flag_frequency}}, \code{\link{flag_weighted}}
#' @examples
#' flags <- tidyr::spread(test_data[, c(1:3)], key = time, value = flags)
#' weights <- tidyr::spread(test_data[, c(1, 3:4)], key = time, value = values)
#'
#' propagate_flag(flags[, c(2:ncol(flags))],"hierarchy","puebscd")
#' propagate_flag(flags[, c(2:ncol(flags))],"hierarchy","estat")
#' propagate_flag(flags[, c(2:ncol(flags))],"frequency")
#'
#' flags<-flags[, c(2:ncol(flags))]
#' weights<-weights[, c(2:ncol(weights))]
#' propagate_flag(flags,"weighted",flag_weights=weights)
#' propagate_flag(flags,"weighted",flag_weights=weights,threshold=0.1)
#'
#' @export
propagate_flag <- function(flags,
method = "",
codelist = NULL,
flag_weights = 0,
threshold = 0.5){
estat_flags <- c("b", "d", "f", "e", "s", "p", "n", "u")
sdmx_flags <- c("B", "J", "S", "D", "I", "F", "E", "P", "N", "U", "V", "G", "A")
if (method=="hierarchy") {
if (is.null(codelist)){
stop("The codelist is missing.")
}
codelist<-codelist[!is.na(codelist)]
if (length(codelist)==0){
stop("The codelist is missing.")
}
else if (length(codelist)==1){
if (codelist=="estat"){
ordinance<- estat_flags
flags<-sapply(flags,function(x) gsub("c",NA,x))
}
else if (codelist=="sdmx"){
ordinance<- sdmx_flags
}
else {
ordinance<- strsplit(paste0(codelist,collapse = ""),split = "")[[1]]
}
}
else {
ordinance<- strsplit(paste0(codelist,collapse = ""),split = "")[[1]]
}
used_flags=strsplit(as.array(unique(strsplit(paste0(unique(flags[!is.na(flags)]),collapse = ""),split = "")[[1]])),split = "")
if (!all(used_flags %in% ordinance)){
if (sum(used_flags %in% ordinance == F) < 2){
stop(paste0("The following flag from the data set is not in the list of hierarchy: ", paste(used_flags[used_flags %in% ordinance == F],collapse = ", "),".\n"))
}
else {
stop(paste0("The following flags from the data set are not in the list of hierarchy: ", paste(used_flags[used_flags %in% ordinance == F],collapse = ", "),".\n"))
}
}
else{
as.list(apply(flags,2, flag_hierarchy, flag_list = ordinance))
}
}
else if (method=="frequency"){
as.list(apply(flags,2, flag_frequency))
}
else if(method=="weighted"){
if (missing(flag_weights)){
stop("The weights are missing.")
}
else if ("logical" %in% class(flag_weights)){
if (is.null(colnames(flags))){
weighted_flags<- list(date0=list(as.character(NA),as.character(NA)))
weighted_flags
}
else{
weighted_flags<-sapply(colnames(flags),function(x) list(list(as.character(NA),as.character(NA))))
weighted_flags
}
}
else{
if ("numeric" %in% class(flag_weights)){
if (sum(flag_weights,na.rm=T)!=1){
flag_weights<-flag_weights/sum(flag_weights,na.rm=T)
flag_weights[is.na(flag_weights)] <- 0
}
weighted_flags<-flag_weighted(1,data.frame(flags,stringsAsFactors=F),data.frame(flag_weights))
weighted_flags[weighted_flags[2]<threshold]<-NA
if (is.null(colnames(flags))){
list(date0=list(weighted_flags[1],weighted_flags[2]))
}
else{
list(list(weighted_flags[1],weighted_flags[2]))
}
}
else{
if (sum(colSums(flag_weights,na.rm = T))!=ncol(flag_weights)){
flag_weights<-apply(flag_weights,2,function(x) x/sum(x,na.rm=T))
flag_weights[is.na(flag_weights)] <- 0
}
weighted_flags<-sapply(1:ncol(flags),flag_weighted,f=data.frame(lapply(flags,as.character),stringsAsFactors=F),w=data.frame(flag_weights))
colnames(weighted_flags)<-colnames(flags)
weighted_flags[,weighted_flags[2,]<threshold]<-NA
apply(weighted_flags, 2, as.list)
}
}
}
else {
stop('The method is incorrect! It should be either "hierarchy", "frequency" or "weighted".')
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.