Nothing
evaluation <-
function(
profiles = NULL,
threshold,
error = 10^(-3),
zeta = getzeta(profiles),
weights = {
if(!is.null(profiles))
profiles$freq
else
rep(1, nrow(zeta))
},
distances = {n <- nrow(zeta); matrix(1, n, n) - diag(1, n)},
linext = lingen(zeta),
nit = floor({n <- nrow(zeta); n^5*log(n)+n^4*log(error^(-1))}),
maxint = 2^31-1,
inequality = FALSE
)
{
n <- nrow(zeta)
if (is.numeric(threshold)) {
stopifnot(max(threshold) <= n)
stopifnot(min(threshold) >= 1)
threshold <- 1:n %in% threshold
}
if (is.character(threshold)) {
oldl <- length(threshold)
threshold <- rownames(zeta) %in% threshold
if (sum(threshold) != oldl)
stop("not all threshold profiles can be found in the poset")
}
stopifnot(is.logical(threshold))
lev <- levels.incidence(zeta)[threshold]
if (any(lev==1))
stop(paste("The elements", paste(names(which(lev==1)), collapse=", "),
"of the threshold define all profiles are poor. Wellness can not be evaluated. Use the function \"idn\" if you want calculate the rank distribution."))
# frammenta le esecuzioni in modo tale da non passare a C numeri interi
# pi? grandi di maxint
nitot <- nit
nit <- rep(maxint, nitot %/% maxint)
resto <- nitot %% maxint
if (resto > 0)
nit <- c(nit, resto)
pb <- txtProgressBar(style = 3, min = 0, max = nitot)
cont <- 0
l <- list(
zeta = zeta,
linext = linext,
n = n,
nit = 0,
rankfreq = matrix(0, n, n, dimnames=list(rownames(zeta), 1:n)),
threshold = threshold,
thrfreq = rep(0, n),
loweqthr = rep(0, n),
weights = weights,
distances = distances,
gapAP = rep(0, n),
gapRP = rep(0, n),
gapAR = rep(0, n),
gapRR = rep(0, n),
inequality = -(!inequality)
)
class(l) <- "pre_parsec"
for(j in nit) {
l$nit <- j
l <- runC(l)
cont <- cont + j
setTxtProgressBar(pb, cont)
}
close(pb)
l$gapAP <- l$gapAP/nitot
l$gapRP <- l$gapRP/nitot
l$gapAR <- l$gapAR/nitot
l$gapRR <- l$gapRR/nitot
names(l$threshold) <- names(l$thrfreq) <-
names(l$loweqthr) <- names(l$gapAP) <- names(l$gapRP) <-
names(l$gapAR) <- names(l$gapRR) <-
rownames(l$distances) <- colnames(l$distances) <-
rownames(zeta)
names(l$linext) <- rownames(zeta)[l$linext][l$linext]
l$nit <- nitot
N <- sum(l$weights)
if (inequality) {
maxpolar <- N^2/4*(n - 1)
l$inequality <- l$inequality/nitot/maxpolar
} else {
l$inequality <- NA
}
#########################
# CREAZIONE DELL'OUTPUT #
#########################
l$rankfreq <- l$rankfreq[,n:1]
colnames(l$rankfreq) <- 1:n
res <- list(
profiles = profiles,
number_of_profiles = l$n,
number_of_variables = ncol(profiles$profiles),
incidence = l$zeta,
cover = incidence2cover(l$zeta),
threshold = l$threshold,
number_of_iterations = l$nit,
rank_dist = l$rankfreq/l$nit,
thr_dist = l$thrfreq/l$nit,
prof_w = l$weights,
edg_w = l$distances,
idn_f = l$loweqthr/l$nit,
svr_abs = l$gapAP,
svr_rel = l$gapRP,
wea_abs = l$gapAR,
wea_rel = l$gapRR,
# head_count_ratio = weighted.mean(l$loweqthr/l$nit, l$weights),
# poverty_gap = weighted.mean(l$gapRP[l$gapRP>0], l$weights[l$gapRP>0]),
# wealth_gap = weighted.mean(l$gapRR[l$gapRR>0], l$weights[l$gapRR>0]),
poverty_gap = weighted.mean(l$gapRP, l$weights*(l$gapRP>0)),
wealth_gap = weighted.mean(l$gapRR, l$weights*(l$gapRR>0)),
inequality = l$inequality
)
class(res) <- "parsec"
return(res)
}
inequality <- function (profiles = NULL, zeta = getzeta(profiles), ...)
{
threshold <- rownames(zeta)[1]
inequality <- TRUE
evaluation(threshold = threshold, zeta = zeta, inequality = inequality, ...)$inequality
}
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.