Skip to content

/ highest_median

Permalink
master

highest_median/packages_functions_data.R

Go to file
 
 
Cannot retrieve contributors at this time
422 lines (409 sloc) 29 KB
Raw Blame
# options(download.file.method = "wget"); # For Ubuntu 14.04
package <- function(p) {
if (!is.element(p, installed.packages()[,1])) {
install.packages(p);
}
library(p, character.only = TRUE)
} # loads packages with automatical install if needed
# package("readODS")
package("clipr")
package("xtable")
# package("RMallow")
package("plotly")
package("Hmisc")
package("stringr")
package("RColorBrewer")
# n <- function(var) { as.numeric(as.vector(var)) }
decrit <- function(variable, miss = FALSE, weights = NULL, numbers=FALSE) {
if (length(annotation(variable))>0 & !numbers) {
if (!miss) {
# if (is.element("Oui", levels(as.factor(variable))) | grepl("(char)", annotation(variable)) | is.element("quotient", levels(as.factor(variable))) | is.element("Pour", levels(as.factor(variable))) | is.element("Plutôt", levels(as.factor(variable))) ) { describe(as.factor(variable[variable!="" & !is.na(variable)]), weights = weights[variable!="" & !is.na(variable)], descript=Label(variable)) }
# else { describe(variable[variable!="" & !is.na(variable)], weights = weights[variable!="" & !is.na(variable)], descript=Label(variable)) }
if (length(which(!is.na(suppressWarnings(as.numeric(levels(as.factor(variable)))))))==0) { describe(as.factor(variable[variable!=""]), weights = weights[variable!=""], descript=Label(variable)) } # encore avant: & !is.na(variable), avant: (length(which(is.numeric(levels(as.factor(variable)))))==0)
else { describe(as.numeric(as.vector(variable[variable!=""])), weights = weights[variable!=""], descript=Label(variable)) } # avant: & !is.na(variable)
}
else {
if (length(which(suppressWarnings(!is.na(as.numeric(levels(as.factor(variable)))))))>10) describe(include.missings(variable[variable!="" & !is.na(variable)]), weights = weights[variable!="" & !is.na(variable)], descript=Label(variable)) # encore avant: & !is.na(variable), avant: (length(which(is.numeric(levels(as.factor(variable)))))==0)
else describe(as.factor(include.missings(variable[variable!="" & !is.na(variable)])), weights = weights[variable!="" & !is.na(variable)], descript=Label(variable)) }
}
else {
if (length(annotation(variable))>0) {
if (miss) describe(variable[variable!=""], weights = weights[variable!=""], descript=Label(variable))
else describe(variable[variable!="" & !is.missing(variable)], weights = weights[variable!="" & !is.missing(variable)], descript=paste(length(which(is.missing(variable))), "missing obs.", Label(variable)))
} else describe(variable[variable!=""], weights = weights[variable!=""]) }
}
##### Rules #####
gauge <- function(grades=elec2012['Hollande',], k = 0.5, scale = -2:4, return = 'qp') {
# if (length(scale) != length(grades) & length(grades)==3) scale <- -1:1
if (length(scale) != length(grades)) scale <- c((floor(-length(grades)/2)+1):(length(grades)+floor(-length(grades)/2)))
majo <- 0
i <- 0
while (majo < k) {
i <- i + 1
majo <- majo + grades[i] }
p <- 1 - majo
q <- majo - grades[i]
g <- i+min(scale)-1
if (g > min(scale) & g < max(scale)) {
if (p*k > q*(1-k)) text = paste(g, "+ ", sep="")
else text = paste(g, "- ", sep="") }
else text = paste(g," ")
if (return=='g') return(g)
else if (return=='p') return(p)
else if (return=='q') return(q)
else if (return=='pq') return(c(p=p, q=q))
else if (return=='qp') return(c(q=q, p=p))
else if (return=='gpq') return(c(g=g, p=p, q=q))
else if (return=='gqp') return(c(g=g, q=q, p=p))
else if (return=='pgq') return(c(p=p, g=g, q=q))
else if (return=='qgp') return(c(q=q, g=g, p=p))
else if (return=='text') return(text=text)
else if (return=='all') return(c(g=g, p=p, q=q, text=text))
else return(c(g, p, q, text))
}
gauges <- function(grades=elec2012, k = 0.5, scale = -2:4, return = 'qp') return(apply(grades, 1, function(x) return(gauge(x, k, scale, return))))
score <- function(rule="mj", grades=elec2012['Hollande',], k = 0.5, name="", print = T, return_text = FALSE, scale=-2:4) {
grades <- grades / sum(grades)
# if (length(scale) != length(grades) & length(grades)==3) scale <- -1:1
if (length(scale) != length(grades)) scale <- c((floor(-length(grades)/2)+1):(length(grades)+floor(-length(grades)/2)))
g <- gauge(grades, k, scale, 'g')
p <- gauge(grades, k, scale, 'p')
q <- gauge(grades, k, scale, 'q')
text <- gauge(grades, k, scale, 'text')
if (print & !return_text) print(paste(text, name, sep=""))
if (return_text) return(text)
else
if (rule=="MJ" | rule=="mj" | rule=="$mj$") return(as.numeric(g + (p>q)*p - (p<=q)*q))
# else if (rule=="s") return(as.numeric(g + 0.5*(p/(p+q) +k-1 + (p*q==0)*(p-q) + (p+q==0)*0.5))) # old
# else if (rule=="s") return(as.numeric(g + 0.5*((p-q)/(p+q)) )) # simple
else if (rule=='s' | rule=='S' | rule=='sigma' | rule=="$\\sigma$" | rule=="$s$") return(as.numeric(g + 0.5*((p-q)/(p+q+3*10^(-8))) + 0.5*((g==max(scale))*(0.5-q) + (g==min(scale))*(p-0.5)) )) # the last two terms are for the ultimate tie-breaking rule
else if (rule=="D" | rule=="d" | rule=="delta" | rule=="Delta" | rule=="$\\Delta$" | rule=="$d$") return(as.numeric(g + p - q))
else if (rule=="N" | rule=="n" | rule=="nu" | rule=="$\\nu$" | rule=="$n$") {
# if (g == min(scale)) { g <- g+1; q <- 1-p; }
# if (g == max(scale)) { g <- g-1; p <- 1-q; }
# return(g + (p*(q<0.5)-q*(p<0.5))/((2*(1-p-q))^(pmax(p,q)<0.5))) }
return(g + (p-q)/(2*(1-p-q))) }
else if (rule=="mean" | rule=="average") return(as.numeric(grades%*%scale))
else print("rule must be: mj, s, D, n or mean.")
} # mj, s, d or mean
aggregate_scores <- function(rule='mj', grades = elec2012, k = 0.5, names = candidats_2012, print = FALSE, return_text = FALSE, scale=-2:4, rounds=3) {
# res <- matrix(ncol = length(names), nrow = 4)
if (!is.matrix(grades)) grades <- matrix(grades, nrow = 1)
if (any(grades < 0)) print('WARNING: some shares of grades are negative!')
if (nrow(grades)!=length(names)) names <- c(1:length(nrow(grades)))
if (ncol(grades)!=length(scale)) scale <- c((floor(-ncol(grades)/2)+1):(ncol(grades)+floor(-ncol(grades)/2)))
res <- c()
# for (i in 1:ncol(grades)) res[,i] <- gauge(grades[,i], k, names[i])
for (i in 1:nrow(grades)) {
if (rule=="MJ" | rule=="mj" | rule=="$mj$") res <- c(res, score(rule='mj', grades[i,], k, names[i], print, return_text, scale))
else if (rule=='s' | rule=='S' | rule=='sigma' | rule=="$\\sigma$" | rule=="$s$") res <- c(res, score(rule='s', grades[i,], k, names[i], print, return_text, scale))
else if (rule=="D" | rule=="d" | rule=="delta" | rule=="Delta" | rule=="$\\Delta$" | rule=="$d$") res <- c(res, score(rule='d', grades[i,], k, names[i], print, return_text, scale))
else if (rule=='mean' | rule=='average') res <- c(res, score(rule='mean', grades[i,], k, names[i], print, return_text, scale))
else if (rule=="N" | rule=="n" | rule=="nu" | rule=="$\\nu$" | rule=="$n$") res <- c(res, score(rule='n', grades[i,], k, names[i], print, return_text, scale))
}
if (return_text) return(res)
else if (rounds) return(round(as.numeric(res), rounds))
else return(as.numeric(res))
}
ranking <- function(rule='mj', grades = elec2012, k = 0.5, names = candidats_2012, print = FALSE, scale=-2:4) {
res <- matrix(nrow = nrow(grades), ncol = 3)
scores <- aggregate_scores(rule=rule, grades, k, names, print, scale=scale)
scores_text <- aggregate_scores(rule=rule, grades, k, names, print, return_text = TRUE, scale=scale)
res[,1] <- names[order(scores, decreasing = TRUE)]
res[,2] <- scores_text[order(scores, decreasing = TRUE)]
res[,3] <- sort(scores, decreasing = TRUE)
return(res)
}
rankings <- function(grades = elec2012, names = candidats_2012, scale=-2:4, return_distance=FALSE, rounds=T) {
scores <- aggregate_scores(rule='mj', grades=grades, names=names, scale=scale, rounds = 3*rounds)
scores_text <- aggregate_scores(rule='mj', grades=grades, names=names, return_text = TRUE, scale=scale, rounds = 3*rounds)
res <- data.frame(matrix(nrow = nrow(grades), ncol = 7))
res[,1] <- names[order(scores, decreasing = TRUE)]
res[,2] <- aggregate_scores(rule='mean', grades=grades, names=names, scale=scale, rounds = 2*rounds)[order(scores, decreasing = TRUE)]
res[,3] <- scores_text[order(scores, decreasing = TRUE)]
res[,4] <- sort(scores, decreasing = TRUE)
res[,5] <- aggregate_scores(rule='d', grades=grades, names=names, scale=scale, rounds = 3*rounds)[order(scores, decreasing = TRUE)]
res[,6] <- aggregate_scores(rule='s', grades=grades, names=names, scale=scale, rounds = 3*rounds)[order(scores, decreasing = TRUE)]
res[,7] <- aggregate_scores(rule='n', grades=grades, names=names, scale=scale, rounds = 3*rounds)[order(scores, decreasing = TRUE)]
colnames(res) <- c('choices', 'mean', 'MG', '$mj$', '$d$', '$s$', '$n$') # c('choices', 'mean', 'MG', '$mj$', '$\\Delta$', '$\\sigma$', '$\\nu$') c('choices', 'mean', 'MG', 'MJ', 's', 'D', 'n')
all_orders <- do.call("rbind", lapply(list(aggregate_scores(rule='mean', grades=grades, names=names, scale=scale, rounds=F), aggregate_scores(grades=grades, names=names, scale=scale, rounds=F),
aggregate_scores(rule='d', grades=grades, names=names, scale=scale, rounds=F), aggregate_scores(rule='s', grades=grades, names=names, scale=scale, rounds=F),
aggregate_scores(rule='n', grades=grades, names=names, scale=scale, rounds=F)), rank))
distances <- AllKendall(all_orders, all_orders)
colnames(distances) <- rownames(distances) <- c('mean', '$mj$', '$d$', '$s$', '$n$') # c('mean', '$mj$', '$\\Delta$', '$\\sigma$', '$\\nu$') c('mj', 's', 'd', 'mean', 'n')
if (return_distance) return(distances)
else return(res)
}
##### Graphiques #####
data5 <- function(vars, data=s, miss=T, weights=T, rev=FALSE) {
matrice <- c()
colors <- c(rainbow(4, end=4/15), "forestgreen") # c("red", "orange", "yellow", "green", "darkgreen") # rainbow(5, end=1/3)
for (var in vars) {
if (miss) {
if (is.null(annotation(data[[var]]))) {
mat <- c(length(which(n(data[[var]])==-2))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==-1))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==0))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==1))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==2))/length(which(!is.missing(n(data[[var]])))),length(which(is.na(data[[var]])))/length(which(!is.missing(n(data[[var]]))))) # removed "n()"
if (weights) { mat <- c(sum(data[['weight']][which(n(data[[var]])==-2)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==-1)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==0)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==1)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==2)])/sum(data[['weight']][!is.missing(n(data[[var]]))]),sum(data[['weight']][which(is.na(data[[var]]))])/sum(data[['weight']][!is.missing(n(data[[var]]))])) } }
else {
mat <- c(length(which(n(data[[var]])==-2))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==-1))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==0))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==1))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==2))/length(which(!is.missing(n(data[[var]])))),length(which(is.missing(data[[var]]) & !is.na(data[[var]])))/length(which(!is.missing(data[[var]])))) # removed "n()"
if (weights) { mat <- c(sum(data[['weight']][which(n(data[[var]])==-2)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==-1)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==0)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==1)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==2)])/sum(data[['weight']][!is.missing(n(data[[var]]))]),sum(data[['weight']][which(is.missing(data[[var]]) & !is.na(data[[var]]))])/sum(data[['weight']][!is.missing(data[[var]])])) } }
colors <- c(colors, "lightgrey") }
else {
mat <- c(length(which(n(data[[var]])==-2))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==-1))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==0))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==1))/length(which(!is.missing(n(data[[var]])))), length(which(n(data[[var]])==2))/length(which(!is.missing(n(data[[var]])))))
if (weights) { mat <- c(sum(data[['weight']][which(n(data[[var]])==-2)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==-1)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==0)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==1)])/sum(data[['weight']][!is.missing(n(data[[var]]))]), sum(data[['weight']][which(n(data[[var]])==2)])/sum(data[['weight']][!is.missing(n(data[[var]]))])) } }
matrice <- c(matrice, mat) }
matrice <- matrix(c(matrice), ncol=length(vars))
if (rev & !(miss)) return(matrice[5:1,])
else if (rev & miss) return(matrice[c(5:1,6),])
else return(matrice)
# return(as.data.frame(matrice))
}
data1 <- function(vars, data=s, weights=T) {
res <- c()
for (var in vars) {
if (weights) { res <- c(res, sum(data[['weight']][which(data[[var]]==TRUE)])/sum(data[['weight']][which(data[[var]]==TRUE | data[[var]]==FALSE)])) }
else { res <- c(res, length(which(data[[var]]==T)))/length(which(data[[var]]==T | data[[var]]==FALSE)) }
}
return( matrix(res, ncol=length(vars)) )
}
dataN <- function(var, data=s, miss=T, weights = T, return = "", fr=T) {
mat <- c()
if (is.character(data[[var]]) | (is.numeric(data[[var]]) & !grepl("item", class(data[[var]])))) v <- as.factor(data[[var]])
else v <- data[[var]]
if (is.null(annotation(v))) levels <- levels(v)
else levels <- labels(v)@.Data
levels <- levels[!(levels %in% c("NSP", "PNR", "Non concerné·e"))]
for (val in levels) { # before: no %in% nowherer below
if (weights) mat <- c(mat, sum(data[['weight']][which(v==val)])/sum(data[['weight']][!is.missing(v) & (!(v %in% c("NSP", "Non concerné·e")))]))
else mat <- c(mat, length(which(v==val))/length(which(!is.missing(v) & (!(v %in% c("NSP", "Non concerné·e")))))) }
if (miss) {
if (is.null(annotation(v))) {
if (weights) mat <- c(mat, sum(data[['weight']][which(is.na(v) | v %in% c("NSP", "Non concerné·e"))])/sum(data[['weight']][!is.missing(v) & (!(v %in% c("NSP", "Non concerné·e")))]))
else mat <- c(mat, length(which(is.na(v) | v %in% c("NSP", "Non concerné·e")))/length(which(!is.missing(v) & (!(v %in% c("NSP", "Non concerné·e"))))))
} else {
if (weights) mat <- c(mat, sum(data[['weight']][which(is.missing(v) & !is.na(v))])/sum(data[['weight']][!is.missing(v)]))
else mat <- c(mat, length(which(is.missing(v) & !is.na(v)))/length(which(!is.missing(v)))) } }
if ((return %in% c("levels", "legend")) & miss & fr) return(c(levels, 'NSP'))
else if ((return %in% c("levels", "legend")) & miss & (!(fr))) return(c(levels, 'PNR'))
else if ((return %in% c("levels", "legend")) & (!(miss))) return(levels)
else return(matrix(mat, ncol=1))
}
dataKN <- function(vars, data=s, miss=T, weights = T, return = "", fr=T) {
res <- c()
for (var in vars) res <- c(res, dataN(var, data, miss, weights, return, fr))
return(matrix(res, ncol=length(vars)))
}
color5 <- c(rainbow(4, end=4/15)[1:3], "#00FF00", "#228B22") # the last two are: green, forestgreen
color <- function(v, grey=FALSE, grey_replaces_last = T, rev_color = FALSE, theme='RdBu') {
if (is.matrix(v)) n <- nrow(v)
else if (length(v) > 1) n <- length(v)
else n <- v # cf. http://research.stowers.org/mcm/efg/R/Color/Chart/ColorChart.pdf
if (grey & grey_replaces_last & n > 1) n <- n-1
if (theme=='rainbow') {
if (n == 1) cols <- c("#66B3B3") # "brown": #A52A2A Presentation Teal: #008096 (title) #1A8C8C (dark) #66B3B3 #99CCCC (light)
else if (n == 2) cols <- c("#66B3B3", "#A52A2A") # c("lightgreen", "plum") = c("#90EE90", "#DDA0DD")
else if (n == 3) cols <- color5[c(1,3,5)]
else if (n == 4) cols <- c(rainbow(4, end=4/15)[1:3], "#228B22")
else if (n == 5) cols <- c(rainbow(4, end=4/15)[1:3], "#00FF00", "#228B22") # the last two are: green, forestgreen
else if (n == 6) cols <- rainbow(6)
else if (n == 7) cols <- c("#000000", rainbow(7)[c(1:3,5:7)])
else cols <- rainbow(n) # diverge_hcl green2red brewer.pal(n, Spectral/RdBu/RdYlGn...) https://www.nceas.ucsb.edu/~frazier/RSpatialGuides/colorPaletteCheatsheet.pdf
} else {
cols <- rev(brewer.pal(n, theme))
if (n == 1) cols <- cols[1]
# if (n == 2) cols <- cols[c(1,3)]
else if (n %% 2 == 0) cols <- rev(brewer.pal(n+2, theme))[c(1:(n/2),(n/2+2):(n+1))] }
if (rev_color) cols <- rev(cols)
if (grey & n > 1) return(c(cols, "#D3D3D3")) # lightgrey
else return(cols)
}
barres <- function(data, file, title="", labels, color=c(), rev_color = FALSE, hover=legend, nsp=TRUE, sort=TRUE, legend=hover, showLegend=T, margin_r=0, margin_l=NA, online=FALSE, display_values=T, thin=FALSE, legend_x=NA, show_ticks=T, xrange=NA, median=T) {
if (length(color)==0) color <- color(data, nsp, rev_color = rev_color)
margin_t <- 0 + 25*(!(thin))
if (title!="") { margin_t <- 100 }
if (grepl("<br>", title)) { margin_t <- 150 }
legendSize <- 16 # 10, 13
legendY <- 1.1 + 0.3*thin/(ncol(data)-1) # last term may be problematic
legendX <- 0.2
# legendFont <- 'Open Sans'
if (is.na(margin_l)) { margin_l <- 4.7*max(nchar(labels)/(1 + str_count(labels, '<br>'))) }
if (max(nchar(labels)) > 25) { legendSize <- 16 } # 9, 13
# if (max(nchar(labels)) > 50) { legendSize <- 8 }
# if (max(nchar(labels)) > 60) { legendSize <- 7 }
if (max(nchar(labels)) > 50) { # 70
legendSize <- 13 # 11
# legendY = 1.2
legendX= -0.2 # 1
# if (ncol(data)>1) margin_t = 170
}
if (!is.na(legend_x)) legendX <- legend_x
if (!showLegend) { margin_t <- max(0, margin_t - 70) }
if (ncol(data)==1) legendY = 1.5 + 0.3*thin
if (sort) {
agree <- c()
if (nrow(data)==5 | nrow(data)==6) { for (i in 1:length(labels)) { agree <- c(agree, data[4, i] + data[5, i]) } }
else if (nrow(data)==7) { for (i in 1:length(labels)) { agree <- c(agree, data[6, i] + data[7, i]) } }
else { for (i in 1:length(labels)) { agree <- c(agree, data[1, i]) } }
labels <- labels[order(agree)]
data <- matrix(data[, order(agree)], nrow=nrow(data))
}
if (nrow(data)==1 & sort) {
hover <- hover[order(agree)]
value <- c()
for (i in 1:length(hover)) {
hover[i] <- paste(hover[i], "<br>Choisi dans ", round(100*data[1, i]), "% des réponses", sep="")
value[i] <- paste(round(100*data[1, i]), '%', sep='') }
hovers <- matrix(hover, nrow=length(hover))
values <- matrix(value, nrow=length(hover))
}
else {
hovers <- values <- c()
if (nsp) {
for (i in 1:(length(hover)-1)) {
for (j in 1:length(labels)) {
hovers <- c(hovers, paste(hover[i], '<br>', round(100*data[i, j]/(1+data[length(hover), j])), '% des réponses<br>', round(100*data[i, j]), '% des réponses exprimées') )
values <- c(values, paste(round(100*data[i, j]/(1+data[length(hover), j])), '%', sep=''))
}
}
for (j in 1:length(labels)) {
hovers <- c(hovers, paste(hover[length(hover)], '<br>', round(100*data[length(hover), j]/(1+data[length(hover), j])), '% des réponses<br>') )
values <- c(values, paste(round(100*data[length(hover), j]/(1+data[length(hover), j])), '%', sep=''))
}
}
else {
if (is.element(hover[length(hover)],c("PNR", "NSP"))) hover <- hover[1:(length(hover)-1)]
if (is.element(legend[length(legend)],c("PNR", "NSP"))) legend <- legend[1:(length(legend)-1)]
for (i in 1:length(hover)) {
for (j in 1:length(labels)) {
hovers <- c(hovers, paste(hover[i], '<br>', round(100*data[i, j]), '% des réponses exprimées<br>') )
values <- c(values, paste(round(100*data[i, j]), '%', sep=''))
}
}
}
hovers <- matrix(hovers, ncol=length(hover))
values <- matrix(values, ncol=length(hover))
}
if (!(display_values)) values <- replace(values, T, '')
bars <- plot_ly(x = data[1,], y = labels, type = 'bar', orientation = 'h', text = values[,1], textposition = 'auto', # sort=FALSE,
hoverinfo = hovers[,1], name=legend[1], marker = list(color = color[1], line = list(color = 'white'))) %>% # , width = 0
layout(xaxis = list(title = "",
showgrid = show_ticks,
showline = FALSE,
showticklabels = show_ticks,
gridcolor = toRGB("gray70"), # + noir, + proche de 0
gridwidth = 1,
griddash = "dot",
autotick = FALSE,
ticks = "outside",
tick0 = 0,
dtick = 0.1,
ticklen = 5*show_ticks,
tickwidth = 1,
tickcolor = toRGB("gray70"),
zeroline = T,
range = xrange,
domain = c(0.01 + 0.14*(!(" " %in% labels)), 1)
),
yaxis = list(title = "",
showgrid = FALSE,
showline = FALSE,
showticklabels = FALSE,
categoryorder = "trace",
# automargin = T,
zeroline = FALSE),
hovermode = 'closest',
barmode = 'stack',
title = title,
titlefont = list(color='black'),
font = list(color='black', size=legendSize), # -1
# paper_bgcolor = 'rgb(248, 248, 255)', plot_bgcolor = 'rgb(248, 248, 255)',
margin = list(l = margin_l, r = margin_r, t = margin_t, b = 24, autoexpand = thin), # 21, autoexpand=FALSE removes useless margin at bottom but creates bug with legend
# margin = list(b = 20, t = margin_t),
legend = list(orientation='h', y=legendY, x=legendX, traceorder='normal', font=list(size=legendSize, color='black')), # family='Balto', , family=legendFont
showlegend = (showLegend & (!("Yes" %in% legend) & !("Oui" %in% legend)))) %>%
# labeling the y-axis
add_annotations(xref = 'paper', yref = 'y', x = 0.14, y = labels,
xanchor = 'right',
text = labels, # 14
font = list(family = 'Arial', size = 16, color = 'black'),
showarrow = FALSE, align = 'right') # %>%
# Legend in the Yes/No case
if (("Yes" %in% legend) | ("Oui" %in% legend)) {
bars <- bars %>% add_annotations(xref = 'x', yref = 'paper',
x = c(0.1, 0.9, 1.1),
y = 1.5,
text = legend,
font = list(family = 'Arial', size = 16, color = 'black'),
showarrow = FALSE) } # %>%
# print(nrow(data))
# print(nrow(hovers))
# print(ncol(hovers))
if (nrow(data)>1) { for (i in 2:nrow(data)) {
bars <- add_trace(bars, evaluate=TRUE, x = data[i,], name=legend[i], text = values[,i], hoverinfo = 'text', hovertext = hovers[,i], marker = list(color = color[i]))
} }
if (median) bars <- bars %>% layout(shapes=list(layer='above', type = "line", x0 = 0.5, x1 = 0.5, yref = "paper", y0 = 0, y1 = 1, line = list(width= 0.5, color = 'blue')))
if (online) { api_create(bars, filename=file, sharing="public") }
return(bars)
}
plot_rules <- function(data = distances, type="density", xlim=NULL, ylim=NULL, xlab="Distance (d)", ylab="Density", title="", pos_legend='bottomright') {
if (title=="") { old_mar <- par()$mar; par(mar = c(4, 4, 1, 1)+0.1) } # 3, 3, 0, 0
if (type=="density") {
if (is.null(ylim)) ylim <- c(0, max(c(density(data[['D']])$y, density(data[['s']])$y, density(data[['mj']])$y, density(data[['n']])$y)))
if (is.null(xlim)) xlim <- c(min(c(density(data[['D']])$x, density(data[['s']])$x, density(data[['mj']])$x)), max(c(density(data[['D']])$x, density(data[['s']])$x, density(data[['mj']])$x)))
plot(density(data[['mj']]), col='black', type='l', lwd=2, xlim=xlim, ylim=ylim, xlab='', ylab='', main=title) + grid()
lines(density(data[['n']]), col='green', type='l', lwd=2, lty=1)
lines(density(data[['s']]), col='blue', type='l', lwd=2, lty=3)
lines(density(data[['D']]), col='red', type='l', lwd=2, lty=2)
} else {
n <- length(data[['D']])
if (is.null(ylim)) ylim <- c(0, 1)
if (is.null(xlim)) xlim <- c(min(c(data[['D']], data[['mj']], data[['s']], data[['n']])), max(c(data[['D']], data[['mj']], data[['s']])))
plot(sort(data[['D']]), (1:n)/n, col='red', type='l', lwd=2, lty=2, xlim=xlim, ylim=ylim, xlab='', ylab='', main=title) + grid() # xlim=c(0, min_group),
lines(sort(data[['n']]), (1:n)/n, col='green', type='l', lwd=2, lty=1)
lines(sort(data[['s']]), (1:n)/n, col='blue', type='l', lwd=2, lty=3)
lines(sort(data[['mj']]), (1:n)/n, col='black', type='l', lwd=2)
}
if (type=='density') legend(pos_legend, col=c('red', 'blue', 'green', 'black'), lwd=2, lty=c(2, 3, 1, 1), legend=c(expression(italic(d)), expression(italic(s)), expression(italic(n)), expression(italic(mj))), horiz=T)
else legend(pos_legend, col=c('red', 'blue', 'green', 'black'), lwd=2, lty=c(2, 3, 1, 1), legend=c(expression(italic(d)), expression(italic(s)), expression(italic(n)), expression(italic(mj))), title='Score') # c(expression(Delta), expression(sigma), expression(nu), expression(italic(mj))), title='Score'
mtext(text = xlab, side = 1, line = 2.2) + mtext(text = ylab, side = 2, line = 2.2)
if (title=="") par(mar = old_mar)
}
##### Data #####
elec2012 <- matrix(0,nrow=10, ncol=7) # B&L 2016 p. 14, 737 votants
row.names(elec2012) <- candidats_2012 <- c("Hollande", "Bayrou", "Sarkozy", "Mélenchon", "Dupont-Aignan", "Joly", "Poutou", "Le Pen", "Arthaud", "Cheminade")
colnames(elec2012) <- c("To reject", "Poor", "Fair", "Good", "Very Good", "Excellent", "Outstanding")
# colnames(elec2012) <- -2:4
elec2012['Hollande',] <- c(0.1424, 0.1425, 0.1479, 0.1167, 0.1642, 0.1615, 0.1248)
elec2012['Bayrou',] <- c(0.0869, 0.1194, 0.2008, 0.2524, 0.2171, 0.0977, 0.0258)
elec2012['Sarkozy',] <- c(0.3175, 0.0787,0.1113, 0.1099, 0.1628, 0.1235, 0.0963)
elec2012['Mélenchon',] <- c(0.2537, 0.1506, 0.171, 0.1465, 0.129, 0.095, 0.0543)
elec2012['Dupont-Aignan',] <- c(0.3392, 0.2551, 0.2022, 0.1126, 0.0597, 0.0258, 0.0054)
elec2012['Joly',] <- c(0.3853, 0.2469, 0.1465, 0.118, 0.0651, 0.0299, 0.0081)
elec2012['Poutou',] <- c(0.4573, 0.2809, 0.1248, 0.0773, 0.0448, 0.0136, 0.0014)
elec2012['Le Pen',] <- c(0.4763, 0.0624, 0.1398, 0.0936, 0.095, 0.0733, 0.0597)
elec2012['Arthaud',] <- c(0.4993, 0.2524, 0.1316, 0.0651, 0.038, 0.0136, 0.0)
elec2012['Cheminade',] <- c(0.5197, 0.2687, 0.1167, 0.0583, 0.0244, 0.0081, 0.0041)
rowSums(elec2012)
elec2017 <- matrix(0, nrow=11, ncol=6) # B&L 2017 Sondage IFOP-Fabrique Spinzo, 1000 votants https://1984f707-a-62cb3a1a-s-sites.googlegroups.com/site/ridalaraki/xfiles/Résultats%20Expérience%20Jugement%20Majoritaire%20Final%20XYZ.pdf http://fabriquespinoza.fr/wp-content/uploads/2017/04/Sondage-IFOP-FS-et-Synopia-.pdf
row.names(elec2017) <- candidats_2017 <- c("Mélenchon", "Macron", "Hamon", "Dupont-Aignan", "Le Pen", "Poutou", "Fillon", "Lassale", "Arthaud", "Asselineau", "Cheminade")
colnames(elec2017) <- c("To reject", "Poor", "Fair", "Quite Good", "Good", "Very Good")
elec2017['Mélenchon',] <- c(0.155, 0.11, 0.091, 0.288, 0.222, 0.133)
elec2017['Macron',] <- c(0.198, 0.111, 0.11, 0.257, 0.228, 0.096)
elec2017['Hamon',] <- c(0.211, 0.153, 0.17, 0.294, 0.117, 0.055)
elec2017['Dupont-Aignan',] <- c(0.244, 0.204, 0.179, 0.239, 0.095, 0.039)
elec2017['Le Pen',] <- c(0.341, 0.136, 0.067, 0.163, 0.14, 0.153)
elec2017['Poutou',] <- c(0.257, 0.228, 0.176, 0.226, 0.085, 0.028)
elec2017['Fillon',] <- c(0.335, 0.179, 0.106, 0.179, 0.119, 0.082)
elec2017['Lassale',] <- c(0.292, 0.272, 0.191, 0.196, 0.04, 0.009)
elec2017['Arthaud',] <- c(0.292, 0.284, 0.163, 0.192, 0.055, 0.014)
elec2017['Asselineau',] <- c(0.316, 0.294, 0.166, 0.179, 0.035, 0.01)
elec2017['Cheminade',] <- c(0.323, 0.309, 0.171, 0.169, 0.024, 0.004)
rowSums(elec2017)
distributions <- t(read.csv("grades_distributions.csv"))
# row.names(distributions) <- distributions_names <- c("Actual", "Egalitarian", "Personnalized", "Median proposed reform", "Demogrant median proposed reform", "Derived from utilitarian optimization", "Derived from Rawlsian optimization")
row.names(distributions) <- distributions_names <- c("Actual", "Egalitarian", "Personnalized", "Median reform", "Demogrant median", "Utilitarian optimal", "Rawlsian optimal")
colnames(distributions) <- -2:2
laprimaire <- read_ods("Highest median - resultats laprimaire.ods") # Source: https://docs.google.com/spreadsheets/d/1MbFtR0lD-QldXZGgID0L-oImUFsqH-MurGBSFRcFGDY/edit#gid=1073724486 cité par articles.laprimaire.org/c8fe612b64cb
laprimaire <- laprimaire[,-1]
for (r in 1:length(laprimaire[1,])) laprimaire[,r] <- laprimaire[,r]/laprimaire[6,r]
laprimaire <- t(laprimaire[-6,])
colnames(laprimaire) <- -2:2 # -1:3
You can’t perform that action at this time.