# ---------------------------------------
# Author: Andreas Alfons
# Vienna University of Technology
# ---------------------------------------
# TODO: error handling
#' Utility functions for indicators on social exclusion and poverty
#'
#' Test for class, print and take subsets of indicators on social exclusion and
#' poverty.
#'
#' @name utils
#'
#' @param x for \code{is.xyz}, any object to be tested. The \code{print} and
#' \code{subset} methods are called by the generic functions if an object of the
#' respective class is supplied.
#' @param years an optional numeric vector giving the years to be extracted.
#' @param strata an optional vector giving the domains of the breakdown to be
#' extracted.
#' @param \dots additional arguments to be passed to and from methods.
#'
#' @return \code{is.indicator} returns \code{TRUE} if \code{x} inherits from
#' class \code{"indicator"} and \code{FALSE} otherwise.
#'
#' \code{is.arpr} returns \code{TRUE} if \code{x} inherits from class
#' \code{"arpr"} and \code{FALSE} otherwise.
#'
#' \code{is.qsr} returns \code{TRUE} if \code{x} inherits from class
#' \code{"qsr"} and \code{FALSE} otherwise.
#'
#' \code{is.rmpg} returns \code{TRUE} if \code{x} inherits from class
#' \code{"rmpg"} and \code{FALSE} otherwise.
#'
#' \code{is.gini} returns \code{TRUE} if \code{x} inherits from class
#' \code{"gini"} and \code{FALSE} otherwise.
#'
#' \code{is.gini} returns \code{TRUE} if \code{x} inherits from class
#' \code{"gini"} and \code{FALSE} otherwise.
#'
#' \code{print.indicator}, \code{print.arpr} and \code{print.rmpg} return
#' \code{x} invisibly.
#'
#' \code{subset.indicator}, \code{subset.arpr} and \code{subset.rmpg} return a
#' subset of \code{x} of the same class.
#'
#' @seealso \code{\link{arpr}}, \code{\link{qsr}}, \code{\link{rmpg}},
#' \code{\link{gini}}, \code{\link{gpg}}
#'
#' @references
#' A. Alfons and M. Templ (2013) Estimation of Social Exclusion Indicators
#' from Complex Surveys: The \R Package \pkg{laeken}. \emph{Journal of
#' Statistical Software}, \bold{54}(15), 1--25. \doi{10.18637/jss.v054.i15}
#'
#' @keywords survey
#'
#' @examples
#' data(eusilc)
#'
#' # at-risk-of-poverty rate
#' a <- arpr("eqIncome", weights = "rb050",
#' breakdown = "db040", data = eusilc)
#' print(a)
#' is.arpr(a)
#' is.indicator(a)
#' subset(a, strata = c("Lower Austria", "Vienna"))
#'
#' # quintile share ratio
#' q <- qsr("eqIncome", weights = "rb050",
#' breakdown = "db040", data = eusilc)
#' print(q)
#' is.qsr(q)
#' is.indicator(q)
#' subset(q, strata = c("Lower Austria", "Vienna"))
#'
#' # relative median at-risk-of-poverty gap
#' r <- rmpg("eqIncome", weights = "rb050",
#' breakdown = "db040", data = eusilc)
#' print(r)
#' is.rmpg(r)
#' is.indicator(r)
#' subset(r, strata = c("Lower Austria", "Vienna"))
#'
#' # Gini coefficient
#' g <- gini("eqIncome", weights = "rb050",
#' breakdown = "db040", data = eusilc)
#' print(g)
#' is.gini(g)
#' is.indicator(g)
#' subset(g, strata = c("Lower Austria", "Vienna"))
#'
NULL
## constructors
# class "indicator"
constructIndicator <- function(value, valueByStratum = NULL,
varMethod = NULL, var = NULL, varByStratum = NULL, ci = NULL,
ciByStratum = NULL, alpha = NULL, years = NULL, strata = NULL) {
# construct and assign class
x <- list(value=value, valueByStratum=valueByStratum, varMethod=varMethod,
var=var, varByStratum=varByStratum, ci=ci, ciByStratum=ciByStratum,
alpha=alpha, years=years, strata=strata)
class(x) <- "indicator"
# return object
return(x)
}
# class "arpr"
constructArpr <- function(..., p = 0.6, threshold) {
x <- constructIndicator(...) # call constructor of superclass
x$p <- p # set specific
x$threshold <- threshold # attributes
class(x) <- c("arpr", class(x)) # assign class
return(x) # return result
}
# class "qsr"
constructQsr <- function(...) {
x <- constructIndicator(...) # call constructor of superclass
class(x) <- c("qsr", class(x)) # assign class
return(x) # return result
}
# class "gpg"
constructGpg <- function(...) {
x <- constructIndicator(...) # call constructor of superclass
class(x) <- c("gpg", class(x)) # assign class
return(x) # return result
}
# class "rmrpg"
constructRmpg <- function(..., threshold) {
x <- constructIndicator(...) # call constructor of superclass
x$threshold <- threshold # set specific attributes
class(x) <- c("rmpg", class(x)) # assign class
return(x) # return result
}
# class "gini"
constructGini <- function(...) {
x <- constructIndicator(...) # call constructor of superclass
class(x) <- c("gini", class(x)) # assign class
return(x) # return result
}
# class "prop"
constructProp <- function(...) {
x <- constructIndicator(...) # call constructor of superclass
class(x) <- c("prop", class(x)) # assign class
return(x) # return result
}
## test for class
#' @rdname utils
#' @export
is.indicator <- function(x) inherits(x, "indicator")
#' @rdname utils
#' @export
is.arpr <- function(x) inherits(x, "arpr")
#' @rdname utils
#' @export
is.qsr <- function(x) inherits(x, "qsr")
#' @rdname utils
#' @export
is.rmpg <- function(x) inherits(x, "rmpg")
#' @rdname utils
#' @export
is.gini <- function(x) inherits(x, "gini")
#' @rdname utils
#' @export
is.prop <- function(x) inherits(x, "prop")
#' @rdname utils
#' @export
is.gpg <- function(x) inherits(x, "gpg")
## print
# class "indicator"
#' @rdname utils
#' @method print indicator
#' @export
print.indicator <- function(x, ...) {
cat("Value:\n")
print(x$value, ...)
if(!is.null(x$var)) {
cat("\nVariance:\n")
print(x$var, ...)
}
if(!is.null(x$ci)) {
cat("\nConfidence interval:\n")
print(x$ci, ...)
}
if(!is.null(x$valueByStratum)) {
cat("\nValue by domain:\n")
print(x$valueByStratum, ...)
}
if(!is.null(x$varByStratum)) {
cat("\nVariance by domain:\n")
print(x$varByStratum, ...)
}
if(!is.null(x$varByStratum)) {
cat("\nConfidence interval by domain:\n")
print(x$ciByStratum, ...)
}
invisible(x)
}
# class "arpr"
#' @rdname utils
#' @method print arpr
#' @export
print.arpr <- function(x, ...) {
print.indicator(x, ...)
cat("\nThreshold:\n")
print(x$threshold, ...)
invisible(x)
}
# class "rmpg"
#' @rdname utils
#' @method print rmpg
#' @export
print.rmpg <- function(x, ...) {
print.indicator(x, ...)
cat("\nThreshold:\n")
print(x$threshold, ...)
invisible(x)
}
# class "minAMSE"
#' @rdname minAMSE
#' @method print minAMSE
#' @export
print.minAMSE <- function(x, ...) {
cat("Optimal k:\n")
print(x$kopt, ...)
cat("\nScale parameter:\n")
print(x$x0, ...)
cat("\nShape parameter:\n")
print(x$theta, ...)
invisible(x)
}
## subsets of indicators
# class "indicator"
#' @rdname utils
#' @method subset indicator
#' @export
subset.indicator <- function(x, years = NULL, strata = NULL, ...) {
# initializations
haveYears <- length(x$years) > 1
haveVar <- !is.null(x$varMethod)
haveStrata <- length(x$strata) > 1
subsetYears <- haveYears && !is.null(years)
subsetStrata <- haveStrata && !is.null(strata)
# error handling
if(subsetYears && !is.numeric(years)) {
stop("'years' must be of type numeric")
}
if(subsetStrata && !is.character(strata)) {
stop("'years' must be of type character")
}
# extract years from overall values (if available and requested)
if(subsetYears) {
ys <- as.character(years)
x$value <- x$value[ys]
if(haveVar) {
x$var <- x$var[ys]
x$ci <- x$ci[ys, , drop=FALSE]
}
x$years <- years #set new years
}
# extract strata from overall values (if available and requested)
if(subsetStrata || (haveStrata && subsetYears)) {
n <- nrow(x$valueByStratum)
if(subsetStrata) keepStrata <- x$valueByStratum$stratum %in% strata
else keepStrata <- rep.int(TRUE, n)
if(subsetYears) keepYears <- x$valueByStratum$year %in% years
else keepYears <- rep.int(TRUE, n)
keep <- keepStrata & keepYears
x$valueByStratum <- x$valueByStratum[keep, , drop=FALSE]
if(haveVar) {
x$varByStratum <- x$varByStratum[keep, , drop=FALSE]
x$ciByStratum <- x$ciByStratum[keep, , drop=FALSE]
}
x$strata <- strata # set new strata
}
# return result
return(x)
}
# class "arpr"
# TODO: allow for subsetting by threshold percentage
#' @rdname utils
#' @method subset arpr
#' @export
subset.arpr <- function(x, years = NULL, strata = NULL, ...) {
haveYear <- length(x$years) > 1
x <- subset.indicator(x, years, strata, ...) # call method for superclass
# subset threshold (if requested and available for multiple years)
if(haveYear && !is.null(years)) {
x$threshold <- x$threshold[as.character(years)]
}
# return result
return(x)
}
# class "rmpg"
#' @rdname utils
#' @method subset rmpg
#' @export
subset.rmpg <- function(x, years = NULL, strata = NULL, ...) {
haveYear <- length(x$years) > 1
x <- subset.indicator(x, years, strata, ...) # call method for superclass
# subset threshold (if requested and available for multiple years)
if(haveYear && !is.null(years)) {
x$threshold <- x$threshold[as.character(years)]
}
# return result
return(x)
}
## other utility functions
# get argument names of a function
argNames <- function(fun, removeDots = TRUE) {
nam <- names(formals(fun))
if(removeDots) nam <- setdiff(nam, "...")
nam
}
# check percentages for the ARPT
checkP <-function(p) {
if(is.numeric(p)) {
keep <- !is.na(p) & p >= 0 & p <= 1
p <- p[keep]
} else p <- numeric()
if(length(p) == 0) stop("'p' must contain numeric values in [0,1]")
p
}
# get labels for percentages of the ARPT
getPLabels <-function(p) paste(signif(p*100), "%", sep="")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.