#' Gi en visuell fremstilling av registerets indikatorer over tid
#'
#' @param indikatordata En dataramme med følgende kolonner:
#' - ReshId
#' - Aar
#' - Teller
#' - SenterKortNavn
#'
#' @export
#'
nraFigIndikator <- function(indikatordata, tittel='', terskel=30, minstekrav = NA, maal = NA, skriftStr=1.3, pktStr=1.4,
legPlass='top', minstekravTxt='Min.', maalTxt='Mål', graaUt=NA, decreasing=F, outfile = '',
lavDG=NA, width=800, height=700, inkl_konf=F, maalretn='hoy', desimal=FALSE, xmax=NA)
{
# tittel='testtittel'; terskel=30; minstekrav = NA; maal = 30; skriftStr=1.3; pktStr=1.4;
# legPlass='top'; minstekravTxt='Min.'; maalTxt='Mål'; graaUt=NA; decreasing=F; outfile = '';
# lavDG=NA; width=800; height=700; inkl_konf=F; maalretn='hoy'
indikatordata <- indikatordata[indikatordata$Aar > max(indikatordata$Aar)-3, ] # behold bare siste 3 år
Tabell <- indikatordata %>% dplyr::group_by(SenterKortNavn, Aar) %>%
dplyr::summarise(Antall = sum(Teller),
N = n(),
Andel = Antall/N*100)
AntTilfeller <- tidyr::spread(Tabell[, -c(4,5)], 'Aar', 'Antall')
AntTilfeller <- dplyr::bind_cols(SenterKortNavn=c(AntTilfeller$SenterKortNavn, "Nasjonalt"),
dplyr::bind_rows(AntTilfeller[,-1], colSums(AntTilfeller[,-1], na.rm = T)))
N <- tidyr::spread(Tabell[, -c(3,5)], 'Aar', 'N')
N <- dplyr::bind_cols(SenterKortNavn=c(N$SenterKortNavn, "Nasjonalt"),
dplyr::bind_rows(N[,-1], colSums(N[,-1], na.rm = T)))
N[is.na(N)] <- 0
# Andeler, inkludert nasjonalt
andeler <- bind_cols(AntTilfeller[,1], AntTilfeller[,-1]/N[,-1] * 100)
# Fjern år med færre registreringer enn terskelverdi og sykehus med for lav dekningsgrad
andeler[N < terskel] <- NA
andeler[andeler$SenterKortNavn %in% lavDG, -1] <- NA
# Ordne rekkefølge, stigende eller synkende
if (decreasing){
rekkefolge <- order(andeler[, dim(andeler)[2]], decreasing = decreasing, na.last = F)
} else {
rekkefolge <- order(andeler[, dim(andeler)[2]], decreasing = decreasing, na.last = F)
}
andeler <- andeler[rekkefolge, ]
N <- N[rekkefolge, ]
# Skjul også tidligere år hvis siste år er sensurert pga. for få reg.
# andeler[as.vector(N[, dim(andeler)[2]]<terskel), 2:3] <- NA
# Beregn konfidensintervaller
KI <- binomkonf(purrr::as_vector(AntTilfeller[rekkefolge, dim(andeler)[2]]),
purrr::as_vector(N[, dim(andeler)[2]]))*100
KI[, is.na(andeler[, dim(andeler)[2]])] <- NA
pst_txt <- paste0(sprintf('%.0f', purrr::as_vector(andeler[, dim(andeler)[2]])), ' %')
if (desimal) {pst_txt <- paste0(sprintf('%.1f', purrr::as_vector(andeler[, dim(andeler)[2]])), ' %')}
# pst_txt[is.na(andeler[, dim(andeler)[2]])] <- paste0('N<', terskel, ' eller dekningsgrad mindre en 60 pst.')
pst_txt[N[, dim(andeler)[2]]<terskel] <- paste0('N<', terskel)
pst_txt[andeler$SenterKortNavn %in% lavDG] <- 'Dekningsgrad < 60 %'
pst_txt <- c(NA, pst_txt, NA, NA)
FigTypUt <- rapFigurer::figtype(outfile=outfile, width=width, height=height, pointsizePDF=11, fargepalett='BlaaOff')
farger <- FigTypUt$farger
soyleFarger <- rep(farger[3], dim(andeler)[1])
soyleFarger[which(andeler$SenterKortNavn=='Nasjonalt')] <- farger[4]
if (!is.na(graaUt[1])) {soyleFarger[which(andeler$SenterKortNavn %in% graaUt)] <- 'gray88'}
soyleFarger <- c(NA, soyleFarger)
# Lagre parameterverdier
oldpar_mar <- par()$mar
oldpar_fig <- par()$fig
oldpar_oma <- par()$oma
cexgr <- skriftStr
if (inkl_konf) {
andeler$SenterKortNavn <- paste0(andeler$SenterKortNavn, ' (', purrr::as_vector(N[, dim(N)[2]]), ')')
andeler <- rbind(andeler, c(NA,NA,NA))
andeler$SenterKortNavn[dim(andeler)[1]] <- paste0('(N, ', names(andeler)[dim(andeler)[2]], ')')
KI <- cbind(c(NA, NA), KI, c(NA, NA))
} else {
andeler <- rbind(andeler, c(NA,NA,NA))
andeler$SenterKortNavn[dim(andeler)[1]] <- ''
}
andeler <- rbind(c(NA,NA), andeler, c(NA,NA))
andeler$SenterKortNavn[dim(andeler)[1]] <- ''
andeler$SenterKortNavn[1] <- ' '
vmarg <- max(0, strwidth(andeler$SenterKortNavn, units='figure', cex=cexgr)*0.75)
# par('fig'=c(vmarg, 1, 0, 1))
# x11()
par('mar'=c(5.1, 6.1, 5.1, 9.1))
# par('oma'=c(0,1,0,0))
if (inkl_konf) {
par('mar'=c(5.1, 4.1, 5.1, 2.1))
xmax <- min(max(KI, na.rm = T)*1.15,100)
} else {
if (is.na(xmax)){xmax <- min(100, 1.15*max(andeler[,-1], na.rm = T))}
}
ypos <- barplot( t(andeler[,dim(andeler)[2]]), beside=T, las=1,
xlim=c(0,xmax),
names.arg=rep('',dim(andeler)[1]),
horiz=T, axes=F, space=c(0,0.3),
col=soyleFarger, border=NA, xlab = 'Andel (%)')
fargerMaalNiva <- c('aquamarine3','#fbf850', 'red')
if (maal > minstekrav & !is.na(maal) & !is.na(minstekrav)) {
rect(xleft=minstekrav, ybottom=1, xright=maal, ytop=max(ypos)-1.6, col = fargerMaalNiva[2], border = NA)
rect(xleft=maal, ybottom=1, xright=min(xmax, 100), ytop=max(ypos)-1.6, col = fargerMaalNiva[1], border = NA)}
if (maal < minstekrav & !is.na(maal) & !is.na(minstekrav)) {
rect(xleft=maal, ybottom=1, xright=minstekrav, ytop=max(ypos)-1.6, col = fargerMaalNiva[2], border = NA)
rect(xleft=0, ybottom=1, xright=maal, ytop=max(ypos)-1.6, col = fargerMaalNiva[1], border = NA)}
if (!is.na(maal) & is.na(minstekrav) & maalretn=='lav') {
# rect(xleft=maal, ybottom=0, xright=minstekrav, ytop=max(ypos)+0.4, col = fargerMaalNiva[2], border = NA)
rect(xleft=0, ybottom=1, xright=maal, ytop=max(ypos)-1.6, col = fargerMaalNiva[1], border = NA)}
if (!is.na(maal) & is.na(minstekrav) & maalretn=='hoy') {
# rect(xleft=maal, ybottom=0, xright=minstekrav, ytop=max(ypos)+0.4, col = fargerMaalNiva[2], border = NA)
rect(xleft=maal, ybottom=1, xright=min(xmax, 100), ytop=max(ypos)-1.6, col = fargerMaalNiva[1], border = NA)}
barplot( t(andeler[,dim(andeler)[2]]), beside=T, las=1,
names.arg=rep('',dim(andeler)[1]),
horiz=T, axes=F, space=c(0,0.3),
col=soyleFarger, border=NA, xlab = 'Andel (%)', add=TRUE)
title(main = tittel)
ypos <- as.numeric(ypos) #as.vector(ypos)
yposOver <- max(ypos)-2 + 0.5*diff(ypos)[1]
if (!is.na(minstekrav)) {
lines(x=rep(minstekrav, 2), y=c(-1, yposOver), col=fargerMaalNiva[2], lwd=2)
par(xpd=TRUE)
text(x=minstekrav, y=yposOver, labels = minstekravTxt,
pos = 4, cex=cexgr*0.65, srt = 90)
par(xpd=FALSE)
}
if (!is.na(maal)) {
lines(x=rep(maal, 2), y=c(-1, yposOver), col=fargerMaalNiva[1], lwd=2)
barplot( t(andeler[, dim(andeler)[2]]), beside=T, las=1,
names.arg=rep('',dim(andeler)[1]),
horiz=T, axes=F, space=c(0,0.3),
col=soyleFarger, border=NA, xlab = 'Andel (%)', add=TRUE)
par(xpd=TRUE)
text(x=maal, y=yposOver, labels = maalTxt, pos = 4, cex=cexgr*0.65, srt = 90) #paste0(maalTxt,maal,'%')
par(xpd=FALSE)
}
if (inkl_konf){
arrows(x0 = KI[1,], y0 = ypos, x1 = KI[2,], y1 = ypos,
length=0.5/max(ypos), code=3, angle=90, lwd=1.8, col='gray') #, col=farger[1])
legend('bottom', cex=0.9*cexgr, bty='n',
lwd=1.8, lty = 1, pt.cex=1.8, col='gray',
legend=paste0('Konfidensintervall ', names(N)[dim(N)[2]]))
}
axis(1,cex.axis=0.9)
mtext( andeler$SenterKortNavn, side=2, line=0.2, las=1, at=ypos, col=1, cex=cexgr)
antAar <- dim(andeler)[2]-1
if (antAar==2) {
if (!inkl_konf){
mtext( c(NA, purrr::as_vector(N[,2]), names(N)[2], NA, NA), side=4, line=3.5, las=1, at=ypos, col=1, cex=cexgr*.7, adj = 1)
mtext( c(NA, purrr::as_vector(N[,3]), names(N)[3], NA, NA), side=4, line=6.5, las=1, at=ypos, col=1, cex=cexgr*.7, adj = 1)
mtext( 'N', side=4, line=5.0, las=1, at=max(ypos), col=1, cex=cexgr*.7, adj = 1)
}
par(xpd=TRUE)
points(y=ypos, x=purrr::as_vector(andeler[,2]),cex=pktStr, pch= 19) #'#4D4D4D'
# points(y=ypos, x=purrr::as_vector(andeler[,3]),cex=pktStr,pch= 19)
par(xpd=FALSE)
if (legPlass=='nede'){
legend(x=82, y=ypos[2]+1 ,xjust=0, cex=cexgr, bty='n', #bg='white', box.col='white',
lwd=c(NA,NA), pch=c(19,15), pt.cex=c(1.2,1.8), col=c('black',farger[3]),
legend=names(N[,-1]), ncol = dim(andeler)[2]-1 )}
if (legPlass=='top'){
legend('top', cex=0.9*cexgr, bty='n', #bg='white', box.col='white',y=max(ypos),
lwd=c(NA,NA), pch=c(19,15), pt.cex=c(1.2,1.8), col=c('black',farger[3]),
legend=names(N[,-1]), ncol = dim(andeler)[2]-1)
}
} else {
if (!inkl_konf) {
mtext( c(NA, purrr::as_vector(N[,2]), names(N)[2], NA, NA), side=4, line=2.5, las=1, at=ypos, col=1, cex=cexgr*.7, adj = 1)
mtext( c(NA, purrr::as_vector(N[,3]), names(N)[3], NA, NA), side=4, line=5, las=1, at=ypos, col=1, cex=cexgr*.7, adj = 1)
mtext( c(NA, purrr::as_vector(N[,4]), names(N)[4], NA, NA), side=4, line=7.5, las=1, at=ypos, col=1, cex=cexgr*.7, adj = 1)
mtext( 'N', side=4, line=5.0, las=1, at=max(ypos), col=1, cex=cexgr*.7, adj = 1)
}
# else {
# mtext( '(N)', side=2, line=0.3, las=1, at=max(ypos)+diff(ypos)[1], col=1, cex=cexgr, adj = 1)
# }
par(xpd=TRUE)
points(y=ypos, x=purrr::as_vector(andeler[,2]),cex=pktStr) #'#4D4D4D'
points(y=ypos, x=purrr::as_vector(andeler[,3]),cex=pktStr,pch= 19)
par(xpd=FALSE)
if (legPlass=='nede'){
legend(x=82, y=ypos[2]+1 ,xjust=0, cex=cexgr, bty='n', #bg='white', box.col='white',
lwd=c(NA,NA,NA), pch=c(1,19,15), pt.cex=c(1.2,1.2,1.8), col=c('black','black',farger[3]),
legend=names(N) )}
if (legPlass=='top'){
legend('top', cex=0.9*cexgr, bty='n', #bg='white', box.col='white',y=max(ypos),
lwd=c(NA,NA,NA), pch=c(1,19,15), pt.cex=c(1.2,1.2,1.8), col=c('black','black',farger[3]),
legend=names(N[,-1]), ncol = dim(andeler)[2]-1)
}
# }
}
text(x=0, y=ypos, labels = pst_txt, cex=0.75, pos=4)
if ( outfile != '') {dev.off()}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.