###################################
# 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])) ] ), ')'
        )
    )
}