API tools faq
paste
lvalnegri

srv_xxx.R

lvalnegri
May 16th, 2018
355
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 69.46 KB | None | 0 0
raw download clone embed print report
  1. ###################################################################################################
  2. # SHINY Explorer - XXX (xxx) - server.R
  3. ###################################################################################################
  4.  
  5. # TOGGLES -----------------------------------------------------------------------------------------------------------------------
  6. onclick('tgl_hsp_geo', toggle(id = 'hdn_hsp_geo', anim = TRUE) )  # geography
  7. onclick('tgl_hsp_tmp', toggle(id = 'hdn_hsp_tmp', anim = TRUE) )  # timespan
  8. onclick('tgl_hsp_mtc', toggle(id = 'hdn_hsp_mtc', anim = TRUE) )  # metrics
  9. onclick('tgl_hsp_opt', toggle(id = 'hdn_hsp_opt', anim = TRUE) )  # options
  10. onclick('tgl_hsp_dwn', toggle(id = 'hdn_hsp_dwn', anim = TRUE) )  # download
  11.  
  12. onclick('tgl_hsp_brp_gen', toggle(id = 'hdn_hsp_brp_gen', anim = TRUE) )           # options / bars / general
  13. onclick('tgl_hsp_brp_axs', toggle(id = 'hdn_hsp_brp_axs', anim = TRUE) )           # options / bars / axis
  14. onclick('tgl_hsp_brp_bkg', toggle(id = 'hdn_hsp_brp_bkg', anim = TRUE) )           # options / bars / background
  15. onclick('tgl_hsp_brp_brs', toggle(id = 'hdn_hsp_brp_brs', anim = TRUE) )           # options / bars / bars
  16. onclick('tgl_hsp_brp_lbl', toggle(id = 'hdn_hsp_brp_lbl', anim = TRUE) )           # options / bars / labels
  17. onclick('tgl_hsp_brp_avg', toggle(id = 'hdn_hsp_brp_avg', anim = TRUE) )           # options / bars / average line
  18.  
  19. onclick('tgl_hsp_bxp_gen', toggle(id = 'hdn_hsp_bxp_gen', anim = TRUE) )           # options / box / general
  20. onclick('tgl_hsp_bxp_axs', toggle(id = 'hdn_hsp_bxp_axs', anim = TRUE) )           # options / box / axis
  21. onclick('tgl_hsp_bxp_bkg', toggle(id = 'hdn_hsp_bxp_bkg', anim = TRUE) )           # options / box / background
  22. onclick('tgl_hsp_bxp_bxs', toggle(id = 'hdn_hsp_bxp_bxs', anim = TRUE) )           # options / box / boxes
  23. onclick('tgl_hsp_bxp_lns', toggle(id = 'hdn_hsp_bxp_lns', anim = TRUE) )           # options / box / lines
  24. onclick('tgl_hsp_bxp_out', toggle(id = 'hdn_hsp_bxp_out', anim = TRUE) )           # options / box / outliers
  25. onclick('tgl_hsp_bxp_avg', toggle(id = 'hdn_hsp_bxp_avg', anim = TRUE) )           # options / box / average line
  26.  
  27. onclick('tgl_hsp_hmp_gen', toggle(id = 'hdn_hsp_hmp_gen', anim = TRUE) )           # options / heat / general
  28. onclick('tgl_hsp_hmp_axs', toggle(id = 'hdn_hsp_hmp_axs', anim = TRUE) )           # options / heat / axis
  29. onclick('tgl_hsp_hmp_bxs', toggle(id = 'hdn_hsp_hmp_bxs', anim = TRUE) )           # options / heat / boxes
  30.  
  31. onclick('tgl_hsp_fnl_gen', toggle(id = 'hdn_hsp_fnl_gen', anim = TRUE) )           # options / scatter / general
  32. onclick('tgl_hsp_fnl_axs', toggle(id = 'hdn_hsp_fnl_axs', anim = TRUE) )           # options / scatter / axis
  33. onclick('tgl_hsp_fnl_bkg', toggle(id = 'hdn_hsp_fnl_bkg', anim = TRUE) )           # options / scatter / background
  34. onclick('tgl_hsp_fnl_pnt', toggle(id = 'hdn_hsp_fnl_pnt', anim = TRUE) )           # options / scatter / points
  35. onclick('tgl_hsp_fnl_lbl', toggle(id = 'hdn_hsp_fnl_lbl', anim = TRUE) )           # options / scatter / labels
  36. onclick('tgl_hsp_fnl_avg', toggle(id = 'hdn_hsp_fnl_avg', anim = TRUE) )           # options / scatter / average line
  37. onclick('tgl_hsp_fnl_fnl', toggle(id = 'hdn_hsp_fnl_fnl', anim = TRUE) )           # options / scatter / funnel limits
  38.  
  39. onclick('tgl_hsp_map_gen', toggle(id = 'hdn_hsp_map_gen', anim = TRUE) )           # options / maps / general
  40. onclick('tgl_hsp_map_pol', toggle(id = 'hdn_hsp_map_pol', anim = TRUE) )           # options / maps / areas
  41. onclick('tgl_hsp_map_pnt', toggle(id = 'hdn_hsp_map_pnt', anim = TRUE) )           # options / maps / points
  42.  
  43.  
  44. # DYNAMIC CONTROLS --------------------------------------------------------------------------------------------------------------
  45.  
  46. ### COMMON -----------------------------------------------------------------------------------------------------------------
  47. # Select months or dates range, only a change in formatting
  48. output$ui_hsp_tmp <- renderUI({
  49.     my.format <- ifelse(input$cbo_hsp_tmp == '3', 'dd-M-yyyy', 'M yyyy')
  50.     dateRangeInput('dts_hsp', 'DATE RANGE:',
  51.         start  = date.range['start'], end = date.range['max'],
  52.         min = date.range['min'], max = date.range['max'],
  53.         weekstart = 1, separator = '►', format = my.format
  54.     )
  55. })
  56. # Colour Choices
  57. ## Barplot
  58. output$ui_hsp_brp_col <- renderUI({
  59.     if(input$cbo_hsp_brpG != 'NONE')
  60.         if(input$cbo_hsp_brp_grp != 'facet') return( selectInput('pal_hsp_brp', 'FILL PALETTE:', choices = lst.palette, selected = 'Dark2') )
  61.     colourpicker::colourInput('col_hsp_brp', 'FILL COLOUR:', pal.default['col'], showColour = 'background')
  62. })
  63. ## Boxplot
  64. output$ui_hsp_bxp_col <- renderUI({
  65.     if(input$cbo_hsp_bxpG != 'NONE')
  66.         if(input$rdb_hsp_bxp_grp != 'facet') return( selectInput('pal_hsp_bxp', 'FILL PALETTE:', choices = lst.palette, selected = 'Dark2') )
  67.     colourpicker::colourInput('col_hsp_bxp', 'FILL COLOUR:', pal.default['col'], showColour = 'background')
  68. })
  69. ## Map: Point
  70. output$ui_hsp_mapZ_col <- renderUI({
  71.     if(!input$chk_hsp_map_hsp) return()
  72.     if(input$cbo_hsp_mapZ != 'NONE') return( selectInput('pal_hsp_mapZ', 'FILL PALETTE:', choices = lst.palette, selected = 'Dark2') )
  73.     colourpicker::colourInput('col_hsp_mapZ', 'FILL COLOUR:', pal.default['col'], showColour = 'background')
  74. })
  75.  
  76. ### TABLE (tbl) -----------------------------------------------------------------------------------------------------------------
  77. # Choose a value from the filtering variable
  78. output$ui_hsp_tbl_flt <- renderUI({
  79.     selectInput('cbo_hsp_tbl_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_tblF) ) ) )
  80. })
  81. # Choice of ordering when not grouped: CNT vs PCT vs QTA vs IDX depending on 1-Quantity, 2-Measure, 3-Metric
  82. output$ui_hsp_tbl_ord <- renderUI({
  83.     ui.list <- tbl.orders[[ min(3, metrics[label == input$cbo_hsp_tblY, type]) ]]
  84.     ui.list <- c(var.hsp.geo(), ui.list)
  85.     selectInput('cbo_hsp_tbl_ord', 'ORDER BY:', choices = ui.list)
  86. })
  87. # Choice of type of ordering, changing icon depending on variable being alpha or numeric
  88. output$ui_hsp_tbl_ort <- renderUI({
  89.     var.type <- ifelse(input$cbo_hsp_tbl_ord %in% names(locations), 'alpha', 'numeric')
  90.     switchInput('swt_hsp_tbl_ord',
  91.         onLabel = paste0('<i class=\"fa fa-sort-', var.type, '-asc\"></i>'), onStatus = 'primary',
  92.         offLabel = paste0('<i class=\"fa fa-sort-', var.type, '-desc\"></i>'), offStatus = 'info',
  93.         size = 'normal', value = TRUE
  94.     )
  95. })
  96. # Choice of result when grouping: CNT vs PCT vs QTA vs IDX depending on 1-Quantity, 2-Measure, 3-Metric
  97. output$ui_hsp_tbl_grp <- renderUI({
  98.     ui.list <-
  99.         if(metrics[label == input$cbo_hsp_tblY, type] == 1){
  100.             c('Counting', 'Quota')
  101.         } else if(metrics[label == input$cbo_hsp_tblY, type] == 2){
  102.             c('Counting', 'Quota', 'Percentage', 'Index')
  103.         } else {
  104.             c('Value', 'Index')
  105.         }
  106.     radioButtons('rdb_hsp_tbl_grp', 'SHOW:', choices = ui.list)
  107. })
  108. # Choice of reference when grouping (apart from Counting)
  109. output$ui_hsp_tbl_gpr <- renderUI({
  110.     if(is.null(input$rdb_hsp_tbl_grp)) return()
  111.     if(input$rdb_hsp_tbl_grp %in% c('Counting', 'Percentage', 'Value')) return()
  112.     ui.list <- c('Columns' = 'C', 'Rows' = 'R')
  113.     if(input$rdb_hsp_tbl_grp == 'Quota') ui.list <- c('Total' = 'T', ui.list)
  114.     radioButtons('rdb_hsp_tbl_gpr', 'VS:', choices = ui.list )
  115. })
  116.  
  117. ### BARPLOT (brp) -----------------------------------------------------------------------------------------------------------------
  118. # Choose a value from the filtering variable
  119. output$ui_hsp_brp_flt <- renderUI({
  120.     selectInput('cbo_hsp_brp_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_brpF) ) ) )
  121. })
  122. # Choice of CNT vs PCT if measure
  123. output$ui_hsp_brp_pct <- renderUI({
  124.     if(metrics[label == input$cbo_hsp_brpY, type] != 2) return()
  125.     checkboxInput('chk_hsp_brp_pct', 'SHOW PERCENTAGES', value = FALSE)
  126. })
  127. # Choice of AVERAGE LINE
  128. output$ui_hsp_brp_avg <- renderUI({
  129.     if(metrics[label == input$cbo_hsp_brpY, type] == 1) return()
  130.     if(metrics[label == input$cbo_hsp_brpY, type] == 2)
  131.         if(!input$chk_hsp_brp_pct) return()
  132.     if(input$cbo_hsp_brpG != 'NONE')
  133.         if(!input$cbo_hsp_brp_grp == 'facet') return()
  134.     checkboxInput('chk_hsp_brp_avg', 'SHOW AVERAGE', value = FALSE)
  135. })
  136. # Choice of grouping type
  137. output$ui_hsp_brp_grp <- renderUI({
  138.     ui.list <- c('dodge', 'facet')
  139.     if(metrics[label == input$cbo_hsp_brpY, type] == 1) ui.list <- c(ui.list, 'stack', 'fill')
  140.     if(metrics[label == input$cbo_hsp_brpY, type] == 2)
  141.         if(!input$chk_hsp_brp_pct) ui.list <- c(ui.list, 'stack', 'fill')
  142.     selectInput('cbo_hsp_brp_grp', 'GROUPING TYPE:', choices = ui.list)
  143. })
  144. # Number of centres to plot
  145. output$ui_hsp_brp_cnt <- renderUI({
  146.     n.centres <- length(unique(hsp_brp_tbl()[[1]]$X))
  147.     sliderInput('sld_hsp_brp_cnt', 'NUMBER OF CENTRES', min = 1, max = n.centres, value = c(1, n.centres), step = 1, ticks = FALSE)
  148. })
  149. # BARPLOT: Axis labels rotation
  150. output$ui_hsp_brp_lbr <- renderUI({
  151.     sliderInput(
  152.         'sld_hsp_brp_lbr', 'AXIS LABEL ROTATION:',
  153.         min = 0, max = 90,
  154.         value = ifelse(input$rdb_hsp_brp_orn == 'Horizontal', 0, 45),
  155.         step = 5, ticks = FALSE
  156.     )
  157. })
  158. # BARPLOT: Choice of colour for Value Labels
  159. output$ui_hsp_brp_lbc <- renderUI({
  160.     colourpicker::colourInput('col_hsp_brp_lbl', 'LABELS COLOUR:', ifelse(input$rdb_hsp_brp_lbp == 'Inside', 'white', 'black'), showColour = 'background')
  161. })
  162. # BARPLOT: Choice of bars labels position if ungrouped or grouped and dosge/facet (for grouped stack & fill position can only be inside!)
  163. # output$ui_hsp_brp_lbp <- renderUI({
  164. #     if( is.hsp.grp() & (input$cbo_hsp_brp_grp %in% c('stack', 'fill')) ) return(NULL)
  165. #     radioButtons('rdb_hsp_brp_lbp', 'POSITION:', choices = c('Inside', 'Outside'), inline = TRUE )
  166. # })
  167.  
  168. ### BOXPLOT (bxp) -----------------------------------------------------------------------------------------------------------------
  169. # Choose a value from the filtering variable
  170. output$ui_hsp_bxp_flt <- renderUI({
  171.     selectInput('cbo_hsp_bxp_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_bxpF) ) ) )
  172. })
  173. # Number of centres to plot
  174. output$ui_hsp_bxp_cnt <- renderUI({
  175.     n.centres <- length(unique(hsp_bxp_tbl()[[1]]$X))
  176.     sliderInput('sld_hsp_bxp_cnt', 'NUMBER OF CENTRES', min = 1, max = n.centres, value = c(1, n.centres), step = 1, ticks = FALSE)
  177. })
  178. # Axis labels rotation
  179. output$ui_hsp_bxp_lbr <- renderUI({
  180.     sliderInput(
  181.         'sld_hsp_bxp_lbr', 'AXIS LABEL ROTATION:',
  182.         min = 0, max = 90,
  183.         value = ifelse(input$rdb_hsp_bxp_orn == 'Horizontal', 0, 45),
  184.         step = 5, ticks = FALSE
  185.     )
  186. })
  187.  
  188. ### HEATMAP (hmp) -----------------------------------------------------------------------------------------------------------------
  189. # Choice of CNT vs PCT if measure
  190. output$ui_hsp_hmp_pct <- renderUI({
  191.     if(metrics[label == input$cbo_hsp_hmpY, type] != 2) return()
  192.     checkboxInput('chk_hsp_hmp_pct', 'SHOW PERCENTAGES', value = FALSE)
  193. })
  194. # Insert names of X-geo and Y-time in RESCALE radiobuttons labels
  195. output$ui_hsp_hmp_rvc <- renderUI({
  196.     ui.list <- list('X', 'X2')
  197.     names(ui.list) <- c( paste('VS', var.hsp.geo() ), paste('VS', names(timeref[which(timeref == input$cbo_hsp_hmpX2)]) ) )
  198.     radioButtons('rdb_hsp_hmp_rvc', '', choices = ui.list)
  199. })
  200. # Choose a value from the filtering variable
  201. output$ui_hsp_hmp_flt <- renderUI({
  202.     selectInput('cbo_hsp_hmp_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_hmpF) ) ) )
  203. })
  204. # Number of centres to plot
  205. output$ui_hsp_hmp_cnt <- renderUI({
  206.     n.centres <- length(unique(hsp_hmp_tbl()[[1]]$X))
  207.     sliderInput('sld_hsp_hmp_cnt', 'NUMBER OF CENTRES', min = 1, max = n.centres, value = c(1, n.centres), step = 1, ticks = FALSE)
  208. })
  209. # Axis labels rotation
  210. output$ui_hsp_hmp_lbr <- renderUI({
  211.     sliderInput('sld_hsp_hmp_lbr', 'AXIS LABEL ROTATION:', min = 0, max = 90, value = ifelse(input$chk_hsp_hmp_orn, 0, 45), step = 5, ticks = FALSE )
  212. })
  213.  
  214. ### FUNNELPLOT (fnl) -----------------------------------------------------------------------------------------------------------------
  215. # Choice of CNT vs PCT (plus FUNNEL) if measure
  216. output$ui_hsp_fnl_pct <- renderUI({
  217.     if(!is.hsp.fnl.msr()) return()
  218.     checkboxInput('chk_hsp_fnl_pct', 'SHOW PERCENTAGES', value = TRUE)
  219. })
  220. # flag when measure instead of metric
  221. is.hsp.fnl.msr <- reactive({
  222.     metrics[label == input$cbo_hsp_fnlY, type] == 2
  223. })
  224. # flag when measure is pct instead of count
  225. is.hsp.fnl.pct <- reactive({
  226.     ifelse(is.hsp.fnl.msr(), input$chk_hsp_fnl_pct, FALSE)
  227. })
  228. # store formulas reference
  229. fnl.ref <- reactive({
  230.     XF <- metrics[label == eval(input$cbo_hsp_fnlX), filter_by]   # The filter for the effect size
  231.     XM <- metrics[label == eval(input$cbo_hsp_fnlX), mutate_as]   # The formula to calculate the effect size
  232.     YF <- metrics[label == eval(input$cbo_hsp_fnlY), filter_by]   # The filter for the count of measure or the value of metric
  233.     YM <- metrics[label == eval(input$cbo_hsp_fnlY), mutate_as]   # The formula to calculate the count of measure or the value of metric
  234.     YFP <- metrics[label == eval(input$cbo_hsp_fnlY), filter_pct] # The filter to calculate the pct of measure. If X is metric, this is used to calculate the valid sample size XV
  235.     YMP <- metrics[label == eval(input$cbo_hsp_fnlY), mutate_pct] # The formula to calculate the pct of measure. If X is metric, this is void and not use afterwards
  236.     list( 'X' = c(XF, XM), 'Y' = c(YF, YM, YFP, YMP), 'pct' = '%')
  237. })
  238. # Trimming effect size
  239. output$ui_hsp_fnl_tmz <- renderUI({
  240.     if(length(hsp_fnl_tbl()[[1]]$X) == 0) return()
  241.     dt.max <- pretty( max( hsp_fnl_tbl()[[1]]$X ) )[2]
  242.     sliderInput('sld_hsp_fnl_tmz', 'TRIM SIZE:', min = 0, max = dt.max, value = c(0, dt.max), step = 10, dragRange = TRUE)
  243. })
  244. # Trimming metric values
  245. output$ui_hsp_fnl_tmt <- renderUI({
  246.     if(is.null(tryNULL(is.object(hsp_fnl_tbl())))) return()
  247.     pct.mult <- ifelse(is.hsp.fnl.pct(), 100, 1)
  248.     dt.min <- pretty( min( hsp_fnl_tbl()[[1]]$Y, na.rm = TRUE ) * pct.mult )[1]
  249.     dt.max <- pretty( max( hsp_fnl_tbl()[[1]]$Y, na.rm = TRUE ) * pct.mult )[2]
  250.     sliderInput('sld_hsp_fnl_tmt', 'TRIM VALUES:', min = 0, max = dt.max,  value = c(dt.min, dt.max), dragRange = TRUE, post = fnl.ref()[['pct']] )
  251. })
  252. # Choose a value from the filtering variable
  253. output$ui_hsp_fnl_flt <- renderUI({
  254.     selectInput('cbo_hsp_fnl_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_fnlF) ) ) )
  255. })
  256. # flag filtered funnelplot
  257. is.hsp.fnl.flt <- reactive({
  258.     ifelse(input$cbo_hsp_fnlF != 'NONE', (input$cbo_hsp_fnl_flt != 'NONE'), FALSE)
  259. })
  260. # show checkbox funnelplot
  261. output$ui_hsp_fnl_fnl <- renderUI({
  262.     if(is.hsp.fnl.msr() & !is.hsp.fnl.pct()) return()
  263.     checkboxInput('chk_hsp_fnl_fnl', 'ADD FUNNEL', FALSE)
  264. })
  265.  
  266. ### MAP (map) -----------------------------------------------------------------------------------------------------------------
  267. # Choose a value from the filtering variable
  268. output$ui_hsp_map_flt <- renderUI({
  269.     selectInput('cbo_hsp_map_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_mapF) ) ) )
  270. })
  271.  
  272. ### DOWNLOAD (dwn) -----------------------------------------------------------------------------------------------------------------
  273. # Choose filename for exporting dataset, chart, map, ...
  274. output$ui_hsp_dwn <- renderUI({
  275.     textInput('txt_hsp_dwn', 'FILENAME:', paste(input$tabs_hsp, audit, 'Centres', input$cbo_hsp_geo, Sys.Date(), sep = '_') )
  276. })
  277.  
  278.  
  279. # AUX VARIABLES ----------------------------------------------------------------------------------------------------------------
  280. var.hsp.geo <- reactive({
  281.     names(locations)[which(locations == input$cbo_hsp_geo)]
  282. })
  283. hsp.subtitle <- reactive({
  284.     switch(input$cbo_hsp_tmp,
  285.         '1' = paste('From', input$sld_hsp_tmp[1], 'to', input$sld_hsp_tmp[2] ),
  286.         '2' = paste('From', format(input$dts_hsp[1], '%b-%Y'), 'to', format(input$dts_hsp[2], '%b-%Y') ),
  287.         '3' = paste('From', format(input$dts_hsp[1], '%a, %d-%b-%Y'), 'to', format(input$dts_hsp[2], '%a, %d-%b-%Y') )
  288.     )
  289. })
  290.  
  291.  
  292. # FILTER DATASET ----------------------------------------------------------------------------------------------------------------
  293. dt_hsp <- reactive({
  294.     # Filter records by selected year(s), month(s) or day(s)
  295.     y <- switch(input$cbo_hsp_tmp,
  296.             '1' = dataset[ date.year >= input$sld_hsp_tmp[1] & date.year <= input$sld_hsp_tmp[2] ],
  297.             '2' = dataset[
  298.                     daten.month >= as.numeric(paste0(substr(input$dts_hsp[1], 1, 4), substr(input$dts_hsp[1], 6, 7))) &
  299.                         daten.month <= as.numeric(paste0(substr(input$dts_hsp[2], 1, 4), substr(input$dts_hsp[2], 6, 7)))
  300.                   ],
  301.             '3' = dataset[ date.day >= input$dts_hsp[1] & date.day <= input$dts_hsp[2] ]
  302.     )
  303.     # Add X-var as of GEO selection
  304.     geoX <- paste0(input$cbo_hsp_geo, ifelse(input$chk_hsp_geo_cdn, '_id', ''))
  305.     y[, X := get(geoX) ][!is.na(X)]
  306. })
  307.  
  308.  
  309. # SERVER CODE --------------------------------------------------------------------------------------------------------------
  310.  
  311. ### TABLE (tbl) -------------------------------------------------------------------------------------------------------------------
  312. hsp.tbl.title <- reactive({
  313.     build.title( var.Y = input$cbo_hsp_tblY, var.X = var.hsp.geo(), var.G1 = input$cbo_hsp_tblG, var.F = input$cbo_hsp_tblF, val.F = input$cbo_hsp_tbl_flt )
  314. })
  315. output$out_hsp_tbx <- renderUI({
  316.     HTML(paste0('<h3>', hsp.tbl.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
  317. })
  318. output$out_hsp_tbl <- renderDataTable({
  319.     is.hsp.tbl.flt <- ifelse(input$cbo_hsp_tblF != 'NONE', (input$cbo_hsp_tbl_flt != 'NONE'), FALSE)
  320.     get.dt.tbl(
  321.         dt = dt_hsp(),
  322.         tblY = input$cbo_hsp_tblY,
  323.         lblX = var.hsp.geo(),
  324.         fld.to.order = input$cbo_hsp_tbl_ord,
  325.         ord.desc= !input$swt_hsp_tbl_ord,
  326.         col.bars = input$col_hsp_tbb,
  327.         col.fonts = input$col_hsp_tbf,
  328.         pal.scale = input$pal_hsp_tbl,
  329.         n.cols = input$sld_hsp_tbl_col,
  330.         reverse = input$chk_hsp_tbl_rvc,
  331.         flt.var = ifelse(is.hsp.tbl.flt, input$cbo_hsp_tblF, NA),
  332.         flt.val = ifelse(is.hsp.tbl.flt, input$cbo_hsp_tbl_flt, NA),
  333.         grp.var = ifelse(input$cbo_hsp_tblG == 'NONE', NA, input$cbo_hsp_tblG),
  334.         grp.type = ifelse(input$cbo_hsp_tblG == 'NONE', NA, input$rdb_hsp_tbl_grp),
  335.         grp.stype = ifelse(input$cbo_hsp_tblG == 'NONE', NA, input$rdb_hsp_tbl_gpr)
  336.     )
  337. })
  338.  
  339.  
  340. ### BARPLOT (brp) -----------------------------------------------------------------------------------------------------------------
  341. hsp.brp.title <- reactive({
  342.     build.title(
  343.         var.Y   = input$cbo_hsp_brpY,
  344.         var.X   = var.hsp.geo(),
  345.         has.pct = ifelse( metrics[label == input$cbo_hsp_brpY, type] == 2, input$chk_hsp_brp_pct, FALSE),
  346.         var.G1  = input$cbo_hsp_brpG,
  347.         var.G2  = input$cbo_hsp_brpG2,
  348.         var.F   = input$cbo_hsp_brpF,
  349.         val.F   = input$cbo_hsp_brp_flt
  350.     )
  351. })
  352. output$out_hsp_brx <- renderUI({
  353.     HTML(paste0('<h3>', hsp.brp.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
  354. })
  355. is.hsp.brp.grp <- reactive( input$cbo_hsp_brpG != 'NONE' )
  356. is.hsp.brp.fll <- reactive( ifelse(is.hsp.brp.grp(), input$cbo_hsp_brp_grp == 'fill', FALSE) )
  357. is.hsp.brp.fct <- reactive( is.hsp.brp.grp() & input$cbo_hsp_brp_grp == 'facet' )
  358. is.hsp.brp.bfc <- reactive( is.hsp.brp.fct() & input$cbo_hsp_brpG2 != 'NONE')
  359. hsp_brp_tbl <- reactive({
  360.     get.dt.brp(dt_hsp(),
  361.         var.Y = input$cbo_hsp_brpY,
  362.         grp1 = if(is.hsp.brp.grp()){ input$cbo_hsp_brpG  } else {NA},
  363.         grp2 = if(is.hsp.brp.bfc()){ input$cbo_hsp_brpG2 } else {NA},
  364.         pct = ifelse( (metrics[label == input$cbo_hsp_brpY, type] == 2), input$chk_hsp_brp_pct, FALSE),
  365.         tt = c(var.hsp.geo(), var.tms.tmr()),
  366.         flt.var = if(input$cbo_hsp_brpF != 'NONE'){ input$cbo_hsp_brpF } else { NA },
  367.         flt.val = if(input$cbo_hsp_brpF != 'NONE'){ input$cbo_hsp_brp_flt } else { NA },
  368.         show.NA = input$chk_hsp_brp_sna,
  369.         ordering = input$cbo_hsp_brp_ord
  370.     )
  371. })
  372. hsp_brp_plt <- reactive({
  373.     var.type <- metrics[label == input$cbo_hsp_brpY, type]
  374.     is.pct <- ifelse(var.type == 2, input$chk_hsp_brp_pct, FALSE)
  375.     y <- hsp_brp_tbl()[[1]]
  376.     # detect number of units to plot
  377.     yg <- trim.dt.X(y, input$sld_hsp_brp_cnt)
  378.     # build first layer
  379.     g <- ggplot(yg, aes(x = X, y = Y, tooltip = ttip, data_id = ttip) )
  380.     # bar attributes
  381.     bars.col <- ifelse(length(input$col_hsp_brp), input$col_hsp_brp, pal.default['col'])
  382.     bars.width <- input$sld_hsp_brp_baw / 10
  383.     # border attributes
  384.     border.size <- ifelse(input$chk_hsp_brp_bdr, input$sld_hsp_brp_bow / 30, 0)
  385.     border.col <- ifelse(input$chk_hsp_brp_bdr, input$col_hsp_brp_boc, NA)
  386.     border.type <- ifelse(input$chk_hsp_brp_bdr, input$cbo_hsp_brp_bot, 'solid')
  387.     # write ggplot instruction to actually plot the bars corresponding to ungrouped / grouped, and in the latter case if faceting or not
  388.     g1 <- geom_bar_interactive(stat = 'identity', fill = bars.col, width = bars.width, size = border.size, color = border.col, linetype = border.type)
  389.     if(is.hsp.brp.grp()){
  390.         if(is.hsp.brp.fct()){
  391.             fct.scale <- if(input$chk_hsp_brp_scl){ 'fixed' } else { 'free_y' }
  392.             if(is.hsp.brp.bfc()){
  393.                 g <- g + g1 + facet_grid(G1~G2, scale = fct.scale)
  394.             } else {
  395.                 g <- g + g1 + facet_wrap(~G, ncol = input$sld_hsp_brp_fct, scale = fct.scale)
  396.             }
  397.         } else {
  398.             g <- g + geom_bar_interactive(
  399.                         stat = 'identity', aes(fill = G), position = input$cbo_hsp_brp_grp,
  400.                         width = bars.width, size = border.size, color = border.col, linetype = border.type
  401.             )
  402.             bars.pal <- ifelse(length(input$pal_hsp_brp), input$pal_hsp_brp, pal.default['cat'])
  403.             bars.pal <-
  404.                 if(brewer.pal.info[bars.pal,]$maxcolors > length(unique(y$G))){
  405.                     rep_len(brewer.pal(length(unique(y$G)), bars.pal), length(unique(y$G)))
  406.                 } else {
  407.                     brewer.pal(length(unique(y$G)), bars.pal)
  408.                 }
  409.             if(input$chk_hsp_brp_rvc) bars.pal <- rev(bars.pal)
  410.             g <- g + scale_fill_manual(values = bars.pal)
  411.         }
  412.     } else {
  413.         g <- g + g1
  414.     }
  415.     # Add average line
  416.     if(length(input$chk_hsp_brp_avg)){
  417.         yt <- hsp_brp_tbl()[[2]]
  418.         if(input$chk_hsp_brp_avg){
  419.             if(is.hsp.brp.fct()){
  420.                 g <- g + geom_hline(
  421.                             data = yt, aes(yintercept = Y),
  422.                             color = input$col_hsp_brp_avc, size = input$sld_hsp_brp_avz / 5, linetype = input$cbo_hsp_brp_avt, alpha = 1 - input$sld_hsp_brp_avt / 10
  423.                 )
  424.             } else {
  425.                 g <- g + geom_hline(
  426.                             yintercept = yt,
  427.                             color = input$col_hsp_brp_avc, size = input$sld_hsp_brp_avz / 5, linetype = input$cbo_hsp_brp_avt, alpha = 1 - input$sld_hsp_brp_avt / 10
  428.                 )
  429.             }
  430.             if(input$chk_hsp_brp_avl){
  431.                 ytl <- ifelse(is.pct, paste0(round(100 * yt, 2), '%'), yt)
  432.                 g <- g + geom_text(
  433.                             aes(1, yt, label = ytl, vjust = -1),
  434.                             color = input$col_hsp_brp_avc, size = input$sld_hsp_brp_avz / 1.5, alpha = 1 - input$sld_hsp_brp_avt / 10
  435.                 )
  436.             }
  437.         }
  438.     }
  439.     # Format y-axis labels
  440.     g <- g + scale_y_continuous(expand = c(0, 0), labels = if(is.pct | (is.hsp.brp.grp() & input$cbo_hsp_brp_grp == 'fill')){ percent } else { comma } )
  441.     # Fix y-axis limits
  442.     if(!is.hsp.brp.fll()){
  443.         if(is.hsp.brp.fct() & !input$chk_hsp_brp_scl){
  444.             if(input$chk_hsp_brp_yzr) g <- g + expand_limits(y = 0)
  445.         } else {
  446.             y.min <- ifelse(is.pct, pretty(100*min(y$Y))[1]/100, pretty(min(y$Y))[1] )
  447.             if(input$chk_hsp_brp_yzr) y.min <- 0
  448.             y.max <- ifelse(is.pct, pretty(100*max(y$Y))[2]/100, pretty(max(y$Y))[2] )
  449.             g <- g + coord_cartesian(ylim = c(y.min, y.max))
  450.         }
  451.     }
  452.     # rotate axis
  453.     if(input$rdb_hsp_brp_orn == 'Horizontal') g <- g + coord_flip()
  454.     # add and format value labels in bars
  455.     if(input$chk_hsp_brp_lbl){
  456.         if(is.hsp.brp.grp()){
  457.             g <- g + geom_text(
  458.                         aes(label = lbl.format(Y, var.type, is.pct)),
  459.                         position = position_dodge(width = -0.8),
  460.                         vjust = val.lbl.pos[[input$rdb_hsp_brp_lbp]][[input$rdb_hsp_brp_orn]][2],
  461.                         color = input$col_hsp_brp_lbl, size = input$sld_hsp_brp_lbz, fontface = 'bold'
  462.             )
  463.         } else {
  464.             g <- g + geom_text(
  465.                         aes(label = lbl.format(Y, var.type, is.pct)),
  466.                         hjust = val.lbl.pos[[input$rdb_hsp_brp_lbp]][[input$rdb_hsp_brp_orn]][1],
  467.                         vjust = val.lbl.pos[[input$rdb_hsp_brp_lbp]][[input$rdb_hsp_brp_orn]][2],
  468.                         color = input$col_hsp_brp_lbl, size = input$sld_hsp_brp_lbz, fontface = 'bold'
  469.             )
  470.         }
  471.     }
  472.     # add legend and axis titles (main title and subtitle are added automatically to the print version)
  473.     g <- g + labs(x = '', y = '')
  474.     if(is.hsp.brp.grp() & !is.hsp.brp.fct())
  475.         g <- g + labs(fill = clear.label(input$cbo_hsp_brpG))
  476. #        g <- g + scale_fill_discrete(name = clear.label(input$cbo_hsp_brpG))
  477.     if(input$chk_hsp_brp_xlt)
  478.         g <- g + labs(x = var.hsp.geo(), y = paste(metrics[label == input$cbo_hsp_brpY, title], if(is.pct){'(%)'} ) )
  479.     # calculate angle rotation for centres labels
  480.     labels.rotation <- ifelse(length(input$sld_hsp_brp_lbr), input$sld_hsp_brp_lbr, 45)
  481.     labels.rotation <- if(input$rdb_hsp_brp_orn == 'Vertical'){ c(labels.rotation, 0) } else { c(0, labels.rotation) }
  482.     # apply general theme
  483.     g <- my.ggtheme(g,
  484.                 xaxis.draw = input$chk_hsp_brp_xlx, yaxis.draw = input$chk_hsp_brp_xly, ticks.draw = input$chk_hsp_brp_xtk,
  485.                 axis.colour = input$col_hsp_brp_xsc, axis.size = as.numeric(input$sld_hsp_brp_xsz) / 10,
  486.                 hgrid.draw = ('Horizontal' %in% input$chg_hsp_brp_grd), vgrid.draw = ('Vertical' %in% input$chg_hsp_brp_grd),
  487.                 grids.colour = input$col_hsp_brp_gdc, grids.size = as.numeric(input$sld_hsp_brp_gdz) / 10, grids.type = input$cbo_hsp_brp_gdt,
  488.                 labels.rotation = labels.rotation,
  489.                 bkg.colour = input$col_hsp_brp_bkg, font.size = input$sld_hsp_brp_xlz,
  490.                 ttl.font.size.mult = as.numeric(input$sld_hsp_brp_xlt)/100, ttl.face = input$cbo_hsp_brp_xlt, plot.border = input$chk_hsp_brp_plb,
  491.                 font.family = input$cbo_hsp_brp_ffm
  492.     )
  493.     g
  494. })
  495. output$out_hsp_brp <- renderggiraph({
  496.     gg.to.ggiraph(hsp_brp_plt(), gg.width = input$sld_hsp_brp_ggw / 10)
  497. })
  498.  
  499.  
  500. ### BOXPLOT (bxp) -----------------------------------------------------------------------------------------------------------------
  501. hsp.bxp.title <- reactive({
  502.     build.title(
  503.         var.Y    = input$cbo_hsp_bxpY,
  504.         is.Y.ref = FALSE,
  505.         var.X    = var.hsp.geo(),
  506.         var.G1   = input$cbo_hsp_bxpG,
  507.         var.G2   = input$cbo_hsp_bxpG2,
  508.         var.F    = input$cbo_hsp_bxpF,
  509.         val.F    = input$cbo_hsp_bxp_flt
  510.     )
  511. })
  512. output$out_hsp_bxx <- renderUI({
  513.     HTML(paste0('<h3>', hsp.bxp.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
  514. })
  515. is.hsp.bxp.grp <- reactive( input$cbo_hsp_bxpG != 'NONE' )
  516. is.hsp.bxp.fct <- reactive( is.hsp.bxp.grp() & input$rdb_hsp_bxp_grp == 'facet' )
  517. is.hsp.bxp.bfc <- reactive( is.hsp.bxp.fct() & input$cbo_hsp_bxpG2 != 'NONE')
  518. hsp_bxp_tbl <- reactive({
  519.     get.dt.bxp(dt_hsp(),
  520.         var.Y = input$cbo_hsp_bxpY,
  521.         grp1 = if(is.hsp.bxp.grp()){ input$cbo_hsp_bxpG } else { NA },
  522.         grp2 = if(is.hsp.bxp.bfc()){ input$cbo_hsp_bxpG2 } else { NA },
  523.         tt = var.hsp.geo(),
  524.         flt.var = if(input$cbo_hsp_bxpF != 'NONE'){ input$cbo_hsp_bxpF } else { NA },
  525.         flt.val = if(input$cbo_hsp_bxpF != 'NONE'){ input$cbo_hsp_bxp_flt } else { NA }
  526.     )
  527. })
  528. hsp_bxp_plt <- reactive({
  529.     y <- hsp_bxp_tbl()[[1]]
  530.     # detect number of units to plot
  531.     yg <- trim.dt.X.bxp(y, input$sld_hsp_bxp_cnt, input$cbo_hsp_bxp_ord)
  532.     # build the first layer of the plot according to the desired order for the bars
  533.     g <- ggplot(yg[[1]], aes(x = X, y = Y, tooltip = ttip, data_id = ttip) ) + scale_x_discrete(limits = yg[[2]])
  534.     # boxes attributes
  535.     bxs.col <- input$col_hsp_bxp_boc
  536.     bxs.width <- input$sld_hsp_bxp_bxw / 10
  537.     bxs.size <- input$sld_hsp_bxp_bbw / 30
  538.     bxs.ltype <- input$cbo_hsp_bxp_bbt
  539.     # build the second layer (= geometry with colour/palette) according to group
  540.     if(is.hsp.bxp.grp() & !is.hsp.bxp.fct()){
  541.         g <- g + geom_boxplot_interactive(
  542.                         aes(fill = G),
  543.                         position = position_dodge(input$sld_hsp_bxp_gdd / 10),
  544.                         color = bxs.col,
  545.                         size = bxs.size,
  546.                         width = bxs.width,
  547.                         linetype = bxs.ltype,
  548.                         outlier.shape = NA
  549.         )
  550.         bars.pal <- ifelse(length(input$pal_hsp_bxp), input$pal_hsp_bxp, pal.default['cat'])
  551.         bars.pal <-
  552.             if(brewer.pal.info[bars.pal,]$maxcolors > length(unique(y$G))){
  553.                 rep_len(brewer.pal(length(unique(y$G)), bars.pal), length(unique(y$G)))
  554.             } else {
  555.                 brewer.pal(length(unique(y$G)), bars.pal)
  556.             }
  557.         if(input$chk_hsp_bxp_rvc) bars.pal <- rev(bars.pal)
  558.         g <- g + scale_fill_manual(values = bars.pal)
  559.         # g <- g + scale_fill_brewer(palette = ifelse(length(input$pal_hsp_bxp) == 0 , 'Dark2', input$pal_hsp_bxp) )
  560.     } else {
  561.         g <- g + geom_boxplot_interactive(
  562.                         fill = ifelse(length(input$col_hsp_bxp), input$col_hsp_bxp, pal.default['col']),
  563.                         color = bxs.col,
  564.                         size = bxs.size,
  565.                         width = bxs.width,
  566.                         linetype = bxs.ltype,
  567.                         outlier.shape = NA
  568.         )
  569.         if(is.hsp.bxp.fct()){
  570.             if(is.hsp.bxp.bfc()){
  571.                 g <- g + facet_grid(G~G2)
  572.             } else {
  573.                 g <- g + facet_wrap(~G, ncol = input$sld_hsp_bxp_fct)
  574.             }
  575.         }
  576.     }
  577.     # Control axis limits and formats, Add OUTLIERS tooltip to the plot, OR remove Outliers and change plot limits to whiskers values
  578.     if(input$chk_hsp_bxp_out){
  579.         out.limits <- boxplot.stats(y$Y)$stats
  580.         g <- g + scale_y_continuous(
  581.                     labels = comma,
  582.                     limits = c(
  583.                         quantile(y$Y, na.rm = TRUE)[2] - IQR(y$Y, na.rm = TRUE) * 1.5,
  584.                         quantile(y$Y, na.rm = TRUE)[4] + IQR(y$Y, na.rm = TRUE) * 1.5
  585.                     )
  586.         )
  587.     } else {
  588.         y.out <- hsp_bxp_tbl()[[2]]
  589.         g <- g + scale_y_continuous(expand = c(0, 0), labels = comma)
  590.         if(is.hsp.bxp.grp() & !is.hsp.bxp.fct()){
  591.             g <- g + geom_point_interactive(data = y.out,
  592.                             aes(fill = G, tooltip = ttip),
  593.                             size = input$sld_hsp_bxp_otz / 5,
  594.                             colour = input$col_hsp_bxp_otb,
  595.                             shape = as.numeric(input$cbo_hsp_bxp_out),
  596.                             alpha = 1 - input$sld_hsp_bxp_ott / 10
  597.             )
  598.         } else {
  599.             g <- g + geom_point_interactive(data = y.out,
  600.                             aes(tooltip = ttip),
  601.                             fill = input$col_hsp_bxp_otf,
  602.                             size = input$sld_hsp_bxp_otz / 5,
  603.                             colour = input$col_hsp_bxp_otb,
  604.                             shape = as.numeric(input$cbo_hsp_bxp_out),
  605.                             alpha = 1 - input$sld_hsp_bxp_ott / 10
  606.             )
  607.         }
  608.         g <- g + coord_cartesian(ylim = c(ifelse(input$chk_hsp_bxp_yzr, 0, pretty(min(y$Y))[1]), pretty(max(y$Y))[2]) )
  609.     }
  610.     # Add mean point and st.dev line in boxes
  611.     if(input$chk_hsp_bxp_avg){
  612.         g <- g + stat_summary(
  613.                     fun.y = mean,
  614.                     geom = 'point',
  615.                     fill = input$col_hsp_bxp_avc,
  616.                     size = input$sld_hsp_bxp_avz/3,
  617.                     shape = as.numeric(input$cbo_hsp_bxp_avs),
  618.                     alpha = 1 - input$sld_hsp_bxp_avt / 10,
  619.                     show.legend = FALSE
  620.         )
  621.     }
  622.     # Flip chart in a horizontal way
  623.     if(input$rdb_hsp_bxp_orn == 'Horizontal') g <- g + coord_flip()
  624.     # if grouped, add legend title
  625.     if(is.hsp.bxp.grp()) g <- g + labs( fill = clear.label(input$cbo_hsp_bxpG) )
  626.     # add axis titles (main title and subtitle are added automatically to the print version)
  627.     g <- g + labs(x = '', y = '')
  628.     if(input$chk_hsp_bxp_xlt)
  629.         g <- g + labs(x = var.hsp.geo(), y = clear.label(input$cbo_hsp_bxpY) )
  630.     # calculate angle rotation for centres labels
  631.     labels.rotation <- ifelse(length(input$sld_hsp_bxp_lbr), input$sld_hsp_bxp_lbr, 45)
  632.     labels.rotation <- if(input$rdb_hsp_bxp_orn == 'Vertical'){ c(labels.rotation, 0) } else { c(0, labels.rotation) }
  633.     # add theme and style options
  634.     g <- my.ggtheme(g,
  635.                 xaxis.draw = input$chk_hsp_bxp_xlx, yaxis.draw = input$chk_hsp_bxp_xly, ticks.draw = input$chk_hsp_bxp_xtk,
  636.                 axis.colour = input$col_hsp_bxp_xsc, axis.size = as.numeric(input$sld_hsp_bxp_xsz) / 10,
  637.                 hgrid.draw = ('Horizontal' %in% input$chg_hsp_bxp_grd), vgrid.draw = ('Vertical' %in% input$chg_hsp_bxp_grd),
  638.                 grids.colour = input$col_hsp_bxp_gdc, grids.size = as.numeric(input$sld_hsp_bxp_gdz) / 10, grids.type = input$cbo_hsp_bxp_gdt,
  639.                 labels.rotation = labels.rotation,
  640.                 bkg.colour = input$col_hsp_bxp_bkg, font.size = input$sld_hsp_bxp_xlz,
  641.                 ttl.font.size.mult = as.numeric(input$sld_hsp_bxp_xlt)/100, ttl.face = input$cbo_hsp_bxp_xlt, plot.border = input$chk_hsp_bxp_plb,
  642.                 font.family = input$cbo_hsp_bxp_ffm
  643.     )
  644.     g
  645. })
  646. output$out_hsp_bxp <- renderggiraph({
  647.     gg.to.ggiraph(hsp_bxp_plt(), gg.width = input$sld_hsp_bxp_ggw / 10)
  648. })
  649.  
  650.  
  651. ### HEATMAP (hmp) -----------------------------------------------------------------------------------------------------------------
  652. is.hsp.hmp.msr <- reactive( metrics[label == input$cbo_hsp_hmpY, type] == 2 )
  653. is.hsp.hmp.grp <- reactive( input$cbo_hsp_hmpG != 'NONE' )
  654. is.hsp.hmp.bfc <- reactive( is.hsp.hmp.grp() & input$cbo_hsp_hmpG2 != 'NONE')
  655. var.hsp.hmp <- reactive( names(timeref[which(timeref == input$cbo_hsp_hmpX2)]) )
  656. hsp.hmp.title <- reactive({
  657.     build.title(
  658.         var.Y   = input$cbo_hsp_hmpY,
  659.         var.X   = var.hsp.geo(),
  660.         var.X2  = names(timeref[which(timeref == input$cbo_hsp_hmpX2)]),
  661.         has.pct = ifelse(is.hsp.hmp.msr(), input$chk_hsp_hmp_pct, FALSE),
  662.         var.G1  = input$cbo_hsp_hmpG,
  663.         var.G2  = input$cbo_hsp_hmpG2,
  664.         var.F   = input$cbo_hsp_hmpF,
  665.         val.F   = input$cbo_hsp_hmp_flt
  666.     )
  667. })
  668. output$out_hsp_hmx <- renderUI({
  669.     HTML(paste0('<h3>', hsp.hmp.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
  670. })
  671. hsp_hmp_tbl <- reactive({
  672.     get.dt.hmp(dt_hsp(),
  673.         var.Y = input$cbo_hsp_hmpY,
  674.         var.X2  = input$cbo_hsp_hmpX2,
  675.         grp1 = ifna(is.hsp.hmp.grp(), input$cbo_hsp_hmpG),
  676.         grp2 = ifna(is.hsp.hmp.bfc(), input$cbo_hsp_hmpG2),
  677.         pct = ifelse(is.hsp.hmp.msr(), input$chk_hsp_hmp_pct, FALSE),
  678.         tt = c(var.hsp.geo(), var.hsp.hmp()),
  679.         flt.var = ifna(input$cbo_hsp_hmpF != 'NONE', input$cbo_hsp_hmpF),
  680.         flt.val = ifna(input$cbo_hsp_hmpF != 'NONE', input$cbo_hsp_hmp_flt),
  681.         mtc.rescale = ifna(input$chk_hsp_hmp_rvv, input$rdb_hsp_hmp_rvc),
  682.         ordering = as.numeric(input$cbo_hsp_hmp_ord),
  683.         show.NA = input$chk_hsp_hmp_sna
  684.     )
  685. })    
  686. hsp_hmp_plt <- reactive({
  687.     is.pct <- ifelse(is.hsp.hmp.msr(), input$chk_hsp_hmp_pct, FALSE)
  688.     y <- hsp_hmp_tbl()[[1]]
  689.    # detect number of units to plot
  690.     yg <- trim.dt.X(y, input$sld_hsp_hmp_cnt)
  691.     # build first layer
  692.     g <- ggplot(yg, aes(x = X, y = X2, tooltip = ttip, data_id = ttip ) ) +
  693.             geom_tile_interactive(
  694.                 aes(fill = Y),
  695.                 alpha = 1 - input$sld_hsp_hmp_trp / 10,
  696.                 color = input$col_hsp_hmp_bbc, # ifelse(length(input$col_hsp_hmp_bbc), input$col_hsp_hmp_bbc, 'white'),
  697.                 linetype = input$cbo_hsp_hmp_bbt,
  698.                 size = input$sld_hsp_hmp_bbz / 20
  699.             )
  700.     # grouping (=Faceting)
  701.     if(is.hsp.hmp.grp()){
  702.         if(is.hsp.hmp.bfc()){
  703.             g <- g + facet_grid(G1~G2)
  704.         } else {
  705.             g <- g + facet_wrap(~G, ncol = input$sld_hsp_hmp_fct)
  706.         }
  707.     }
  708.     # palette
  709.     boxes.pal <- ifelse(length(input$pal_hsp_hmp), input$pal_hsp_hmp, pal.default['seq'])
  710.     boxes.pal <- brewer.pal(max(3, min(nlevels(y$G), brewer.pal.info[boxes.pal, 'maxcolors'])), boxes.pal)
  711.     if(input$chk_hsp_hmp_rvc) boxes.pal <- rev(boxes.pal)
  712.     # format the values in the legend as comma/pct, plus NAs colour
  713.     g <- g + scale_fill_gradientn(
  714.                     colours = boxes.pal,
  715. #                    limits = c(pretty(min(y$Y))[1], pretty(max(y$Y))[2]),
  716.                     labels = ifelse(is.pct, percent, comma),
  717.                     na.value = input$col_hsp_hmp_nas
  718.     )
  719.     # Flip chart in a horizontal way
  720.     if(input$chk_hsp_hmp_orn) g <- g + coord_flip()
  721.     # Square boxes (does NOT work if coord_flip() is present)
  722.     if(input$chk_hsp_hmp_sqb) g <- g + coord_fixed(ratio = 1)
  723.     # Add axis and legend titles (main title and subtitle are added automatically to the print version)
  724.     g <- g + labs(x = '', y = '', fill = input$cbo_hsp_hmpY)
  725.     if(input$chk_hsp_hmp_xlt) g <- g + labs(x = var.hsp.geo(), y = var.hsp.hmp() )
  726.     # When dayOfMonth / hour let X2-axis draw all labels through 1-31 / 0-23
  727.     if(input$cbo_hsp_hmpX2 == 'day_nid') g <- g + scale_y_continuous(breaks = 1:31)
  728.     if(input$cbo_hsp_hmpX2 == 'date.hour') g <- g + scale_y_continuous(breaks = 0:23)
  729.     # calculate angle rotation for centres labels
  730.     labels.rotation <- ifelse(length(input$sld_hsp_hmp_lbr), input$sld_hsp_hmp_lbr, 45)
  731.     labels.rotation <- if(input$chk_hsp_hmp_orn){ c(0, labels.rotation, 0) } else { c(labels.rotation, 0) }
  732.     # add theme and style options
  733.     g <- my.ggtheme(g,
  734.                 ticks.draw = input$chk_hsp_hmp_xtk, axis.size = as.numeric(input$sld_hsp_hmp_bbz) / 10,
  735.                 labels.rotation = labels.rotation, font.size = input$sld_hsp_hmp_xlz,
  736.                 ttl.font.size.mult = as.numeric(input$sld_hsp_hmp_xlt)/100, ttl.face = input$cbo_hsp_hmp_xlt,
  737.                 font.family = input$cbo_hsp_hmp_ffm
  738.     )
  739.     g
  740.    
  741. })
  742. output$out_hsp_hmp <- renderggiraph({
  743.     gg.to.ggiraph(hsp_hmp_plt(), gg.width = input$sld_hsp_hmp_ggw / 10)
  744. })
  745.  
  746.  
  747. ### FUNNELPLOT (fnl) ------------------------------------------------------------------------------------------------------------
  748. hsp.fnl.title <- reactive({
  749.     build.title(
  750.         var.Y    = input$cbo_hsp_fnlY,
  751.         var.X    = metrics[label == input$cbo_hsp_fnlX, title],
  752.         fnl.area = var.hsp.geo(),
  753.         has.pct  = is.hsp.fnl.pct(),
  754.         var.G1   = 'NONE',
  755.         var.F    = input$cbo_hsp_fnlF,
  756.         val.F    = input$cbo_hsp_fnl_flt
  757.     )
  758. })
  759. output$out_hsp_scx <- renderUI({
  760.     HTML(paste0('<h3>', hsp.fnl.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
  761. })
  762. dt_hsp_fnl <- reactive({
  763.     y <- dt_hsp()[ eval( parse(text = fnl.ref()[['X']][1] ) )]
  764.     if(is.hsp.fnl.flt()){
  765.         flt.lbl <- lookups[domain_id == gsub('X', '', input$cbo_hsp_fnlF) & lookup_id == input$cbo_hsp_fnl_flt, description]
  766.         y <- y[ get(input$cbo_hsp_fnlF) == flt.lbl ]
  767.     }
  768.     y
  769. })
  770. hsp_fnl_tbl <- reactive({
  771.     if(length(dt_hsp_fnl()) == 0) return()
  772.     # calculate total effect size
  773.     dtx <- dt_hsp_fnl()[,
  774.         .( X = eval(parse(text = fnl.ref()[['X']][2])) ),
  775.         .( LW = get(input$cbo_hsp_geo), W = get(paste0(input$cbo_hsp_geo, '_id')) )
  776.     ]
  777.     # calculate counting for reference metric/measure
  778.     dtyn <- dt_hsp_fnl()[
  779.         eval(parse(text = fnl.ref()[['Y']][1]) ),
  780.         .( Y = eval(parse(text = fnl.ref()[['Y']][2])) ),
  781.         .( W = get(paste0(input$cbo_hsp_geo, '_id')) )
  782.     ]
  783.     # merge the above
  784.     y <- dtyn[dtx, on = 'W'][is.na(Y), Y := 0]
  785.     if(is.hsp.fnl.msr()){
  786.         # calculate percentage for reference measure
  787.         dtyp <- dt_hsp_fnl()[
  788.             eval( parse(text = fnl.ref()[['Y']][3] ) ),
  789.             .( YP = eval(parse(text = fnl.ref()[['Y']][4])) ),
  790.             .( W = get(paste0(input$cbo_hsp_geo, '_id')) )
  791.         ]
  792.         # merge percentage with previous counts
  793.         y <- y[dtyp, on = 'W']
  794.         # calculate total counting for reference measure
  795.         yt  <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][1] ) ), .(eval(parse(text = paste(fnl.ref()[['Y']][2])))) ])
  796.         # calculate total percentage for reference measure for binomial funnel
  797.         ytp <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][3] ) ), .(eval(parse(text = paste(fnl.ref()[['Y']][4])))) ])
  798.         # sd is not requested for measure
  799.         yt.sd <- NA
  800.         # calculate index vs national
  801.         y[, IDX := round(YP/ytp, 3)]
  802.     } else {
  803.         # calculate total counting for reference metric
  804.         yt <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][1] ) ), .(eval(parse(text = paste(fnl.ref()[['Y']][2])))) ])
  805.         # percentage is not requested for metric
  806.         ytp <- NA
  807.         # calculate total standard deviation for reference metric for normal funnel
  808.         yt.sd <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][1] ) ), .( eval(parse(text = metrics[label == eval(input$cbo_hsp_fnlY), mutate_fnl])) ) ])
  809.         # calculate index vs national
  810.         y[, IDX := round(Y/yt, 3)]
  811.     }
  812.     # calculate the tooltip
  813.     y[, ttip := paste0(
  814.                     var.hsp.geo(), ': <b>', LW, '</b><br/>',
  815.                     metrics[label == input$cbo_hsp_fnlX, title], ': <b>', prettyNum(X, big.mark = ','), '</b><br/>',
  816.                     metrics[label == input$cbo_hsp_fnlY, label], ':<br/>',
  817.                     '<ul>',
  818.                         '<li>', ifelse(metrics[label == input$cbo_hsp_fnlY, type] <= 2, 'Counting', 'Value'), ': <b>', prettyNum(Y, big.mark = ','), '</b></li>',
  819.                         if(is.hsp.fnl.msr()){ paste0('<li>Percentage: <b>', round(100*YP, 2), '%</b></li>') },
  820.                         '<li>Index: <b>', IDX, '</b></li>',
  821.                     '</ul>'
  822.     )]
  823.     # add the code to pass when points are clicked
  824.     y[, clk := W]
  825.     if(is.hsp.fnl.pct()){
  826.         # change fields names for Y if measure and percentage
  827.         setnames(y, c('Y', 'YP'), c('YN', 'Y') ) # y[, YN := Y][, Y := YP][, YP := NULL]
  828.         # change fields names for X if reduced size
  829.         if(input$chk_hsp_fnl_pcY) setnames(y, c('X', 'YN'), c('XT', 'X') )
  830.     }
  831.     # return as a list of 1) main dataset and 2) total summaries  
  832.     list(y, c(yt, ytp, yt.sd) )
  833. })
  834. hsp_fnl_plt <- reactive({
  835.     y <- hsp_fnl_tbl()[[1]]
  836.     # initialize plot (assuming ALL stored effect sizes are simply counts)
  837.     g <- ggplot(y, aes(x = X, y = Y))
  838.     # add geometry
  839.     g <- g + geom_point_interactive(
  840.                 aes(tooltip = ttip, data_id = clk),
  841.                 size =  input$sld_hsp_fnl_pnz / 3,
  842.                 shape  = as.numeric(input$cbo_hsp_fnl_pnh),
  843.                 colour = input$col_hsp_fnl_pnc,
  844.                 fill  = input$col_hsp_fnl_pnf,
  845.                 alpha = input$sld_hsp_fnl_pno / 10
  846.     )
  847.     # add labels
  848.     g <- g + geom_text_repel(
  849.                 aes(label = W),
  850.                 # labels
  851.                 family = input$cbo_hsp_fnl_ffm,
  852.                 size  = input$sld_hsp_fnl_lbz / 2,
  853.                 color = input$col_hsp_fnl_lbc,
  854.                 alpha = input$sld_hsp_fnl_lbo / 10,
  855.                 # segments
  856.                 segment.color = input$col_hsp_fnl_sgc,
  857.                 segment.size = input$sld_hsp_fnl_sgz / 8,
  858.                 segment.alpha = input$sld_hsp_fnl_sgt / 10,
  859.                 min.segment.length = unit(input$sld_hsp_fnl_sgm, 'lines'),
  860.                 arrow = arrow(length = unit(input$chk_hsp_fnl_sgr * 0.01, 'npc'))
  861.     )
  862.     # add average line
  863.     yt <- hsp_fnl_tbl()[[2]][1 + is.hsp.fnl.pct()]
  864.     if(input$chk_hsp_fnl_avg){
  865.         g <- g + geom_hline(
  866.                     yintercept = yt,
  867.                     linetype = input$cbo_hsp_fnl_avt,
  868.                     color = input$col_hsp_fnl_avc,
  869.                     size = input$sld_hsp_fnl_avz / 8
  870.         )
  871.         if(input$chk_hsp_fnl_avl){
  872.             ytl <- ifelse(is.hsp.fnl.pct(), paste0(round(100 * yt, 2), '%'), yt)
  873.             g <- g + geom_text(aes(pretty(max(y$X))[2], yt), label = ytl, vjust = -0.5, size = 3, color = input$col_hsp_fnl_avc)
  874.         }
  875.     }
  876.     # add funnel control limits
  877.     if(input$chk_hsp_fnl_fnl){
  878.         yt.sd <- hsp_fnl_tbl()[[2]][3]
  879.         if(length(input$cbo_hsp_fnl_flm) > 0){
  880.             fnl.lims <- sort(input$cbo_hsp_fnl_flm)
  881.             fnl.nlims <- length(fnl.lims)
  882.             fnl.cols <- if(length(input$cbo_hsp_fnl_fnc) == 0) { 'black' } else { input$cbo_hsp_fnl_fnc }
  883.             if(length(fnl.cols) < fnl.nlims)
  884.                 fnl.cols <- c(fnl.cols, rep(fnl.cols[length(fnl.cols)], fnl.nlims - length(fnl.cols)) )
  885.             fnl.types <- if(length(input$cbo_hsp_fnl_fnt) == 0) { 'solid' } else { input$cbo_hsp_fnl_fnt }
  886.             if(length(fnl.types) < fnl.nlims)
  887.                 fnl.types <- c(fnl.types, rep(fnl.types[length(fnl.types)], fnl.nlims - length(fnl.types)) )
  888.             for(idx in 1:fnl.nlims){
  889.                 if(is.hsp.fnl.msr()){
  890.                     funnel.limits <- get.funnel.limits(as.numeric(fnl.lims[idx]), max(y$X), yt)
  891.                 } else {
  892.                     funnel.limits <- get.funnel.limits(as.numeric(fnl.lims[idx]), max(y$X), yt, yt.sd)
  893.                 }
  894.                 g <- g + geom_line(
  895.                             data = funnel.limits,
  896.                             aes(x = x, y = liminf),
  897.                             color = fnl.cols[idx],
  898.                             linetype = fnl.types[idx],
  899.                             size = input$sld_hsp_fnl_fnz / 8
  900.                 )
  901.                 g <- g + geom_line(
  902.                             data = funnel.limits,
  903.                             aes(x = x, y = limsup),
  904.                             color = fnl.cols[idx],
  905.                             linetype = fnl.types[idx],
  906.                             size = input$sld_hsp_fnl_fnz / 8
  907.                 )
  908.                 if(input$chk_hsp_fnl_fnv){
  909.                     g <- g + geom_text(
  910.                                 data = funnel.limits,
  911.                                 aes(pretty(max(y$X))[2], min(limsup)),
  912.                                 label = paste0(100*as.numeric(fnl.lims[idx]), '%'),
  913.                                 size = 2,
  914.                                 hjust = -0.05,
  915.                                 color = fnl.cols[idx]
  916.                     )
  917.                 }
  918.             }
  919.         }
  920.     }
  921.     # format x-axis and trim effect size to desired details
  922.     g <- g + scale_x_continuous(labels = comma, limits = input$sld_hsp_fnl_tmz )
  923.     # format y-axis (if measure format percentage) and trim metric values to desired details
  924.     if(length(input$sld_hsp_fnl_tmt) > 0)
  925.         g <- g + scale_y_continuous(
  926.                     labels = if(is.hsp.fnl.pct()){ percent } else { comma },
  927.                     limits = input$sld_hsp_fnl_tmt/if(is.hsp.fnl.pct()){ 100 } else { 1 }
  928.         )
  929.     # if selected, add axis titles (main title and subtitle are added automatically to the print version)
  930.     g <- g + labs(x = '', y = '')
  931.     if(input$chk_hsp_fnl_xlt)
  932.         g <- g + labs(x = paste(metrics[label == input$cbo_hsp_fnlX, title], 'in', var.hsp.geo()), y = metrics[label == input$cbo_hsp_fnlY, title] )
  933.     # add theme and style options
  934.     g <- my.ggtheme(g,
  935.                 xaxis.draw = input$chk_hsp_fnl_xlx, yaxis.draw = input$chk_hsp_fnl_xly, ticks.draw = input$chk_hsp_fnl_xtk,
  936.                 axis.colour = input$col_hsp_fnl_xsc, axis.size = as.numeric(input$sld_hsp_fnl_xsz) / 10,
  937.                 hgrid.draw = ('Horizontal' %in% input$chg_hsp_fnl_grd), vgrid.draw = ('Vertical' %in% input$chg_hsp_fnl_grd),
  938.                 grids.colour = input$col_hsp_fnl_gdc, grids.size = as.numeric(input$sld_hsp_fnl_gdz) / 10, grids.type = input$cbo_hsp_fnl_gdt,
  939.                 labels.rotation = c(0, 0), bkg.colour = input$col_hsp_fnl_bkg, font.size = input$sld_hsp_fnl_xlz,
  940.                 ttl.font.size.mult = as.numeric(input$sld_hsp_fnl_xlt)/100, ttl.face = input$cbo_hsp_fnl_xlt, plot.border = input$chk_hsp_fnl_plb,
  941.                 font.family = input$cbo_hsp_fnl_ffm
  942.     )
  943.     g
  944. })
  945. output$out_hsp_fnl <- renderggiraph({
  946.     gg.to.ggiraph(hsp_fnl_plt(), sel.type = 'multiple', gg.width = input$sld_hsp_fnl_ggw / 10 )
  947. })
  948. # Handle dot(s) selection
  949. observeEvent(input$btn_hsp_fnl_rst, {
  950.     session$sendCustomMessage(type = 'out_hsp_fnl_set', message = character(0))
  951. })
  952. sel_hsp_fnl <- reactive({
  953.     if(is.null(input$out_hsp_fnl_selected)) return(character(0))
  954.     input$out_hsp_fnl_selected
  955. })
  956. output$out_hsp_sel <- renderText({
  957.     paste0('Centres Selected: ', length(sel_hsp_fnl()), '. ', paste(sort(sel_hsp_fnl()), collapse = ', ') )
  958. })
  959. # Build timeseries from selection
  960. output$ui_hsp_scl_flt <- renderUI({
  961.     if(is.null(input$out_hsp_fnl_selected)) return()
  962.     selectInput('cbo_hsp_scl_flt', 'TIME REFERENCE:',
  963.         choices = c('Year' = 'date.year', 'Quarter' = 'date.quarter', 'Month' = 'date.month', 'Week' = 'date.week', 'Day' = 'date.day' ),
  964.         selected = 'date.month'
  965.     )
  966. })
  967. # If checked, display an additional line being the TOTAL UK
  968. output$ui_hsp_scl_tuk <- renderUI({
  969.     if( length(sel_hsp_fnl()) < 1 ) return()
  970.     checkboxInput('chk_hsp_scl_tuk', 'Add Total Line', value = FALSE)
  971. })
  972. # Should the metric be calculated on all records as a sngle entity ? (Only if selection > 1 dot)
  973. output$ui_hsp_scl_agg <- renderUI({
  974.     if( length(sel_hsp_fnl()) <= 1 ) return()
  975.     checkboxInput('chk_hsp_scl_agg', 'Aggregate selected', value = FALSE)
  976. })
  977. # Display the time series
  978. output$out_hsp_scl <- renderDygraph({
  979.     # Check if at least one dot is selected
  980.     if( length(sel_hsp_fnl()) < 1 ) return()
  981.     # Check if when having multiple  dots shoudl return the dots as a single aggregated entity
  982.     calc.aggregate <- FALSE
  983.     if( length(sel_hsp_fnl()) > 1 )
  984.         if(input$chk_hsp_scl_agg) calc.aggregate <- TRUE
  985.     # Query the dataset vs selected dot(s)
  986.     y <- dt_hsp_fnl()[ get( paste0(input$cbo_hsp_geo, '_id') ) %in% sel_hsp_fnl() ]
  987.     # Query the formula to be applied
  988.     if(metrics[label == input$cbo_hsp_fnlY, type] == 2){
  989.         YM <- metrics[label == input$cbo_hsp_fnlY, mutate_pct]
  990.     } else {
  991.         YM <- metrics[label == input$cbo_hsp_fnlY, mutate_as]
  992.     }
  993.     # transform the dataset correpsonding to the selected options
  994.     if(calc.aggregate){
  995.         y <- y[, .(Y = eval(parse(text = YM)) ), .(X = get(input$cbo_hsp_scl_flt) ) ]
  996.     } else {
  997.         y <- y[, .(Y = eval(parse(text = YM)) ), .(X = get(input$cbo_hsp_scl_flt), W = get( paste0(input$cbo_hsp_geo, '_id') ) ) ]
  998.         y <- dcast.data.table(y, X~W, value.var = 'Y')
  999.     }
  1000.     if(input$cbo_hsp_scl_flt == 'date.year') y[, X := as.Date(paste0(X, '1231'), '%Y%m%d') ]
  1001.     # build the correct time object
  1002.     y <- as.data.frame(y)
  1003.     y <- xts(y[, -1], order.by = y[, 1])
  1004.     # build the chart object
  1005.     dg <- dygraph(y) %>%
  1006.             dyAxis('y', label = metrics[label == input$cbo_hsp_fnlY, title], drawGrid = TRUE) %>%
  1007.             dyHighlight(
  1008.                 highlightCircleSize = 4,
  1009.                 highlightSeriesBackgroundAlpha = 0.4,
  1010.                 hideOnMouseOut = TRUE,
  1011.                 highlightSeriesOpts = list(strokeWidth = 2)
  1012.             ) %>%
  1013.             dyRangeSelector(
  1014.                 dateWindow = unname(c(date.range['start'], date.range['max'])),
  1015.                 height = 30,
  1016.                 strokeColor = 'black',
  1017.                 retainDateWindow = TRUE
  1018.             ) %>%
  1019.             dyRoller(rollPeriod = 1)
  1020.     # if(!is.hsp.grp()){
  1021.     #    dg <- dg %>% dySeries('V1', label = input$cbo_tms_Y, color = input$cbo_tms_plq)
  1022.     #    dg <- dg %>% dyLegend(show = 'follow')
  1023.     #    html('lgn_tms_lns', '')
  1024.     # } else {
  1025.     #     dg <- dg %>% dyLegend(show = 'always', hideOnMouseOut = FALSE, labelsSeparateLines = TRUE, labelsDiv = 'lgn_tms_lns')
  1026.     #     dg <- dg %>% dyOptions(axisLineWidth = 1.25, colors = brewer.pal(ncol(y) -1, input$cbo_tms_plq))
  1027.     #     if(input$chk_tms_stg) dg <- dg %>% dyOptions(stackedGraph = TRUE)
  1028.     # }
  1029.     dg
  1030. })
  1031. # If checked, display an additional table with all records related to above selections
  1032. output$ui_hsp_fnl_tbl <- renderUI({
  1033.     if( length(sel_hsp_fnl()) < 1 ) return()
  1034.     checkboxInput('chk_hsp_fnl_tbl', 'Display all records', value = FALSE)
  1035. })
  1036. # Build the dataset for the table
  1037. output$ui_hsp_sct_flt <- renderUI({
  1038.     if( length(sel_hsp_fnl()) < 1 ) return()
  1039.     if( !input$chk_hsp_fnl_tbl ) return()
  1040.     selectInput('cbo_hsp_sct_flt', 'FIELDS:',
  1041.         choices = build_uiV( c('CAT', 'NUM', 'LGC', 'DTM') ),
  1042.         multiple = TRUE,
  1043.         selected = fields.selection,
  1044.         width = '100%'
  1045.     )
  1046. })
  1047. # Display the table
  1048. output$out_hsp_sct <- renderDataTable({
  1049.     if( length(sel_hsp_fnl()) < 1 ) return()
  1050.     if( !input$chk_hsp_fnl_tbl ) return()
  1051.     y <- get.dt.renamed(input$cbo_hsp_sct_flt, sel_hsp_fnl() )
  1052.     t <- datatable(y,
  1053.             rownames = FALSE,
  1054.             selection = 'none',
  1055.             class = 'cell-border stripe hover nowrap',
  1056.             extensions = c('Buttons', 'FixedColumns'),
  1057.             options = list(
  1058.                 pageLength = 15,
  1059.                 lengthMenu = c(5, 10, 15, 20, 25, 30, 50, 100),
  1060.                 scrollX = TRUE,
  1061.                 searchHighlight = TRUE,
  1062.                 buttons = c('copy', 'csv', 'excel', 'pdf', 'print'),
  1063.                 fixedColumns = list(leftColumns = 2),
  1064.                 columnDefs = list(list(
  1065.                     targets = 1,
  1066.                     render = JS(
  1067.                         "function(data, type, row, meta) {",
  1068.                             "return type === 'display' && data.length > 9 ?",
  1069.                             "'<span title=\"' + data + '\">' + data.substr(0, 9) + '...</span>' : data;",
  1070.                         "}"
  1071.                     )
  1072.                 )),
  1073.                 initComplete = JS(
  1074.                     "function(settings, json) {",
  1075.                         "$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});",
  1076.                     "}"
  1077.                 ),
  1078.                 dom = 'Biftlp'
  1079.             )
  1080.     )
  1081. })
  1082.  
  1083.  
  1084. ### CHOROPLET + POINTS (map) ------------------------------------------------------------------------------------------------------------
  1085. is.map.flt <- reactive({
  1086.     if(input$cbo_hsp_mapF != 'NONE')
  1087.         if(input$cbo_hsp_map_flt != 'NONE') return(TRUE)
  1088.     return(FALSE)
  1089. })
  1090. is.hsp.map.msr <- reactive({
  1091.     metrics[label == input$cbo_hsp_mapY, type] == 2
  1092. })
  1093. hsp.map.title <- reactive({
  1094.     ttl <- paste(metrics[label == input$cbo_hsp_mapY, title], 'by', var.hsp.geo() )
  1095.     if(is.map.flt())
  1096.         ttl <-  paste0(ttl,
  1097.                     ', filtered by ', clear.label(input$cbo_hsp_mapF), ' = <i>',
  1098.                     lookups[domain_id == gsub('X', '', input$cbo_hsp_mapF) & lookup_id == input$cbo_hsp_map_flt, description], '</i>'
  1099.         )
  1100.     if(input$chk_hsp_map_hsp){
  1101.         if(input$cbo_hsp_mapZ1 != 'NONE' | input$cbo_hsp_mapZ2 != 'NONE')
  1102.         ttl <-  paste(ttl, '<br/>',
  1103.                     if(input$cbo_hsp_mapZ1 != 'NONE'){ clear.label(input$cbo_hsp_mapZ1) },
  1104.                     if( (input$cbo_hsp_mapZ1 != 'NONE') & (input$cbo_hsp_mapZ2 != 'NONE') ){ 'and' },
  1105.                     if(input$cbo_hsp_mapZ2 != 'NONE'){ clear.label(input$cbo_hsp_mapZ2) },
  1106.                     'by Hospitals'
  1107.         )
  1108.     }
  1109.     ttl
  1110. })
  1111. output$out_hsp_mpx <- renderUI({
  1112.     HTML(paste0('<h3>', hsp.map.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
  1113. })
  1114. dt_hsp_map_plg <- reactive({
  1115.     if(input$cbo_hsp_mapY == 'NONE') return(NULL)
  1116.     mtc <- input$cbo_hsp_mapY
  1117.     geo <- input$cbo_hsp_geo
  1118.     # flag for measure (ie, calculate percentage)
  1119.     is.hsp.map.msr <- (metrics[label == mtc, type] == 2)
  1120.     # determine dataset: YF = formula for filter, YM = formula for measure / metric
  1121.     if(is.hsp.map.msr){
  1122.         YF <- metrics[label == mtc, filter_pct]
  1123.         YM <- metrics[label == mtc, mutate_pct]
  1124.     } else {
  1125.         YF <- metrics[label == mtc, filter_by]
  1126.         YM <- metrics[label == mtc, mutate_as]
  1127.     }
  1128.     y <- dt_hsp()[eval(parse(text = YF))]
  1129.     if(input$cbo_hsp_mapF != 'NONE'){
  1130.         if(input$cbo_hsp_map_flt != 'NONE'){
  1131.             flt.map.lbl <- lookups[domain_id == gsub('X', '', input$cbo_hsp_mapF) & lookup_id == input$cbo_hsp_map_flt, description]
  1132.             y <- y[ get(input$cbo_hsp_mapF) == flt.map.lbl ]
  1133.         }
  1134.     }
  1135.     y <- y[, .( N = .N, Y = eval(parse(text = paste(YM))) ), .( LW = get(geo), W = get(paste0(geo, '_id')) ) ]
  1136.     yt <-
  1137.         if(input$cbo_hsp_fnlF == 'NONE'){
  1138.             dt_hsp()[, .(T = .N), .(W = get( paste0(geo, '_id'))) ]
  1139.         } else {
  1140.             dt_hsp()[get(input$cbo_hsp_mapF) == flt.map.lbl, .(T = .N), .(W = get( paste0(geo, '_id'))) ]
  1141.         }
  1142.     setkey(y, 'W')
  1143.     setkey(yt, 'W')
  1144.     y <- y[yt][, C := N/T]
  1145.     y[, ttip := paste0(
  1146.                     var.hsp.geo(), ': <b>', LW, '</b><br/>',
  1147.                     if(input$cbo_hsp_fnlF == 'NONE'){ paste0('') },
  1148.                     'N. Procedures: <b>', T, '</b><br/>',
  1149.                     'Completeness: <b>', formatC(100*C, digits = 2, format = 'f'), '%</b> (', round(N), ')', '<br/>',
  1150.                     metrics[label == mtc, label], ': <b>',
  1151.                     if(is.hsp.map.msr){ paste0(formatC(100*Y, digits = 2, format = 'f'), '%</b> (', round(N*Y), ')') } else { Y }, '<br/>'
  1152.     )]
  1153.     setkey(y, 'W')
  1154.     setkey(areas, 'nhs_id')
  1155.     areas[, .(nhs_id, Wo = ons_id)][y]
  1156. })
  1157.  
  1158. # observeEvent(input$cbo_hsp_geo,
  1159. #     {
  1160. #         updateSelectInput(session, 'cbo_hsp_mapY', 'AREA METRIC:', choices = c('NONE', build_uiY('map')))
  1161. # #        updateSelectInput(session, )
  1162. #     }
  1163. # )
  1164. # Initial Layer
  1165. output$out_hsp_map <- renderLeaflet({
  1166.     bnd <- boundaries[[loca.ini]]
  1167.     if(length(boundaries[[input$cbo_hsp_geo]]) > 0) bnd <- boundaries[[input$cbo_hsp_geo]]
  1168.     bnd.void <- subset(bnd, is.na(bnd$H))
  1169.     bnd.ok <- subset(bnd, !is.na(bnd$H))
  1170.     pal <- colorNumeric(palette = brewer.pal(3, pal.ini), domain = 1:max(bnd.ok$H, na.rm = TRUE), na.color = 'grey')
  1171.     leaflet(bnd) %>%
  1172.         fitBounds(lng1 = 1.8, lat1 = 49.9, lng2 = -8.3, lat2 = 58.0 ) %>%
  1173.         addTiles(tile.ini) %>%
  1174.         addPolygons(data = bnd.void, group = 'poly.void',
  1175.             stroke = TRUE,
  1176.             color = '#444444',
  1177.             opacity = 1.0,
  1178.             weight = 0.6,
  1179.             smoothFactor = 0.5,
  1180.             fill = TRUE,
  1181.             fillColor = 'grey',
  1182.             fillOpacity = 0.4,
  1183.             highlightOptions = highlightOptions(
  1184.                 color = 'red',
  1185.                 weight = 3,
  1186.                 bringToFront = TRUE
  1187.             ),
  1188.             label = lapply(1:length(bnd.void), function(x) HTML(paste0(bnd.void$name[x], ' (', bnd.void$nhs_id[x], '). ', '<b>Not Supported</b>') ) ),
  1189.             labelOptions = labelOptions(
  1190.                 textsize = '12px',
  1191.                 direction = 'auto',
  1192.                 style = list('font-weight' = 'normal', 'padding' = '2px 6px')
  1193.             )
  1194.         ) %>%
  1195.         addPolygons(data = bnd.ok, group = 'poly.ok',
  1196.             stroke = TRUE,
  1197.             color = '#444444',
  1198.             opacity = 1.0,
  1199.             weight = 0.6,
  1200.             smoothFactor = 0.5,
  1201.             fill = TRUE,
  1202.             fillColor = ~pal(H),
  1203.             fillOpacity = 0.4,
  1204.             highlightOptions = highlightOptions(
  1205.                 color = 'white',
  1206.                 weight = 5,
  1207.                 bringToFront = TRUE
  1208.             ),
  1209.             label = lapply(1:length(bnd), function(x) HTML(paste0(bnd.ok$name[x], ' (', bnd.ok$nhs_id[x], '). Hospitals:<b>', bnd.ok$H[x], '</b>') ) ),
  1210.             labelOptions = labelOptions(
  1211.                 textsize = '12px',
  1212.                 direction = 'auto',
  1213.                 style = list('font-weight' = 'normal', 'padding' = '2px 6px')
  1214.             )
  1215.         ) %>%
  1216.         addLegend(
  1217.             pal = pal,
  1218.             values = ~H,
  1219.             title = 'N Centres',
  1220.             position = 'bottomright',
  1221.             opacity = 0.8
  1222.         )
  1223. })
  1224. # Merge boundaries with chosen data. ===>>> NEEDS tweak for names when missing data <<<===
  1225. hsp_map_bnd <- reactive({
  1226.     bnd <- boundaries[[input$cbo_hsp_geo]]
  1227.     bnd <- subset(bnd, !is.na(bnd$H))
  1228.     merge(bnd, dt_hsp_map_plg(), by.x = 'id', by.y = 'Wo', all.x = FALSE)
  1229. })
  1230. # Determine the number of different classes
  1231. n.col <- reactive({
  1232.    min(length(unique(hsp_map_bnd()$Y)), input$sld_hsp_map_Ycn, brewer.pal.info[input$pal_hsp_mapY, 'maxcolors'])
  1233. })
  1234. # Determine the values for the bins
  1235. brks <- reactive({
  1236.     classIntervals(hsp_map_bnd()$Y, n = n.col(), style = input$cbo_hsp_map_Ycl)
  1237. })
  1238. # Determine the colors to use
  1239. col_codes <- reactive({
  1240.     y <- brewer.pal(n = n.col(), name = input$pal_hsp_mapY)[1:n.col()]
  1241.     if(input$chk_hsp_mapY_rvc) y <- rev(y)
  1242.     y
  1243. })
  1244. # associate colors and classes
  1245. colorpal <- reactive({
  1246.     findColours(brks(), col_codes())
  1247. })
  1248.  
  1249. # Update changes in Tiles
  1250. observe({
  1251.     proxy <- leafletProxy('out_hsp_map')
  1252.     proxy %>% clearTiles()
  1253.     proxy %>% addTiles(input$cbo_hsp_map_tls)
  1254. })
  1255. # Update changes In Polygons
  1256. observe({
  1257.     if(input$cbo_hsp_mapY != 'NONE'){
  1258.         pal <- colorpal()
  1259.         bnd <- hsp_map_bnd()
  1260.         leafletProxy('out_hsp_map') %>%
  1261.             clearGroup('poly.ok') %>%
  1262.             addPolygons(data = bnd, group ='poly.ok',
  1263.                 stroke = TRUE,
  1264.                 color = input$col_hsp_mapY_bcl,
  1265.                 opacity = 1.0,
  1266.                 weight = as.integer(input$sld_hsp_mapY_bsz) / 10,
  1267.                 smoothFactor = 0.5,
  1268.                 fill = TRUE,
  1269.                 fillColor = pal,
  1270.                 fillOpacity = 1 - as.integer(input$sld_hsp_mapY_trp) / 10,
  1271.                 highlightOptions = highlightOptions(
  1272.                     color = 'white',
  1273.                     weight = 3,
  1274.                     bringToFront = TRUE
  1275.                 ),
  1276.                 label = lapply(bnd$ttip, HTML),
  1277.                 labelOptions = labelOptions(
  1278.                     textsize = '15px',
  1279.                     direction = 'auto',
  1280.                     style = list('font-weight' = 'normal', 'padding' = '3px 8px')
  1281.                 )
  1282.             )
  1283.     }
  1284. })
  1285. # Draw / Clear Polygons Legend
  1286. observe({
  1287.     if(input$cbo_hsp_mapY != 'NONE'){
  1288.         pal <- colorpal()
  1289.         bnd <- hsp_map_bnd()
  1290.         proxy <- leafletProxy('out_hsp_map')
  1291.         proxy %>% clearControls()
  1292.         if(input$chk_hsp_map_lgn){
  1293.             # mtc.type <- metrics[label == input$cbo_hsp_mapY, type]
  1294.             # lbl.brks <- brks()[[2]]
  1295.             # if(mtc.type == 1){
  1296.             #     lbl.brks <- format(round(lbl.brks, 0), big.mark = ',')
  1297.             # } else if(mtc.type == 2){
  1298.             #     lbl.brks <- format(round(100*lbl.brks, 2), nsmall = 2)
  1299.             # } else {
  1300.             #     lbl.brks <- format(round(lbl.brks, 1), nsmall = 1)
  1301.             # }
  1302.             # lbl.text <- sapply(2:n.col(),
  1303.             #     function(x)
  1304.             #         paste0(
  1305.             #             lbl.brks[x-1], ' \u2264 n < ', lbl.brks[x],
  1306.             #             ' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[x-1])) & bnd$Y < as.numeric(gsub(',', '', lbl.brks[x])) ] ), ')'
  1307.             #         )
  1308.             # )
  1309.             # lbl.text <- c(lbl.text,
  1310.             #     paste0(
  1311.             #         lbl.brks[n.col()], ' \u2264 n \u2264 ', lbl.brks[n.col() + 1],
  1312.             #         ' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[n.col()])) & bnd$Y <= as.numeric(gsub(',', '', lbl.brks[n.col() + 1])) ] ), ')'
  1313.             #     )
  1314.             # )
  1315.             lbl.text <- get.legend.colnames(bnd, metrics[label == input$cbo_hsp_mapY, type], brks()[[2]], n.col())
  1316.             proxy %>%
  1317.                 addLegend(
  1318.                     colors = col_codes(),
  1319.                     labels = lbl.text,
  1320.                     title = metrics[label == input$cbo_hsp_mapY, title],
  1321.                     position = input$cbo_hsp_map_lgn,
  1322.                     opacity = 1 - as.integer(input$sld_hsp_mapY_trp) / 10
  1323.                 )
  1324.         }
  1325.     }
  1326. })
  1327. # Update Markers: Hospitals points / icons, with correspondin Size / Colours Metrics
  1328. observe({
  1329.     proxy <- leafletProxy('out_hsp_map')
  1330.     proxy %>% clearMarkers()
  1331.     if(input$chk_hsp_map_hsp){
  1332.         proxy %>%
  1333.             addAwesomeMarkers(data = centres,
  1334.                 lng = ~X_lon, lat = ~Y_lat,
  1335.                 label = ~as.character(HSP_id),
  1336.                 labelOptions = labelOptions(
  1337.                     opacity = 0.8
  1338.                 ),
  1339.                 popup = ~as.character(paste(HSP_id, '-', HSP)),
  1340.                 popupOptions = labelOptions(
  1341.                     opacity = 0.8
  1342.                 ),
  1343.                 icon = hsp.icons
  1344.             )
  1345.     }
  1346. })
  1347.  
  1348.  
  1349. ### DOWNLOAD (dwn) ----------------------------------------------------------------------------------------------------------------
  1350. # DATASET
  1351. output$out_hsp_dwn <- renderText({
  1352.     paste('The dataset contains', format(nrow(dt_hsp()), big.mark = ','), 'records')
  1353. })
  1354. output$dwn_hsp_dta <- downloadHandler(
  1355.     filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.csv') },
  1356.     content <- function(file){
  1357.                     write.table(
  1358.                         dt.for.export(
  1359.                             switch(input$cbo_hsp_tmp,
  1360.                                 '1' = dataset[ date.year >= input$sld_hsp_tmp[1] & date.year <= input$sld_hsp_tmp[2] ],
  1361.                                 '2' = dataset[
  1362.                                         daten.month >= as.numeric(paste0(substr(input$dts_hsp[1], 1, 4), substr(input$dts_hsp[1], 6, 7))) &
  1363.                                             daten.month <= as.numeric(paste0(substr(input$dts_hsp[2], 1, 4), substr(input$dts_hsp[2], 6, 7)))
  1364.                                       ],
  1365.                                 '3' = dataset[ date.day >= input$dts_hsp[1] & date.day <= input$dts_hsp[2] ]
  1366.                             )
  1367.                         ),
  1368.                         file, sep = ',', row.names = FALSE
  1369.                     )
  1370.         }
  1371. )
  1372. # TABLES
  1373. output$dwn_hsp_tbl <- downloadHandler(
  1374.     filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.csv') },
  1375.     content <- function(file){
  1376.                     write.table(
  1377.                         switch(input$tabs_hsp,
  1378.                             'barplot' = dt.csv.output(hsp_brp_tbl()[[1]]),
  1379.                             'boxplot' = dt.csv.output(hsp_bxp_tbl()[[1]]),
  1380.                             'heatmap' = dt.csv.output(hsp_hmp_tbl()[[1]]),
  1381.                             'funnelplot' = dt.csv.output(hsp_fnl_tbl()[[1]]),
  1382.                             'maps'    = dt.csv.output(hsp_map_tbl())
  1383.                         ),
  1384.                         file, sep = ',', row.names = FALSE
  1385.                     )
  1386.         }
  1387. )
  1388. # PLOTS
  1389. output$dwn_hsp_plt <- downloadHandler(
  1390.     filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.png') },
  1391.     content = function(file) ggsave(file, plot = {
  1392.         switch(input$tabs_hsp,
  1393.             'barplot'   = {
  1394.                 hsp_brp_plt() + labs(
  1395.                                     title    = plot.title.clean(hsp.brp.title()),
  1396.                                     subtitle = plot.title.clean(hsp.subtitle()),
  1397.                                     caption  = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
  1398.                                 )
  1399.                 },
  1400.             'boxplot'     = {
  1401.                 hsp_bxp_plt() + labs(
  1402.                                     title    = plot.title.clean(hsp.bxp.title()),
  1403.                                     subtitle = plot.title.clean(hsp.subtitle()),
  1404.                                     caption  = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
  1405.                                 )
  1406.                 },
  1407.             'heatmap'     = {
  1408.                 hsp_hmp_plt() + labs(
  1409.                                     title = plot.title.clean(hsp.hmp.title()),
  1410.                                     subtitle = plot.title.clean(hsp.subtitle()),
  1411.                                     caption  = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
  1412.                                 )
  1413.                 },
  1414.             'funnelplot' = {
  1415.                 hsp_fnl_plt() + labs(
  1416.                                     title = plot.title.clean(hsp.fnl.title()),
  1417.                                     subtitle = plot.title.clean(hsp.subtitle()),
  1418.                                     caption  = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
  1419.                                 )
  1420.                 }
  1421.         )
  1422.     }, type = 'cairo-png')
  1423. )
  1424. # MAPS - STATIC
  1425. output$dwn_hsp_mpp <- downloadHandler(
  1426.     filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.jpg') },
  1427.     content = function(file) mapview(hsp_map_plt(), filename)
  1428. )
  1429. # MAPS - INTERACTIVE
  1430. output$dwn_hsp_mph <- downloadHandler(
  1431.     filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.html') },
  1432.     content = function(file) saveWidget(hsp_map_plt(), filename)
  1433. )
Advertisement
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!