#'Søylediagram som viser sentralmål (gj.sn./median) for hvert sykehus
#'
#' Funksjon som genererer en figur med gjennomsnitt/median
#' for hvert sykehus og kan ta inn ulike numeriske variable.
#' Funksjonen er delvis skrevet for å kunne brukes til andre grupperingsvariable enn sykehus
#'
#' @inheritParams NakkeFigAndeler
#' @inheritParams NakkeUtvalgEnh
#' @param valgtMaal Sentralmål 'Med' gir median, alt annet gir gjennomsnitt
#' @param medKI vise konfidensintervall? 0-nei, 1-ja
#' @param Ngrense nedre grense for antall observasjoner for at et resultat (ei søyle) skal vises
#' @param valgtVar Variabelen det skal vises resultat for.
#' Alder: alder (år)
#' EMSscorePreOp: EMS hos Myelopatipasienter før
#' EMSendr12mnd: Forbedring av EMS hos myelopati-pasienter, 12 mnd.
#' EMSendr3mnd: Forbedring av EMS hos myelopati-pasienter, 3 mnd.
#' EQ5Dendr12mnd: Forbedring av EQ5D, 12 mnd.
#' EQ5Dendr3mnd: Forbedring av EQ5D, 3 mnd.
#' KnivtidTotalMin: total knivtid
#' NDIscorePreOp: NDI før operasjon
#' NDIendr3mnd:
#' LiggeDognPostop: liggetid etter operasjon
#' LiggeDognTotalt: antall liggedøgn, totalt
#' NRSsmerteArmPreOp: NSR, arm før operasjon
#' NRSsmerteNakkePreOp: NSR, nakke før operasjon
#'
#' @return Figur med...
#'
#' @export
NakkeFigGjsnGrVar <- function(RegData, valgtVar='Alder', valgtMaal='Gjsn',
datoFra='2012-01-01', datoTil='2050-12-31',
myelopati=99, fremBak=0, Ngrense=10, medKI=1,
minald=0, maxald=130, erMann='', inngrep=99,
reshID=0, outfile='', hentData=0, preprosess=0,...) {
if ("session" %in% names(list(...))) {
rapbase::repLogger(session = list(...)[["session"]], msg = paste0('NakkeFigGjsnTid: ',valgtVar))
}
if (hentData == 1) {
RegData <- NakkeRegDataSQL() #RegData <- NakkeLoadRegDataMinimal()
}
# Preprosessere data
if (preprosess==1){
RegData <- NakkePreprosess(RegData=RegData)
}
#----------- Figurparametre ------------------------------
grVar <- 'ShNavn'
#RegData[ ,grVar] <- factor(RegData[ ,grVar])
NakkeVarSpes <- NakkeVarTilrettelegg(RegData=RegData, valgtVar=valgtVar, figurtype = 'gjsnGrVar')
RegData <- NakkeVarSpes$RegData
sortAvtagende <- NakkeVarSpes$sortAvtagende
KImaal <- NakkeVarSpes$KImaal
KImaaltxt <- NakkeVarSpes$KImaaltxt
deltittel <- NakkeVarSpes$deltittel
xAkseTxt <- NakkeVarSpes$xAkseTxt
#Gjør utvalg
NakkeUtvalg <- NakkeUtvalgEnh(RegData=RegData, datoFra=datoFra, datoTil=datoTil,
minald=minald, maxald=maxald, inngrep=inngrep,
erMann=erMann, myelopati=myelopati, fremBak=fremBak)
RegData <- NakkeUtvalg$RegData
utvalgTxt <- NakkeUtvalg$utvalgTxt
N <- dim(RegData)[1]
if(N > 0) {Ngr <- table(RegData[ ,grVar])} else {Ngr <- 0}
Ngrtxt <- paste0('N=', as.character(Ngr))
indGrUt <- as.numeric(which(Ngr < Ngrense))
if (length(indGrUt)==0) { indGrUt <- 0}
Ngrtxt[indGrUt] <- paste0(' (<', Ngrense,')')
if (valgtMaal=='Med') {
t1 <- 'Median'
tleg <- t1} else {
t1 <- 'Gj.sn.'
tleg <- 'Gjennomsnitt'}
tittel <- paste(t1, deltittel, sep=' ')
#--------------------------------------------------------
dummy0 <- NA #-0.001
#Kommer ut ferdig sortert!
if (valgtMaal=='Med') {
MedIQR <- plot(RegData[ ,grVar], RegData$Variabel, notch=TRUE, plot=FALSE)
MedIQR$stats[ ,indGrUt] <- dummy0
MedIQR$conf[ ,indGrUt] <- dummy0
sortInd <- order( MedIQR$stats[3,], decreasing=TRUE)
Midt <- as.numeric(MedIQR$stats[3, sortInd])
KIned <- MedIQR$conf[1, sortInd]
KIopp <- MedIQR$conf[2, sortInd]
MedIQRHele <- boxplot.stats(RegData$Variabel, do.conf = TRUE)
MidtHele <- as.numeric(MedIQRHele$stats[3]) #median(RegData$Variabel)
KIHele <- MedIQRHele$conf
#The notches (if requested) extend to +/-1.58 IQR/sqrt(n). (Chambers et al. (1983, p. 62), given in McGill et al. (1978, p. 16).)
#They are based on asymptotic normality of the median and roughly equal sample sizes for the two medians being compared,
#and are said to be rather insensitive to the underlying distributions of the samples. The idea appears to be to give
#roughly a 95% confidence interval for the difference in two medians.
} else { #Gjennomsnitt blir standard.
Gjsn <- tapply(RegData$Variabel, RegData[ ,grVar], mean, na.rm=T)
SE <- tapply(RegData$Variabel, RegData[ ,grVar], sd, na.rm=T)/sqrt(Ngr)
Gjsn[indGrUt] <- dummy0
SE[indGrUt] <- 0
sortInd <- order(Gjsn, decreasing=TRUE)
Midt <- as.numeric(Gjsn[sortInd])
KIned <- Gjsn[sortInd] - 2*SE[sortInd]
KIopp <- Gjsn[sortInd] + 2*SE[sortInd]
MidtHele <- round(mean(RegData$Variabel),1)
KIHele <- MidtHele + sd(RegData$Variabel)/sqrt(N)*c(-2,2)
}
AntGr <- length(which(Ngr >= Ngrense)) #length(which(Midt>0))
soyletxt <- c(sprintf('%.1f',Midt[1:AntGr]), rep('',length(Ngr)-AntGr)) # #round(Midt[1:AntGr],1)
xmax <- min(1.1*max(c(Midt, KIned, KIopp), na.rm = T), 1.5*max(Midt, na.rm = T), na.rm = T)
xmin <- min(c(0,c(Midt, KIned, KIopp)), na.rm=T)
Ngr <- Ngr[sortInd]
GrNavnSort <- names(Ngr)
cexGrNavn <- 1
cexSoyletxt <- 1
AggVerdier <- list(Hoved=Midt, Rest=NULL, KIned=KIned, KIopp=KIopp, KIHele=KIHele)
SentralmaalTxt <- switch(valgtMaal,
gjsn='Gjennomsnitt',
med='Median')
if (valgtVar == 'NDIendr12mnd' & myelopati==0 & fremBak==1) {
KImaalGrenser <- c(0, MidtHele, 100) } else {
KImaalGrenser <- NA }
FigDataParam <- list(AggVerdier=AggVerdier, #Endres til Soyleverdi? Evt. AggVerdier
AggTot=MidtHele, #Til AggVerdiTot?
N=list(Hoved=N),
Ngr=Ngr,
grtxt2='',
medKI=medKI,
KImaal = NakkeVarSpes$KImaal,
soyletxt=soyletxt,
grtxt=GrNavnSort,
valgtMaal=valgtMaal,
SentralmaalTxt=SentralmaalTxt,
tittel=tittel, #NakkeVarSpes$tittel,
#yAkseTxt=yAkseTxt,
retn='H',
xAkseTxt=NakkeVarSpes$xAkseTxt,
grTypeTxt=NakkeUtvalg$grTypeTxt,
utvalgTxt=NakkeUtvalg$utvalgTxt,
fargepalett=NakkeUtvalg$fargepalett,
medSml=NakkeUtvalg$medSml,
smltxt=NakkeUtvalg$smltxt)
#-----------Figur---------------------------------------
#print(Ngr)
#print(Ngrense)
if (max(Ngr, na.rm = T) < Ngrense) {#Dvs. hvis ALLE er mindre enn grensa.
FigTypUt <- rapFigurer::figtype(outfile)
farger <- FigTypUt$farger
plot.new()
if (dim(RegData)[1]>0) {
tekst <- paste0('Færre enn ', Ngrense, ' registreringer ved hvert av sykehusene')
} else {tekst <- 'Ingen registrerte data for dette utvalget'}
title(main=tittel, cex=0.95) #line=-8,
text(0.5, 0.6, tekst, cex=1.2)
#text(0.5, 0.3, , cex=1.2)
legend('topleft',utvalgTxt, bty='n', cex=0.9, text.col=farger[1])
if ( outfile != '') {dev.off()}
} else {
#--------------------------FIGUR---------------------------------------------------
FigTypUt <- rapFigurer::figtype(outfile, height=3*800, fargepalett=NakkeUtvalg$fargepalett) #, res=96
farger <- FigTypUt$farger
#Tilpasse marger for å kunne skrive utvalgsteksten
NutvTxt <- length(utvalgTxt)
vmarg <- max(0, strwidth(GrNavnSort, units='figure', cex=cexGrNavn)*0.7)
#NB: strwidth oppfører seg ulikt avh. av device...
par('fig'=c(vmarg, 1, 0, 1-0.02*(NutvTxt-1))) #Har alltid datoutvalg med
pos <- barplot(Midt, horiz=T, border=NA, col=farger[3],
xlim=c(xmin,xmax), ylim=c(0.05, 1.25)*length(Ngr), font.main=1, xlab='', las=1, cex.names=cexGrNavn)
indGrUtPlot <- AntGr+(1:length(indGrUt))
posKI <- pos[1:AntGr]
ybunn <- 0
ytopp <- max(posKI)*1.05 #min(posKI)
# if (!is.na(KImaalGrenser)) {
# lines(x=rep(KImaalGrenser, 2), y=c(minpos, maxpos), col= '#FF7260', lwd=2.5) #y=c(0, max(pos)+0.55),
# text(x=KImaalGrenser, y=maxpos+0.6, paste0('Mål:', KImaaltxt), cex=0.9*cexgr, col= '#FF7260',adj=c(0.5,0))
# }
if (!is.na(KImaalGrenser[1])) {
antMaalNivaa <- length(KImaalGrenser)-1
rekkef <- 1:antMaalNivaa
if (sortAvtagende == TRUE) {rekkef <- rev(rekkef)}
fargerMaalNiva <- c('#4fc63f', '#fbf850', '#c6312a')[rekkef] #c('green','yellow')# #c('#ddffcc', '#ffffcc') #, '#fff0e6') #Grønn, gul, rød
#fargerMaalNiva <- c('#3baa34', '#fd9c00', '#e30713')[rekkef] #Grønn, gul, rød Likt med sykehusviser
maalOppTxt <- c('Høy', 'Moderat til lav', 'Lav')[rekkef]
rect(xleft=KImaalGrenser[1:antMaalNivaa], ybottom=0, xright=KImaalGrenser[2:(antMaalNivaa+1)],
ytop=max(posKI)+0.5, col = fargerMaalNiva[1:antMaalNivaa], border = NA) #add = TRUE, #pos[AntGrNgr+1],
legend(x=0, y=-2.5, pch=c(NA,rep(15, antMaalNivaa)), col=c(NA, fargerMaalNiva[1:antMaalNivaa]),
ncol=antMaalNivaa+1,
xpd=TRUE, border=NA, box.col='white',cex=0.8, pt.cex=1.5,
legend=c('Måloppnåelse:', maalOppTxt[1:antMaalNivaa])) #,
}
polygon( c(rep(KIHele[1],2), rep(KIHele[2],2)), c(ybunn, ytopp, ytopp, ybunn),
col=farger[4], border=farger[4])
lines(x=rep(MidtHele, 2), y=c(ybunn, ytopp), col=farger[2], lwd=2)
legend('top', fill=c('white', farger[4]), border='white', lwd=2,
col=c(farger[2], farger[4]), seg.len=0.6, merge=TRUE, bty='n',
c(paste0(tleg, ', alle: ', sprintf('%.1f', MidtHele), ', N=', N),
paste0('95% konf.int., alle (',
sprintf('%.1f', KIHele[1]), '-', sprintf('%.1f', KIHele[2]), ')')))
barplot(Midt, horiz=T, border=NA, col=farger[3], xlim=c(xmin, xmax), add=TRUE,
font.main=1, xlab = xAkseTxt, las=1) #xlim=c(0,ymax), #, cex.names=0.5
title(tittel, line=1, font.main=1, cex.main=1.3)
#title('med 95% konfidensintervall', line=0.5, font.main=1, cex.main=0.95)
mtext(at=pos+0.18, GrNavnSort, side=2, las=1, cex=cexGrNavn, adj=1, line=0.25) #Sykehusnavn
mtext(at=pos-0.18, Ngrtxt[sortInd], side=2, las=1, cex=cexGrNavn, adj=1, line=0.25) #Sykehusnavn
text(x=1.1*max(strwidth(soyletxt, units='user', cex=cexSoyletxt)), y=pos, #y=pos+0.1,
soyletxt, las=1, cex=cexSoyletxt, adj=1, col=farger[4]) #Tekst på søylene (verdi)
#OK text(x=xmax/20, y=pos+0.1, soyletxt, las=1, cex=0.75, adj=1, col=farger[1]) #Tekst på søylene (verdi)
#Tekst som angir hvilket utvalg som er gjort
mtext(utvalgTxt, side=3, las=1, cex=0.9, adj=0, col=farger[1], line=c(2.2+0.8*((NutvTxt-1):0)))
# mtext(utvalgTxt, side=3, las=1, cex=cexGrNavn*0.9, adj=0, col=farger[1], line=c(3+0.8*((NutvTxt-1):0)))
options(warn = -1) #Unngå melding om KI med lengde 0. Fungerer av en eller annen grunn ikke i pdf.
arrows(x0=Midt[-indGrUtPlot]*0.999, y0=posKI, x1=KIopp[-indGrUtPlot], y1=posKI,
length=0.5/max(pos), code=2, angle=90, lwd=1.5, col=farger[1])
arrows(x0=Midt[-indGrUtPlot]*1.001, y0=posKI, x1=KIned[-indGrUtPlot], y1=posKI,
length=0.5/max(pos), code=2, angle=90, lwd=1.5, col=farger[1])
par('fig'=c(0, 1, 0, 1))
if ( outfile != '') {dev.off()}
#----------------------------------------------------------------------------------
}
return(invisible(FigDataParam))
} #end function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.