238 lines
10 KiB
R
238 lines
10 KiB
R
|
|
||
|
|
#------------------------------------ CUSTOM FUNCTIONS ----------------------------------#
|
||
|
|
# Rounding up the values----------------------------------
|
||
|
|
round2 = function(x, n) {
|
||
|
|
posneg = sign(x)
|
||
|
|
z = abs(x)*10^n
|
||
|
|
z = z + 0.5
|
||
|
|
z = trunc(z)
|
||
|
|
z = z/10^n
|
||
|
|
z*posneg
|
||
|
|
}
|
||
|
|
|
||
|
|
# Factor to numeric---------------------------------------
|
||
|
|
as.numeric.factor <- function(x) {as.numeric(levels(x))[x]}
|
||
|
|
|
||
|
|
# For creating tables-------------------------------------
|
||
|
|
wordTabela <- function (data, ime.vrstice = NULL , sirina.vrstice = NULL, sirina.stolpca, st.vrstice.barva = NULL) {
|
||
|
|
## data: data frame
|
||
|
|
## ime.vrstice: string z imenom dodane vrstice: gre za ime tabele
|
||
|
|
## sirina.vrstice: cez koliko stolpcev se bo razprostiralo ime tabele
|
||
|
|
## sirina stolpca: sirina stolpcev v tabeli
|
||
|
|
## st.vrstice.barva: v primeru, da želimo pobarvati zadnjo vsrtico v tabeli: Glej tabelo 2
|
||
|
|
# First we want only table, witohut header columns
|
||
|
|
# because we will first add another row with table caption
|
||
|
|
# and after that we will add header columns
|
||
|
|
tabela <- FlexTable(data = data, header.columns = FALSE)
|
||
|
|
# add first header row
|
||
|
|
# tabela <- addHeaderRow(tabela, text.properties = textBold(),
|
||
|
|
# value = ime.vrstice, colspan = sirina.vrstice,
|
||
|
|
# cell.properties = cellProperties(background.color="#DEEBF7" ))
|
||
|
|
# add second header row
|
||
|
|
tabela <- addHeaderRow(tabela, value = names(data),
|
||
|
|
text.properties = textBold(),
|
||
|
|
cell.properties = cellProperties(background.color="#81d4FA" ))
|
||
|
|
# Set width of columns
|
||
|
|
tabela <- setFlexTableWidths(tabela, widths = sirina.stolpca)
|
||
|
|
# Opcijsko
|
||
|
|
if (!is.null(st.vrstice.barva)) {
|
||
|
|
# Collor last row
|
||
|
|
tabela <- setFlexTableBackgroundColors(tabela, i = nrow(data), colors = "#81d4FA" )
|
||
|
|
# Bold text
|
||
|
|
tabela[nrow(data),] <- textBold(color="black")
|
||
|
|
}
|
||
|
|
# Vrni tabelo
|
||
|
|
return(tabela)
|
||
|
|
}
|
||
|
|
|
||
|
|
# GGPLOT------------------------------------------------
|
||
|
|
# Define colors for bars:
|
||
|
|
cu.pall <- c("#0288D1", "#81d4FA")
|
||
|
|
graf <- function(data, x1, y1, z, xime, yime, sirinastolpca) {
|
||
|
|
p <- ggplot(data, aes(x = x1, y = y1, fill = z)) +
|
||
|
|
# a theme with a white background
|
||
|
|
theme_bw() +
|
||
|
|
# Barplot z širino stolpcev 0.4 in position dodge pomeni primerjava (glej graf)
|
||
|
|
geom_bar(stat = "identity",width = sirinastolpca, position = "dodge") +
|
||
|
|
# Horizontalna postavitev grafa
|
||
|
|
coord_flip()
|
||
|
|
# Y os naj bo od 1-5 in ne od 0-5
|
||
|
|
p <- p + scale_y_continuous(expand = c(0, 0), limits = c(1, 5.4), oob = rescale_none) +
|
||
|
|
# barva stolpcev (name = "") ker ne želimo še poimenovati "legendo" grafa
|
||
|
|
scale_fill_manual(values=cu.pall) +
|
||
|
|
# Ime x in y osi
|
||
|
|
labs(x = xime, y = yime, fill = "") +
|
||
|
|
# Legenda naj se prikaže pod grafom
|
||
|
|
theme(legend.position="bottom") +
|
||
|
|
# V posameznih stolpcih bodo prikazana povprečja posameznih kategorij
|
||
|
|
# Pozicija prikazanih povprečjih pa bo vedno tam, kjer je maksimalna vrednost
|
||
|
|
# geom_text(aes(x = x1, y = max(y1), label = round(y1, 2)),
|
||
|
|
# angle = 0, position = position_dodge(width = sirinastolpca), size = 3.2)
|
||
|
|
geom_text(aes(x = x1, y = max(y1, na.rm = TRUE), label = ifelse(is.nan(y1), "", sprintf("%1.2f",y1))),
|
||
|
|
angle = 0, position = position_dodge(width = sirinastolpca), size = 3.2)
|
||
|
|
|
||
|
|
return(p)
|
||
|
|
}
|
||
|
|
|
||
|
|
# Loop: Povprečna ocena uslužbenca za vsakega od 20 področij
|
||
|
|
pripr.podatk <- function(upravnaenota, vseupravneenote, Q2value, UEime) {
|
||
|
|
if (!is.null(upravnaenota)) { # V primeru, da delamo grafe oz. poročilo za vse UE potem
|
||
|
|
# podatkov za posamezno UE ne potrebujemo.
|
||
|
|
# UPRAVNA ENOTA-----------------
|
||
|
|
single.UE <- subset(upravnaenota, Q2 == Q2value, select = c(Q3a, Q3b, Q3c, Q3d, Q3e, Q3f))
|
||
|
|
# dplyr: mutate_all
|
||
|
|
# Convert character to numeric for entire data frame
|
||
|
|
single.UE <- mutate_all(single.UE, function(x) as.numeric(as.character(x)))
|
||
|
|
# Calculate average
|
||
|
|
single.UE <- round2(colMeans(single.UE, na.rm = TRUE), 2)
|
||
|
|
single.UE <- data.frame(single.UE)
|
||
|
|
}
|
||
|
|
# VSE UPRAVNE ENOTE-------------
|
||
|
|
UE.all <- subset(vseupravneenote, Q2 == Q2value, select = c(Q3a, Q3b, Q3c, Q3d, Q3e, Q3f))
|
||
|
|
# melt the data frame for plotting
|
||
|
|
UE.all <- mutate_all(UE.all, function(x) as.numeric(as.character(x)))
|
||
|
|
# Calculate average
|
||
|
|
UE.all <- round2(colMeans(UE.all, na.rm = TRUE), 2)
|
||
|
|
UE.all <- data.frame(UE.all)
|
||
|
|
|
||
|
|
if (!is.null(upravnaenota)) { # Samo delamo poročilo za posamezno UE
|
||
|
|
# MERGE by rownames
|
||
|
|
UEall <- merge(UE.all, single.UE , by = 0, all = TRUE)
|
||
|
|
} else {
|
||
|
|
# MERGE by rownames
|
||
|
|
UEall <- data.frame(Row.names = rownames(UE.all), UE.all, stringsAsFactors = FALSE)
|
||
|
|
}
|
||
|
|
UEall$Row.names[UEall$Row.names == "Q3a"] <- "strokoven"
|
||
|
|
UEall$Row.names[UEall$Row.names == "Q3b"] <- "nepristranski"
|
||
|
|
UEall$Row.names[UEall$Row.names == "Q3c"] <- "pripravljen pomagati"
|
||
|
|
UEall$Row.names[UEall$Row.names == "Q3d"] <- "razumljiv"
|
||
|
|
UEall$Row.names[UEall$Row.names == "Q3e"] <- "vreden zaupanja"
|
||
|
|
UEall$Row.names[UEall$Row.names == "Q3f"] <- "vljuden in prijazen"
|
||
|
|
# Add colnames
|
||
|
|
if (!is.null(upravnaenota)) { # Če delamo poročilo za posamezno UE, potrebujemo
|
||
|
|
# še ime UE
|
||
|
|
colnames(UEall) <- c("Grupiranje", "Povpre\u010Dje vse UE", paste0("UE ", UEime))
|
||
|
|
} else {
|
||
|
|
colnames(UEall) <- c("Grupiranje", "Povpre\u010Dje vse UE")
|
||
|
|
}
|
||
|
|
# Melt data for ggplot
|
||
|
|
UEall <- melt(UEall, id.vars='Grupiranje')
|
||
|
|
UEall$Grupiranje <- factor(UEall$Grupiranje, levels = c("vljuden in prijazen",
|
||
|
|
"vreden zaupanja",
|
||
|
|
"razumljiv",
|
||
|
|
"pripravljen pomagati",
|
||
|
|
"nepristranski",
|
||
|
|
"strokoven"))
|
||
|
|
|
||
|
|
|
||
|
|
return(UEall)
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Priprava podatkov za grafe: Povprečja posameznih postavk vprašanja Q3 in Q4 bomo
|
||
|
|
# Prikazali v grafu glede na socio demografski spremenljivki Q14- starost in
|
||
|
|
# Q15- izobrazba. Torej bomo imeli npr. za vsako postavko Q3 (npr. nepristranski,
|
||
|
|
# razumljiv, itd) po dva grafa.
|
||
|
|
pripr.podatk.demo <- function(upravnaenota, vseupravneenote, spr1, spr2, UEime,
|
||
|
|
label1, label2, label3, label4, label5) {
|
||
|
|
# upravnaenota - baza izbrane upravne enote
|
||
|
|
# vseupravneenote - baza vseh upravnih enot
|
||
|
|
# spr1: spremenljivka po kateri bomo grupirali povprečja
|
||
|
|
# spr2: spremenljivka, za katero bomo računali povprečja
|
||
|
|
# UE: ime upravne enote
|
||
|
|
# label1, label2, label3: labele kategorij npr: 1:"do 25 let"
|
||
|
|
if (!is.null(upravnaenota)) { # V primeru, da delamo grafe oz. poročilo za vse UE potem
|
||
|
|
# podatkov za posamezno UE ne potrebujemo, ker ocene posamezne UE ne bomo primerjali
|
||
|
|
# z vsemi UE
|
||
|
|
# UPRAVNA ENOTA----------
|
||
|
|
upr <- upravnaenota[, grepl(paste0(spr1,"|",spr2), colnames(upravnaenota))]
|
||
|
|
# melt the data frame for plotting
|
||
|
|
upr <- melt(upr, id.vars=spr1)
|
||
|
|
upr <- subset(upr, !is.na(upr[,1]))
|
||
|
|
upr$value <- as.numeric(upr$value)
|
||
|
|
# Calculate mean by first column wh8ch can be: starost ali izobrazba
|
||
|
|
upr <- ddply(upr, .(upr[,1]), summarize, Povprecje = mean(value,na.rm=TRUE))
|
||
|
|
}
|
||
|
|
# VSE UPRAVNE ENOTE---------
|
||
|
|
upr.all <- vseupravneenote[, grepl(paste0(spr1,"|",spr2), colnames(vseupravneenote))]
|
||
|
|
# melt the data frame for plotting
|
||
|
|
upr.all <- melt(upr.all, id.vars=spr1)
|
||
|
|
upr.all <- subset(upr.all, !is.na(upr.all[,1]))
|
||
|
|
upr.all$value <- as.numeric(upr.all$value )
|
||
|
|
upr.all <- ddply(upr.all, .(upr.all[,1]), summarize, Povprecje = mean(value,na.rm=TRUE))
|
||
|
|
# Combined data frame----------------------------------------------------
|
||
|
|
if (!is.null(upravnaenota)) {
|
||
|
|
# MERGE by rownames
|
||
|
|
# Upr.df <- merge(upr, upr.all , by = 0, all.x = TRUE)
|
||
|
|
# V primeru, da kakšna kategorija manjka (primer je UE Ljubljana-Vič Rudnik)
|
||
|
|
# merge naredimo po imenu stolpcev:
|
||
|
|
Upr.df <- merge(upr.all, upr, by.x = "upr.all[, 1]", by.y="upr[, 1]", all.y = TRUE)
|
||
|
|
# Remove unnecessary columns
|
||
|
|
#Upr.df[, 2] <- NULL
|
||
|
|
# Upr.df[, 3] <- NULL
|
||
|
|
} else {
|
||
|
|
# MERGE by rownames
|
||
|
|
Upr.df <- data.frame(Row.names = rownames(upr.all), upr.all, stringsAsFactors = FALSE)
|
||
|
|
Upr.df[, 2] <- NULL
|
||
|
|
}
|
||
|
|
# Add data labels
|
||
|
|
# Upr.df$Row.names[Upr.df$Row.names == "1"] <- label1
|
||
|
|
# Upr.df$Row.names[Upr.df$Row.names == "2"] <- label2
|
||
|
|
# Upr.df$Row.names[Upr.df$Row.names == "3"] <- label3
|
||
|
|
# Upr.df$Row.names[Upr.df$Row.names == "4"] <- label4
|
||
|
|
# Upr.df$Row.names[Upr.df$Row.names == "5"] <- label5
|
||
|
|
# Add data labels
|
||
|
|
Upr.df[,1][Upr.df[,1]== "1"] <- label1
|
||
|
|
Upr.df[,1][Upr.df[,1]== "2"] <- label2
|
||
|
|
Upr.df[,1][Upr.df[,1]== "3"] <- label3
|
||
|
|
Upr.df[,1][Upr.df[,1]== "4"] <- label4
|
||
|
|
Upr.df[,1][Upr.df[,1]== "5"] <- label5
|
||
|
|
# Add colnames
|
||
|
|
if (!is.null(upravnaenota)) {
|
||
|
|
colnames(Upr.df) <- c("Grupiranje", "Povpre\u010Dje vse UE", paste0("UE ", UEime))
|
||
|
|
} else {
|
||
|
|
colnames(Upr.df) <- c("Grupiranje", "Povpre\u010Dje vse UE")
|
||
|
|
}
|
||
|
|
# Melt data for ggplot
|
||
|
|
Upr.df <- melt(Upr.df, id.vars='Grupiranje')
|
||
|
|
Upr.df$Grupiranje <- factor(Upr.df$Grupiranje, levels = c(label5,
|
||
|
|
label4,
|
||
|
|
label3,
|
||
|
|
label2,
|
||
|
|
label1))
|
||
|
|
|
||
|
|
return(Upr.df)
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# V primeru ko delamo kontingenčno tabelo:
|
||
|
|
# porazdelitev vprašanja Q5 glede na starost in glede na izobrazbo obstaja
|
||
|
|
# verjetnost, da pri UE zaradi manjkajočih odgovorov nekatere kategorije manjkajo
|
||
|
|
# in ker fkrevencam posamezne UE v oklepajih pripišemo tudi frekvence vseh UE
|
||
|
|
# se lahko zgodi, da se kategorije ne ujemajo in vrne error. Torej je potrebno
|
||
|
|
# preveriti, ali pri posamezni UE manjka kakšna kategorija glede na vse UE,
|
||
|
|
# ter to kategorijo ustvarimo in dodamo frekvenco 0
|
||
|
|
miss.kat <- function(all, single){
|
||
|
|
|
||
|
|
diff.col <- setdiff(colnames(all), colnames(single))
|
||
|
|
diff.rows <- setdiff(rownames(all), rownames(single))
|
||
|
|
|
||
|
|
if (!identical(diff.rows, character(0)) & !identical(diff.col, character(0))){
|
||
|
|
single <- rbind(single, 0)
|
||
|
|
single <- cbind(c(0, 0, 0), single)
|
||
|
|
} else if (identical(diff.rows, character(0)) & !identical(diff.col, character(0))) {
|
||
|
|
if(nrow(single) > 2){
|
||
|
|
single <- cbind(c(0, 0, 0), single)
|
||
|
|
} else {
|
||
|
|
single <- cbind(c(0, 0), single)
|
||
|
|
}
|
||
|
|
} else if (identical(diff.rows, character(0)) & identical(diff.col, character(0))) {
|
||
|
|
single <- single
|
||
|
|
} else if (!identical(diff.rows, character(0))) {
|
||
|
|
single <- rbind(single, 0)
|
||
|
|
}
|
||
|
|
return(single)
|
||
|
|
}
|
||
|
|
#---------------------------------- //CUSTOM FUNCTIONS// --------------------------------#
|
||
|
|
|