In raubreywhite/dashboards_sykdomspuls: Depreciated - to be removed
library(flexdashboard)
library(ggplot2)
library(ggrepel)
library(data.table)
library(fhi)
library(magrittr)
library(dplyr)
fd::initialize("sykdomspuls")
# GET GLOBAL INFORMATION
GLOBAL <- new.env(parent = emptyenv())
val <- pool %>% tbl("spuls_standard_results") %>%
dplyr::summarize(date=max(date,na.rm=T)) %>%
dplyr::collect() %>%
fd::latin1_to_utf8()
GLOBAL$dateMax <- val$date
GLOBAL$dateMinRestrictedRecent <- GLOBAL$dateMax - 365
GLOBAL$dateMinRestrictedLine <- GLOBAL$dateMax - 365 * 15
GLOBAL$outbreaksyrwk <- GLOBAL$weeklyyrwk <- rev(fhidata::days[yrwk<=fhi::isoyearweek(GLOBAL$dateMax)]$yrwk)[1:20]
vals <- unique(fd::norway_locations()[,c("county_code","county_name")])
GLOBAL$weeklyCounties <- c("norge", vals$county_code)
names(GLOBAL$weeklyCounties) <- c("Norge", vals$county_name)
CONFIG_OLD <- ConvertConfigForAPI()
GLOBAL$weeklyTypes <- GLOBAL$dailyTypes <- CONFIG_OLD$SYNDROMES[CONFIG_OLD$SYNDROMES %in% CONFIG$STANDARD[websiteInternal == TRUE]$tag]
GLOBAL$weeklyAges <- GLOBAL$dailyAges <- CONFIG_OLD$AGES
vals <- fd::norway_locations_long()[location_code!="norway"]
vals[fd::norway_locations(),on="location_code==municip_code",county_code:=county_code]
vals[is.na(county_code),county_code:=location_code]
GLOBAL$municipToCounty <- vals
GLOBAL$weeklyValues <- c(
"Konsultasjoner" = "consults",
"1 uke eksess" = "excess1"
)
# FUNCTIONS
Getlocation_name <- function(location) {
location_name <- "Norge"
locationHTML <- "Norge"
if (location != "Norge") {
location_name <- fd::norway_locations_long()[location_code==location]$location_name
}
return(location_name)
}
GetCols <- function(){
retval <- c('#fc8d59','#ffffbf','#91cf60')
#if(!is.null(input$colourBlind)){
# if(input$colourBlind){
# retval <- c('#fc8d59','#ffffbf','#91bfdb')
# }
#}
return(retval)
}
GetCols5 <- reactive({
retval <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00')
if(!is.null(input$colourBlind)){
if(input$colourBlind){
retval <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00')
}
}
return(retval)
})
GetStepGraph <- reactive({
retval <- FALSE
if(!is.null(input$stepGraph)){
if(input$stepGraph){
retval <- TRUE
}
}
return(retval)
})
Nyheter {.storyboard}
Fra august 2016 er det en økning i antall konsultasjoner i aldersgruppen 15-19 år grunnet behov for sykemelding ved fravær i den videregående skole
Fra august 2016 er det en økning i antall konsultasjoner i aldersgruppen 15-19 år grunnet behov for sykemelding ved fravær i den videregående skole
Lansering av Sykdomspulsen
Velkommen til Sykdomspulsen!
Velkommen til Sykdomspulsen!
Oversikt (ukentlig)
weeklyBarometerPlotBrushData <- reactive({
x_tag <- input$weeklyBarometerType
x_location <- input$weeklyBarometerCounty
x_age <- input$weeklyBarometerAge
retData <- pool %>% tbl("spuls_standard_results") %>%
filter(tag == x_tag &
location_code== x_location &
granularity_time =="weekly" &
age== x_age) %>% collect()
setDT(retData)
return(retData)
})
output$weeklyBarometerPlotBrush <- renderPlot({
pd <- weeklyBarometerPlotBrushData()
if(is.null(pd)){
return(
data.frame(x=1:3,y=1:3) %>%
ggplot(aes(x=x,y=y)) +
geom_point(alpha=0)
)
}
fhiplot::make_line_brush_plot(pd,x="date",dataVal="n",L2="threshold2",L3="threshold4", GetCols=GetCols)
})
weeklyBarometerPlotData <- reactive({
if (is.null(input$weeklyBarometerCounty)) {
x_table <- "spuls_standard_results"
x_tag <- GLOBAL$weeklyTypes[1]
x_age <- GLOBAL$weeklyAges[1]
retData <- pool %>% tbl(x_table) %>%
filter(tag == x_tag &
granularity_time == "weekly" &
(granularity_geo == "county" | granularity_geo == "national") &
age==x_age) %>% collect()
} else if(input$weeklyBarometerCounty=="norge"){
x_table <- "spuls_standard_results"
x_tag <- input$weeklyBarometerType
x_age <- input$weeklyBarometerAge
retData <- pool %>% tbl(x_table) %>%
filter(tag == x_tag &
granularity_time == "weekly" &
(granularity_geo == "county" | granularity_geo == "national") &
age==x_age) %>% collect()
} else {
x_table <- "spuls_standard_results"
x_tag <- input$weeklyBarometerType
x_age <- input$weeklyBarometerAge
x_county <- input$weeklyBarometerCounty
retData <- pool %>% tbl(x_table) %>%
filter(tag == x_tag &
age==x_age &
granularity_time == "weekly" &
county_code==x_county) %>% collect()
}
setDT(retData)
if (nrow(retData) == 0) retData <- NULL
return(retData)
})
MakeBarometerPlot <- function(pd, title, GetCols){
location_nameOrder <- fd::norway_locations_long()$location_name[fd::norway_locations_long()$location_name %in% unique(pd$location_name)]
location_nameOrder <- c("1 uke",rev(unique(location_nameOrder))," 1 uke")
skeleton <- data.table(expand.grid(seq(min(pd$date)-6,max(pd$date),by=1),location_nameOrder,stringsAsFactors = FALSE))
setnames(skeleton,c("date","location_name"))
pd <- merge(skeleton,pd,by=c("location_name","date"),all.x=TRUE)
pd[pd$location_name=="1 uke",]$status <- rep(c(rep("White",7),rep("Black",7)),sum(pd$location_name=="1 uke"))[1:sum(pd$location_name=="1 uke")]
pd[pd$location_name==" 1 uke",]$status <- rep(c(rep("White",7),rep("Black",7)),sum(pd$location_name==" 1 uke"))[1:sum(pd$location_name==" 1 uke")]
pd$printWeek <- ""
pd$printWeekYear <- ""
pd[pd$location_name %in% c("1 uke"," 1 uke"),]$printWeek <- format.Date(pd[pd$location_name %in% c("1 uke"," 1 uke"),]$date,"%V")
pd[pd$location_name %in% c("1 uke"," 1 uke"),]$printWeekYear <- format.Date(pd[pd$location_name %in% c("1 uke"," 1 uke"),]$date,"%V/%G")
setorder(pd,location_name,date)
indexErase <- which(c(1:nrow(pd)%%7+1)!=4)
pd[indexErase,]$printWeek <- ""
pd[indexErase,]$printWeekYear <- ""
pd$location_name <- factor(pd$location_name,levels=location_nameOrder)
setorder(pd,location_name,-date)
varNames <- "status"
pd$status <- zoo::na.locf(pd$status)
includeNormal <- sum(pd$status=="Normal")>0
includeMedium <- sum(pd$status=="Medium")>0
includeHigh <- sum(pd$status=="High")>0
colours <- NULL
if(includeHigh) colours <- c(colours,GetCols()[1])
if(includeMedium) colours <- c(colours,GetCols()[2])
limits <- range(pd$date)
limitsSize <- max(1,(limits[2] - limits[1])*0.005)
limits[1] <- limits[1] - limitsSize
limits[2] <- limits[2] + limitsSize
q <- ggplot(pd,aes(x=date,y=location_name))
q <- q + geom_tile(aes(fill = "L1"), alpha = 0.0)
q <- q + geom_tile(aes(fill = "L2"), alpha = 0.0)
q <- q + geom_tile(aes(fill = "L3"), alpha = 0.0)
if(includeHigh) q <- q + geom_tile(aes(fill = "L1"), alpha = 0.6, data=pd[pd$status=="High",])
if(includeMedium) q <- q + geom_tile(aes(fill = "L2"), alpha = 0.6, data=pd[pd$status=="Medium",])
if(includeNormal) q <- q + geom_tile(aes(fill = "L3"), alpha = 0.6, data=pd[pd$status=="Normal",])
q <- q + geom_tile(fill="black", alpha = 0.6, data=pd[pd$status=="Black",])
q <- q + geom_tile(fill="white", alpha = 0.6, data=pd[pd$status=="White",])
q <- q + fhiplot::theme_fhi_basic(legend_position = "bottom")
breaksDF <- pd[pd$location_name %in% c("1 uke") & pd$status %in% c("Black","White") & pd$printWeekYear!="",]
if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*0.5){
breaksDF <- breaksDF[seq(1,nrow(breaksDF),2),]
} else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*1){
breaksDF <- breaksDF[seq(1,nrow(breaksDF),2),]
} else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*2){
breaksDF <- breaksDF[seq(1,nrow(breaksDF),4),]
} else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*4){
breaksDF <- breaksDF[seq(1,nrow(breaksDF),8),]
} else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*10){
breaksDF <- breaksDF[seq(1,nrow(breaksDF),16),]
} else {
breaksDF <- breaksDF[seq(1,nrow(breaksDF),64),]
}
breaksDF$printLabel <- breaksDF$printWeekYear
q <- q + scale_x_date("", breaks = breaksDF$date, labels = breaksDF$printLabel)
q <- q + scale_y_discrete("")
q <- q + scale_fill_manual("",values=GetCols(),labels=c(
"Betydelig høyere enn forventet",
"Høyere enn forventet",
"Forventet"))
q <- q + coord_cartesian(xlim=limits,expand = FALSE)
q <- q + labs(title=title)
q
}
output$weeklyBarometerPlot <- renderPlot({
pd <- weeklyBarometerPlotData()
if(is.null(pd)){
return(
data.frame(x=1:3,y=1:3) %>%
ggplot(aes(x=x,y=y)) +
geom_point(alpha=0)
)
}
if(!is.null(input$weeklyBarometerBrush)){
pd <- pd[pd$date>=input$weeklyBarometerBrush$xmin & pd$date<=input$weeklyBarometerBrush$xmax,]
}
pd <- pd[,c("date","location_name","status"),with=F]
t1 <- names(GLOBAL$weeklyTypes)[GLOBAL$weeklyTypes==input$weeklyBarometerType]
t2 <- Getlocation_name(input$weeklyBarometerCounty)
title <- paste0(t1, " i ",t2, " (",input$weeklyBarometerAge," alder)\n")
MakeBarometerPlot(pd, title=title, GetCols=GetCols)
})
Instillinger {.sidebar}
selectInput("weeklyBarometerType", "Sykdom/Symptom", as.list(GLOBAL$weeklyTypes), selected = GLOBAL$weeklyTypes[1])
selectInput("weeklyBarometerAge", "Alder", as.list(GLOBAL$weeklyAges), selected = "Totalt")
selectInput("weeklyBarometerCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1])
Row {data-height=800 .tabset}
Figur
plotOutput("weeklyBarometerPlot")
Info
Tabellen viser en oversikt over forekomsten av sykdom/symptom i et valgt tidsrom.
Valg av tidsrom gjøres på tidslinje nederst på siden. Valg av sykdom/symptom gjøres på venstre side. På venstre side kan man også velge Norge eller et fylke i Norge. Hvis man velger Norge vil hvert fylke få en rad i tabellen. Hvis man velger et fylke vil alle kommunene i valgte fylke få en rad i tabellen.
Dersom ruten for en gitt uke er farget med grønn farge betyr det at antall konsultasjoner i den gitte kommunen eller fylket er som forventet denne uken. En gul farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er høyere enn forventet denne uken. En rød farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er betydelig høyere enn forventet denne uken. Fargene er laget ut fra beregninger fra de foregående 5 årene i fylke eller kommunen.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Row {data-height=200}
plotOutput("weeklyBarometerPlotBrush", brush = brushOpts("weeklyBarometerBrush", direction="x", opacity=0.4))
Signaler (ukentlig)
Row {data-height=800 .tabset}
Fylker
#tableOutput("weeklySignalTableDF")
renderTable({
x_wkyr <- input$weeklyOutbreakWeek
data_county <- pool %>% tbl("spuls_standard_results") %>%
filter(tag != "influensa" &
granularity_time == "weekly" &
granularity_geo == "county" &
yrwk==x_wkyr) %>% collect()
data_municipality <- pool %>% tbl("spuls_standard_results") %>%
filter(tag != "influensa" &
granularity_time == "weekly" &
granularity_geo == "municip" &
yrwk==x_wkyr) %>% collect()
setDT(data_county)
setDT(data_municipality)
data <- GenerateOutbreakListInternal(df=data_county,
dk=data_municipality, saveFiles=NULL)
data <- data[["df"]]
if(input$weeklyOutbreakHideEmpty){
data <- data[data$High!="",]
}
if(input$weeklyOutbreakSort=="zscore"){
setorder(data,-meanZScore)
} else if(input$weeklyOutbreakSort=="cases"){
setorder(data,-sumCum)
}
if(nrow(data)==0) return(data.frame("Obs"="Ingen utbrudd denne uken"))
data$yrwk <- NULL
data$sumCum[is.na(data$sumCum)] <- 0
data$sumCum <- formatC(data$sumCum,digits=0,format="f")
data$sumCum[data$sumCum=="0"] <- ""
setnames(data,c("Sykdom","Alder","Fylke (Z verdi)","Gj. Z Verdi","Eksess tilfeller"))
data$Sykdom <- factor(data$Sykdom,levels=sykdomspuls::CONFIG$STANDARD$tag)
levels(data$Sykdom) <- sykdomspuls::CONFIG$STANDARD$namesLong
data
},
striped=TRUE)
Kommuner
#tableOutput("weeklySignalTableDK")
renderTable({
x_wkyr <- input$weeklyOutbreakWeek
data_county <- pool %>% tbl("spuls_standard_results") %>%
filter(tag != "influensa" &
granularity_time == "weekly" &
granularity_geo == "county" &
yrwk==x_wkyr) %>% collect()
data_municipality <- pool %>% tbl("spuls_standard_results") %>%
filter(tag != "influensa" &
granularity_time == "weekly" &
granularity_geo == "municip" &
yrwk==x_wkyr) %>% collect()
setDT(data_county)
setDT(data_municipality)
data <- GenerateOutbreakListInternal(df=data_county,
dk=data_municipality, saveFiles=NULL)
data <- data[["dk"]]
if(input$weeklyOutbreakHideEmpty){
data <- data[data$High!="",]
}
if(input$weeklyOutbreakSort=="zscore"){
setorder(data,-meanZScore)
} else if(input$weeklyOutbreakSort=="cases"){
setorder(data,-sumCum)
}
if(nrow(data)==0) return(data.frame("Obs"="Ingen utbrudd denne uken"))
data$yrwk <- NULL
data$sumCum[is.na(data$sumCum)] <- 0
data$sumCum <- formatC(data$sumCum,digits=0,format="f")
data$sumCum[data$sumCum=="0"] <- ""
setnames(data,c("Sykdom","Alder","Fylke","Kommune (Z verdi)","Gj. Z Verdi","Eksess tilfeller"))
data$Sykdom <- factor(data$Sykdom,levels=sykdomspuls::CONFIG$STANDARD$tag)
levels(data$Sykdom) <- sykdomspuls::CONFIG$STANDARD$namesLong
data
},
striped=TRUE)
Info
Tabellen viser en oversikt over forekomsten av sykdom/symptom i et valgt tidsrom.
Valg av tidsrom gjøres på bunnefiguren. Valg av sykdom/symptom gjøres på venstre side. På venstre side kan man også velge Norge eller et fylke i Norge. Hvis man velger Norge vil hvert fylke få en rad i tabellen. Hvis man velger et fylke vil alle kommunene få en rad i tabellen.
Dersom ruten for en gitt uke er farget med grønn farge betyr det at antall konsultasjoner i den gitte kommunen eller fylket er som forventet denne uken. En gul farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er høyere enn forventet denne uken. En rød farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er betydelig høyere enn forventet denne uken. Fargene er laget ut fra beregninger fra de foregående 5 årene.
Se punktet Om Sykdomspulsen på venstre side for mer utfyllende informasjon om dataene og beregninger.
Instillinger {.sidebar}
selectInput("weeklyOutbreakWeek", "Uker", as.list(GLOBAL$outbreaksyrwk), selected = GLOBAL$outbreaksyrwk[1])
selectInput("weeklyOutbreakSort", "Rangere etter", list("Z verdi"="zscore","Eksess tilfeller"="cases","Navn"="none"), selected = "zscore")
checkboxInput("weeklyOutbreakHideEmpty", "Skjul tomme", TRUE)
Antall (ukentlig)
## weekly
weeklyPlotData <- reactive({
if (is.null(input$weeklyCounty) | is.null(input$weeklyMunicip)) {
x_tbl <- "spuls_standard_results"
x_tag <- GLOBAL$weeklyTypes[1]
x_location <- "norge"
x_age <- "Totalt"
} else if (input$weeklyMunicip %in% c("norge", "Fylke")) {
x_tbl <- "spuls_standard_results"
x_tag <- input$weeklyType
x_location <- input$weeklyCounty
x_age <- input$weeklyAge
} else {
x_tbl <- "spuls_standard_results"
x_tag <- input$weeklyType
x_location <- input$weeklyMunicip
x_age <- input$weeklyAge
}
retData <- pool %>% tbl(x_tbl) %>%
filter(tag == x_tag &
location_code== x_location &
granularity_time=="weekly" &
age == x_age) %>% collect()
setDT(retData)
if(!is.null(retData)){
retData$top <- max(c(retData$n, retData$threshold4), na.rm = T) + 2
retData$bottom <- 0
}
return(retData)
})
output$weeklyNumberPlotBrush <- renderPlot({
pd <- weeklyPlotData()
if(is.null(pd)){
return(
data.frame(x=1:3,y=1:3) %>%
ggplot(aes(x=x,y=y)) +
geom_point(alpha=0)
)
}
fhiplot::make_line_brush_plot(pd,x="date",dataVal="n",L2="threshold2",L3="threshold4", GetCols=GetCols)
})
output$weeklyNumberPlot <- renderPlot({
pd <- weeklyPlotData()
if(is.null(pd) | is.null(input$weeklyMunicip)){
return(
data.frame(x=1:3,y=1:3) %>%
ggplot(aes(x=x,y=y)) +
geom_point(alpha=0)
)
}
if(!is.null(input$weeklyNumberBrush)){
pd <- pd[pd$date>=input$weeklyNumberBrush$xmin & pd$date<=input$weeklyNumberBrush$xmax,]
}
t1 <- names(GLOBAL$weeklyTypes)[GLOBAL$weeklyTypes==input$weeklyType]
if(input$weeklyMunicip=="Fylke"){
t2 <- Getlocation_name(input$weeklyCounty)
} else {
t2 <- Getlocation_name(input$weeklyMunicip)
}
title <- paste0(t1, " i ",t2, " (",input$weeklyAge," alder)\n")
if(input$weeklyValue=="consults"){
return(fhiplot::make_line_threshold_plot(pd,x="date",dataVal="n",L1="bottom",L2="threshold2",L3="threshold4",L4="top",title=title, pointShift = -3.5, weekNumbers=TRUE, step=GetStepGraph(), GetCols=GetCols, legend_position = "bottom"))
} else {
val <- stringr::str_extract(input$weeklyValue,"[0-9]$")
fhiplot::make_line_excess_graph(pd,x="date",dataVal=paste0("cumE",val),dataZ=paste0("cumZ",val),dataCIL=paste0("cumL",val), dataCIU=paste0("cumU",val),title=title, pointShift = -3.5, weekNumbers=TRUE, step=FALSE, GetCols=GetCols,allPoints = F, legend_position = "bottom")
}
})
output$weeklyPlotTitle <- renderText({
if(is.null(input$weeklyType)){
return("")
}
t1 <- names(GLOBAL$weeklyTypes)[GLOBAL$weeklyTypes==input$weeklyType]
if(input$weeklyMunicip=="Fylke"){
t2 <- Getlocation_name(input$weeklyCounty)
} else {
t2 <- Getlocation_name(input$weeklyMunicip)
}
paste0(t1, " i ",t2, " (",input$weeklyAge," alder)")
})
Row {data-height=800 .tabset}
Figur
plotOutput("weeklyNumberPlot")
Info
Grafen viser antall konsultasjoner per uke med en indikasjon om antallet er som forventet eller ikke. Valg av sykdom/symptom, sted og tidsrom gjøres på venstre side. Den svarte streken med rundingene viser antallet faktiske konsultasjoner. Bakgrunnsfargen er laget ut fra beregninger fra de foregående 5 årene i samme geografiske område. Når den svarte streken ligger i den grønne bakgrunnsfargen er antallet konsultasjoner som forventet og rundingen vises med svart. Når den svarte streken ligger i det gule feltet er antall konsultasjoner høyere enn forventet og fyllet i rundingen blir gult. Dersom den svarte streken ligger i det røde feltet er antall konsultasjoner betydelig høyere enn forventet og fyllet i rundingen blir rødt.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Row {data-height=200}
plotOutput("weeklyNumberPlotBrush", brush = brushOpts("weeklyNumberBrush", direction="x", opacity=0.4))
Instillinger {.sidebar}
selectInput("weeklyType", "Sykdom/Symptom", as.list(GLOBAL$weeklyTypes), selected = GLOBAL$weeklyTypes[1])
selectInput("weeklyAge", "Alder", as.list(GLOBAL$weeklyAges), selected = "Totalt")
selectInput("weeklyCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1])
weeklyMunicipChoices <- reactive({
if (is.null(input$weeklyCounty))
return(NULL)
if (input$weeklyCounty == "norge") {
return(list("Norge"="norge"))
} else {
data <- fd::norway_locations()[county_code==input$weeklyCounty]
x <- data$municip_code
names(x) <- data$municip_name
return(c("Fylke", x))
}
})
renderUI({
selectInput("weeklyMunicip", "Kommune", as.list(weeklyMunicipChoices()), selected = weeklyMunicipChoices()[1])
})
selectInput("weeklyValue", "Verdier", as.list(GLOBAL$weeklyValues), selected = GLOBAL$weeklyValues[1])
Antall (daglige)
start_date <- GLOBAL$dateMinRestrictedRecent
dailyPlotBrushData <- reactive({
x_tag <- input$dailyType
x_location <- input$dailyCounty
x_age <- input$dailyAge
retData <- pool %>%
tbl("spuls_standard_results") %>%
filter(tag == x_tag &
location_code == x_location &
granularity_time == "weekly" &
date >= start_date &
age == x_age) %>%
collect()
setDT(retData)
retData <- retData[retData$date >= GLOBAL$dateMinRestrictedRecent,]
return(retData)
})
output$dailyPlotBrush <- renderPlot({
pd <- dailyPlotBrushData()
if(is.null(pd)){
return(
data.frame(x=1:3,y=1:3) %>%
ggplot(aes(x=x,y=y)) +
geom_point(alpha=0)
)
}
fhiplot::make_line_brush_plot(pd,x="date",dataVal="n",L2="threshold2",L3="threshold4", GetCols=GetCols)
})
dailyPlotData <- reactive({
x_tag <- input$dailyType
x_location <- input$dailyCounty
x_age <- input$dailyAge
retData <- pool %>%
tbl("spuls_standard_results") %>%
filter(tag == x_tag &
location_code == x_location &
granularity_time == "daily" &
date >= start_date &
age == x_age) %>%
collect()
setDT(retData)
retData$top <- max(c(retData$n, retData$threshold4), na.rm = T) + 2
retData$bottom <- 0
return(retData)
})
output$dailyNumberPlot <- renderPlot({
pd <- dailyPlotData()
if(is.null(pd)){
return(
data.frame(x=1:3,y=1:3) %>%
ggplot(aes(x=x,y=y)) +
geom_point(alpha=0)
)
}
if(!is.null(input$dailyBrush)){
pd <- pd[pd$date>=input$dailyBrush$xmin-6 & pd$date<=input$dailyBrush$xmax,]
}
t1 <- names(GLOBAL$dailyTypes)[GLOBAL$dailyTypes==input$dailyType]
t2 <- Getlocation_name(input$dailyCounty)
title <- paste0(t1, " i ",t2, " (",input$dailyAge," alder)\n")
fhiplot::make_line_threshold_plot(pd,x="date",dataVal="n",L1="bottom",L2="threshold2",L3="threshold4",L4="top",allPoints=FALSE,title=title,xShift=0.5, step=GetStepGraph(), GetCols=GetCols, legend_position = "bottom")
})
output$dailyPlotTitle <- renderText({
if(is.null(input$dailyType)){
return("")
}
t1 <- names(dailyTypes)[dailyTypes==input$dailyType]
t2 <- Getlocation_name(input$dailyCounty)
paste0(t1, " i ",t2, " (",input$dailyAge," alder)")
})
Row {data-height=800 .tabset}
Figur
plotOutput("dailyNumberPlot")
Info
Grafen viser antall konsultasjoner per dag med en indikasjon om antallet er som forventet eller ikke. Valg av sykdom/symptom, sted og tidsrom gjøres på høyre side. Den svarte streken med rundingene viser antallet faktiske konsultasjoner. Bakgrunnsfargen er laget ut fra beregninger fra de foregående 5 årene. Når den svarte streken ligger i den grønne bakgrunnsfargen er antallet konsultasjoner som forventet og rundingen vises med svart. Når den svarte streken ligger i det gule feltet er antall konsultasjoner høyere enn forventet og fyllet i rundingen blir gult. Dersom den svarte streken ligger i det røde feltet er antall konsultasjoner betydelig høyere enn forventet og fyllet i rundingen blir rødt.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Row {data-height=200}
plotOutput("dailyPlotBrush", brush = brushOpts("dailyBrush", direction="x", opacity=0.4))
Instillinger {.sidebar}
selectInput("dailyType", "Sykdom/Symptom", as.list(GLOBAL$dailyTypes), selected = GLOBAL$dailyTypes[1])
selectInput("dailyAge", "Alder", as.list(GLOBAL$dailyAges), selected = "Totalt")
selectInput("dailyCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1])
MEMinfluensa
influensa_data <- reactive({
x_location <- input$influensaCounty
x_season <- input$influensaSeason
data <- pool %>%
tbl("spuls_mem_results") %>%
filter(season == x_season &
location_code == x_location &
tag == "influensa") %>%
collect()
setDT(data)
return(data)
})
output$influensa_plot <- renderPlot({
data <- influensa_data()
t2 <- Getlocation_name(input$influensaCounty)
title<- paste0("Prosent pasienter med influensa i ", t2)
q <- fhiplot::make_influenza_threshold_chart(data, title)
return(q)
})
Row {data-height=800 .tabset}
Figur
plotOutput("influensa_plot")
Info
Grafen viser antall konsultasjoner per dag med en indikasjon om antallet er som forventet eller ikke. Valg av sykdom/symptom, sted og tidsrom gjøres på høyre side. Den svarte streken med rundingene viser antallet faktiske konsultasjoner. Bakgrunnsfargen er laget ut fra beregninger fra de foregående årene.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Instillinger {.sidebar}
current_season <- fhi::season(GLOBAL$outbreaksyrwk[1], start_week=30)
seasons <- pool %>%
tbl("spuls_mem_results") %>%
filter(tag == "influensa" & !is.na(low)) %>%
distinct(season) %>% arrange(desc(season)) %>%
collect()
selectInput("influensaCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1])
selectInput("influensaSeason", "Sesong", as.list(seasons)$season, selected = current_season)
Om Sykdomspulsen
Row
Sykdomspulsen er et overvåkningssystem basert på diagnosekoder (ICPC-2 koder) satt på legekontorer og legevakter i hele Norge. Formålet med Sykdomspulsen er å se trender og udbredelse av smittsomme sykdommer slik at utbrudd oppdages så tidlig som mulig. I tillegg kan overvåkningen brukes til å iverksette folkehelsetiltak og se effekt av tiltak.
Diagnosekoder som registreres hos lege eller legevakt sendes til Helsedirektoratet som en del av legenes refusjonskrav (KUHR-systemet*). Folkehelseinstituttet mottar daglig oppdatert KUHR-data til Sykdomspulsen. Dataene er anonyme uten pasientidentifikasjon, men med informasjon om kjønn, aldersgruppe, konsultasjonsdato og sted for konsultasjon. Dataene blir bearbeidet og quasiposson regresjon blir brukt for å detektere forhøyet forekomst av et spesifikt syndrom. Dette er basert på de foregående 5 årene i det samme geografiske området. På denne måten kan antall faktiske konsultasjoner bli identifisert som forventet, høyere enn forventet eller mye høyere enn forventet. Selv om dataene noen ganger viser seg å ligge i området høyere enn forventet eller mye høyere enn forventet trenger dette ikke å være noen grunn til bekymring. Resultatene blir undersøkt av leger og epidemiologer på Folkehelseinstituttet og i kommunene.
Dersom du ønsker mer informasjon om Sykdosmspulsen kan du kontakte Gry M Grøneng, Gunnar Rø, eller Richard White på mailadressene: GryMarysol.Groneng@fhi.no, GunnarOyvindIsaksson.Ro@fhi.no, og RichardAubrey.White@fhi.no.
*KUHR-systemet: Regninger for all behandling som utføres utenfor sykehus sendes til HELFO for utbetaling og kontroll (legenes refusjonskrav).
R pakke versjon: r packageVersion("sykdomspuls")
raubreywhite/dashboards_sykdomspuls documentation built on April 27, 2020, 6:11 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(flexdashboard) library(ggplot2) library(ggrepel) library(data.table) library(fhi) library(magrittr) library(dplyr) fd::initialize("sykdomspuls") # GET GLOBAL INFORMATION GLOBAL <- new.env(parent = emptyenv()) val <- pool %>% tbl("spuls_standard_results") %>% dplyr::summarize(date=max(date,na.rm=T)) %>% dplyr::collect() %>% fd::latin1_to_utf8() GLOBAL$dateMax <- val$date GLOBAL$dateMinRestrictedRecent <- GLOBAL$dateMax - 365 GLOBAL$dateMinRestrictedLine <- GLOBAL$dateMax - 365 * 15 GLOBAL$outbreaksyrwk <- GLOBAL$weeklyyrwk <- rev(fhidata::days[yrwk<=fhi::isoyearweek(GLOBAL$dateMax)]$yrwk)[1:20] vals <- unique(fd::norway_locations()[,c("county_code","county_name")]) GLOBAL$weeklyCounties <- c("norge", vals$county_code) names(GLOBAL$weeklyCounties) <- c("Norge", vals$county_name) CONFIG_OLD <- ConvertConfigForAPI() GLOBAL$weeklyTypes <- GLOBAL$dailyTypes <- CONFIG_OLD$SYNDROMES[CONFIG_OLD$SYNDROMES %in% CONFIG$STANDARD[websiteInternal == TRUE]$tag] GLOBAL$weeklyAges <- GLOBAL$dailyAges <- CONFIG_OLD$AGES vals <- fd::norway_locations_long()[location_code!="norway"] vals[fd::norway_locations(),on="location_code==municip_code",county_code:=county_code] vals[is.na(county_code),county_code:=location_code] GLOBAL$municipToCounty <- vals GLOBAL$weeklyValues <- c( "Konsultasjoner" = "consults", "1 uke eksess" = "excess1" ) # FUNCTIONS Getlocation_name <- function(location) { location_name <- "Norge" locationHTML <- "Norge" if (location != "Norge") { location_name <- fd::norway_locations_long()[location_code==location]$location_name } return(location_name) } GetCols <- function(){ retval <- c('#fc8d59','#ffffbf','#91cf60') #if(!is.null(input$colourBlind)){ # if(input$colourBlind){ # retval <- c('#fc8d59','#ffffbf','#91bfdb') # } #} return(retval) } GetCols5 <- reactive({ retval <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00') if(!is.null(input$colourBlind)){ if(input$colourBlind){ retval <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00') } } return(retval) }) GetStepGraph <- reactive({ retval <- FALSE if(!is.null(input$stepGraph)){ if(input$stepGraph){ retval <- TRUE } } return(retval) })
Nyheter {.storyboard}
Fra august 2016 er det en økning i antall konsultasjoner i aldersgruppen 15-19 år grunnet behov for sykemelding ved fravær i den videregående skole
Fra august 2016 er det en økning i antall konsultasjoner i aldersgruppen 15-19 år grunnet behov for sykemelding ved fravær i den videregående skole
Lansering av Sykdomspulsen
Velkommen til Sykdomspulsen!
Velkommen til Sykdomspulsen!
Oversikt (ukentlig)
weeklyBarometerPlotBrushData <- reactive({ x_tag <- input$weeklyBarometerType x_location <- input$weeklyBarometerCounty x_age <- input$weeklyBarometerAge retData <- pool %>% tbl("spuls_standard_results") %>% filter(tag == x_tag & location_code== x_location & granularity_time =="weekly" & age== x_age) %>% collect() setDT(retData) return(retData) }) output$weeklyBarometerPlotBrush <- renderPlot({ pd <- weeklyBarometerPlotBrushData() if(is.null(pd)){ return( data.frame(x=1:3,y=1:3) %>% ggplot(aes(x=x,y=y)) + geom_point(alpha=0) ) } fhiplot::make_line_brush_plot(pd,x="date",dataVal="n",L2="threshold2",L3="threshold4", GetCols=GetCols) }) weeklyBarometerPlotData <- reactive({ if (is.null(input$weeklyBarometerCounty)) { x_table <- "spuls_standard_results" x_tag <- GLOBAL$weeklyTypes[1] x_age <- GLOBAL$weeklyAges[1] retData <- pool %>% tbl(x_table) %>% filter(tag == x_tag & granularity_time == "weekly" & (granularity_geo == "county" | granularity_geo == "national") & age==x_age) %>% collect() } else if(input$weeklyBarometerCounty=="norge"){ x_table <- "spuls_standard_results" x_tag <- input$weeklyBarometerType x_age <- input$weeklyBarometerAge retData <- pool %>% tbl(x_table) %>% filter(tag == x_tag & granularity_time == "weekly" & (granularity_geo == "county" | granularity_geo == "national") & age==x_age) %>% collect() } else { x_table <- "spuls_standard_results" x_tag <- input$weeklyBarometerType x_age <- input$weeklyBarometerAge x_county <- input$weeklyBarometerCounty retData <- pool %>% tbl(x_table) %>% filter(tag == x_tag & age==x_age & granularity_time == "weekly" & county_code==x_county) %>% collect() } setDT(retData) if (nrow(retData) == 0) retData <- NULL return(retData) }) MakeBarometerPlot <- function(pd, title, GetCols){ location_nameOrder <- fd::norway_locations_long()$location_name[fd::norway_locations_long()$location_name %in% unique(pd$location_name)] location_nameOrder <- c("1 uke",rev(unique(location_nameOrder))," 1 uke") skeleton <- data.table(expand.grid(seq(min(pd$date)-6,max(pd$date),by=1),location_nameOrder,stringsAsFactors = FALSE)) setnames(skeleton,c("date","location_name")) pd <- merge(skeleton,pd,by=c("location_name","date"),all.x=TRUE) pd[pd$location_name=="1 uke",]$status <- rep(c(rep("White",7),rep("Black",7)),sum(pd$location_name=="1 uke"))[1:sum(pd$location_name=="1 uke")] pd[pd$location_name==" 1 uke",]$status <- rep(c(rep("White",7),rep("Black",7)),sum(pd$location_name==" 1 uke"))[1:sum(pd$location_name==" 1 uke")] pd$printWeek <- "" pd$printWeekYear <- "" pd[pd$location_name %in% c("1 uke"," 1 uke"),]$printWeek <- format.Date(pd[pd$location_name %in% c("1 uke"," 1 uke"),]$date,"%V") pd[pd$location_name %in% c("1 uke"," 1 uke"),]$printWeekYear <- format.Date(pd[pd$location_name %in% c("1 uke"," 1 uke"),]$date,"%V/%G") setorder(pd,location_name,date) indexErase <- which(c(1:nrow(pd)%%7+1)!=4) pd[indexErase,]$printWeek <- "" pd[indexErase,]$printWeekYear <- "" pd$location_name <- factor(pd$location_name,levels=location_nameOrder) setorder(pd,location_name,-date) varNames <- "status" pd$status <- zoo::na.locf(pd$status) includeNormal <- sum(pd$status=="Normal")>0 includeMedium <- sum(pd$status=="Medium")>0 includeHigh <- sum(pd$status=="High")>0 colours <- NULL if(includeHigh) colours <- c(colours,GetCols()[1]) if(includeMedium) colours <- c(colours,GetCols()[2]) limits <- range(pd$date) limitsSize <- max(1,(limits[2] - limits[1])*0.005) limits[1] <- limits[1] - limitsSize limits[2] <- limits[2] + limitsSize q <- ggplot(pd,aes(x=date,y=location_name)) q <- q + geom_tile(aes(fill = "L1"), alpha = 0.0) q <- q + geom_tile(aes(fill = "L2"), alpha = 0.0) q <- q + geom_tile(aes(fill = "L3"), alpha = 0.0) if(includeHigh) q <- q + geom_tile(aes(fill = "L1"), alpha = 0.6, data=pd[pd$status=="High",]) if(includeMedium) q <- q + geom_tile(aes(fill = "L2"), alpha = 0.6, data=pd[pd$status=="Medium",]) if(includeNormal) q <- q + geom_tile(aes(fill = "L3"), alpha = 0.6, data=pd[pd$status=="Normal",]) q <- q + geom_tile(fill="black", alpha = 0.6, data=pd[pd$status=="Black",]) q <- q + geom_tile(fill="white", alpha = 0.6, data=pd[pd$status=="White",]) q <- q + fhiplot::theme_fhi_basic(legend_position = "bottom") breaksDF <- pd[pd$location_name %in% c("1 uke") & pd$status %in% c("Black","White") & pd$printWeekYear!="",] if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*0.5){ breaksDF <- breaksDF[seq(1,nrow(breaksDF),2),] } else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*1){ breaksDF <- breaksDF[seq(1,nrow(breaksDF),2),] } else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*2){ breaksDF <- breaksDF[seq(1,nrow(breaksDF),4),] } else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*4){ breaksDF <- breaksDF[seq(1,nrow(breaksDF),8),] } else if(as.numeric(difftime(limits[2],limits[1],"days"))/7 < 52*10){ breaksDF <- breaksDF[seq(1,nrow(breaksDF),16),] } else { breaksDF <- breaksDF[seq(1,nrow(breaksDF),64),] } breaksDF$printLabel <- breaksDF$printWeekYear q <- q + scale_x_date("", breaks = breaksDF$date, labels = breaksDF$printLabel) q <- q + scale_y_discrete("") q <- q + scale_fill_manual("",values=GetCols(),labels=c( "Betydelig høyere enn forventet", "Høyere enn forventet", "Forventet")) q <- q + coord_cartesian(xlim=limits,expand = FALSE) q <- q + labs(title=title) q } output$weeklyBarometerPlot <- renderPlot({ pd <- weeklyBarometerPlotData() if(is.null(pd)){ return( data.frame(x=1:3,y=1:3) %>% ggplot(aes(x=x,y=y)) + geom_point(alpha=0) ) } if(!is.null(input$weeklyBarometerBrush)){ pd <- pd[pd$date>=input$weeklyBarometerBrush$xmin & pd$date<=input$weeklyBarometerBrush$xmax,] } pd <- pd[,c("date","location_name","status"),with=F] t1 <- names(GLOBAL$weeklyTypes)[GLOBAL$weeklyTypes==input$weeklyBarometerType] t2 <- Getlocation_name(input$weeklyBarometerCounty) title <- paste0(t1, " i ",t2, " (",input$weeklyBarometerAge," alder)\n") MakeBarometerPlot(pd, title=title, GetCols=GetCols) })
Instillinger {.sidebar}
selectInput("weeklyBarometerType", "Sykdom/Symptom", as.list(GLOBAL$weeklyTypes), selected = GLOBAL$weeklyTypes[1]) selectInput("weeklyBarometerAge", "Alder", as.list(GLOBAL$weeklyAges), selected = "Totalt") selectInput("weeklyBarometerCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1])
Row {data-height=800 .tabset}
Figur
plotOutput("weeklyBarometerPlot")
Info
Tabellen viser en oversikt over forekomsten av sykdom/symptom i et valgt tidsrom.
Valg av tidsrom gjøres på tidslinje nederst på siden. Valg av sykdom/symptom gjøres på venstre side. På venstre side kan man også velge Norge eller et fylke i Norge. Hvis man velger Norge vil hvert fylke få en rad i tabellen. Hvis man velger et fylke vil alle kommunene i valgte fylke få en rad i tabellen.
Dersom ruten for en gitt uke er farget med grønn farge betyr det at antall konsultasjoner i den gitte kommunen eller fylket er som forventet denne uken. En gul farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er høyere enn forventet denne uken. En rød farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er betydelig høyere enn forventet denne uken. Fargene er laget ut fra beregninger fra de foregående 5 årene i fylke eller kommunen.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Row {data-height=200}
plotOutput("weeklyBarometerPlotBrush", brush = brushOpts("weeklyBarometerBrush", direction="x", opacity=0.4))
Signaler (ukentlig)
Row {data-height=800 .tabset}
Fylker
#tableOutput("weeklySignalTableDF") renderTable({ x_wkyr <- input$weeklyOutbreakWeek data_county <- pool %>% tbl("spuls_standard_results") %>% filter(tag != "influensa" & granularity_time == "weekly" & granularity_geo == "county" & yrwk==x_wkyr) %>% collect() data_municipality <- pool %>% tbl("spuls_standard_results") %>% filter(tag != "influensa" & granularity_time == "weekly" & granularity_geo == "municip" & yrwk==x_wkyr) %>% collect() setDT(data_county) setDT(data_municipality) data <- GenerateOutbreakListInternal(df=data_county, dk=data_municipality, saveFiles=NULL) data <- data[["df"]] if(input$weeklyOutbreakHideEmpty){ data <- data[data$High!="",] } if(input$weeklyOutbreakSort=="zscore"){ setorder(data,-meanZScore) } else if(input$weeklyOutbreakSort=="cases"){ setorder(data,-sumCum) } if(nrow(data)==0) return(data.frame("Obs"="Ingen utbrudd denne uken")) data$yrwk <- NULL data$sumCum[is.na(data$sumCum)] <- 0 data$sumCum <- formatC(data$sumCum,digits=0,format="f") data$sumCum[data$sumCum=="0"] <- "" setnames(data,c("Sykdom","Alder","Fylke (Z verdi)","Gj. Z Verdi","Eksess tilfeller")) data$Sykdom <- factor(data$Sykdom,levels=sykdomspuls::CONFIG$STANDARD$tag) levels(data$Sykdom) <- sykdomspuls::CONFIG$STANDARD$namesLong data }, striped=TRUE)
Kommuner
#tableOutput("weeklySignalTableDK") renderTable({ x_wkyr <- input$weeklyOutbreakWeek data_county <- pool %>% tbl("spuls_standard_results") %>% filter(tag != "influensa" & granularity_time == "weekly" & granularity_geo == "county" & yrwk==x_wkyr) %>% collect() data_municipality <- pool %>% tbl("spuls_standard_results") %>% filter(tag != "influensa" & granularity_time == "weekly" & granularity_geo == "municip" & yrwk==x_wkyr) %>% collect() setDT(data_county) setDT(data_municipality) data <- GenerateOutbreakListInternal(df=data_county, dk=data_municipality, saveFiles=NULL) data <- data[["dk"]] if(input$weeklyOutbreakHideEmpty){ data <- data[data$High!="",] } if(input$weeklyOutbreakSort=="zscore"){ setorder(data,-meanZScore) } else if(input$weeklyOutbreakSort=="cases"){ setorder(data,-sumCum) } if(nrow(data)==0) return(data.frame("Obs"="Ingen utbrudd denne uken")) data$yrwk <- NULL data$sumCum[is.na(data$sumCum)] <- 0 data$sumCum <- formatC(data$sumCum,digits=0,format="f") data$sumCum[data$sumCum=="0"] <- "" setnames(data,c("Sykdom","Alder","Fylke","Kommune (Z verdi)","Gj. Z Verdi","Eksess tilfeller")) data$Sykdom <- factor(data$Sykdom,levels=sykdomspuls::CONFIG$STANDARD$tag) levels(data$Sykdom) <- sykdomspuls::CONFIG$STANDARD$namesLong data }, striped=TRUE)
Info
Tabellen viser en oversikt over forekomsten av sykdom/symptom i et valgt tidsrom.
Valg av tidsrom gjøres på bunnefiguren. Valg av sykdom/symptom gjøres på venstre side. På venstre side kan man også velge Norge eller et fylke i Norge. Hvis man velger Norge vil hvert fylke få en rad i tabellen. Hvis man velger et fylke vil alle kommunene få en rad i tabellen.
Dersom ruten for en gitt uke er farget med grønn farge betyr det at antall konsultasjoner i den gitte kommunen eller fylket er som forventet denne uken. En gul farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er høyere enn forventet denne uken. En rød farge en gitt uke betyr at antall konsultasjoner i den gitte kommunen eller fylket er betydelig høyere enn forventet denne uken. Fargene er laget ut fra beregninger fra de foregående 5 årene.
Se punktet Om Sykdomspulsen på venstre side for mer utfyllende informasjon om dataene og beregninger.
Instillinger {.sidebar}
selectInput("weeklyOutbreakWeek", "Uker", as.list(GLOBAL$outbreaksyrwk), selected = GLOBAL$outbreaksyrwk[1]) selectInput("weeklyOutbreakSort", "Rangere etter", list("Z verdi"="zscore","Eksess tilfeller"="cases","Navn"="none"), selected = "zscore") checkboxInput("weeklyOutbreakHideEmpty", "Skjul tomme", TRUE)
Antall (ukentlig)
## weekly weeklyPlotData <- reactive({ if (is.null(input$weeklyCounty) | is.null(input$weeklyMunicip)) { x_tbl <- "spuls_standard_results" x_tag <- GLOBAL$weeklyTypes[1] x_location <- "norge" x_age <- "Totalt" } else if (input$weeklyMunicip %in% c("norge", "Fylke")) { x_tbl <- "spuls_standard_results" x_tag <- input$weeklyType x_location <- input$weeklyCounty x_age <- input$weeklyAge } else { x_tbl <- "spuls_standard_results" x_tag <- input$weeklyType x_location <- input$weeklyMunicip x_age <- input$weeklyAge } retData <- pool %>% tbl(x_tbl) %>% filter(tag == x_tag & location_code== x_location & granularity_time=="weekly" & age == x_age) %>% collect() setDT(retData) if(!is.null(retData)){ retData$top <- max(c(retData$n, retData$threshold4), na.rm = T) + 2 retData$bottom <- 0 } return(retData) }) output$weeklyNumberPlotBrush <- renderPlot({ pd <- weeklyPlotData() if(is.null(pd)){ return( data.frame(x=1:3,y=1:3) %>% ggplot(aes(x=x,y=y)) + geom_point(alpha=0) ) } fhiplot::make_line_brush_plot(pd,x="date",dataVal="n",L2="threshold2",L3="threshold4", GetCols=GetCols) }) output$weeklyNumberPlot <- renderPlot({ pd <- weeklyPlotData() if(is.null(pd) | is.null(input$weeklyMunicip)){ return( data.frame(x=1:3,y=1:3) %>% ggplot(aes(x=x,y=y)) + geom_point(alpha=0) ) } if(!is.null(input$weeklyNumberBrush)){ pd <- pd[pd$date>=input$weeklyNumberBrush$xmin & pd$date<=input$weeklyNumberBrush$xmax,] } t1 <- names(GLOBAL$weeklyTypes)[GLOBAL$weeklyTypes==input$weeklyType] if(input$weeklyMunicip=="Fylke"){ t2 <- Getlocation_name(input$weeklyCounty) } else { t2 <- Getlocation_name(input$weeklyMunicip) } title <- paste0(t1, " i ",t2, " (",input$weeklyAge," alder)\n") if(input$weeklyValue=="consults"){ return(fhiplot::make_line_threshold_plot(pd,x="date",dataVal="n",L1="bottom",L2="threshold2",L3="threshold4",L4="top",title=title, pointShift = -3.5, weekNumbers=TRUE, step=GetStepGraph(), GetCols=GetCols, legend_position = "bottom")) } else { val <- stringr::str_extract(input$weeklyValue,"[0-9]$") fhiplot::make_line_excess_graph(pd,x="date",dataVal=paste0("cumE",val),dataZ=paste0("cumZ",val),dataCIL=paste0("cumL",val), dataCIU=paste0("cumU",val),title=title, pointShift = -3.5, weekNumbers=TRUE, step=FALSE, GetCols=GetCols,allPoints = F, legend_position = "bottom") } }) output$weeklyPlotTitle <- renderText({ if(is.null(input$weeklyType)){ return("") } t1 <- names(GLOBAL$weeklyTypes)[GLOBAL$weeklyTypes==input$weeklyType] if(input$weeklyMunicip=="Fylke"){ t2 <- Getlocation_name(input$weeklyCounty) } else { t2 <- Getlocation_name(input$weeklyMunicip) } paste0(t1, " i ",t2, " (",input$weeklyAge," alder)") })
Row {data-height=800 .tabset}
Figur
plotOutput("weeklyNumberPlot")
Info
Grafen viser antall konsultasjoner per uke med en indikasjon om antallet er som forventet eller ikke. Valg av sykdom/symptom, sted og tidsrom gjøres på venstre side. Den svarte streken med rundingene viser antallet faktiske konsultasjoner. Bakgrunnsfargen er laget ut fra beregninger fra de foregående 5 årene i samme geografiske område. Når den svarte streken ligger i den grønne bakgrunnsfargen er antallet konsultasjoner som forventet og rundingen vises med svart. Når den svarte streken ligger i det gule feltet er antall konsultasjoner høyere enn forventet og fyllet i rundingen blir gult. Dersom den svarte streken ligger i det røde feltet er antall konsultasjoner betydelig høyere enn forventet og fyllet i rundingen blir rødt.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Row {data-height=200}
plotOutput("weeklyNumberPlotBrush", brush = brushOpts("weeklyNumberBrush", direction="x", opacity=0.4))
Instillinger {.sidebar}
selectInput("weeklyType", "Sykdom/Symptom", as.list(GLOBAL$weeklyTypes), selected = GLOBAL$weeklyTypes[1]) selectInput("weeklyAge", "Alder", as.list(GLOBAL$weeklyAges), selected = "Totalt") selectInput("weeklyCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1]) weeklyMunicipChoices <- reactive({ if (is.null(input$weeklyCounty)) return(NULL) if (input$weeklyCounty == "norge") { return(list("Norge"="norge")) } else { data <- fd::norway_locations()[county_code==input$weeklyCounty] x <- data$municip_code names(x) <- data$municip_name return(c("Fylke", x)) } }) renderUI({ selectInput("weeklyMunicip", "Kommune", as.list(weeklyMunicipChoices()), selected = weeklyMunicipChoices()[1]) }) selectInput("weeklyValue", "Verdier", as.list(GLOBAL$weeklyValues), selected = GLOBAL$weeklyValues[1])
Antall (daglige)
start_date <- GLOBAL$dateMinRestrictedRecent dailyPlotBrushData <- reactive({ x_tag <- input$dailyType x_location <- input$dailyCounty x_age <- input$dailyAge retData <- pool %>% tbl("spuls_standard_results") %>% filter(tag == x_tag & location_code == x_location & granularity_time == "weekly" & date >= start_date & age == x_age) %>% collect() setDT(retData) retData <- retData[retData$date >= GLOBAL$dateMinRestrictedRecent,] return(retData) }) output$dailyPlotBrush <- renderPlot({ pd <- dailyPlotBrushData() if(is.null(pd)){ return( data.frame(x=1:3,y=1:3) %>% ggplot(aes(x=x,y=y)) + geom_point(alpha=0) ) } fhiplot::make_line_brush_plot(pd,x="date",dataVal="n",L2="threshold2",L3="threshold4", GetCols=GetCols) }) dailyPlotData <- reactive({ x_tag <- input$dailyType x_location <- input$dailyCounty x_age <- input$dailyAge retData <- pool %>% tbl("spuls_standard_results") %>% filter(tag == x_tag & location_code == x_location & granularity_time == "daily" & date >= start_date & age == x_age) %>% collect() setDT(retData) retData$top <- max(c(retData$n, retData$threshold4), na.rm = T) + 2 retData$bottom <- 0 return(retData) }) output$dailyNumberPlot <- renderPlot({ pd <- dailyPlotData() if(is.null(pd)){ return( data.frame(x=1:3,y=1:3) %>% ggplot(aes(x=x,y=y)) + geom_point(alpha=0) ) } if(!is.null(input$dailyBrush)){ pd <- pd[pd$date>=input$dailyBrush$xmin-6 & pd$date<=input$dailyBrush$xmax,] } t1 <- names(GLOBAL$dailyTypes)[GLOBAL$dailyTypes==input$dailyType] t2 <- Getlocation_name(input$dailyCounty) title <- paste0(t1, " i ",t2, " (",input$dailyAge," alder)\n") fhiplot::make_line_threshold_plot(pd,x="date",dataVal="n",L1="bottom",L2="threshold2",L3="threshold4",L4="top",allPoints=FALSE,title=title,xShift=0.5, step=GetStepGraph(), GetCols=GetCols, legend_position = "bottom") }) output$dailyPlotTitle <- renderText({ if(is.null(input$dailyType)){ return("") } t1 <- names(dailyTypes)[dailyTypes==input$dailyType] t2 <- Getlocation_name(input$dailyCounty) paste0(t1, " i ",t2, " (",input$dailyAge," alder)") })
Row {data-height=800 .tabset}
Figur
plotOutput("dailyNumberPlot")
Info
Grafen viser antall konsultasjoner per dag med en indikasjon om antallet er som forventet eller ikke. Valg av sykdom/symptom, sted og tidsrom gjøres på høyre side. Den svarte streken med rundingene viser antallet faktiske konsultasjoner. Bakgrunnsfargen er laget ut fra beregninger fra de foregående 5 årene. Når den svarte streken ligger i den grønne bakgrunnsfargen er antallet konsultasjoner som forventet og rundingen vises med svart. Når den svarte streken ligger i det gule feltet er antall konsultasjoner høyere enn forventet og fyllet i rundingen blir gult. Dersom den svarte streken ligger i det røde feltet er antall konsultasjoner betydelig høyere enn forventet og fyllet i rundingen blir rødt.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Row {data-height=200}
plotOutput("dailyPlotBrush", brush = brushOpts("dailyBrush", direction="x", opacity=0.4))
Instillinger {.sidebar}
selectInput("dailyType", "Sykdom/Symptom", as.list(GLOBAL$dailyTypes), selected = GLOBAL$dailyTypes[1]) selectInput("dailyAge", "Alder", as.list(GLOBAL$dailyAges), selected = "Totalt") selectInput("dailyCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1])
MEMinfluensa
influensa_data <- reactive({ x_location <- input$influensaCounty x_season <- input$influensaSeason data <- pool %>% tbl("spuls_mem_results") %>% filter(season == x_season & location_code == x_location & tag == "influensa") %>% collect() setDT(data) return(data) }) output$influensa_plot <- renderPlot({ data <- influensa_data() t2 <- Getlocation_name(input$influensaCounty) title<- paste0("Prosent pasienter med influensa i ", t2) q <- fhiplot::make_influenza_threshold_chart(data, title) return(q) })
Row {data-height=800 .tabset}
Figur
plotOutput("influensa_plot")
Info
Grafen viser antall konsultasjoner per dag med en indikasjon om antallet er som forventet eller ikke. Valg av sykdom/symptom, sted og tidsrom gjøres på høyre side. Den svarte streken med rundingene viser antallet faktiske konsultasjoner. Bakgrunnsfargen er laget ut fra beregninger fra de foregående årene.
Se fanen Om Sykdomspulsen øverst for mer utfyllende informasjon om dataene og beregninger.
Instillinger {.sidebar}
current_season <- fhi::season(GLOBAL$outbreaksyrwk[1], start_week=30) seasons <- pool %>% tbl("spuls_mem_results") %>% filter(tag == "influensa" & !is.na(low)) %>% distinct(season) %>% arrange(desc(season)) %>% collect() selectInput("influensaCounty", "Fylke", as.list(GLOBAL$weeklyCounties), selected = GLOBAL$weeklyCounties[1]) selectInput("influensaSeason", "Sesong", as.list(seasons)$season, selected = current_season)
Om Sykdomspulsen
Row
Sykdomspulsen er et overvåkningssystem basert på diagnosekoder (ICPC-2 koder) satt på legekontorer og legevakter i hele Norge. Formålet med Sykdomspulsen er å se trender og udbredelse av smittsomme sykdommer slik at utbrudd oppdages så tidlig som mulig. I tillegg kan overvåkningen brukes til å iverksette folkehelsetiltak og se effekt av tiltak.
Diagnosekoder som registreres hos lege eller legevakt sendes til Helsedirektoratet som en del av legenes refusjonskrav (KUHR-systemet*). Folkehelseinstituttet mottar daglig oppdatert KUHR-data til Sykdomspulsen. Dataene er anonyme uten pasientidentifikasjon, men med informasjon om kjønn, aldersgruppe, konsultasjonsdato og sted for konsultasjon. Dataene blir bearbeidet og quasiposson regresjon blir brukt for å detektere forhøyet forekomst av et spesifikt syndrom. Dette er basert på de foregående 5 årene i det samme geografiske området. På denne måten kan antall faktiske konsultasjoner bli identifisert som forventet, høyere enn forventet eller mye høyere enn forventet. Selv om dataene noen ganger viser seg å ligge i området høyere enn forventet eller mye høyere enn forventet trenger dette ikke å være noen grunn til bekymring. Resultatene blir undersøkt av leger og epidemiologer på Folkehelseinstituttet og i kommunene.
Dersom du ønsker mer informasjon om Sykdosmspulsen kan du kontakte Gry M Grøneng, Gunnar Rø, eller Richard White på mailadressene: GryMarysol.Groneng@fhi.no, GunnarOyvindIsaksson.Ro@fhi.no, og RichardAubrey.White@fhi.no.
*KUHR-systemet: Regninger for all behandling som utføres utenfor sykehus sendes til HELFO for utbetaling og kontroll (legenes refusjonskrav).
R pakke versjon: r packageVersion("sykdomspuls")
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.