API tools faq
paste
lvalnegri

global.R

lvalnegri
May 16th, 2018
203
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 49.31 KB | None | 0 0
raw download clone embed print report
  1. ###################################
  2. # SHINY Explorer - global.R
  3. ###################################
  4.  
  5. #===== LOAD PACKAGES -----------------------------------------------------------------------------------------------------------
  6. pkg <- c(
  7.      'bsplus', 'Cairo', 'colourpicker', 'data.table', 'DT', 'dygraphs', 'fst', 'ggplot2', 'ggiraph', 'ggrepel', 'ggthemes',
  8.     'htmltools', 'leaflet', 'mapview', 'plyr', 'RColorBrewer', 'rgdal', 'RMySQL', 'rpivotTable', 'rvest', 'scales',
  9.     'shiny', 'shinycssloaders', 'shinyDND', 'shinyjs', 'shinyjqui', 'shinythemes', 'shinyWidgets',
  10.     'sp', 'tidyr', 'xts'
  11. #    'circlize', 'extrafont', 'GGally', 'ggmap', 'ggspatial', 'ggparallel', 'tmap',
  12. )
  13. invisible( lapply(pkg, require, character.only = TRUE) )
  14. # for(conn in dbListConnections(MySQL())) dbDisconnect(conn)
  15.  
  16. #===== GENERAL OPTIONS ----------------------------------------------------------------------------------------------------------
  17. options(spinner.color = '#e5001a', spinner.size = 1, spinner.type = 4)
  18.  
  19. #===== LOAD DATA ----------------------------------------------------------------------------------------------------------------
  20. # From fst shared rep
  21. dataset <- read.fst(paste0(data.path, audit, '_dt.fst'), as.data.table = TRUE )
  22. # The following recoding is necessary until a new version of the fst package fixes the bug with dates converted into integers
  23. dataset[, `:=`(
  24.     date.day = as.Date(date.day, origin = '1970-01-01'),
  25.     date.week = as.Date(date.week, origin = '1970-01-01'),
  26.     date.month = as.Date(date.month, origin = '1970-01-01'),
  27.     date.quarter = as.Date(date.quarter, origin = '1970-01-01')
  28. )]
  29. if(has_consultants){
  30.     dt_cons <- read.fst(paste0(data.path, audit, '_pc.fst'), as.data.table = TRUE )
  31.     consultants <- read.fst(paste0(data.path, 'consultants.fst'), as.data.table = TRUE )
  32. }
  33. # From databases
  34. db_conn <- dbConnect(MySQL(), group = 'shiny', dbname = audit)
  35. # dataset <- suppressWarnings(data.table(dbReadTable(db_conn, 'shinyexp_dataset'), key = 'HSP_id' ) )
  36. lookups <- suppressWarnings(data.table(dbGetQuery(db_conn, 'SELECT * FROM lookups WHERE domain_id != 9') ) )
  37. vars <- suppressWarnings(data.table(dbReadTable(db_conn, 'vars') ) )
  38. metrics <- suppressWarnings(data.table(dbReadTable(db_conn, 'metrics') ) )
  39. calendar <- suppressWarnings(data.table(dbReadTable(db_conn, 'calendar') ) )
  40. load.tabs <- suppressWarnings(data.table(dbReadTable(db_conn, 'tabs'), key = 'name' ) )
  41. # dt_cons <- suppressWarnings(data.table(dbReadTable(db_conn, 'procedures_consultants'), key = 'proc_id' ) )
  42. completeness <- suppressWarnings(data.table(dbGetQuery(db_conn, 'SELECT item, filter_by FROM completeness WHERE is_active') ) )
  43. dbDisconnect(db_conn)
  44. db_conn <- dbConnect(MySQL(), group = 'shiny', dbname = 'common')
  45. areas <- suppressWarnings(data.table(dbReadTable(db_conn, 'locations') ) )
  46. centres <- suppressWarnings(data.table(dbReadTable(db_conn, 'centres'), key = 'HSP_id') )
  47. font.table <- suppressWarnings(data.table(dbGetQuery(db_conn, 'SELECT DISTINCT family FROM fonts WHERE is_active ORDER BY family') ) )
  48. maptiles <- suppressWarnings(data.table(dbGetQuery(db_conn,
  49.                     'SELECT CONCAT(provider, ".", name) AS name, url, attribution FROM maptiles WHERE require_reg = 0 ORDER BY name'
  50. )))
  51. # consultants <- suppressWarnings(data.table(dbReadTable(db_conn, 'consultants'), key = 'consultant_id' ) )
  52. dbDisconnect(db_conn)
  53. hospitals <- centres[get(audit) == 1]
  54.  
  55.  
  56. #===== FUNCTIONS ----------------------------------------------------------------------------------------------------------------
  57. # ifelse(x1, x2, NA)
  58. ifna <- function(x1, x2) ifelse(x1, x2, NA)
  59. # Create a list of variables from <vars> specifying one or more "type" (type could be: LGC, CAT, NUM, GEO, TMS)
  60. build_uiV <- function(tp){
  61.     ui.list <- as.list(vars[nature %in% tp & is_active == 1][order(ordering)][, lookup_id])
  62.     names(ui.list) <- vars[nature %in% tp & is_active == 1][order(ordering)][, description]
  63.     return(ui.list)
  64. }
  65. # Create a list of reference variables from <metrics> specifying a "subtab" and a (optional) type
  66. build_uiY <- function(tb, tp = 1:4){
  67.     ui.list <- as.list(metrics[get(tb) == 1 & type %in% tp ][order(ordering)][, label])
  68.     return(ui.list)
  69. }
  70. # Create a list of locations from <hospitals> specifying a "hierarchy"
  71. build_uiG <- function(h){
  72.     y <- unique(hospitals[, .( get(h), get(paste0(h, '_id')) )][!(V1 %in% labels.del)][order(V1)])
  73.     ui.list <- as.list(y[, V2])
  74.     names(ui.list) <- y[, V1]
  75.     return(ui.list)
  76. }
  77. # Create a list of values from <lookups> specifying a variable
  78. build_uiF <- function(v){
  79.     y <- lookups[domain_id == v, .(lookup_id, description ) ][order(lookup_id)][!(description %in% labels.del)]
  80.     ui.list <- as.list(y[, lookup_id])
  81.     names(ui.list) <- y[, description]
  82.     return(ui.list)
  83. }
  84. # Create a combobox of locations for a given tab 'tb', specifying child 'lw' and parent 'lb' area codes, and a parent area id 'ipt'
  85. build_uiGeo <- function(tb, hg, lw, ipt){
  86.     hg.id <- paste(hg, '_id', sep = '')
  87.     lw.id <- paste(lw, '_id', sep = '')
  88.     inp.obj <- paste('cbo_', tb, '_', hg, sep = '')
  89.     ui.list <- c('TOTAL')
  90.     if(ipt != 'TOTAL'){
  91.         ui.list <- as.list(unique(hospitals[get(hg.id) == ipt][order(get(lw))][, get(lw.id)]))
  92.         names(ui.list) <- unique(hospitals[get(hg.id) == ipt][order(get(lw))][, get(lw)])
  93.     }
  94.     if(length(ui.list) > 1) ui.list <- c('TOTAL', ui.list)
  95.     return(ui.list)
  96. }
  97. # Build the title for most substabs
  98. 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){
  99.     ttl <-
  100.         if(is.Y.ref){
  101.             paste( metrics[label == var.Y, title], ifelse(has.pct, '(%)', ''))
  102.         } else {
  103.             clear.label(var.Y)
  104.         }
  105.     ttl <- paste( ttl, 'by', var.X )
  106.     if(!is.na(var.X2)) ttl <-  paste(ttl, 'and', var.X2)
  107.     if(!is.na(fnl.area)) ttl <-  paste(ttl, 'in', fnl.area)
  108.     if(var.G1 != 'NONE')
  109.         ttl <-  paste0(
  110.                     ttl, '<br/>',
  111.                     'Grouped by ', clear.label(var.G1), if(var.G2 != 'NONE'){ paste(' and', clear.label(var.G2)) }
  112.                 )
  113.     if(var.F != 'NONE'){
  114.         if(val.F != 'NONE')
  115.             ttl <-  paste0(
  116.                         ttl, '<br/>',
  117.                         'Filtered by ', clear.label(var.F), ' = <i>', lookups[domain_id == gsub('X', '', var.F) & lookup_id == val.F, description], '</i>'
  118.             )
  119.     }
  120.     trimws(gsub('  ', ' ', ttl))
  121. }
  122. # Return filter and function for a metric, according to "normal" or "percentage" behaviour
  123. mtc.parsed <- function(mtc, pct = FALSE){
  124.     if(!pct){
  125.         F <- metrics[label == eval(mtc), filter_by]
  126.         M <- metrics[label == eval(mtc), mutate_as]
  127.     } else {
  128.         F <- metrics[label == eval(mtc), filter_pct]
  129.         M <- metrics[label == eval(mtc), mutate_pct]
  130.     }
  131.     return( parse(text = c(F, M) ) )
  132. }
  133. # Given a categorical var id (without the leading "X") and one or some of its ids, return the corresponding label(s)
  134. get.Xlabel <- function(x.id, x.val = 1){
  135.     x.id <- as.numeric(gsub('X', '', x.id))
  136.     lookups[domain_id == x.id & lookup_id %in% x.val, description]
  137. }
  138. # Renames the dataset for pivot table
  139. mydt.rename <- function(dt){
  140.     nm <- names(dt)[substr(names(dt), 1, 1) == 'X']
  141.     nm <- c('HSP_id', 'HSP', 'CCG', 'LAT', 'NHSR', 'CCR', 'CTRY', paste('datec.', c('day', 'week', 'month', 'quarter', 'year'), sep = ''), nm)
  142.     dt <- dt[, nm, with = FALSE]
  143.     m1 <- as.data.table(names(dt), key = 'V1')
  144.     m2 <- data.table(lookups[domain_id <= 1, .( old = paste('X', lookup_id, sep = ''), new = description ) ], key = 'old')
  145.     names(dt) <- m2[m1][is.na(new), new := old][, new]
  146.     setnames(dt,
  147.         c('HSP_id','HSP', 'CCG', 'LAT', 'NHSR', 'CCR', 'CTRY', 'datec.day', 'datec.week', 'datec.month', 'datec.quarter', 'datec.year'),
  148.         c('Hospital_code','Hospital', 'Comm. Group', 'Area Team', 'NHS Region', 'Comm. Region', 'Country', 'day', 'week', 'month', 'quarter', 'year')
  149.     )
  150.     dt
  151. }
  152. # Returns a renamed dataset after specifying columns and optionally records to retain
  153. get.dt.renamed <- function(columns, records = NA){
  154.     columns <- c('HSP_id', 'HSP', 'datec.day', columns[substr(columns, 1, 1) == 'X'])
  155.     if(is.na(records)){
  156.         dt <- dataset[, columns, with = FALSE]
  157.     } else {
  158.         dt <- dataset[HSP_id %in% records, columns, with = FALSE]
  159.     }
  160.     m1 <- as.data.table(names(dt), key = 'V1')
  161.     m2 <- data.table(lookups[domain_id <= 1, .( old = paste('X', lookup_id, sep = ''), new = description ) ], key = 'old')
  162.     names(dt) <- m2[m1][is.na(new), new := old][, new]
  163.     dt[, Hospital := paste(HSP_id, '-', HSP)]
  164.     dt[, `:=`(HSP_id = NULL, HSP = NULL)]
  165.     setnames(dt, 'datec.day', 'day')
  166.     setcolorder(dt, c('Hospital', setdiff(names(dt), 'Hospital')))
  167.     dt[order(Hospital, -day)]
  168. }
  169. # Renames the exporting dataset for easier reading
  170. dt.for.export <- function(dt){
  171.     fld2save <- c('date.day', 'date.hour', 'datec.month', 'datec.quarter', 'date.year', 'HSP_id', 'HSP', 'CCG', 'LAT', 'NHSR', 'CCR', 'CTRY')
  172.     fld2name <- c('day', 'hour', 'month', 'quarter', 'year', 'hospital_code', 'hospital', 'Comm. Group', 'Area Team', 'NHS Region', 'Comm. Region', 'Country')
  173.     for(idx in 1:length(names(dt))){
  174.         if(substr(names(dt)[idx], 1, 1) == 'X'){
  175.             fld2save <- c(fld2save, names(dt)[idx])
  176.             fld2name <- c(fld2name, lookups[lookup_id == substr(names(dt)[idx], 2, nchar(names(dt)[idx])), description ])
  177.         }
  178.     }
  179.     dt <- dt[, fld2save, with = FALSE]
  180.     setnames(dt, fld2save, fld2name)
  181.     dt
  182. }
  183. # Clean the filename, keep only alphanum, dash and underline
  184. filename.clean <- function(fn){
  185.     fn <- gsub('[ \\.]', '-', fn)
  186.     gsub('[^[:alnum:]_-]', '', fn)
  187. }
  188. # Clean the title of the plot for exporting
  189. plot.title.clean <- function(fn){
  190.     fn <- gsub('<br/>', '\n', fn)
  191.     fn <- gsub('<(.*)>', '', fn)
  192.     fn
  193. }
  194. # Trim a dataset based on the values of (usually) a slider input wrt some quantity
  195. shrink.dataset <- function(dt, field.from, quant.obj){
  196.     setnames(dt, field.from, 'quantity')
  197.     limInfQuant <- as.numeric(quant.obj)[1]/100
  198.     limSupQuant <- as.numeric(quant.obj)[2]/100
  199.     if(limInfQuant > 0 | limSupQuant < 1)
  200.     dt <- dt[ quantity >= quantile(quantity, limInfQuant, na.rm = TRUE) & quantity <= quantile(quantity, limSupQuant, na.rm = TRUE) ]
  201.     setnames(dt, 'quantity', field.from)
  202.     return(dt)
  203. }
  204. # delete number of item in questionaire from label
  205. clear.label <- function(lbl){
  206.     lbl <- vars[lookup_id == eval(lbl), description]
  207.     if(grepl('^[[:digit:]]', lbl)) return( substr(lbl, regexpr(' ', lbl) + 1, nchar(lbl)) )
  208.     lbl
  209. }
  210. # return the correct expression for the ggplot mapping argument
  211. get.list.aes <- function(lst.aes) {
  212.     if(!length(lst.aes)) return(NULL)
  213.     result <- 'aes('
  214.     for(idx in 1:length(lst.aes)) result <- paste0(result, names(lst.aes[idx]), ' = ', lst.aes[[idx]], ', ')
  215.     result <- paste0(substr(result, 1, nchar(result) - 2), ')')
  216.     eval(parse(text = result))
  217. }
  218. # convert a ggplot into its corresponding interactive plot from ggiraph extension
  219. gg.to.ggiraph <- function(p, sel.type = 'single', gg.width = 0.8){
  220.         ggiraph( code = {print(p)},
  221.             width  = gg.width,
  222.             zoom_max  = 1,
  223.             selection_type = sel.type,
  224.             # selected_css = "",
  225.             tooltip_offx = 20, tooltip_offy = -10,
  226.             hover_css = "fill:red;cursor:pointer;r:4pt;opacity-value:0.5;",
  227.             tooltip_extra_css= "background-color:wheat;color:gray20;border-radius:10px;padding:3pt;",
  228.             tooltip_opacity = 0.9,
  229.             pointsize = 12
  230.         )
  231. }
  232. # calculate both funnel plot limits based on given "total" probability and maximum effect size
  233. get.funnel.limits <- function(plevel, maxn, theta1, theta2 = NULL){
  234.     ord.magn <- ifelse(nchar(maxn) <= 4, 1, nchar(maxn) - 3)
  235.     my.funnel <- data.table(x = seq(1, pretty(maxn)[2], 10^(ord.magn - 1) ) )
  236.     plevel.inf <- (1 - plevel)/2
  237.     plevel.sup <- plevel + plevel.inf
  238.     if(!is.null(theta2)){
  239.         my.funnel[, liminf := qnorm(plevel.inf, theta1, theta2/sqrt(x)) ]
  240.         my.funnel[, limsup := qnorm(plevel.sup, theta1, theta2/sqrt(x)) ]
  241.     } else {
  242.         my.funnel[, nu := qbinom(plevel.inf, x, theta1) ]
  243.         my.funnel[, num := ( pbinom(nu, x, theta1) - plevel.inf ) ]
  244.         my.funnel[, den := ( pbinom(nu, x, theta1) - pbinom(nu - 1, x, theta1) ) ]
  245.         my.funnel[, alpha := num / den ]
  246.         my.funnel[, liminf := (nu - alpha) / x ]
  247.         my.funnel[, nu := qbinom(plevel.sup, x, theta1) ]
  248.         my.funnel[, num := ( pbinom(nu, x, theta1) - plevel.sup ) ]
  249.         my.funnel[, den := ( pbinom(nu, x, theta1) - pbinom(nu - 1, x, theta1) ) ]
  250.         my.funnel[, alpha := num / den ]
  251.         my.funnel[, limsup := (nu - alpha) / x ]
  252.     }
  253.     return(my.funnel[, .(x, liminf, limsup) ])
  254. }
  255. # recode multiple fields as ordered factors, using themselves or the lookup table as reference for the labels/levels
  256. recode.factors <-  function(dt, flds, lkps = FALSE){
  257.     for(fn in flds){
  258.         if(lkps){
  259.             lk <- sub('X', '', fn)
  260.             lvls <- lookups[domain_id == lk, lookup_id ]
  261.             lbls <- lookups[domain_id == lk, description ]
  262.         } else {
  263.             lvls <- sort(unique(dt[[fn]]))
  264.             lvls <- lvls[!(lvls %in% c(NA))]
  265.             lbls <- lvls
  266.         }
  267.         dt[, (fn) := factor(dt[[fn]], levels = lvls, labels = lbls, ordered = TRUE) ]
  268.     }
  269. }
  270. # get long name of day/month starting from 3-chars name
  271. get.longname <- function(shortname){
  272.     longname <- lookups[domain_id == 200091 & lookup_id == lookups[domain_id == 200092 & description == shortname, lookup_id], description]
  273.     if(length(longname) > 0) return(longname)
  274.     longname <- lookups[domain_id == 200093 & lookup_id == lookups[domain_id == 200094 & description == shortname, lookup_id], description]
  275.     if(length(longname) > 0) return(longname)
  276.     shortname
  277. }
  278. vget.longname <- Vectorize(get.longname)
  279. # get the summary dataset for the different tabs V1
  280. get.y.tms <- function(dt, var.Y, var.X = NA, grp1 = NA, grp2 = NA, tt = NULL, pct = FALSE, flt.var = NA, flt.val = NA){
  281.     # retrieve formulas for calculate the metric  
  282.     mtc.def <- mtc.parsed(var.Y, pct)
  283.     # apply the filter that define the metric
  284.     y <- dt[ eval(mtc.def[1]) ]
  285.     # if needed, determine the independent var X
  286.     if(!is.na(var.X)) y[, X := get(var.X) ][!is.na(X)]
  287.     # if needed, filter over the specified variable
  288.     if(!is.na(flt.var)){
  289.         if(flt.val != 'NONE'){
  290.             flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
  291.             y <- y[ get(flt.var) == flt.lbl ]
  292.         }
  293.     }
  294.     # calculate the metrics
  295.     if(is.na(grp1)){
  296.         # ungrouped case
  297.         y <- y[, .( Y = eval(mtc.def[2]) ), X ][, G := 1]
  298.     } else {
  299.        if(is.na(grp2)){
  300.             # grouped case, one grouping var
  301.             y <- y[, G := get(grp1) ][!(G %in% labels.del)][, .( Y = eval(mtc.def[2]) ), .(X, G) ]
  302.         } else {
  303.             # grouped case, two grouping vars
  304.             y <- y[, G1 := get(grp1) ][!(G1 %in% labels.del)][, G2 := get(grp2) ][!(G2 %in% labels.del)]
  305.             y <- y[, .( Y = eval(mtc.def[2]) ), .(X, G1, G2) ][, G := 1]
  306.         }
  307.     }
  308.     # if needed, calculate the tooltip
  309.     if(!is.null(tt))
  310.         y[, ttip := paste0(
  311.                         if(!is.na(tt[1])){ paste0('<b>', tt[1], '</b><br/>') },
  312.                         tt[2], ': <b>', X, '</b><br/>',
  313.                         if(!is.na(grp1)){
  314.                             if(is.na(grp2)){
  315.                                 paste0(clear.label(grp1), ': <b>', G, '</b><br/>')
  316.                             } else {
  317.                                 paste0(clear.label(grp1), ': <b>', G1, '</b><br/>', clear.label(grp2), ': <b>', G2, '</b><br/>')
  318.                             }
  319.                         },
  320.                         metrics[label == var.Y, title], ': <b>', if(pct) { paste0(100*Y, '%') } else {Y}, '</b>'
  321.         )]
  322.     return(y)
  323. }
  324. # return the summary dataset to display in the "table" subtab
  325. get.dt.tbl <- function(dt,
  326.                 tblY, lblX, fld.to.order = NA, ord.desc = FALSE, is.time = FALSE,
  327.                 col.bars = '#80cdc1', col.fonts = 'black', pal.scale = 'Spectrum', n.cols = 7, reverse = FALSE,
  328.                 flt.var = NA, flt.val = NA, grp.var = NA, grp.type = NA, grp.stype = NA
  329.     ){
  330.     ## A1- DETERMINE THE MAIN DATASET -----------------------------------------------------------------------
  331.     # Tables display following columns:
  332.     #  - type =  1 (quantities) : 'Count', 'Quota'
  333.     #  - type =  2 (measure)    : 'Count', 'Quota', 'Percent', 'Index'
  334.     #  - type >= 3 (metrics)    : 'Value', 'Index'
  335.         # filtering
  336.         if(!is.na(flt.var)){
  337.             if(!is.na(flt.val)){
  338.                 flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
  339.                 dt <- dt[ get(flt.var) == flt.lbl ]
  340.             }
  341.         }
  342.         # query the type of the variable
  343.         var.type <- min(3, metrics[label == tblY, type])    
  344.         # query filter and formula for counting  (type = 1) and metrics (type >= 3)
  345.         YF <- metrics[label == tblY, filter_by]
  346.         YM <- metrics[label == tblY, mutate_as]
  347.         # filter the dataset for the main table
  348.         y <- dt[eval( parse(text = YF) )]
  349.         # calculate and store total if metric
  350.         if(var.type == 3) yt <- y[, eval( parse(text = YM) ) ]
  351.         # calculate counting or metric
  352.         if(is.time){
  353.             y <- y[ , .( m = eval( parse(text = YM) ) ), X ][order(-X)]
  354.         } else {
  355.             y <- y[ , .( m = eval( parse(text = YM) ) ), .( X = as.character(X) ) ]
  356.         }
  357.         if(var.type == 3){
  358.             # calculate Index if metric
  359.             y[, yt := yt][, Index := round(m / yt, 4)][, yt := NULL]
  360.         } else {
  361.             # calculate and store total if counting
  362.             yt <- y[, sum(m)]
  363.             y[, Quota := round(m / sum(m), 4)]
  364.         }
  365.         # define row for the total
  366.         df.total <- data.frame('TOTAL', yt, NA)
  367.         if(var.type == 2){
  368.             # calculataion percentages as above if measure (type = 2)
  369.             YFP <- metrics[label == tblY, filter_pct]
  370.             YMP <- metrics[label == tblY, mutate_pct]
  371.             yp <- dt[eval( parse(text = YFP) )]
  372.             ytp <- yp[, eval( parse(text = YMP) ) ]
  373.             yp <- yp[ , .( m = eval( parse(text = YMP) ) ), .( X = as.character(X) ) ]
  374.             yp[, ytp := ytp][, Index := round(m / ytp, 4)][, ytp := NULL]
  375.             setkey(y, 'X')
  376.             setkey(yp, 'X')
  377.             y <- y[yp]
  378.             df.total <- data.frame('TOTAL', yt, NA, ytp, NA)
  379.         }
  380.         # order table according to user choices: variable + type
  381.         setnames(y, c(lblX, tbl.headings[[var.type]]))
  382.         if(!is.na(fld.to.order)) y <- y[order(get(fld.to.order), decreasing = ord.desc)]
  383.         # add total row at the top
  384.         y <- rbindlist(list( df.total, y) )
  385.         # rename columns
  386.         setnames(y, c(lblX, tbl.headings[[var.type]]))
  387.  
  388.     ## A2- IF REQUESTED, DETERMINE AND ADD TO THE ABOVE THE GROUP DATASET -----------------------------------
  389.     # Tables display following columns:
  390.     #  - type = 1 (quantities):
  391.     #    - 'Count'
  392.     #    - 'Quota': vs Total National, vs Grouped Item
  393.     #  - type =  2 (measure)    : 'Count', 'Quota', 'Percent', 'Index'
  394.     #    - 'Count'
  395.     #    - 'Quota': vs Total National, vs Grouped Item
  396.     #    - 'Percentage': vs Total National, vs Grouped Item
  397.     #    - 'Index' (vs Grouped Items only)
  398.     #  - type >= 3 (metrics)'', ''
  399.     #    - 'Value'
  400.     #    - 'Index' (vs Grouped Items only)
  401.         if(!is.na(grp.var)){
  402.             dt[, G := get(grp.var) ]
  403.             yg <- dt[!(G %in% labels.del)][eval( parse(text = YF) )]
  404.             if(var.type == 1){
  405.                 yg <- yg[, .( m = eval( parse(text = YM) ) ), .( X = as.character(X), G ) ]
  406.                 yg <- dcast.data.table(yg, X~G, value.var = 'm', fill = 0)
  407.                 yn <- names(yg)
  408.                 yg <- rbindlist( list( data.frame('TOTAL', yg[, lapply(.SD, sum), .SDcols = 2:ncol(yg)]), yg) )
  409.                 names(yg) <- yn
  410.                 y <- merge(y, yg, by.x = lblX, by.y = 'X')
  411.                 if(grp.type == 'Quota'){
  412.                     y[, T := rowSums(y[,4:ncol(y), with = FALSE])]
  413.                     yq <-
  414.                         if(grp.stype == 'R'){
  415.                             y[, lapply(.SD, function(x) round(x/T, 4)), .SDcols = 4:ncol(y)]
  416.                         } else if(grp.stype == 'C'){
  417.                             y[, lapply(.SD, function(x) round(x/x[1], 4)), .SDcols = 4:ncol(y)]
  418.                            
  419.                         } else {
  420.                             y[, lapply(.SD, function(x) round(x/sum(T[2:.N]), 4)), .SDcols = 4:ncol(y)]
  421.                         }
  422.                     yq[, T := NULL]
  423.                     if(grp.stype == 'C') yq[1, names(yq) := NA]
  424.                     y <- cbind(y[, 1:3], yq)
  425.                 }
  426.             } else if(var.type == 2){
  427.            
  428.             } else {
  429.                 ygt <- t(yg[, .( m = eval( parse(text = YM) ) ), G ][, m])
  430.                 yg <- yg[, .( m = eval( parse(text = YM) ) ), .( X = as.character(X), G ) ]
  431.                 yg <- dcast.data.table(yg, X~G, value.var = 'm', fill = NA)
  432.                 yn <- names(yg)
  433.                 yg <- rbindlist( list( data.frame('TOTAL', ygt), yg) )
  434.                 names(yg) <- yn
  435.                 y <- merge(y, yg, by.x = lblX, by.y = 'X')
  436.                 if(grp.type == 'Index'){
  437.                     if(grp.stype == 'R'){
  438.                         yq <- y[, lapply(.SD, function(x) round(x/Value, 4)), .SDcols = 4:ncol(y)]
  439.                     } else if(grp.stype == 'C'){
  440.                         yq <- y[, lapply(.SD, function(x) round(x/x[1], 4)), .SDcols = 4:ncol(y)]
  441.                         yq[1, names(yq) := NA]
  442.                     }
  443.                     y <- cbind(y[, 1:3], yq)
  444.                 }
  445.             }
  446.         }
  447.        
  448.     ## B- BUILD THE TABLE -----------------------------------------------------------------------------------
  449.         t <- datatable(y,
  450.                 rownames = FALSE,
  451.                 selection = 'none',
  452.                 class = 'cell-border stripe hover nowrap',
  453.                 extensions = c('Buttons', 'FixedColumns', 'Scroller'),
  454.                 options = list(
  455.                     scrollX = TRUE,
  456.                     scrollY = 400,
  457.                     scroller = TRUE,
  458.                     buttons = c('copy', 'csv', 'excel', 'pdf', 'print'),
  459.                     fixedColumns = list(leftColumns = 1),
  460.                     ordering = FALSE,
  461.                     deferRender = TRUE,
  462.                     dom = 'Btip'
  463.                 )
  464.         )
  465.  
  466.     ## C- STYLE THE DATATABLE -------------------------------------------------------------------------------
  467.         if('Counting' %in% names(y)){
  468.             t <- t %>% formatCurrency('Counting', '', digits = 0)
  469.         }
  470.         if('Quota' %in% names(y)){
  471.             t <- t %>% formatPercentage('Quota', digits = 2)
  472.             t <- t %>% formatStyle('Quota',
  473.                             color = col.fonts,
  474.                             background = styleColorBar(y[, Quota], col.bars ),
  475.                             backgroundSize = '90% 70%', backgroundRepeat = 'no-repeat', backgroundPosition = 'center'
  476.             )
  477.         }
  478.         if('Percentage' %in% names(y)){
  479.             t <- t %>% formatPercentage('Percentage', digits = 2)
  480.             t <- t %>% formatStyle('Percentage',
  481.                             color = col.fonts,
  482.                             background = styleColorBar(y[, Percentage], col.bars ),
  483.                             backgroundSize = '90% 70%', backgroundRepeat = 'no-repeat', backgroundPosition = 'center'
  484.             )
  485.         }
  486.         if('Value' %in% names(y)){
  487.             t <- t %>% formatCurrency('Value', '', digits = 2)
  488.             t <- t %>% formatStyle('Value',
  489.                             color = col.fonts,
  490.                             background = styleColorBar(y[, Value], col.bars ),
  491.                             backgroundSize = '90% 70%', backgroundRepeat = 'no-repeat', backgroundPosition = 'center'
  492.             )
  493.         }
  494.         if('Index' %in% names(y)){
  495.             t <- t %>% formatCurrency('Index', '', digits = 3)
  496.             pal <- brewer.pal(n.cols + 1, pal.scale)
  497.             if(reverse) pal <- rev(pal)
  498.             t <- t %>% formatStyle('Index',
  499.                             backgroundColor = styleInterval(
  500.                                 quantile(y$Index, prob = seq(0, 1, length = n.cols + 1), na.rm = TRUE)[2:(n.cols + 1)],
  501.                                 pal
  502.                             )
  503.             )
  504.         }
  505.         if(!is.na(grp.var)){
  506.             tg.names <- names(y[, 4:ncol(y)])
  507.             tg.range <- y[2:nrow(y), 4:ncol(y)]
  508.             if(var.type == 1){
  509.                 if(grp.type == 'Counting'){
  510.                     t <- t %>% formatCurrency(tg.names, '', digits = 0)
  511.                     # if(grp.stype == 'T'){
  512.                     #     t <- t %>% formatStyle(tg.names,
  513.                     #                   background = styleColorBar(as.matrix(tg.range), 'lightblue'),
  514.                     #                   backgroundSize = '90% 80%',
  515.                     #                   backgroundRepeat = 'no-repeat',
  516.                     #                   backgroundPosition = 'center'
  517.                     #            )
  518.                     # }
  519.                 } else {
  520.                     t <- t %>% formatPercentage(tg.names, digits = 2)
  521.                 }
  522.             } else if(var.type == 2){
  523.                
  524.             } else {
  525.                 t <- t %>% formatCurrency(tg.names, '', digits = 2 + as.numeric(grp.type == 'Index'))
  526.             }
  527.         }
  528.         # format TOTAL first row as bigger font size, bold typeface.
  529.         t <- t %>% formatStyle(lblX, target = 'row',
  530.                             backgroundColor = styleEqual('TOTAL', 'black' ),
  531.                             color = styleEqual('TOTAL', 'white' ),
  532.                             fontWeight = styleEqual('TOTAL', 'bold'),
  533.                             fontSize = styleEqual('TOTAL', '130%' )
  534.         )
  535.  
  536.     ## RETURN -----------------------------------------------------------------------------------------------
  537.         t
  538. }
  539. # returns the summary dataset for the BARPLOT as a 2-elements list: 1st the dataset, 2nd the national total
  540. 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){
  541.     # retrieve formulas for calculate the metric  
  542.     mtc.def <- mtc.parsed(var.Y, pct)
  543.     # apply the filter that define the metric
  544.     y <- dt[ eval(mtc.def[1]) ]
  545.     # if needed, determine the independent var X
  546.     if(!is.na(var.X)) y[, X := get(var.X)][!is.na(X)]
  547. #    y[, X := as.character(X)]
  548.     # if needed, filter over the specified variable
  549.     if(!is.na(flt.var)){
  550.         if(flt.val != 'NONE'){
  551.             flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
  552.             y <- y[ get(flt.var) == flt.lbl ]
  553.         }
  554.     }
  555.     # calculate the metrics
  556.     if(is.na(grp1)){
  557.         # ungrouped case
  558.         yt <- as.numeric(y[, .( Y = eval(mtc.def[2]) ) ])
  559.         y <- y[, .( Y = eval(mtc.def[2]) ), X ][, G := 1]
  560.     } else {
  561.        if(is.na(grp2)){
  562.             # grouped case, one grouping var
  563.             y <- y[, G := get(grp1) ][!(G %in% labels.del)]
  564.             yt <- y[, .( Y = eval(mtc.def[2]) ), G ]
  565.             y <- y[, .( Y = eval(mtc.def[2]) ), .(X, G) ]
  566.             if(show.NA)
  567.                 y <- setDT(complete(y, X, nesting(G), fill = list(Y = 0) ) )
  568.         } else {
  569.             # grouped case, two grouping vars
  570.             y <- y[, G1 := get(grp1) ][!(G1 %in% labels.del)][, G2 := get(grp2) ][!(G2 %in% labels.del)]
  571.             yt <- y[, .( Y = eval(mtc.def[2]) ), .(G1, G2) ]
  572.             y <- y[, .( Y = eval(mtc.def[2]) ), .(X, G1, G2) ][, G := 1]
  573.         }
  574.     }
  575.     # if needed, calculate the tooltip
  576.     if(!is.null(tt))
  577.         y[, ttip := paste0(
  578.                         if(!is.na(tt[1])){ paste0('<b>', tt[1], '</b><br/>') },
  579.                         tt[2], ': <b>', X, '</b><br/>',
  580.                         if(!is.na(grp1)){
  581.                             if(is.na(grp2)){
  582.                                 paste0(clear.label(grp1), ': <b>', G, '</b><br/>')
  583.                             } else {
  584.                                 paste0(clear.label(grp1), ': <b>', G1, '</b><br/>', clear.label(grp2), ': <b>', G2, '</b><br/>')
  585.                             }
  586.                         },
  587.                         metrics[label == var.Y, title], ': <b>', if(pct) { paste0(100*Y, '%') } else {Y}, '</b>'
  588.         )]
  589.     # cancel factor on X
  590.     y[, X := as.character(X)]
  591.     # order bars
  592.     y <- switch(ordering, '1' = y[order(X)], '2' = y[order(-X)], '3' = y[order(Y)], '4' = y[order(-Y)] )
  593.    
  594.     return( list(y, yt, ytg = NA, ytg2 = NA) )
  595. }
  596. # returns the summary dataset for the BOXPLOT as a 2-elements list: 1st the dataset, 2nd the outliers
  597. get.dt.bxp <- function(dt, var.Y, var.X = NA, grp1 = NA, grp2 = NA, tt = NULL, flt.var = NA, flt.val = NA){
  598.     cols = c('X')
  599.     y0 <- dt[, Y := get(var.Y) ]
  600.     if(!is.na(var.X)) y0[, X := get(var.X)][!is.na(X)]
  601.     if(!is.na(grp1)){
  602.         y0 <- y0[, G := get(grp1) ][!(G %in% labels.del)]
  603.         cols = c(cols, 'G')
  604.         if(!is.na(grp2)){
  605.             y0 <- y0[, G2 := get(grp2) ][!(G2 %in% labels.del)]
  606.             cols = c(cols, 'G2')
  607.         }
  608.            
  609.     }
  610.     # if needed, filter over the specified variable
  611.     if(!is.na(flt.var)){
  612.         if(flt.val != 'NONE'){
  613.             flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
  614.             y0 <- y0[ get(flt.var) == flt.lbl ]
  615.         }
  616.     }
  617.     y <- y0[, .SD, .SDcols = c(cols, 'Y')]
  618.     setkeyv(y, cols)
  619.     yt <- y[, .(V0 = sum(is.na(Y))), cols]
  620.     y <- y[!(Y %in% labels.del)]
  621.     yt <- yt[y[, .(
  622.                     V1 = .N, V2 = median(Y), V3 = quantile(Y)[2], V4 = quantile(Y)[4], V5 = IQR(Y), V6 = paste(range(Y), collapse = '-'),
  623.                     V11 = round(mean(Y), 2), V12 = round(sd(Y), 2)
  624.                   ),
  625.                   cols
  626.     ]]
  627.     yt <- yt[y[, .(V7 = sum( Y < (quantile(Y)[2] - IQR(Y) * 1.5) | Y > (quantile(Y)[4] + IQR(Y) * 1.5) )), cols ]]
  628.     yt[, ttip := as.factor(paste0(
  629.             tt, ': <b>', X, '</b><br/>',
  630.             if(!is.na(grp1)) paste0(clear.label(grp1), ': <b>', G, '</b><br/>'),
  631.             if(!is.na(grp2)) paste0(clear.label(grp2), ': <b>', G2, '</b><br/>'),
  632.             'N. Procedures: <b>', format(V1, big.mark = ','), '</b><br/><br/>',
  633.             toupper(clear.label(var.Y)), '<ul>',
  634.             '<li>Completeness: <b>', ifelse(V0 > 0, paste0('<font color="red">', paste0(round(100*(1-V0/(V0+V1)), 2), '%'), '</font>'), '100%'), '</b><br/>',
  635.             '<li>Median: <b>', V2, '</b><br/>',
  636.             '<li>1st quartile: <b>', V3, '</b><br/>',
  637.             '<li>3rd quartile: <b>', V4, '</b><br/>',
  638.             '<li>IQR: <b>', V5, '</b><br/>',
  639.             '<li>Range: <b>', V6, '</b><br/>',
  640.             '<li>N. Outliers: <b>', ifelse(V7 > 0, paste0('<font color="red">', V7, '</font>'), '--'), '</b><br/>',
  641.             '<li>Mean: <b>', V11, '</b><br/>',
  642.             '<li>St Dev: <b>', V12, '</b><br/></ul>'
  643.     ))]
  644.     y <- y[yt[, c(cols, 'ttip'), with = FALSE]]
  645.     # outliers        
  646.     y0[, D := datec.day]
  647.     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]
  648.     y.out[, ttip := paste0(
  649.                 tt, ': <b>', X, '</b><br/>',
  650.                 if(!is.na(grp1)) paste0(clear.label(grp1), ': <b>', G, '</b><br/>'),
  651.                 if(!is.na(grp2)) paste0(clear.label(grp2), ': <b>', G2, '</b><br/>'),
  652.                 clear.label(var.Y), ': ', Y, '<br/>',
  653.                 'Date of Procedure: ', D
  654.     )]
  655.     # cancel factor on X
  656.     y[, X := as.character(X)]
  657.    
  658.     return( list(y, y.out) )
  659. }
  660. # returns the summary dataset for the HEATMAPS
  661. 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){
  662.     # retrieve formulas for calculate the metric  
  663.     mtc.def <- mtc.parsed(var.Y, pct)
  664.     # apply the filter that define the metric
  665.     y <- dt[ eval(mtc.def[1]) ]
  666.     # if needed, determine the independent vars X and X2
  667.     if(!is.na(var.X)) y[, X := get(var.X)][!is.na(X)]
  668.     if(!is.na(var.X2)) y[, X2 := get(var.X2)][!is.na(X2)]
  669.     # if needed, filter over the specified variable
  670.     if(!is.na(flt.var)){
  671.         if(flt.val != 'NONE'){
  672.             flt.lbl <- lookups[domain_id == gsub('X', '', flt.var) & lookup_id == flt.val, description]
  673.             y <- y[ get(flt.var) == flt.lbl ]
  674.         }
  675.     }
  676.     # calculate the metrics
  677.     if(is.na(grp1)){
  678.         # ungrouped case
  679.         y <- y[, .( Y = eval(mtc.def[2]) ), .(X, X2) ]
  680.         if(show.NA) y <- setDT(complete(y, X, nesting(X2)) )
  681.     } else {
  682.        if(is.na(grp2)){
  683.             # grouped case, one grouping var
  684.             y <- y[, G := get(grp1) ][!(G %in% labels.del)]
  685.             y <- y[, .( Y = eval(mtc.def[2]) ), .(X, X2, G) ]
  686.             if(show.NA) y <- setDT(complete(y, X, nesting(X2, G) ) )
  687.         } else {
  688.             # grouped case, two grouping vars
  689.             y <- y[, G1 := get(grp1) ][!(G1 %in% labels.del)]
  690.             y <- y[, G2 := get(grp2) ][!(G2 %in% labels.del)]
  691.             y <- y[, .( Y = eval(mtc.def[2]) ), .(X, X2, G1, G2) ][, G := 1]
  692.             if(show.NA) y <- setDT(complete(y, X, nesting(X2, G1, G2) ) )
  693.         }
  694.     }
  695.     # calculate the tooltip
  696.     if(length(tt)){
  697.         y[, ttip := paste0(
  698.                         tt[1], ': <b>', X, '</b><br/>',
  699.                         tt[2], ': <b>', X2, '</b><br/>',
  700.                         if(!is.na(grp1)){
  701.                             if(is.na(grp2)){
  702.                                 paste0(clear.label(grp1), ': <b>', G, '</b><br/>')
  703.                             } else {
  704.                                 paste0(clear.label(grp1), ': <b>', G1, '</b><br/>', clear.label(grp2), ': <b>', G2, '</b><br/>')
  705.                             }
  706.                         },
  707.                         metrics[label == var.Y, title], ': <b>', if(pct) { paste0(100*Y, '%') } else {Y}, '</b>'
  708.         )]
  709.     }
  710.     # Rescaling along X-geo or X2-time
  711.     if(!is.na(mtc.rescale)) y <- setDT( ddply(y, .(get(mtc.rescale)), transform, Y = round(rescale(Y) * 100, 0) ) )
  712.     if(ordering){
  713.         # cancel factor on X
  714.         y[, X := as.character(X)]
  715.         # order bars
  716.         y <- switch(ordering, '1' = y[order(X)], '2' = y[order(-X)], '3' = y[order(Y)], '4' = y[order(-Y)] )
  717.     }    
  718.     return( list(y, yt = NA, ytg = NA, ytg2 = NA) )
  719. }
  720.  
  721. # return only the X-items with positions indicated by vals
  722. trim.dt.X <- function(dt, vals){
  723.     if(length(vals) == 0) vals <- c(1, length(unique(dt$X)))
  724.     y <- dt[X %in% unique(dt$X)[vals[1]:vals[2] ] ]
  725.     y$X <- factor(y$X, levels = unique(y$X))
  726.     return(y)
  727. }
  728. # return only the X-items with positions indicated by vals
  729. trim.dt.X.bxp <- function(dt, vals, ordering){
  730.     if(length(vals) == 0) vals <- c(1, length(unique(dt$X)))
  731.     yo <- switch(ordering,
  732.             '1' = unique(dt[, .(X)])[order(X)][vals[1]:vals[2] ],
  733.             '2' = unique(dt[, .(X)])[order(-X)][vals[1]:vals[2] ],
  734.             '3' = dt[, median(Y), X][order(V1), .(X)][vals[1]:vals[2] ],
  735.             '4' = dt[, median(Y), X][order(-V1), .(X)][vals[1]:vals[2] ]
  736.     )
  737.     yo <- unlist(yo)
  738.     y <- dt[X %in% yo]
  739.     return( list(y, yo) )
  740. }
  741.  
  742. # embellish the dataset to be downloaded from the user as CSV file
  743. dt.csv.output <- function(dt){
  744.     y <- copy(dt)
  745.     y[, `:=`(ttip = NULL, data_id = NULL, clk = NULL)]
  746. }
  747.  
  748.  
  749.  
  750. #===== OPTIONAL TABS ------------------------------------------------------------------------------------------------------------
  751.  
  752. #
  753. if(load.tabs['consultants', status]){    
  754.    
  755. }
  756.  
  757. #
  758. if(load.tabs['patients', status]){    
  759.    
  760. }
  761.  
  762. # Build Completeness table, with all different areas and timespans
  763. if(load.tabs['completeness', status]){
  764.     cmp.tbl <- data.table()
  765.     for(itm in 1:nrow(completeness)){
  766.         W = parse(text = paste0(completeness[itm, filter_by]))
  767.         cmp.tbl <- rbindlist(list(
  768.             cmp.tbl,
  769.             cbind(
  770.                 item = completeness[itm, item],
  771.                 dataset[,
  772.                     .( count = sum( eval(W) ), total = .N ),
  773.                     .(HSP_id, year = date.year, quarter = date.quarter, month = date.month)
  774.                 ][order(HSP_id, month)]
  775.             )
  776.         ))
  777.     }
  778.     setkey(cmp.tbl, 'HSP_id')
  779.     setkey(hospitals, 'HSP_id')
  780.     cmp.tbl <- cmp.tbl[hospitals[, .(HSP_id, CCG_id, CTRY_id) ] ]
  781. }
  782.  
  783.  
  784. #===== VARIABLES/LABELS ----------------------------------------------------------------------------------------------------------------
  785.  
  786. # List for the GEOGRAPHY combo box
  787. locations <- c(
  788.     'Country' = 'CTRY', 'Comm. Region' = 'CCR', 'NHS Region' = 'NHSR',  'Area Team' = 'LAT', 'Comm. Group' = 'CCG', 'Hospital' = 'HSP'
  789. )
  790. # List for the TIME REFERENCE single period in heatmaps hospitals
  791. timeref <- c(
  792.     'Year' = 'datec.year', 'Quarter' = 'datec.quarter', 'Month of Year' = 'month_st',
  793.     'Day of Month' = 'day_nid', 'Day of Week' = 'day_st', 'Daypart' = 'daypart', 'Hour of Day' = 'date.hour'
  794. )
  795. # List for the TIME REFERENCE single period in timeseries
  796. timeper <- c(
  797.     'Year' = 'datec.year', 'Quarter' = 'datec.quarter', 'Month' = 'datec.month', 'Week' = 'datec.week', 'Day' = 'datec.day'
  798. )
  799. # List for the DATES double combo
  800. date.range <- c(
  801.     start = max(dataset$date.day) - 365*3 - 1,
  802.     min   = min(dataset$date.day),
  803.     max   = max(dataset$date.day)
  804. )
  805. # Values to delete from labels
  806. labels.del <- c(
  807.     'Unknown', 'Not Applicable', 'Not measured', 'Not known', 'Not specified', NA, ''
  808. )
  809. # List of Function to apply to numeric measures
  810. fun.measures <- c(
  811.     'Mean' = 'mean', 'Minimum' = 'min', 'Maximum' = 'max', 'Interquartile Range' = 'IQR', 'Standard Deviation' = 'sd'
  812. )
  813. # Default color/palette
  814. pal.default <- c('col' = 'steelblue3', 'cat' = 'Dark2', 'seq' = 'YlGnBu', 'div' = 'RdBu', 'na' = 'grey62')
  815. # List of palettes to be used with ColourBrewer package:  
  816. lst.palette <- list(
  817.     'SEQUENTIAL' = c( # ordinal data where (usually) low is less important and high is more important
  818.         'Blues' = 'Blues', 'Blue-Green' = 'BuGn', 'Blue-Purple' = 'BuPu', 'Green-Blue' = 'GnBu', 'Greens' = 'Greens', 'Greys' = 'Greys',
  819.         'Oranges' = 'Oranges', 'Orange-Red' = 'OrRd', 'Purple-Blue' = 'PuBu', 'Purple-Blue-Green' = 'PuBuGn', 'Purple-Red' = 'PuRd', 'Purples' = 'Purples',
  820.         'Red-Purple' = 'RdPu', 'Reds' = 'Reds', 'Yellow-Green' = 'YlGn', 'Yellow-Green-Blue' = 'YlGnBu', 'Yellow-Orange-Brown' = 'YlOrBr',
  821.         'Yellow-Orange-Red' = 'YlOrRd'
  822.     ),
  823.     'DIVERGING' = c(  # ordinal data where both low and high are important (i.e. deviation from some reference "average" point)
  824.         'Brown-Blue-Green' = 'BrBG', 'Pink-Blue-Green' = 'PiYG', 'Purple-Red-Green' = 'PRGn', 'Orange-Purple' = 'PuOr', 'Red-Blue' = 'RdBu', 'Red-Grey' = 'RdGy',
  825.         'Red-Yellow-Blue' = 'RdYlBu', 'Red-Yellow-Green' = 'RdYlGn', 'Spectral' = 'Spectral'
  826.     ),  
  827.     'QUALITATIVE' = c(  # categorical/nominal data where there is no logical order
  828.         'Accent' = 'Accent', 'Dark2' = 'Dark2', 'Paired' = 'Paired', 'Pastel1' = 'Pastel1', 'Pastel2' = 'Pastel2',
  829.         'Set1' = 'Set1', 'Set2' = 'Set2', 'Set3' = 'Set3'
  830.     )
  831. )
  832. # list of labels for download buttons
  833. 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')
  834. # list of options for charts
  835. point.shapes <- c('circle' = 21, 'square' = 22, 'diamond' = 23, 'triangle up' = 24, 'triangle down' = 25)
  836. line.types <- c('dashed', 'dotted', 'solid', 'dotdash', 'longdash', 'twodash')
  837. face.types <- c('plain', 'bold', 'italic', 'bold.italic')
  838. val.lbl.pos <- list(
  839.     'Inside'  = list('Vertical' = c(0.5,  1.5), 'Horizontal' = c( 1.2, 0.2) ),
  840.     'Outside' = list('Vertical' = c(0.4, -0.3), 'Horizontal' = c(-0.2, 0.2) )
  841. )
  842. lbl.format <- function(y, type, is.pct = FALSE){
  843.     if(type == 1){
  844.         format(y, big.mark = ',', nsmall = 0)
  845.     } else if(type == 2){
  846.         if(is.pct){
  847.             paste0(format(round(100 * y, 2), nsmall = 2), '%')
  848.         } else {
  849.             format(y, big.mark = ',', nsmall = 0)
  850.         }    
  851.     } else {
  852.         format(y, nsmall = 2)
  853.     }
  854. }
  855. # default probabilities and colors for funnel plots limits
  856. funnel.defaults <- list(
  857.     'prob.tot' = c('90%' = 0.9, '95%' = 0.95, '98.5%' = 0.985, '99%' = 0.99, '99.8%' = 0.998, '99.9%' = 0.999),
  858.     'prob.sel' = c(0.998, 0.95),
  859.     'col.tot' = c('green', 'red', 'blue', 'black', 'cyan', 'magenta', 'yellow', 'gray'),
  860.     'col.sel' = c('green', 'red'),
  861.     'type.tot' = line.types,
  862.     'type.sel' = c('solid', 'dotted')  
  863. )
  864. # table headings
  865. tbl.headings <- list(
  866.     'cnt' = c('Counting', 'Quota'),
  867.     'mtc' = c('Counting', 'Quota', 'Percentage', 'Index'),
  868.     'msr' = c('Value', 'Index')
  869. )
  870. # table ordering variables
  871. tbl.orders <- list(
  872.     'cnt' = c('Counting'),
  873.     'mtc' = c('Counting', 'Percentage'),
  874.     'msr' = c('Value')
  875. )
  876. # plot caption
  877. plt.caption <- paste0('@', year(Sys.Date()), ' ATG')
  878.  
  879.  
  880. #===== STYLES ----------------------------------------------------------------------------------------------------------------
  881.  
  882. # add text at the left of the upper navbar
  883. navbarPageWithText <- function(..., text) {
  884.     navbar <- navbarPage(...)
  885.     textEl <- tags$p(class = "navbar-text", text)
  886.     navbar[[3]][[1]]$children[[1]] <- htmltools::tagAppendChild( navbar[[3]][[1]]$children[[1]], textEl)
  887.     navbar
  888. }
  889. # return correct spacing for axis labels rotation
  890. lbl.plt.rotation = function(angle, position = 'x'){
  891.     positions = list(x = 0, y = 90, top = 180, right = 270)
  892.     rads  = (angle - positions[[ position ]]) * pi / 180
  893.     hjust = 0.5 * (1 - sin(rads))
  894.     vjust = 0.5 * (1 + cos(rads))
  895.     element_text(angle = angle, vjust = vjust, hjust = hjust)
  896. }
  897. # global style for ggplot charts
  898. my.ggtheme <- function(g,
  899.                     xaxis.draw = FALSE, yaxis.draw = FALSE, axis.draw = FALSE, ticks.draw = FALSE, axis.colour = 'black', axis.size = 0.1,
  900.                     hgrid.draw = FALSE, vgrid.draw = FALSE, grids.colour = 'black', grids.size = 0.1, grids.type = 'dotted',
  901.                     labels.rotation = c(45, 0), labels.rotate = FALSE,
  902.                     bkg.colour = 'white', font.size = 6, ttl.font.size.mult = 1.2, ttl.face = 'bold',
  903.                     legend.pos = 'bottom', plot.border = FALSE, font.family = 'Arial'
  904.               ){
  905.     g <- g + theme(
  906.                 text             = element_text(family = font.family),
  907.                 plot.title       = element_text(hjust = 0, size = rel(1.2) ),  # hjust: 0-left, 0.5-center, 1-right
  908.                 plot.background  = element_blank(),
  909.                 plot.margin      = unit(c(1, 0.5, 0, 0.5), 'lines'),  # space around the plot as in: TOP, RIGHT, BOTTOM, RIGHT
  910.                 plot.caption     = element_text(size = 8, face = 'italic'),
  911.                 axis.line        = element_blank(),
  912.                 axis.ticks       = element_blank(),
  913.                 axis.text        = element_text(size = font.size, color = axis.colour),
  914.                 axis.text.x      = element_text(angle = labels.rotation[1], hjust = 1), # vjust = 0.5),
  915.                 axis.text.y      = element_text(angle = labels.rotation[2]), # , hjust = , vjust = ),
  916.                 axis.title       = element_text(size = font.size * (1 + ttl.font.size.mult), face = ttl.face),
  917.                 axis.title.x     = element_text(vjust = -0.3),
  918.                 axis.title.y     = element_text(vjust = 0.8, margin = margin(0, 10, 0, 0) ),
  919.                 legend.text      = element_text(size = 6),
  920.                 legend.title     = element_text(size = 8),
  921.                 legend.title.align = 1,
  922.                 legend.position  = legend.pos,
  923.                 legend.background = element_blank(),
  924.                 legend.spacing   = unit(0, 'cm'),
  925. #                legend.key = element_blank(),
  926.                 legend.key.size  = unit(0.2, 'cm'),
  927.                 legend.key.height = unit(0.4, 'cm'),      
  928.                 legend.key.width = unit(1, 'cm'),
  929.                 panel.background = element_rect(fill = bkg.colour, colour = bkg.colour),
  930.                 panel.border     = element_blank(),
  931.                 panel.grid       = element_blank(),
  932.                 panel.spacing.x  = unit(3, 'lines'),
  933.                 panel.spacing.y  = unit(2, 'lines'),
  934.                 strip.text       = element_text(hjust = 0.5, size = font.size * (1 + ttl.font.size.mult), face = ttl.face),
  935.                 strip.background = element_blank()
  936.     )
  937.     if(plot.border) g <- g + theme( panel.border = element_rect(colour = axis.colour, size = axis.size, fill = NA) )
  938.     if(axis.draw){
  939.         g <- g + theme( axis.line = element_line(color = axis.colour, size = axis.size ) )
  940.     } else {
  941.         if(xaxis.draw) g <- g + theme( axis.line.x = element_line(color = axis.colour, size = axis.size ) )
  942.         if(yaxis.draw) g <- g + theme( axis.line.y = element_line(color = axis.colour, size = axis.size ) )
  943.     }
  944.     if(ticks.draw)  g <- g + theme( axis.ticks = element_line(color = axis.colour, size = axis.size ) )
  945.     if(hgrid.draw & vgrid.draw){
  946.         g <- g + theme( panel.grid.major = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
  947.     } else{
  948.         if(vgrid.draw) g <- g + theme( panel.grid.major.x = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
  949.         if(hgrid.draw) g <- g + theme( panel.grid.major.y = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
  950.     }
  951.    if(labels.rotate){
  952.        g <- g + theme( axis.text.x = element_text(hjust = 1, angle = 45 ) )
  953.    }
  954.     return(g)
  955. }
  956.  
  957.  
  958. #===== MAPS ----------------------------------------------------------------------------------------------------------------
  959. proj.wgs <- '+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0'
  960. UK_centre <- c(-2.421976, 53.825564)
  961. UK_bounds <- c(-8.3, 49.9, 1.8, 59.0 )
  962.  
  963. # List for the MAPTILES combo box
  964. tiles.list <- as.list(maptiles[, url])
  965. names(tiles.list) <- maptiles[, name]
  966. tile.ini <- tiles.list$CartoDB.Positron
  967. loca.map <- c('CCG', 'LAT', 'NHSR', 'CCR', 'CTRY')
  968. loca.ini <- 'LAT'
  969. pal.ini <- 'Blues' # c("#CDC673", "#90EE90", "#20B2AA")
  970.  
  971. # icons for hospitals: green = nhs, red = private
  972. hsp.icons <- awesomeIcons(
  973.     icon = 'h-square',
  974.     library = 'fa',
  975.     squareMarker = TRUE,
  976.     markerColor = sapply(centres$type, function(x) if(x == 1){ "lightgreen" } else { "lightred" }),
  977.     iconColor = 'white'
  978. )
  979.  
  980. # list of classification methods, to be used with classInt and ColorBrewer packages
  981. class.methods <- c(
  982. #    'Fixed' = 'fixed',                  # need an additional argument fixedBreaks that lists the n+1 values to be used
  983.     'Equal Intervals' = 'equal',        # the range of the variable is divided into n part of equal space
  984.     'Quantiles' = 'quantile',           # each class contains (more or less) the same amount of values
  985. #    '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.
  986.     'Natural Breaks' = 'jenks',         # seeks to reduce the variance within classes and maximize the variance between classes
  987.     'Hierarchical Cluster' = 'hclust',  # Cluster with short distance
  988.     'K-means Cluster' = 'kmeans'        # Cluster with low variance and similar size
  989. )
  990.  
  991. # Read boundaries as shapefiles from files in www directory
  992. # boundaries <- lapply(loca.map, function(x) readOGR(shp.path, x))
  993. # names(boundaries) <- loca.map
  994. # for(m in loca.map){
  995. #     boundaries[[m]] <- merge(boundaries[[m]], areas[, .(ons_id, nhs_id, name)], by.x = 'id', by.y = 'ons_id')
  996. #     boundaries[[m]] <- merge(boundaries[[m]], centres[get(audit) == 1, .(H = .N), .(ons_id = get(paste0(m, '_ons')))], by.x = 'id', by.y = 'ons_id')
  997. # }
  998. # Read boundaries as unique list from rds shared rep
  999. boundaries <- readRDS(paste0(data.path, 'boundaries.rds'))
  1000. for(m in loca.map){
  1001.     boundaries[[m]] <- merge(boundaries[[m]], centres[get(audit) == 1, .(H = .N), .(ons_id = get(paste0(m, '_ons')))], by.x = 'id', by.y = 'ons_id')
  1002. }
  1003.  
  1004. # Determines the text intervals for the colours in the map legend
  1005. get.legend.colnames <- function(bnd, mtc.type, lbl.brks, ncols) {
  1006.     if(mtc.type == 1){
  1007.         lbl.brks <- format(round(lbl.brks, 0), big.mark = ',')
  1008.     } else if(mtc.type == 2){
  1009.         lbl.brks <- format(round(100*lbl.brks, 2), nsmall = 2)
  1010.     } else {
  1011.         lbl.brks <- format(round(lbl.brks, 1), nsmall = 1)
  1012.     }
  1013.     lbl.text <- sapply(2:ncols,
  1014.         function(x)
  1015.             paste0(
  1016.                 lbl.brks[x-1], ' \u2264 n < ', lbl.brks[x],
  1017.                 ' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[x-1])) & bnd$Y < as.numeric(gsub(',', '', lbl.brks[x])) ] ), ')'
  1018.             )
  1019.     )
  1020.     lbl.text <- c(lbl.text,
  1021.         paste0(
  1022.             lbl.brks[ncols], ' \u2264 n \u2264 ', lbl.brks[ncols + 1],
  1023.             ' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[ncols])) & bnd$Y <= as.numeric(gsub(',', '', lbl.brks[ncols + 1])) ] ), ')'
  1024.         )
  1025.     )
  1026. }
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!