###################################
# SHINY Explorer - global.R
###################################
#===== LOAD PACKAGES -----------------------------------------------------------------------------------------------------------
pkg <- c(
'bsplus', 'Cairo', 'colourpicker', 'data.table', 'DT', 'dygraphs', 'fst', 'ggplot2', 'ggiraph', 'ggrepel', 'ggthemes',
'htmltools', 'leaflet', 'mapview', 'plyr', 'RColorBrewer', 'rgdal', 'RMySQL', 'rpivotTable', 'rvest', 'scales',
'shiny', 'shinycssloaders', 'shinyDND', 'shinyjs', 'shinyjqui', 'shinythemes', 'shinyWidgets',
'sp', 'tidyr', 'xts'
# 'circlize', 'extrafont', 'GGally', 'ggmap', 'ggspatial', 'ggparallel', 'tmap',
)
invisible( lapply(pkg, require, character.only = TRUE) )
# for(conn in dbListConnections(MySQL())) dbDisconnect(conn)
#===== GENERAL OPTIONS ----------------------------------------------------------------------------------------------------------
options(spinner.color = '#e5001a', spinner.size = 1, spinner.type = 4)
#===== LOAD DATA ----------------------------------------------------------------------------------------------------------------
# From fst shared rep
dataset <- read.fst(paste0(data.path, audit, '_dt.fst'), as.data.table = TRUE )
# The following recoding is necessary until a new version of the fst package fixes the bug with dates converted into integers
dataset[, `:=`(
date.day = as.Date(date.day, origin = '1970-01-01'),
date.week = as.Date(date.week, origin = '1970-01-01'),
date.month = as.Date(date.month, origin = '1970-01-01'),
date.quarter = as.Date(date.quarter, origin = '1970-01-01')
)]
if(has_consultants){
dt_cons <- read.fst(paste0(data.path, audit, '_pc.fst'), as.data.table = TRUE )
consultants <- read.fst(paste0(data.path, 'consultants.fst'), as.data.table = TRUE )
}
# From databases
db_conn <- dbConnect(MySQL(), group = 'shiny', dbname = audit)
# dataset <- suppressWarnings(data.table(dbReadTable(db_conn, 'shinyexp_dataset'), key = 'HSP_id' ) )
lookups <- suppressWarnings(data.table(dbGetQuery(db_conn, 'SELECT * FROM lookups WHERE domain_id != 9') ) )
vars <- suppressWarnings(data.table(dbReadTable(db_conn, 'vars') ) )
metrics <- suppressWarnings(data.table(dbReadTable(db_conn, 'metrics') ) )
calendar <- suppressWarnings(data.table(dbReadTable(db_conn, 'calendar') ) )
load.tabs <- suppressWarnings(data.table(dbReadTable(db_conn, 'tabs'), key = 'name' ) )
# dt_cons <- suppressWarnings(data.table(dbReadTable(db_conn, 'procedures_consultants'), key = 'proc_id' ) )
completeness <- suppressWarnings(data.table(dbGetQuery(db_conn, 'SELECT item, filter_by FROM completeness WHERE is_active') ) )
dbDisconnect(db_conn)
db_conn <- dbConnect(MySQL(), group = 'shiny', dbname = 'common')
areas <- suppressWarnings(data.table(dbReadTable(db_conn, 'locations') ) )
centres <- suppressWarnings(data.table(dbReadTable(db_conn, 'centres'), key = 'HSP_id') )
font.table <- suppressWarnings(data.table(dbGetQuery(db_conn, 'SELECT DISTINCT family FROM fonts WHERE is_active ORDER BY family') ) )
maptiles <- suppressWarnings(data.table(dbGetQuery(db_conn,
'SELECT CONCAT(provider, ".", name) AS name, url, attribution FROM maptiles WHERE require_reg = 0 ORDER BY name'
)))
# consultants <- suppressWarnings(data.table(dbReadTable(db_conn, 'consultants'), key = 'consultant_id' ) )
dbDisconnect(db_conn)
hospitals <- centres[get(audit) == 1]
#===== FUNCTIONS ----------------------------------------------------------------------------------------------------------------
# ifelse(x1, x2, NA)
ifna <- function(x1, x2) ifelse(x1, x2, NA)
# Create a list of variables from <vars> specifying one or more "type" (type could be: LGC, CAT, NUM, GEO, TMS)
build_uiV <- function(tp){
ui.list <- as.list(vars[nature %in% tp & is_active == 1][order(ordering)][, lookup_id])
names(ui.list) <- vars[nature %in% tp & is_active == 1][order(ordering)][, description]
return(ui.list)
}
# Create a list of reference variables from <metrics> specifying a "subtab" and a (optional) type
build_uiY <- function(tb, tp = 1:4){
ui.list <- as.list(metrics[get(tb) == 1 & type %in% tp ][order(ordering)][, label])
return(ui.list)
}
# Create a list of locations from <hospitals> specifying a "hierarchy"
build_uiG <- function(h){
y <- unique(hospitals[, .( get(h), get(paste0(h, '_id')) )][!(V1 %in% labels.del)][order(V1)])
ui.list <- as.list(y[, V2])
names(ui.list) <- y[, V1]
return(ui.list)
}
# Create a list of values from <lookups> specifying a variable
build_uiF <- function(v){
y <- lookups[domain_id == v, .(lookup_id, description ) ][order(lookup_id)][!(description %in% labels.del)]
ui.list <- as.list(y[, lookup_id])
names(ui.list) <- y[, description]
return(ui.list)
}
# Create a combobox of locations for a given tab 'tb', specifying child 'lw' and parent 'lb' area codes, and a parent area id 'ipt'
build_uiGeo <- function(tb, hg, lw, ipt){
hg.id <- paste(hg, '_id', sep = '')
lw.id <- paste(lw, '_id', sep = '')
inp.obj <- paste('cbo_', tb, '_', hg, sep = '')
ui.list <- c('TOTAL')
if(ipt != 'TOTAL'){
ui.list <- as.list(unique(hospitals[get(hg.id) == ipt][order(get(lw))][, get(lw.id)]))
names(ui.list) <- unique(hospitals[get(hg.id) == ipt][order(get(lw))][, get(lw)])
}
if(length(ui.list) > 1) ui.list <- c('TOTAL', ui.list)
return(ui.list)
}
# Build the title for most substabs
build.title <- function(var.Y, is.Y.ref = TRUE, var.X, var.X2 = NA, fnl.area = NA, has.pct = FALSE, var.G1, var.G2 = 'NONE', var.F, val.F){
ttl <-
if(is.Y.ref){
paste( metrics[label == var.Y, title], ifelse(has.pct, '(%)', ''))
} else {
clear.label(var.Y)
}
ttl <- paste( ttl, 'by', var.X )
if(!is.na(var.X2)) ttl <- paste(ttl, 'and', var.X2)
if(!is.na(fnl.area)) ttl <- paste(ttl, 'in', fnl.area)
if(var.G1 != 'NONE')
ttl <- paste0(
ttl, '<br/>',
'Grouped by ', clear.label(var.G1), if(var.G2 != 'NONE'){ paste(' and', clear.label(var.G2)) }
)
if(var.F != 'NONE'){
if(val.F != 'NONE')
ttl <- paste0(
ttl, '<br/>',
'Filtered by ', clear.label(var.F), ' = <i>', lookups[domain_id == gsub('X', '', var.F) & lookup_id == val.F, description], '</i>'
)
}
trimws(gsub(' ', ' ', ttl))
}
# Return filter and function for a metric, according to "normal" or "percentage" behaviour
mtc.parsed <- function(mtc, pct = FALSE){
if(!pct){
F <- metrics[label == eval(mtc), filter_by]
M <- metrics[label == eval(mtc), mutate_as]
} else {
F <- metrics[label == eval(mtc), filter_pct]
M <- metrics[label == eval(mtc), mutate_pct]
}
return( parse(text = c(F, M) ) )
}
# Given a categorical var id (without the leading "X") and one or some of its ids, return the corresponding label(s)
get.Xlabel <- function(x.id, x.val = 1){
x.id <- as.numeric(gsub('X', '', x.id))
lookups[domain_id == x.id & lookup_id %in% x.val, description]
}
# Renames the dataset for pivot table
mydt.rename <- function(dt){
nm <- names(dt)[substr(names(dt), 1, 1) == 'X']
nm <- c('HSP_id', 'HSP', 'CCG', 'LAT', 'NHSR', 'CCR', 'CTRY', paste('datec.', c('day', 'week', 'month', 'quarter', 'year'), sep = ''), nm)
dt <- dt[, nm, with = FALSE]
m1 <- as.data.table(names(dt), key = 'V1')
m2 <- data.table(lookups[domain_id <= 1, .( old = paste('X', lookup_id, sep = ''), new = description ) ], key = 'old')
names(dt) <- m2[m1][is.na(new), new := old][, new]
setnames(dt,
c('HSP_id','HSP', 'CCG', 'LAT', 'NHSR', 'CCR', 'CTRY', 'datec.day', 'datec.week', 'datec.month', 'datec.quarter', 'datec.year'),
c('Hospital_code','Hospital', 'Comm. Group', 'Area Team', 'NHS Region', 'Comm. Region', 'Country', 'day', 'week', 'month', 'quarter', 'year')
)
dt
}
# Returns a renamed dataset after specifying columns and optionally records to retain
get.dt.renamed <- function(columns, records = NA){
columns <- c('HSP_id', 'HSP', 'datec.day', columns[substr(columns, 1, 1) == 'X'])
if(is.na(records)){
dt <- dataset[, columns, with = FALSE]
} else {
dt <- dataset[HSP_id %in% records, columns, with = FALSE]
}
m1 <- as.data.table(names(dt), key = 'V1')
m2 <- data.table(lookups[domain_id <= 1, .( old = paste('X', lookup_id, sep = ''), new = description ) ], key = 'old')
names(dt) <- m2[m1][is.na(new), new := old][, new]
dt[, Hospital := paste(HSP_id, '-', HSP)]
dt[, `:=`(HSP_id = NULL, HSP = NULL)]
setnames(dt, 'datec.day', 'day')
setcolorder(dt, c('Hospital', setdiff(names(dt), 'Hospital')))
dt[order(Hospital, -day)]
}
# Renames the exporting dataset for easier reading
dt.for.export <- function(dt){
fld2save <- c('date.day', 'date.hour', 'datec.month', 'datec.quarter', 'date.year', 'HSP_id', 'HSP', 'CCG', 'LAT', 'NHSR', 'CCR', 'CTRY')
fld2name <- c('day', 'hour', 'month', 'quarter', 'year', 'hospital_code', 'hospital', 'Comm. Group', 'Area Team', 'NHS Region', 'Comm. Region', 'Country')
for(idx in 1:length(names(dt))){
if(substr(names(dt)[idx], 1, 1) == 'X'){
fld2save <- c(fld2save, names(dt)[idx])
fld2name <- c(fld2name, lookups[lookup_id == substr(names(dt)[idx], 2, nchar(names(dt)[idx])), description ])
}
}
dt <- dt[, fld2save, with = FALSE]
setnames(dt, fld2save, fld2name)
dt
}
# Clean the filename, keep only alphanum, dash and underline
filename.clean <- function(fn){
fn <- gsub('[ \\.]', '-', fn)
gsub('[^[:alnum:]_-]', '', fn)
}
# Clean the title of the plot for exporting
plot.title.clean <- function(fn){
fn <- gsub('<br/>', '\n', fn)
fn <- gsub('<(.*)>', '', fn)
fn
}
# Trim a dataset based on the values of (usually) a slider input wrt some quantity
shrink.dataset <- function(dt, field.from, quant.obj){
setnames(dt, field.from, 'quantity')
limInfQuant <- as.numeric(quant.obj)[1]/100
limSupQuant <- as.numeric(quant.obj)[2]/100
if(limInfQuant > 0 | limSupQuant < 1)
dt <- dt[ quantity >= quantile(quantity, limInfQuant, na.rm = TRUE) & quantity <= quantile(quantity, limSupQuant, na.rm = TRUE) ]
setnames(dt, 'quantity', field.from)
return(dt)
}
# delete number of item in questionaire from label
clear.label <- function(lbl){
lbl <- vars[lookup_id == eval(lbl), description]
if(grepl('^[[:digit:]]', lbl)) return( substr(lbl, regexpr(' ', lbl) + 1, nchar(lbl)) )
lbl
}
# return the correct expression for the ggplot mapping argument
get.list.aes <- function(lst.aes) {
if(!length(lst.aes)) return(NULL)
result <- 'aes('
for(idx in 1:length(lst.aes)) result <- paste0(result, names(lst.aes[idx]), ' = ', lst.aes[[idx]], ', ')
result <- paste0(substr(result, 1, nchar(result) - 2), ')')
eval(parse(text = result))
}
# convert a ggplot into its corresponding interactive plot from ggiraph extension
gg.to.ggiraph <- function(p, sel.type = 'single', gg.width = 0.8){
ggiraph( code = {print(p)},
width = gg.width,
zoom_max = 1,
selection_type = sel.type,
# selected_css = "",
tooltip_offx = 20, tooltip_offy = -10,
hover_css = "fill:red;cursor:pointer;r:4pt;opacity-value:0.5;",
tooltip_extra_css= "background-color:wheat;color:gray20;border-radius:10px;padding:3pt;",
tooltip_opacity = 0.9,
pointsize = 12
)
}
# calculate both funnel plot limits based on given "total" probability and maximum effect size
get.funnel.limits <- function(plevel, maxn, theta1, theta2 = NULL){
ord.magn <- ifelse(nchar(maxn) <= 4, 1, nchar(maxn) - 3)
my.funnel <- data.table(x = seq(1, pretty(maxn)[2], 10^(ord.magn - 1) ) )
plevel.inf <- (1 - plevel)/2
plevel.sup <- plevel + plevel.inf
if(!is.null(theta2)){
my.funnel[, liminf := qnorm(plevel.inf, theta1, theta2/sqrt(x)) ]
my.funnel[, limsup := qnorm(plevel.sup, theta1, theta2/sqrt(x)) ]
} else {
my.funnel[, nu := qbinom(plevel.inf, x, theta1) ]
my.funnel[, num := ( pbinom(nu, x, theta1) - plevel.inf ) ]
my.funnel[, den := ( pbinom(nu, x, theta1) - pbinom(nu - 1, x, theta1) ) ]
my.funnel[, alpha := num / den ]
my.funnel[, liminf := (nu - alpha) / x ]
my.funnel[, nu := qbinom(plevel.sup, x, theta1) ]
my.funnel[, num := ( pbinom(nu, x, theta1) - plevel.sup ) ]
my.funnel[, den := ( pbinom(nu, x, theta1) - pbinom(nu - 1, x, theta1) ) ]
my.funnel[, alpha := num / den ]
my.funnel[, limsup := (nu - alpha) / x ]
}
return(my.funnel[, .(x, liminf, limsup) ])
}
# recode multiple fields as ordered factors, using themselves or the lookup table as reference for the labels/levels
recode.factors <- function(dt, flds, lkps = FALSE){
for(fn in flds){
if(lkps){
lk <- sub('X', '', fn)
lvls <- lookups[domain_id == lk, lookup_id ]
lbls <- lookups[domain_id == lk, description ]
} else {
lvls <- sort(unique(dt[[fn]]))
lvls <- lvls[!(lvls %in% c(NA))]
lbls <- lvls
}
dt[, (fn) := factor(dt[[fn]], levels = lvls, labels = lbls, ordered = TRUE) ]
}
}
# get long name of day/month starting from 3-chars name
get.longname <- function(shortname){
longname <- lookups[domain_id == 200091 & lookup_id == lookups[domain_id == 200092 & description == shortname, lookup_id], description]
if(length(longname) > 0) return(longname)
longname <- lookups[domain_id == 200093 & lookup_id == lookups[domain_id == 200094 & description == shortname, lookup_id], description]
if(length(longname) > 0) return(longname)
shortname
}
vget.longname <- Vectorize(get.longname)
# get the summary dataset for the different tabs V1
get.y.tms <- function(dt, var.Y, var.X = NA, grp1 = NA, grp2 = NA, tt = NULL, pct = FALSE, flt.var = NA, flt.val = NA){
# retrieve formulas for calculate the metric
mtc.def <- mtc.parsed(var.Y, pct)
# apply the filter that define the metric
y <- dt[ eval(mtc.def[1]) ]
# if needed, determine the independent var X
if(!is.na(var.X)) y[, X := get(var.X) ][!is.na(X)]
# if needed, filter over the specified variable
if(!is.na(flt.var)){
if(flt.val != 'NONE'){
flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
y <- y[ get(flt.var) == flt.lbl ]
}
}
# calculate the metrics
if(is.na(grp1)){
# ungrouped case
y <- y[, .( Y = eval(mtc.def[2]) ), X ][, G := 1]
} else {
if(is.na(grp2)){
# grouped case, one grouping var
y <- y[, G := get(grp1) ][!(G %in% labels.del)][, .( Y = eval(mtc.def[2]) ), .(X, G) ]
} else {
# grouped case, two grouping vars
y <- y[, G1 := get(grp1) ][!(G1 %in% labels.del)][, G2 := get(grp2) ][!(G2 %in% labels.del)]
y <- y[, .( Y = eval(mtc.def[2]) ), .(X, G1, G2) ][, G := 1]
}
}
# if needed, calculate the tooltip
if(!is.null(tt))
y[, ttip := paste0(
if(!is.na(tt[1])){ paste0('<b>', tt[1], '</b><br/>') },
tt[2], ': <b>', X, '</b><br/>',
if(!is.na(grp1)){
if(is.na(grp2)){
paste0(clear.label(grp1), ': <b>', G, '</b><br/>')
} else {
paste0(clear.label(grp1), ': <b>', G1, '</b><br/>', clear.label(grp2), ': <b>', G2, '</b><br/>')
}
},
metrics[label == var.Y, title], ': <b>', if(pct) { paste0(100*Y, '%') } else {Y}, '</b>'
)]
return(y)
}
# return the summary dataset to display in the "table" subtab
get.dt.tbl <- function(dt,
tblY, lblX, fld.to.order = NA, ord.desc = FALSE, is.time = FALSE,
col.bars = '#80cdc1', col.fonts = 'black', pal.scale = 'Spectrum', n.cols = 7, reverse = FALSE,
flt.var = NA, flt.val = NA, grp.var = NA, grp.type = NA, grp.stype = NA
){
## A1- DETERMINE THE MAIN DATASET -----------------------------------------------------------------------
# Tables display following columns:
# - type = 1 (quantities) : 'Count', 'Quota'
# - type = 2 (measure) : 'Count', 'Quota', 'Percent', 'Index'
# - type >= 3 (metrics) : 'Value', 'Index'
# filtering
if(!is.na(flt.var)){
if(!is.na(flt.val)){
flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
dt <- dt[ get(flt.var) == flt.lbl ]
}
}
# query the type of the variable
var.type <- min(3, metrics[label == tblY, type])
# query filter and formula for counting (type = 1) and metrics (type >= 3)
YF <- metrics[label == tblY, filter_by]
YM <- metrics[label == tblY, mutate_as]
# filter the dataset for the main table
y <- dt[eval( parse(text = YF) )]
# calculate and store total if metric
if(var.type == 3) yt <- y[, eval( parse(text = YM) ) ]
# calculate counting or metric
if(is.time){
y <- y[ , .( m = eval( parse(text = YM) ) ), X ][order(-X)]
} else {
y <- y[ , .( m = eval( parse(text = YM) ) ), .( X = as.character(X) ) ]
}
if(var.type == 3){
# calculate Index if metric
y[, yt := yt][, Index := round(m / yt, 4)][, yt := NULL]
} else {
# calculate and store total if counting
yt <- y[, sum(m)]
y[, Quota := round(m / sum(m), 4)]
}
# define row for the total
df.total <- data.frame('TOTAL', yt, NA)
if(var.type == 2){
# calculataion percentages as above if measure (type = 2)
YFP <- metrics[label == tblY, filter_pct]
YMP <- metrics[label == tblY, mutate_pct]
yp <- dt[eval( parse(text = YFP) )]
ytp <- yp[, eval( parse(text = YMP) ) ]
yp <- yp[ , .( m = eval( parse(text = YMP) ) ), .( X = as.character(X) ) ]
yp[, ytp := ytp][, Index := round(m / ytp, 4)][, ytp := NULL]
setkey(y, 'X')
setkey(yp, 'X')
y <- y[yp]
df.total <- data.frame('TOTAL', yt, NA, ytp, NA)
}
# order table according to user choices: variable + type
setnames(y, c(lblX, tbl.headings[[var.type]]))
if(!is.na(fld.to.order)) y <- y[order(get(fld.to.order), decreasing = ord.desc)]
# add total row at the top
y <- rbindlist(list( df.total, y) )
# rename columns
setnames(y, c(lblX, tbl.headings[[var.type]]))
## A2- IF REQUESTED, DETERMINE AND ADD TO THE ABOVE THE GROUP DATASET -----------------------------------
# Tables display following columns:
# - type = 1 (quantities):
# - 'Count'
# - 'Quota': vs Total National, vs Grouped Item
# - type = 2 (measure) : 'Count', 'Quota', 'Percent', 'Index'
# - 'Count'
# - 'Quota': vs Total National, vs Grouped Item
# - 'Percentage': vs Total National, vs Grouped Item
# - 'Index' (vs Grouped Items only)
# - type >= 3 (metrics)'', ''
# - 'Value'
# - 'Index' (vs Grouped Items only)
if(!is.na(grp.var)){
dt[, G := get(grp.var) ]
yg <- dt[!(G %in% labels.del)][eval( parse(text = YF) )]
if(var.type == 1){
yg <- yg[, .( m = eval( parse(text = YM) ) ), .( X = as.character(X), G ) ]
yg <- dcast.data.table(yg, X~G, value.var = 'm', fill = 0)
yn <- names(yg)
yg <- rbindlist( list( data.frame('TOTAL', yg[, lapply(.SD, sum), .SDcols = 2:ncol(yg)]), yg) )
names(yg) <- yn
y <- merge(y, yg, by.x = lblX, by.y = 'X')
if(grp.type == 'Quota'){
y[, T := rowSums(y[,4:ncol(y), with = FALSE])]
yq <-
if(grp.stype == 'R'){
y[, lapply(.SD, function(x) round(x/T, 4)), .SDcols = 4:ncol(y)]
} else if(grp.stype == 'C'){
y[, lapply(.SD, function(x) round(x/x[1], 4)), .SDcols = 4:ncol(y)]
} else {
y[, lapply(.SD, function(x) round(x/sum(T[2:.N]), 4)), .SDcols = 4:ncol(y)]
}
yq[, T := NULL]
if(grp.stype == 'C') yq[1, names(yq) := NA]
y <- cbind(y[, 1:3], yq)
}
} else if(var.type == 2){
} else {
ygt <- t(yg[, .( m = eval( parse(text = YM) ) ), G ][, m])
yg <- yg[, .( m = eval( parse(text = YM) ) ), .( X = as.character(X), G ) ]
yg <- dcast.data.table(yg, X~G, value.var = 'm', fill = NA)
yn <- names(yg)
yg <- rbindlist( list( data.frame('TOTAL', ygt), yg) )
names(yg) <- yn
y <- merge(y, yg, by.x = lblX, by.y = 'X')
if(grp.type == 'Index'){
if(grp.stype == 'R'){
yq <- y[, lapply(.SD, function(x) round(x/Value, 4)), .SDcols = 4:ncol(y)]
} else if(grp.stype == 'C'){
yq <- y[, lapply(.SD, function(x) round(x/x[1], 4)), .SDcols = 4:ncol(y)]
yq[1, names(yq) := NA]
}
y <- cbind(y[, 1:3], yq)
}
}
}
## B- BUILD THE TABLE -----------------------------------------------------------------------------------
t <- datatable(y,
rownames = FALSE,
selection = 'none',
class = 'cell-border stripe hover nowrap',
extensions = c('Buttons', 'FixedColumns', 'Scroller'),
options = list(
scrollX = TRUE,
scrollY = 400,
scroller = TRUE,
buttons = c('copy', 'csv', 'excel', 'pdf', 'print'),
fixedColumns = list(leftColumns = 1),
ordering = FALSE,
deferRender = TRUE,
dom = 'Btip'
)
)
## C- STYLE THE DATATABLE -------------------------------------------------------------------------------
if('Counting' %in% names(y)){
t <- t %>% formatCurrency('Counting', '', digits = 0)
}
if('Quota' %in% names(y)){
t <- t %>% formatPercentage('Quota', digits = 2)
t <- t %>% formatStyle('Quota',
color = col.fonts,
background = styleColorBar(y[, Quota], col.bars ),
backgroundSize = '90% 70%', backgroundRepeat = 'no-repeat', backgroundPosition = 'center'
)
}
if('Percentage' %in% names(y)){
t <- t %>% formatPercentage('Percentage', digits = 2)
t <- t %>% formatStyle('Percentage',
color = col.fonts,
background = styleColorBar(y[, Percentage], col.bars ),
backgroundSize = '90% 70%', backgroundRepeat = 'no-repeat', backgroundPosition = 'center'
)
}
if('Value' %in% names(y)){
t <- t %>% formatCurrency('Value', '', digits = 2)
t <- t %>% formatStyle('Value',
color = col.fonts,
background = styleColorBar(y[, Value], col.bars ),
backgroundSize = '90% 70%', backgroundRepeat = 'no-repeat', backgroundPosition = 'center'
)
}
if('Index' %in% names(y)){
t <- t %>% formatCurrency('Index', '', digits = 3)
pal <- brewer.pal(n.cols + 1, pal.scale)
if(reverse) pal <- rev(pal)
t <- t %>% formatStyle('Index',
backgroundColor = styleInterval(
quantile(y$Index, prob = seq(0, 1, length = n.cols + 1), na.rm = TRUE)[2:(n.cols + 1)],
pal
)
)
}
if(!is.na(grp.var)){
tg.names <- names(y[, 4:ncol(y)])
tg.range <- y[2:nrow(y), 4:ncol(y)]
if(var.type == 1){
if(grp.type == 'Counting'){
t <- t %>% formatCurrency(tg.names, '', digits = 0)
# if(grp.stype == 'T'){
# t <- t %>% formatStyle(tg.names,
# background = styleColorBar(as.matrix(tg.range), 'lightblue'),
# backgroundSize = '90% 80%',
# backgroundRepeat = 'no-repeat',
# backgroundPosition = 'center'
# )
# }
} else {
t <- t %>% formatPercentage(tg.names, digits = 2)
}
} else if(var.type == 2){
} else {
t <- t %>% formatCurrency(tg.names, '', digits = 2 + as.numeric(grp.type == 'Index'))
}
}
# format TOTAL first row as bigger font size, bold typeface.
t <- t %>% formatStyle(lblX, target = 'row',
backgroundColor = styleEqual('TOTAL', 'black' ),
color = styleEqual('TOTAL', 'white' ),
fontWeight = styleEqual('TOTAL', 'bold'),
fontSize = styleEqual('TOTAL', '130%' )
)
## RETURN -----------------------------------------------------------------------------------------------
t
}
# returns the summary dataset for the BARPLOT as a 2-elements list: 1st the dataset, 2nd the national total
get.dt.brp <- function(dt, var.Y, var.X = NA, grp1 = NA, grp2 = NA, tt = NULL, pct = FALSE, flt.var = NA, flt.val = NA, show.NA = FALSE, ordering = 1){
# retrieve formulas for calculate the metric
mtc.def <- mtc.parsed(var.Y, pct)
# apply the filter that define the metric
y <- dt[ eval(mtc.def[1]) ]
# if needed, determine the independent var X
if(!is.na(var.X)) y[, X := get(var.X)][!is.na(X)]
# y[, X := as.character(X)]
# if needed, filter over the specified variable
if(!is.na(flt.var)){
if(flt.val != 'NONE'){
flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
y <- y[ get(flt.var) == flt.lbl ]
}
}
# calculate the metrics
if(is.na(grp1)){
# ungrouped case
yt <- as.numeric(y[, .( Y = eval(mtc.def[2]) ) ])
y <- y[, .( Y = eval(mtc.def[2]) ), X ][, G := 1]
} else {
if(is.na(grp2)){
# grouped case, one grouping var
y <- y[, G := get(grp1) ][!(G %in% labels.del)]
yt <- y[, .( Y = eval(mtc.def[2]) ), G ]
y <- y[, .( Y = eval(mtc.def[2]) ), .(X, G) ]
if(show.NA)
y <- setDT(complete(y, X, nesting(G), fill = list(Y = 0) ) )
} else {
# grouped case, two grouping vars
y <- y[, G1 := get(grp1) ][!(G1 %in% labels.del)][, G2 := get(grp2) ][!(G2 %in% labels.del)]
yt <- y[, .( Y = eval(mtc.def[2]) ), .(G1, G2) ]
y <- y[, .( Y = eval(mtc.def[2]) ), .(X, G1, G2) ][, G := 1]
}
}
# if needed, calculate the tooltip
if(!is.null(tt))
y[, ttip := paste0(
if(!is.na(tt[1])){ paste0('<b>', tt[1], '</b><br/>') },
tt[2], ': <b>', X, '</b><br/>',
if(!is.na(grp1)){
if(is.na(grp2)){
paste0(clear.label(grp1), ': <b>', G, '</b><br/>')
} else {
paste0(clear.label(grp1), ': <b>', G1, '</b><br/>', clear.label(grp2), ': <b>', G2, '</b><br/>')
}
},
metrics[label == var.Y, title], ': <b>', if(pct) { paste0(100*Y, '%') } else {Y}, '</b>'
)]
# cancel factor on X
y[, X := as.character(X)]
# order bars
y <- switch(ordering, '1' = y[order(X)], '2' = y[order(-X)], '3' = y[order(Y)], '4' = y[order(-Y)] )
return( list(y, yt, ytg = NA, ytg2 = NA) )
}
# returns the summary dataset for the BOXPLOT as a 2-elements list: 1st the dataset, 2nd the outliers
get.dt.bxp <- function(dt, var.Y, var.X = NA, grp1 = NA, grp2 = NA, tt = NULL, flt.var = NA, flt.val = NA){
cols = c('X')
y0 <- dt[, Y := get(var.Y) ]
if(!is.na(var.X)) y0[, X := get(var.X)][!is.na(X)]
if(!is.na(grp1)){
y0 <- y0[, G := get(grp1) ][!(G %in% labels.del)]
cols = c(cols, 'G')
if(!is.na(grp2)){
y0 <- y0[, G2 := get(grp2) ][!(G2 %in% labels.del)]
cols = c(cols, 'G2')
}
}
# if needed, filter over the specified variable
if(!is.na(flt.var)){
if(flt.val != 'NONE'){
flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
y0 <- y0[ get(flt.var) == flt.lbl ]
}
}
y <- y0[, .SD, .SDcols = c(cols, 'Y')]
setkeyv(y, cols)
yt <- y[, .(V0 = sum(is.na(Y))), cols]
y <- y[!(Y %in% labels.del)]
yt <- yt[y[, .(
V1 = .N, V2 = median(Y), V3 = quantile(Y)[2], V4 = quantile(Y)[4], V5 = IQR(Y), V6 = paste(range(Y), collapse = '-'),
V11 = round(mean(Y), 2), V12 = round(sd(Y), 2)
),
cols
]]
yt <- yt[y[, .(V7 = sum( Y < (quantile(Y)[2] - IQR(Y) * 1.5) | Y > (quantile(Y)[4] + IQR(Y) * 1.5) )), cols ]]
yt[, ttip := as.factor(paste0(
tt, ': <b>', X, '</b><br/>',
if(!is.na(grp1)) paste0(clear.label(grp1), ': <b>', G, '</b><br/>'),
if(!is.na(grp2)) paste0(clear.label(grp2), ': <b>', G2, '</b><br/>'),
'N. Procedures: <b>', format(V1, big.mark = ','), '</b><br/><br/>',
toupper(clear.label(var.Y)), '<ul>',
'<li>Completeness: <b>', ifelse(V0 > 0, paste0('<font color="red">', paste0(round(100*(1-V0/(V0+V1)), 2), '%'), '</font>'), '100%'), '</b><br/>',
'<li>Median: <b>', V2, '</b><br/>',
'<li>1st quartile: <b>', V3, '</b><br/>',
'<li>3rd quartile: <b>', V4, '</b><br/>',
'<li>IQR: <b>', V5, '</b><br/>',
'<li>Range: <b>', V6, '</b><br/>',
'<li>N. Outliers: <b>', ifelse(V7 > 0, paste0('<font color="red">', V7, '</font>'), '--'), '</b><br/>',
'<li>Mean: <b>', V11, '</b><br/>',
'<li>St Dev: <b>', V12, '</b><br/></ul>'
))]
y <- y[yt[, c(cols, 'ttip'), with = FALSE]]
# outliers
y0[, D := datec.day]
y.out <- y0[!(Y %in% labels.del)][Y < (quantile(Y)[2] - IQR(Y) * 1.5) | Y > (quantile(Y)[4] + IQR(Y) * 1.5)][, c(cols, 'D', 'Y'), with = FALSE]
y.out[, ttip := paste0(
tt, ': <b>', X, '</b><br/>',
if(!is.na(grp1)) paste0(clear.label(grp1), ': <b>', G, '</b><br/>'),
if(!is.na(grp2)) paste0(clear.label(grp2), ': <b>', G2, '</b><br/>'),
clear.label(var.Y), ': ', Y, '<br/>',
'Date of Procedure: ', D
)]
# cancel factor on X
y[, X := as.character(X)]
return( list(y, y.out) )
}
# returns the summary dataset for the HEATMAPS
get.dt.hmp <- function(dt, var.Y, var.X = NA, var.X2 = NA, grp1 = NA, grp2 = NA, tt = NULL, pct = FALSE, flt.var = NA, flt.val = NA, mtc.rescale = NA, ordering = 1, show.NA = FALSE){
# retrieve formulas for calculate the metric
mtc.def <- mtc.parsed(var.Y, pct)
# apply the filter that define the metric
y <- dt[ eval(mtc.def[1]) ]
# if needed, determine the independent vars X and X2
if(!is.na(var.X)) y[, X := get(var.X)][!is.na(X)]
if(!is.na(var.X2)) y[, X2 := get(var.X2)][!is.na(X2)]
# if needed, filter over the specified variable
if(!is.na(flt.var)){
if(flt.val != 'NONE'){
flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
y <- y[ get(flt.var) == flt.lbl ]
}
}
# calculate the metrics
if(is.na(grp1)){
# ungrouped case
y <- y[, .( Y = eval(mtc.def[2]) ), .(X, X2) ]
if(show.NA) y <- setDT(complete(y, X, nesting(X2)) )
} else {
if(is.na(grp2)){
# grouped case, one grouping var
y <- y[, G := get(grp1) ][!(G %in% labels.del)]
y <- y[, .( Y = eval(mtc.def[2]) ), .(X, X2, G) ]
if(show.NA) y <- setDT(complete(y, X, nesting(X2, G) ) )
} else {
# grouped case, two grouping vars
y <- y[, G1 := get(grp1) ][!(G1 %in% labels.del)]
y <- y[, G2 := get(grp2) ][!(G2 %in% labels.del)]
y <- y[, .( Y = eval(mtc.def[2]) ), .(X, X2, G1, G2) ][, G := 1]
if(show.NA) y <- setDT(complete(y, X, nesting(X2, G1, G2) ) )
}
}
# calculate the tooltip
if(length(tt)){
y[, ttip := paste0(
tt[1], ': <b>', X, '</b><br/>',
tt[2], ': <b>', X2, '</b><br/>',
if(!is.na(grp1)){
if(is.na(grp2)){
paste0(clear.label(grp1), ': <b>', G, '</b><br/>')
} else {
paste0(clear.label(grp1), ': <b>', G1, '</b><br/>', clear.label(grp2), ': <b>', G2, '</b><br/>')
}
},
metrics[label == var.Y, title], ': <b>', if(pct) { paste0(100*Y, '%') } else {Y}, '</b>'
)]
}
# Rescaling along X-geo or X2-time
if(!is.na(mtc.rescale)) y <- setDT( ddply(y, .(get(mtc.rescale)), transform, Y = round(rescale(Y) * 100, 0) ) )
if(ordering){
# cancel factor on X
y[, X := as.character(X)]
# order bars
y <- switch(ordering, '1' = y[order(X)], '2' = y[order(-X)], '3' = y[order(Y)], '4' = y[order(-Y)] )
}
return( list(y, yt = NA, ytg = NA, ytg2 = NA) )
}
# return only the X-items with positions indicated by vals
trim.dt.X <- function(dt, vals){
if(length(vals) == 0) vals <- c(1, length(unique(dt$X)))
y <- dt[X %in% unique(dt$X)[vals[1]:vals[2] ] ]
y$X <- factor(y$X, levels = unique(y$X))
return(y)
}
# return only the X-items with positions indicated by vals
trim.dt.X.bxp <- function(dt, vals, ordering){
if(length(vals) == 0) vals <- c(1, length(unique(dt$X)))
yo <- switch(ordering,
'1' = unique(dt[, .(X)])[order(X)][vals[1]:vals[2] ],
'2' = unique(dt[, .(X)])[order(-X)][vals[1]:vals[2] ],
'3' = dt[, median(Y), X][order(V1), .(X)][vals[1]:vals[2] ],
'4' = dt[, median(Y), X][order(-V1), .(X)][vals[1]:vals[2] ]
)
yo <- unlist(yo)
y <- dt[X %in% yo]
return( list(y, yo) )
}
# embellish the dataset to be downloaded from the user as CSV file
dt.csv.output <- function(dt){
y <- copy(dt)
y[, `:=`(ttip = NULL, data_id = NULL, clk = NULL)]
}
#===== OPTIONAL TABS ------------------------------------------------------------------------------------------------------------
#
if(load.tabs['consultants', status]){
}
#
if(load.tabs['patients', status]){
}
# Build Completeness table, with all different areas and timespans
if(load.tabs['completeness', status]){
cmp.tbl <- data.table()
for(itm in 1:nrow(completeness)){
W = parse(text = paste0(completeness[itm, filter_by]))
cmp.tbl <- rbindlist(list(
cmp.tbl,
cbind(
item = completeness[itm, item],
dataset[,
.( count = sum( eval(W) ), total = .N ),
.(HSP_id, year = date.year, quarter = date.quarter, month = date.month)
][order(HSP_id, month)]
)
))
}
setkey(cmp.tbl, 'HSP_id')
setkey(hospitals, 'HSP_id')
cmp.tbl <- cmp.tbl[hospitals[, .(HSP_id, CCG_id, CTRY_id) ] ]
}
#===== VARIABLES/LABELS ----------------------------------------------------------------------------------------------------------------
# List for the GEOGRAPHY combo box
locations <- c(
'Country' = 'CTRY', 'Comm. Region' = 'CCR', 'NHS Region' = 'NHSR', 'Area Team' = 'LAT', 'Comm. Group' = 'CCG', 'Hospital' = 'HSP'
)
# List for the TIME REFERENCE single period in heatmaps hospitals
timeref <- c(
'Year' = 'datec.year', 'Quarter' = 'datec.quarter', 'Month of Year' = 'month_st',
'Day of Month' = 'day_nid', 'Day of Week' = 'day_st', 'Daypart' = 'daypart', 'Hour of Day' = 'date.hour'
)
# List for the TIME REFERENCE single period in timeseries
timeper <- c(
'Year' = 'datec.year', 'Quarter' = 'datec.quarter', 'Month' = 'datec.month', 'Week' = 'datec.week', 'Day' = 'datec.day'
)
# List for the DATES double combo
date.range <- c(
start = max(dataset$date.day) - 365*3 - 1,
min = min(dataset$date.day),
max = max(dataset$date.day)
)
# Values to delete from labels
labels.del <- c(
'Unknown', 'Not Applicable', 'Not measured', 'Not known', 'Not specified', NA, ''
)
# List of Function to apply to numeric measures
fun.measures <- c(
'Mean' = 'mean', 'Minimum' = 'min', 'Maximum' = 'max', 'Interquartile Range' = 'IQR', 'Standard Deviation' = 'sd'
)
# Default color/palette
pal.default <- c('col' = 'steelblue3', 'cat' = 'Dark2', 'seq' = 'YlGnBu', 'div' = 'RdBu', 'na' = 'grey62')
# List of palettes to be used with ColourBrewer package:
lst.palette <- list(
'SEQUENTIAL' = c( # ordinal data where (usually) low is less important and high is more important
'Blues' = 'Blues', 'Blue-Green' = 'BuGn', 'Blue-Purple' = 'BuPu', 'Green-Blue' = 'GnBu', 'Greens' = 'Greens', 'Greys' = 'Greys',
'Oranges' = 'Oranges', 'Orange-Red' = 'OrRd', 'Purple-Blue' = 'PuBu', 'Purple-Blue-Green' = 'PuBuGn', 'Purple-Red' = 'PuRd', 'Purples' = 'Purples',
'Red-Purple' = 'RdPu', 'Reds' = 'Reds', 'Yellow-Green' = 'YlGn', 'Yellow-Green-Blue' = 'YlGnBu', 'Yellow-Orange-Brown' = 'YlOrBr',
'Yellow-Orange-Red' = 'YlOrRd'
),
'DIVERGING' = c( # ordinal data where both low and high are important (i.e. deviation from some reference "average" point)
'Brown-Blue-Green' = 'BrBG', 'Pink-Blue-Green' = 'PiYG', 'Purple-Red-Green' = 'PRGn', 'Orange-Purple' = 'PuOr', 'Red-Blue' = 'RdBu', 'Red-Grey' = 'RdGy',
'Red-Yellow-Blue' = 'RdYlBu', 'Red-Yellow-Green' = 'RdYlGn', 'Spectral' = 'Spectral'
),
'QUALITATIVE' = c( # categorical/nominal data where there is no logical order
'Accent' = 'Accent', 'Dark2' = 'Dark2', 'Paired' = 'Paired', 'Pastel1' = 'Pastel1', 'Pastel2' = 'Pastel2',
'Set1' = 'Set1', 'Set2' = 'Set2', 'Set3' = 'Set3'
)
)
# list of labels for download buttons
btndwn.text <- c('Save Dataset as CSV', 'Save Chart as PNG', 'Save Static Map as PNG', 'Save Interactive Map as HTML', 'Save Table as CSV')
# list of options for charts
point.shapes <- c('circle' = 21, 'square' = 22, 'diamond' = 23, 'triangle up' = 24, 'triangle down' = 25)
line.types <- c('dashed', 'dotted', 'solid', 'dotdash', 'longdash', 'twodash')
face.types <- c('plain', 'bold', 'italic', 'bold.italic')
val.lbl.pos <- list(
'Inside' = list('Vertical' = c(0.5, 1.5), 'Horizontal' = c( 1.2, 0.2) ),
'Outside' = list('Vertical' = c(0.4, -0.3), 'Horizontal' = c(-0.2, 0.2) )
)
lbl.format <- function(y, type, is.pct = FALSE){
if(type == 1){
format(y, big.mark = ',', nsmall = 0)
} else if(type == 2){
if(is.pct){
paste0(format(round(100 * y, 2), nsmall = 2), '%')
} else {
format(y, big.mark = ',', nsmall = 0)
}
} else {
format(y, nsmall = 2)
}
}
# default probabilities and colors for funnel plots limits
funnel.defaults <- list(
'prob.tot' = c('90%' = 0.9, '95%' = 0.95, '98.5%' = 0.985, '99%' = 0.99, '99.8%' = 0.998, '99.9%' = 0.999),
'prob.sel' = c(0.998, 0.95),
'col.tot' = c('green', 'red', 'blue', 'black', 'cyan', 'magenta', 'yellow', 'gray'),
'col.sel' = c('green', 'red'),
'type.tot' = line.types,
'type.sel' = c('solid', 'dotted')
)
# table headings
tbl.headings <- list(
'cnt' = c('Counting', 'Quota'),
'mtc' = c('Counting', 'Quota', 'Percentage', 'Index'),
'msr' = c('Value', 'Index')
)
# table ordering variables
tbl.orders <- list(
'cnt' = c('Counting'),
'mtc' = c('Counting', 'Percentage'),
'msr' = c('Value')
)
# plot caption
plt.caption <- paste0('@', year(Sys.Date()), ' ATG')
#===== STYLES ----------------------------------------------------------------------------------------------------------------
# add text at the left of the upper navbar
navbarPageWithText <- function(..., text) {
navbar <- navbarPage(...)
textEl <- tags$p(class = "navbar-text", text)
navbar[[3]][[1]]$children[[1]] <- htmltools::tagAppendChild( navbar[[3]][[1]]$children[[1]], textEl)
navbar
}
# return correct spacing for axis labels rotation
lbl.plt.rotation = function(angle, position = 'x'){
positions = list(x = 0, y = 90, top = 180, right = 270)
rads = (angle - positions[[ position ]]) * pi / 180
hjust = 0.5 * (1 - sin(rads))
vjust = 0.5 * (1 + cos(rads))
element_text(angle = angle, vjust = vjust, hjust = hjust)
}
# global style for ggplot charts
my.ggtheme <- function(g,
xaxis.draw = FALSE, yaxis.draw = FALSE, axis.draw = FALSE, ticks.draw = FALSE, axis.colour = 'black', axis.size = 0.1,
hgrid.draw = FALSE, vgrid.draw = FALSE, grids.colour = 'black', grids.size = 0.1, grids.type = 'dotted',
labels.rotation = c(45, 0), labels.rotate = FALSE,
bkg.colour = 'white', font.size = 6, ttl.font.size.mult = 1.2, ttl.face = 'bold',
legend.pos = 'bottom', plot.border = FALSE, font.family = 'Arial'
){
g <- g + theme(
text = element_text(family = font.family),
plot.title = element_text(hjust = 0, size = rel(1.2) ), # hjust: 0-left, 0.5-center, 1-right
plot.background = element_blank(),
plot.margin = unit(c(1, 0.5, 0, 0.5), 'lines'), # space around the plot as in: TOP, RIGHT, BOTTOM, RIGHT
plot.caption = element_text(size = 8, face = 'italic'),
axis.line = element_blank(),
axis.ticks = element_blank(),
axis.text = element_text(size = font.size, color = axis.colour),
axis.text.x = element_text(angle = labels.rotation[1], hjust = 1), # vjust = 0.5),
axis.text.y = element_text(angle = labels.rotation[2]), # , hjust = , vjust = ),
axis.title = element_text(size = font.size * (1 + ttl.font.size.mult), face = ttl.face),
axis.title.x = element_text(vjust = -0.3),
axis.title.y = element_text(vjust = 0.8, margin = margin(0, 10, 0, 0) ),
legend.text = element_text(size = 6),
legend.title = element_text(size = 8),
legend.title.align = 1,
legend.position = legend.pos,
legend.background = element_blank(),
legend.spacing = unit(0, 'cm'),
# legend.key = element_blank(),
legend.key.size = unit(0.2, 'cm'),
legend.key.height = unit(0.4, 'cm'),
legend.key.width = unit(1, 'cm'),
panel.background = element_rect(fill = bkg.colour, colour = bkg.colour),
panel.border = element_blank(),
panel.grid = element_blank(),
panel.spacing.x = unit(3, 'lines'),
panel.spacing.y = unit(2, 'lines'),
strip.text = element_text(hjust = 0.5, size = font.size * (1 + ttl.font.size.mult), face = ttl.face),
strip.background = element_blank()
)
if(plot.border) g <- g + theme( panel.border = element_rect(colour = axis.colour, size = axis.size, fill = NA) )
if(axis.draw){
g <- g + theme( axis.line = element_line(color = axis.colour, size = axis.size ) )
} else {
if(xaxis.draw) g <- g + theme( axis.line.x = element_line(color = axis.colour, size = axis.size ) )
if(yaxis.draw) g <- g + theme( axis.line.y = element_line(color = axis.colour, size = axis.size ) )
}
if(ticks.draw) g <- g + theme( axis.ticks = element_line(color = axis.colour, size = axis.size ) )
if(hgrid.draw & vgrid.draw){
g <- g + theme( panel.grid.major = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
} else{
if(vgrid.draw) g <- g + theme( panel.grid.major.x = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
if(hgrid.draw) g <- g + theme( panel.grid.major.y = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
}
if(labels.rotate){
g <- g + theme( axis.text.x = element_text(hjust = 1, angle = 45 ) )
}
return(g)
}
#===== MAPS ----------------------------------------------------------------------------------------------------------------
proj.wgs <- '+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0'
UK_centre <- c(-2.421976, 53.825564)
UK_bounds <- c(-8.3, 49.9, 1.8, 59.0 )
# List for the MAPTILES combo box
tiles.list <- as.list(maptiles[, url])
names(tiles.list) <- maptiles[, name]
tile.ini <- tiles.list$CartoDB.Positron
loca.map <- c('CCG', 'LAT', 'NHSR', 'CCR', 'CTRY')
loca.ini <- 'LAT'
pal.ini <- 'Blues' # c("#CDC673", "#90EE90", "#20B2AA")
# icons for hospitals: green = nhs, red = private
hsp.icons <- awesomeIcons(
icon = 'h-square',
library = 'fa',
squareMarker = TRUE,
markerColor = sapply(centres$type, function(x) if(x == 1){ "lightgreen" } else { "lightred" }),
iconColor = 'white'
)
# list of classification methods, to be used with classInt and ColorBrewer packages
class.methods <- c(
# 'Fixed' = 'fixed', # need an additional argument fixedBreaks that lists the n+1 values to be used
'Equal Intervals' = 'equal', # the range of the variable is divided into n part of equal space
'Quantiles' = 'quantile', # each class contains (more or less) the same amount of values
# 'Pretty Integers' = 'pretty', # sequence of about ‘n+1’ equally spaced ‘round’ values which cover the range of the values in ‘x’. The values are chosen so that they are 1, 2 or 5 times a power of 10.
'Natural Breaks' = 'jenks', # seeks to reduce the variance within classes and maximize the variance between classes
'Hierarchical Cluster' = 'hclust', # Cluster with short distance
'K-means Cluster' = 'kmeans' # Cluster with low variance and similar size
)
# Read boundaries as shapefiles from files in www directory
# boundaries <- lapply(loca.map, function(x) readOGR(shp.path, x))
# names(boundaries) <- loca.map
# for(m in loca.map){
# boundaries[[m]] <- merge(boundaries[[m]], areas[, .(ons_id, nhs_id, name)], by.x = 'id', by.y = 'ons_id')
# boundaries[[m]] <- merge(boundaries[[m]], centres[get(audit) == 1, .(H = .N), .(ons_id = get(paste0(m, '_ons')))], by.x = 'id', by.y = 'ons_id')
# }
# Read boundaries as unique list from rds shared rep
boundaries <- readRDS(paste0(data.path, 'boundaries.rds'))
for(m in loca.map){
boundaries[[m]] <- merge(boundaries[[m]], centres[get(audit) == 1, .(H = .N), .(ons_id = get(paste0(m, '_ons')))], by.x = 'id', by.y = 'ons_id')
}
# Determines the text intervals for the colours in the map legend
get.legend.colnames <- function(bnd, mtc.type, lbl.brks, ncols) {
if(mtc.type == 1){
lbl.brks <- format(round(lbl.brks, 0), big.mark = ',')
} else if(mtc.type == 2){
lbl.brks <- format(round(100*lbl.brks, 2), nsmall = 2)
} else {
lbl.brks <- format(round(lbl.brks, 1), nsmall = 1)
}
lbl.text <- sapply(2:ncols,
function(x)
paste0(
lbl.brks[x-1], ' \u2264 n < ', lbl.brks[x],
' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[x-1])) & bnd$Y < as.numeric(gsub(',', '', lbl.brks[x])) ] ), ')'
)
)
lbl.text <- c(lbl.text,
paste0(
lbl.brks[ncols], ' \u2264 n \u2264 ', lbl.brks[ncols + 1],
' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[ncols])) & bnd$Y <= as.numeric(gsub(',', '', lbl.brks[ncols + 1])) ] ), ')'
)
)
}
Comments