## 6.1 Alkire-Foster Class Function Definition

svyafc <-
function(formula,
design,
k ,
g ,
cutoffs ,
dimw = NULL,
na.rm = FALSE,
...) {
if (k <= 0 |
k > 1)
stop("This functions is only defined for k in (0,1].")
if (g < 0)
stop("This function is undefined for g < 0.")
if (!is.list(cutoffs))
stop("The parameter 'cutoffs' has to be a list.")

ach.matrix <-
model.frame(formula, design$variables, na.action = na.pass)[, ] if (!is.null(dimw)) { if (any(is.na(dimw))) { stop("Invalid value in dimension weights vector.") } if (sum(dimw) > 1) { stop("The sum of dimension weigths have to be equal to one.") } if (any(dimw > 1 | dimw < 0)) { stop("Dim. weights have to be within interval [0,1].") } if (length(dimw) != ncol(ach.matrix)) { stop("Dimension weights' length differs from number of dimensions in formula") } } var.class <- lapply(ach.matrix, function(x) class(x)[1]) var.class <- matrix( var.class, nrow = 1, ncol = ncol(ach.matrix), dimnames = list(c("var.class"), colnames(ach.matrix)) ) if (any(!(var.class %in% c("numeric", "integer", "ordered")))) { stop( "This function is only applicable to variables of types 'numeric' or 'ordered factor'." ) } if (any((var.class == "integer"))) { stop( "At least one of the variables is an integer.\nCoerce your column to numeric with as.numeric if you are sure it's what you want." ) } w <- 1 / design$prob

if (any(ach.matrix[w != 0, var.class == "numeric"] < 0, na.rm = TRUE))
stop(
"The Alkire-Foster multidimensional poverty class is defined for non-negative numeric variables only."
)

if (na.rm) {
nas <- apply(ach.matrix, 1, function(x)
any(is.na(x)))
design <- design[nas == 0,]
w <- 1 / design$prob } ach.matrix <- model.frame(formula, design$variables, na.action = na.pass)[, ]
ach.matrix <- ach.matrix [w > 0,]
w <- w [w > 0]

if (any(is.na(ach.matrix))) {
if (is.null(dimw)) {
dimw = rep(1 / ncol(var.class), length(var.class))
}

rval <- as.numeric(NA)
variance <- as.numeric(NA)
class(rval) <- c("cvystat" , "svystat")
attr(rval, "var") <- variance
names(rval)[1] <- attr(rval, "statistic") <- "alkire-foster"
dimtable <-
as.data.frame(matrix(
c(strsplit(as.character(formula)[[2]] , ' \\+ ')[[1]], dimw),
nrow = ncol(var.class),
ncol = 2,
dimnames = list(paste("dimension", 1:ncol(var.class)), c("variables", "weight"))
),
stringsAsFactors = FALSE)
dimtable[, 2] <- as.numeric(dimtable[, 2])
attr(rval, "dimensions") <- dimtable
attr(rval, "parameters") <-
matrix(
c(g, k),
nrow = 1,
ncol = 2,
dimnames = list("parameters", c("g=", "k="))
)

return(rval)

}

# Deprivation Matrix
dep.matrix <-
sapply(
seq_along(var.class),
FUN = function(i) {
1 * (cutoffs[[i]] > ach.matrix[, i])
}
)
colnames(dep.matrix) <- colnames(var.class)

# Unweighted count of deprivations:
# depr.count <- rowSums( dep.matrix )

# deprivation k cut
if (is.null(dimw)) {
dimw = rep(1 / ncol(dep.matrix), ncol(dep.matrix))
}

# Weighted sum of deprivations:
depr.sums <- rowSums(sweep(dep.matrix, MARGIN = 2 , dimw, *))

# k multidimensional cutoff:
multi.cut <- depr.sums * (depr.sums >= k)
rm(dep.matrix)

# Censored Deprivation Matrix
cen.dep.matrix <-
sapply(
seq_along(cutoffs) ,
FUN = function(x) {
if (var.class[x] == "numeric") {
1 * (cutoffs[[x]] > ach.matrix[, x]) * ((cutoffs[[x]] - ach.matrix[, x]) / cutoffs[[x]]) ^
g
} else {
1 * (cutoffs[[x]] > ach.matrix[, x])
}
}
)
colnames(cen.dep.matrix) <- colnames(var.class)
cen.dep.matrix[multi.cut == 0,] <- 0

# Sum of censored deprivations:
cen.depr.sums <-
rowSums(sweep(cen.dep.matrix, MARGIN = 2 , dimw, *))
rm(cen.dep.matrix, ach.matrix)

w <- 1 / design$prob w[w > 0] <- cen.depr.sums cen.depr.sums <- w rm(w) if (g == 0) { w <- 1 / design$prob
w[w > 0] <- (depr.sums >= k)
h_i <- w
rm(w)

h_est <- survey::svymean(h_i, design)

w <- 1 / design\$prob
w[w > 0] <- multi.cut
multi.cut <- w
rm(w)

a_est <- survey::svyratio(multi.cut, h_i, design)

}

rval <- survey::svymean(cen.depr.sums , design)
names(rval)[1] <- attr(rval, "statistic") <- "alkire-foster"
dimtable <-
as.data.frame(matrix(
c(strsplit(as.character(formula)[[2]] , ' \\+ ')[[1]], dimw),
nrow = ncol(var.class),
ncol = 2,
dimnames = list(paste("dimension", 1:ncol(var.class)), c("variables", "weight"))
),
stringsAsFactors = FALSE)
dimtable[, 2] <- as.numeric(dimtable[, 2])
attr(rval, "dimensions") <- dimtable
attr(rval, "parameters") <-
matrix(
c(g, k),
nrow = 1,
ncol = 2,
dimnames = list("parameters", c("g=", "k="))
)
if (g == 0) {
attr(rval, "extra") <-
matrix(
c(h_est[1], a_est[[1]], attr(h_est, "var")[1] ^ .5, a_est[[2]] ^ .5),
nrow = 2,
ncol = 2,
dimnames = list(c("H", "A"), c("coef", "SE"))
)
}
class(rval) <- c("cvystat" , "svystat")

return(rval)

}