###################################################################################################
# SHINY Explorer - XXX (xxx) - server.R
###################################################################################################
# TOGGLES -----------------------------------------------------------------------------------------------------------------------
onclick('tgl_hsp_geo', toggle(id = 'hdn_hsp_geo', anim = TRUE) ) # geography
onclick('tgl_hsp_tmp', toggle(id = 'hdn_hsp_tmp', anim = TRUE) ) # timespan
onclick('tgl_hsp_mtc', toggle(id = 'hdn_hsp_mtc', anim = TRUE) ) # metrics
onclick('tgl_hsp_opt', toggle(id = 'hdn_hsp_opt', anim = TRUE) ) # options
onclick('tgl_hsp_dwn', toggle(id = 'hdn_hsp_dwn', anim = TRUE) ) # download
onclick('tgl_hsp_brp_gen', toggle(id = 'hdn_hsp_brp_gen', anim = TRUE) ) # options / bars / general
onclick('tgl_hsp_brp_axs', toggle(id = 'hdn_hsp_brp_axs', anim = TRUE) ) # options / bars / axis
onclick('tgl_hsp_brp_bkg', toggle(id = 'hdn_hsp_brp_bkg', anim = TRUE) ) # options / bars / background
onclick('tgl_hsp_brp_brs', toggle(id = 'hdn_hsp_brp_brs', anim = TRUE) ) # options / bars / bars
onclick('tgl_hsp_brp_lbl', toggle(id = 'hdn_hsp_brp_lbl', anim = TRUE) ) # options / bars / labels
onclick('tgl_hsp_brp_avg', toggle(id = 'hdn_hsp_brp_avg', anim = TRUE) ) # options / bars / average line
onclick('tgl_hsp_bxp_gen', toggle(id = 'hdn_hsp_bxp_gen', anim = TRUE) ) # options / box / general
onclick('tgl_hsp_bxp_axs', toggle(id = 'hdn_hsp_bxp_axs', anim = TRUE) ) # options / box / axis
onclick('tgl_hsp_bxp_bkg', toggle(id = 'hdn_hsp_bxp_bkg', anim = TRUE) ) # options / box / background
onclick('tgl_hsp_bxp_bxs', toggle(id = 'hdn_hsp_bxp_bxs', anim = TRUE) ) # options / box / boxes
onclick('tgl_hsp_bxp_lns', toggle(id = 'hdn_hsp_bxp_lns', anim = TRUE) ) # options / box / lines
onclick('tgl_hsp_bxp_out', toggle(id = 'hdn_hsp_bxp_out', anim = TRUE) ) # options / box / outliers
onclick('tgl_hsp_bxp_avg', toggle(id = 'hdn_hsp_bxp_avg', anim = TRUE) ) # options / box / average line
onclick('tgl_hsp_hmp_gen', toggle(id = 'hdn_hsp_hmp_gen', anim = TRUE) ) # options / heat / general
onclick('tgl_hsp_hmp_axs', toggle(id = 'hdn_hsp_hmp_axs', anim = TRUE) ) # options / heat / axis
onclick('tgl_hsp_hmp_bxs', toggle(id = 'hdn_hsp_hmp_bxs', anim = TRUE) ) # options / heat / boxes
onclick('tgl_hsp_fnl_gen', toggle(id = 'hdn_hsp_fnl_gen', anim = TRUE) ) # options / scatter / general
onclick('tgl_hsp_fnl_axs', toggle(id = 'hdn_hsp_fnl_axs', anim = TRUE) ) # options / scatter / axis
onclick('tgl_hsp_fnl_bkg', toggle(id = 'hdn_hsp_fnl_bkg', anim = TRUE) ) # options / scatter / background
onclick('tgl_hsp_fnl_pnt', toggle(id = 'hdn_hsp_fnl_pnt', anim = TRUE) ) # options / scatter / points
onclick('tgl_hsp_fnl_lbl', toggle(id = 'hdn_hsp_fnl_lbl', anim = TRUE) ) # options / scatter / labels
onclick('tgl_hsp_fnl_avg', toggle(id = 'hdn_hsp_fnl_avg', anim = TRUE) ) # options / scatter / average line
onclick('tgl_hsp_fnl_fnl', toggle(id = 'hdn_hsp_fnl_fnl', anim = TRUE) ) # options / scatter / funnel limits
onclick('tgl_hsp_map_gen', toggle(id = 'hdn_hsp_map_gen', anim = TRUE) ) # options / maps / general
onclick('tgl_hsp_map_pol', toggle(id = 'hdn_hsp_map_pol', anim = TRUE) ) # options / maps / areas
onclick('tgl_hsp_map_pnt', toggle(id = 'hdn_hsp_map_pnt', anim = TRUE) ) # options / maps / points
# DYNAMIC CONTROLS --------------------------------------------------------------------------------------------------------------
### COMMON -----------------------------------------------------------------------------------------------------------------
# Select months or dates range, only a change in formatting
output$ui_hsp_tmp <- renderUI({
my.format <- ifelse(input$cbo_hsp_tmp == '3', 'dd-M-yyyy', 'M yyyy')
dateRangeInput('dts_hsp', 'DATE RANGE:',
start = date.range['start'], end = date.range['max'],
min = date.range['min'], max = date.range['max'],
weekstart = 1, separator = '►', format = my.format
)
})
# Colour Choices
## Barplot
output$ui_hsp_brp_col <- renderUI({
if(input$cbo_hsp_brpG != 'NONE')
if(input$cbo_hsp_brp_grp != 'facet') return( selectInput('pal_hsp_brp', 'FILL PALETTE:', choices = lst.palette, selected = 'Dark2') )
colourpicker::colourInput('col_hsp_brp', 'FILL COLOUR:', pal.default['col'], showColour = 'background')
})
## Boxplot
output$ui_hsp_bxp_col <- renderUI({
if(input$cbo_hsp_bxpG != 'NONE')
if(input$rdb_hsp_bxp_grp != 'facet') return( selectInput('pal_hsp_bxp', 'FILL PALETTE:', choices = lst.palette, selected = 'Dark2') )
colourpicker::colourInput('col_hsp_bxp', 'FILL COLOUR:', pal.default['col'], showColour = 'background')
})
## Map: Point
output$ui_hsp_mapZ_col <- renderUI({
if(!input$chk_hsp_map_hsp) return()
if(input$cbo_hsp_mapZ != 'NONE') return( selectInput('pal_hsp_mapZ', 'FILL PALETTE:', choices = lst.palette, selected = 'Dark2') )
colourpicker::colourInput('col_hsp_mapZ', 'FILL COLOUR:', pal.default['col'], showColour = 'background')
})
### TABLE (tbl) -----------------------------------------------------------------------------------------------------------------
# Choose a value from the filtering variable
output$ui_hsp_tbl_flt <- renderUI({
selectInput('cbo_hsp_tbl_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_tblF) ) ) )
})
# Choice of ordering when not grouped: CNT vs PCT vs QTA vs IDX depending on 1-Quantity, 2-Measure, 3-Metric
output$ui_hsp_tbl_ord <- renderUI({
ui.list <- tbl.orders[[ min(3, metrics[label == input$cbo_hsp_tblY, type]) ]]
ui.list <- c(var.hsp.geo(), ui.list)
selectInput('cbo_hsp_tbl_ord', 'ORDER BY:', choices = ui.list)
})
# Choice of type of ordering, changing icon depending on variable being alpha or numeric
output$ui_hsp_tbl_ort <- renderUI({
var.type <- ifelse(input$cbo_hsp_tbl_ord %in% names(locations), 'alpha', 'numeric')
switchInput('swt_hsp_tbl_ord',
onLabel = paste0('<i class=\"fa fa-sort-', var.type, '-asc\"></i>'), onStatus = 'primary',
offLabel = paste0('<i class=\"fa fa-sort-', var.type, '-desc\"></i>'), offStatus = 'info',
size = 'normal', value = TRUE
)
})
# Choice of result when grouping: CNT vs PCT vs QTA vs IDX depending on 1-Quantity, 2-Measure, 3-Metric
output$ui_hsp_tbl_grp <- renderUI({
ui.list <-
if(metrics[label == input$cbo_hsp_tblY, type] == 1){
c('Counting', 'Quota')
} else if(metrics[label == input$cbo_hsp_tblY, type] == 2){
c('Counting', 'Quota', 'Percentage', 'Index')
} else {
c('Value', 'Index')
}
radioButtons('rdb_hsp_tbl_grp', 'SHOW:', choices = ui.list)
})
# Choice of reference when grouping (apart from Counting)
output$ui_hsp_tbl_gpr <- renderUI({
if(is.null(input$rdb_hsp_tbl_grp)) return()
if(input$rdb_hsp_tbl_grp %in% c('Counting', 'Percentage', 'Value')) return()
ui.list <- c('Columns' = 'C', 'Rows' = 'R')
if(input$rdb_hsp_tbl_grp == 'Quota') ui.list <- c('Total' = 'T', ui.list)
radioButtons('rdb_hsp_tbl_gpr', 'VS:', choices = ui.list )
})
### BARPLOT (brp) -----------------------------------------------------------------------------------------------------------------
# Choose a value from the filtering variable
output$ui_hsp_brp_flt <- renderUI({
selectInput('cbo_hsp_brp_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_brpF) ) ) )
})
# Choice of CNT vs PCT if measure
output$ui_hsp_brp_pct <- renderUI({
if(metrics[label == input$cbo_hsp_brpY, type] != 2) return()
checkboxInput('chk_hsp_brp_pct', 'SHOW PERCENTAGES', value = FALSE)
})
# Choice of AVERAGE LINE
output$ui_hsp_brp_avg <- renderUI({
if(metrics[label == input$cbo_hsp_brpY, type] == 1) return()
if(metrics[label == input$cbo_hsp_brpY, type] == 2)
if(!input$chk_hsp_brp_pct) return()
if(input$cbo_hsp_brpG != 'NONE')
if(!input$cbo_hsp_brp_grp == 'facet') return()
checkboxInput('chk_hsp_brp_avg', 'SHOW AVERAGE', value = FALSE)
})
# Choice of grouping type
output$ui_hsp_brp_grp <- renderUI({
ui.list <- c('dodge', 'facet')
if(metrics[label == input$cbo_hsp_brpY, type] == 1) ui.list <- c(ui.list, 'stack', 'fill')
if(metrics[label == input$cbo_hsp_brpY, type] == 2)
if(!input$chk_hsp_brp_pct) ui.list <- c(ui.list, 'stack', 'fill')
selectInput('cbo_hsp_brp_grp', 'GROUPING TYPE:', choices = ui.list)
})
# Number of centres to plot
output$ui_hsp_brp_cnt <- renderUI({
n.centres <- length(unique(hsp_brp_tbl()[[1]]$X))
sliderInput('sld_hsp_brp_cnt', 'NUMBER OF CENTRES', min = 1, max = n.centres, value = c(1, n.centres), step = 1, ticks = FALSE)
})
# BARPLOT: Axis labels rotation
output$ui_hsp_brp_lbr <- renderUI({
sliderInput(
'sld_hsp_brp_lbr', 'AXIS LABEL ROTATION:',
min = 0, max = 90,
value = ifelse(input$rdb_hsp_brp_orn == 'Horizontal', 0, 45),
step = 5, ticks = FALSE
)
})
# BARPLOT: Choice of colour for Value Labels
output$ui_hsp_brp_lbc <- renderUI({
colourpicker::colourInput('col_hsp_brp_lbl', 'LABELS COLOUR:', ifelse(input$rdb_hsp_brp_lbp == 'Inside', 'white', 'black'), showColour = 'background')
})
# BARPLOT: Choice of bars labels position if ungrouped or grouped and dosge/facet (for grouped stack & fill position can only be inside!)
# output$ui_hsp_brp_lbp <- renderUI({
# if( is.hsp.grp() & (input$cbo_hsp_brp_grp %in% c('stack', 'fill')) ) return(NULL)
# radioButtons('rdb_hsp_brp_lbp', 'POSITION:', choices = c('Inside', 'Outside'), inline = TRUE )
# })
### BOXPLOT (bxp) -----------------------------------------------------------------------------------------------------------------
# Choose a value from the filtering variable
output$ui_hsp_bxp_flt <- renderUI({
selectInput('cbo_hsp_bxp_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_bxpF) ) ) )
})
# Number of centres to plot
output$ui_hsp_bxp_cnt <- renderUI({
n.centres <- length(unique(hsp_bxp_tbl()[[1]]$X))
sliderInput('sld_hsp_bxp_cnt', 'NUMBER OF CENTRES', min = 1, max = n.centres, value = c(1, n.centres), step = 1, ticks = FALSE)
})
# Axis labels rotation
output$ui_hsp_bxp_lbr <- renderUI({
sliderInput(
'sld_hsp_bxp_lbr', 'AXIS LABEL ROTATION:',
min = 0, max = 90,
value = ifelse(input$rdb_hsp_bxp_orn == 'Horizontal', 0, 45),
step = 5, ticks = FALSE
)
})
### HEATMAP (hmp) -----------------------------------------------------------------------------------------------------------------
# Choice of CNT vs PCT if measure
output$ui_hsp_hmp_pct <- renderUI({
if(metrics[label == input$cbo_hsp_hmpY, type] != 2) return()
checkboxInput('chk_hsp_hmp_pct', 'SHOW PERCENTAGES', value = FALSE)
})
# Insert names of X-geo and Y-time in RESCALE radiobuttons labels
output$ui_hsp_hmp_rvc <- renderUI({
ui.list <- list('X', 'X2')
names(ui.list) <- c( paste('VS', var.hsp.geo() ), paste('VS', names(timeref[which(timeref == input$cbo_hsp_hmpX2)]) ) )
radioButtons('rdb_hsp_hmp_rvc', '', choices = ui.list)
})
# Choose a value from the filtering variable
output$ui_hsp_hmp_flt <- renderUI({
selectInput('cbo_hsp_hmp_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_hmpF) ) ) )
})
# Number of centres to plot
output$ui_hsp_hmp_cnt <- renderUI({
n.centres <- length(unique(hsp_hmp_tbl()[[1]]$X))
sliderInput('sld_hsp_hmp_cnt', 'NUMBER OF CENTRES', min = 1, max = n.centres, value = c(1, n.centres), step = 1, ticks = FALSE)
})
# Axis labels rotation
output$ui_hsp_hmp_lbr <- renderUI({
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 )
})
### FUNNELPLOT (fnl) -----------------------------------------------------------------------------------------------------------------
# Choice of CNT vs PCT (plus FUNNEL) if measure
output$ui_hsp_fnl_pct <- renderUI({
if(!is.hsp.fnl.msr()) return()
checkboxInput('chk_hsp_fnl_pct', 'SHOW PERCENTAGES', value = TRUE)
})
# flag when measure instead of metric
is.hsp.fnl.msr <- reactive({
metrics[label == input$cbo_hsp_fnlY, type] == 2
})
# flag when measure is pct instead of count
is.hsp.fnl.pct <- reactive({
ifelse(is.hsp.fnl.msr(), input$chk_hsp_fnl_pct, FALSE)
})
# store formulas reference
fnl.ref <- reactive({
XF <- metrics[label == eval(input$cbo_hsp_fnlX), filter_by] # The filter for the effect size
XM <- metrics[label == eval(input$cbo_hsp_fnlX), mutate_as] # The formula to calculate the effect size
YF <- metrics[label == eval(input$cbo_hsp_fnlY), filter_by] # The filter for the count of measure or the value of metric
YM <- metrics[label == eval(input$cbo_hsp_fnlY), mutate_as] # The formula to calculate the count of measure or the value of metric
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
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
list( 'X' = c(XF, XM), 'Y' = c(YF, YM, YFP, YMP), 'pct' = '%')
})
# Trimming effect size
output$ui_hsp_fnl_tmz <- renderUI({
if(length(hsp_fnl_tbl()[[1]]$X) == 0) return()
dt.max <- pretty( max( hsp_fnl_tbl()[[1]]$X ) )[2]
sliderInput('sld_hsp_fnl_tmz', 'TRIM SIZE:', min = 0, max = dt.max, value = c(0, dt.max), step = 10, dragRange = TRUE)
})
# Trimming metric values
output$ui_hsp_fnl_tmt <- renderUI({
if(is.null(tryNULL(is.object(hsp_fnl_tbl())))) return()
pct.mult <- ifelse(is.hsp.fnl.pct(), 100, 1)
dt.min <- pretty( min( hsp_fnl_tbl()[[1]]$Y, na.rm = TRUE ) * pct.mult )[1]
dt.max <- pretty( max( hsp_fnl_tbl()[[1]]$Y, na.rm = TRUE ) * pct.mult )[2]
sliderInput('sld_hsp_fnl_tmt', 'TRIM VALUES:', min = 0, max = dt.max, value = c(dt.min, dt.max), dragRange = TRUE, post = fnl.ref()[['pct']] )
})
# Choose a value from the filtering variable
output$ui_hsp_fnl_flt <- renderUI({
selectInput('cbo_hsp_fnl_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_fnlF) ) ) )
})
# flag filtered funnelplot
is.hsp.fnl.flt <- reactive({
ifelse(input$cbo_hsp_fnlF != 'NONE', (input$cbo_hsp_fnl_flt != 'NONE'), FALSE)
})
# show checkbox funnelplot
output$ui_hsp_fnl_fnl <- renderUI({
if(is.hsp.fnl.msr() & !is.hsp.fnl.pct()) return()
checkboxInput('chk_hsp_fnl_fnl', 'ADD FUNNEL', FALSE)
})
### MAP (map) -----------------------------------------------------------------------------------------------------------------
# Choose a value from the filtering variable
output$ui_hsp_map_flt <- renderUI({
selectInput('cbo_hsp_map_flt', 'ON:', choices = c('Choose a value...' = 'NONE', build_uiF(gsub('X', '', input$cbo_hsp_mapF) ) ) )
})
### DOWNLOAD (dwn) -----------------------------------------------------------------------------------------------------------------
# Choose filename for exporting dataset, chart, map, ...
output$ui_hsp_dwn <- renderUI({
textInput('txt_hsp_dwn', 'FILENAME:', paste(input$tabs_hsp, audit, 'Centres', input$cbo_hsp_geo, Sys.Date(), sep = '_') )
})
# AUX VARIABLES ----------------------------------------------------------------------------------------------------------------
var.hsp.geo <- reactive({
names(locations)[which(locations == input$cbo_hsp_geo)]
})
hsp.subtitle <- reactive({
switch(input$cbo_hsp_tmp,
'1' = paste('From', input$sld_hsp_tmp[1], 'to', input$sld_hsp_tmp[2] ),
'2' = paste('From', format(input$dts_hsp[1], '%b-%Y'), 'to', format(input$dts_hsp[2], '%b-%Y') ),
'3' = paste('From', format(input$dts_hsp[1], '%a, %d-%b-%Y'), 'to', format(input$dts_hsp[2], '%a, %d-%b-%Y') )
)
})
# FILTER DATASET ----------------------------------------------------------------------------------------------------------------
dt_hsp <- reactive({
# Filter records by selected year(s), month(s) or day(s)
y <- switch(input$cbo_hsp_tmp,
'1' = dataset[ date.year >= input$sld_hsp_tmp[1] & date.year <= input$sld_hsp_tmp[2] ],
'2' = dataset[
daten.month >= as.numeric(paste0(substr(input$dts_hsp[1], 1, 4), substr(input$dts_hsp[1], 6, 7))) &
daten.month <= as.numeric(paste0(substr(input$dts_hsp[2], 1, 4), substr(input$dts_hsp[2], 6, 7)))
],
'3' = dataset[ date.day >= input$dts_hsp[1] & date.day <= input$dts_hsp[2] ]
)
# Add X-var as of GEO selection
geoX <- paste0(input$cbo_hsp_geo, ifelse(input$chk_hsp_geo_cdn, '_id', ''))
y[, X := get(geoX) ][!is.na(X)]
})
# SERVER CODE --------------------------------------------------------------------------------------------------------------
### TABLE (tbl) -------------------------------------------------------------------------------------------------------------------
hsp.tbl.title <- reactive({
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 )
})
output$out_hsp_tbx <- renderUI({
HTML(paste0('<h3>', hsp.tbl.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
})
output$out_hsp_tbl <- renderDataTable({
is.hsp.tbl.flt <- ifelse(input$cbo_hsp_tblF != 'NONE', (input$cbo_hsp_tbl_flt != 'NONE'), FALSE)
get.dt.tbl(
dt = dt_hsp(),
tblY = input$cbo_hsp_tblY,
lblX = var.hsp.geo(),
fld.to.order = input$cbo_hsp_tbl_ord,
ord.desc= !input$swt_hsp_tbl_ord,
col.bars = input$col_hsp_tbb,
col.fonts = input$col_hsp_tbf,
pal.scale = input$pal_hsp_tbl,
n.cols = input$sld_hsp_tbl_col,
reverse = input$chk_hsp_tbl_rvc,
flt.var = ifelse(is.hsp.tbl.flt, input$cbo_hsp_tblF, NA),
flt.val = ifelse(is.hsp.tbl.flt, input$cbo_hsp_tbl_flt, NA),
grp.var = ifelse(input$cbo_hsp_tblG == 'NONE', NA, input$cbo_hsp_tblG),
grp.type = ifelse(input$cbo_hsp_tblG == 'NONE', NA, input$rdb_hsp_tbl_grp),
grp.stype = ifelse(input$cbo_hsp_tblG == 'NONE', NA, input$rdb_hsp_tbl_gpr)
)
})
### BARPLOT (brp) -----------------------------------------------------------------------------------------------------------------
hsp.brp.title <- reactive({
build.title(
var.Y = input$cbo_hsp_brpY,
var.X = var.hsp.geo(),
has.pct = ifelse( metrics[label == input$cbo_hsp_brpY, type] == 2, input$chk_hsp_brp_pct, FALSE),
var.G1 = input$cbo_hsp_brpG,
var.G2 = input$cbo_hsp_brpG2,
var.F = input$cbo_hsp_brpF,
val.F = input$cbo_hsp_brp_flt
)
})
output$out_hsp_brx <- renderUI({
HTML(paste0('<h3>', hsp.brp.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
})
is.hsp.brp.grp <- reactive( input$cbo_hsp_brpG != 'NONE' )
is.hsp.brp.fll <- reactive( ifelse(is.hsp.brp.grp(), input$cbo_hsp_brp_grp == 'fill', FALSE) )
is.hsp.brp.fct <- reactive( is.hsp.brp.grp() & input$cbo_hsp_brp_grp == 'facet' )
is.hsp.brp.bfc <- reactive( is.hsp.brp.fct() & input$cbo_hsp_brpG2 != 'NONE')
hsp_brp_tbl <- reactive({
get.dt.brp(dt_hsp(),
var.Y = input$cbo_hsp_brpY,
grp1 = if(is.hsp.brp.grp()){ input$cbo_hsp_brpG } else {NA},
grp2 = if(is.hsp.brp.bfc()){ input$cbo_hsp_brpG2 } else {NA},
pct = ifelse( (metrics[label == input$cbo_hsp_brpY, type] == 2), input$chk_hsp_brp_pct, FALSE),
tt = c(var.hsp.geo(), var.tms.tmr()),
flt.var = if(input$cbo_hsp_brpF != 'NONE'){ input$cbo_hsp_brpF } else { NA },
flt.val = if(input$cbo_hsp_brpF != 'NONE'){ input$cbo_hsp_brp_flt } else { NA },
show.NA = input$chk_hsp_brp_sna,
ordering = input$cbo_hsp_brp_ord
)
})
hsp_brp_plt <- reactive({
var.type <- metrics[label == input$cbo_hsp_brpY, type]
is.pct <- ifelse(var.type == 2, input$chk_hsp_brp_pct, FALSE)
y <- hsp_brp_tbl()[[1]]
# detect number of units to plot
yg <- trim.dt.X(y, input$sld_hsp_brp_cnt)
# build first layer
g <- ggplot(yg, aes(x = X, y = Y, tooltip = ttip, data_id = ttip) )
# bar attributes
bars.col <- ifelse(length(input$col_hsp_brp), input$col_hsp_brp, pal.default['col'])
bars.width <- input$sld_hsp_brp_baw / 10
# border attributes
border.size <- ifelse(input$chk_hsp_brp_bdr, input$sld_hsp_brp_bow / 30, 0)
border.col <- ifelse(input$chk_hsp_brp_bdr, input$col_hsp_brp_boc, NA)
border.type <- ifelse(input$chk_hsp_brp_bdr, input$cbo_hsp_brp_bot, 'solid')
# write ggplot instruction to actually plot the bars corresponding to ungrouped / grouped, and in the latter case if faceting or not
g1 <- geom_bar_interactive(stat = 'identity', fill = bars.col, width = bars.width, size = border.size, color = border.col, linetype = border.type)
if(is.hsp.brp.grp()){
if(is.hsp.brp.fct()){
fct.scale <- if(input$chk_hsp_brp_scl){ 'fixed' } else { 'free_y' }
if(is.hsp.brp.bfc()){
g <- g + g1 + facet_grid(G1~G2, scale = fct.scale)
} else {
g <- g + g1 + facet_wrap(~G, ncol = input$sld_hsp_brp_fct, scale = fct.scale)
}
} else {
g <- g + geom_bar_interactive(
stat = 'identity', aes(fill = G), position = input$cbo_hsp_brp_grp,
width = bars.width, size = border.size, color = border.col, linetype = border.type
)
bars.pal <- ifelse(length(input$pal_hsp_brp), input$pal_hsp_brp, pal.default['cat'])
bars.pal <-
if(brewer.pal.info[bars.pal,]$maxcolors > length(unique(y$G))){
rep_len(brewer.pal(length(unique(y$G)), bars.pal), length(unique(y$G)))
} else {
brewer.pal(length(unique(y$G)), bars.pal)
}
if(input$chk_hsp_brp_rvc) bars.pal <- rev(bars.pal)
g <- g + scale_fill_manual(values = bars.pal)
}
} else {
g <- g + g1
}
# Add average line
if(length(input$chk_hsp_brp_avg)){
yt <- hsp_brp_tbl()[[2]]
if(input$chk_hsp_brp_avg){
if(is.hsp.brp.fct()){
g <- g + geom_hline(
data = yt, aes(yintercept = Y),
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
)
} else {
g <- g + geom_hline(
yintercept = yt,
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
)
}
if(input$chk_hsp_brp_avl){
ytl <- ifelse(is.pct, paste0(round(100 * yt, 2), '%'), yt)
g <- g + geom_text(
aes(1, yt, label = ytl, vjust = -1),
color = input$col_hsp_brp_avc, size = input$sld_hsp_brp_avz / 1.5, alpha = 1 - input$sld_hsp_brp_avt / 10
)
}
}
}
# Format y-axis labels
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 } )
# Fix y-axis limits
if(!is.hsp.brp.fll()){
if(is.hsp.brp.fct() & !input$chk_hsp_brp_scl){
if(input$chk_hsp_brp_yzr) g <- g + expand_limits(y = 0)
} else {
y.min <- ifelse(is.pct, pretty(100*min(y$Y))[1]/100, pretty(min(y$Y))[1] )
if(input$chk_hsp_brp_yzr) y.min <- 0
y.max <- ifelse(is.pct, pretty(100*max(y$Y))[2]/100, pretty(max(y$Y))[2] )
g <- g + coord_cartesian(ylim = c(y.min, y.max))
}
}
# rotate axis
if(input$rdb_hsp_brp_orn == 'Horizontal') g <- g + coord_flip()
# add and format value labels in bars
if(input$chk_hsp_brp_lbl){
if(is.hsp.brp.grp()){
g <- g + geom_text(
aes(label = lbl.format(Y, var.type, is.pct)),
position = position_dodge(width = -0.8),
vjust = val.lbl.pos[[input$rdb_hsp_brp_lbp]][[input$rdb_hsp_brp_orn]][2],
color = input$col_hsp_brp_lbl, size = input$sld_hsp_brp_lbz, fontface = 'bold'
)
} else {
g <- g + geom_text(
aes(label = lbl.format(Y, var.type, is.pct)),
hjust = val.lbl.pos[[input$rdb_hsp_brp_lbp]][[input$rdb_hsp_brp_orn]][1],
vjust = val.lbl.pos[[input$rdb_hsp_brp_lbp]][[input$rdb_hsp_brp_orn]][2],
color = input$col_hsp_brp_lbl, size = input$sld_hsp_brp_lbz, fontface = 'bold'
)
}
}
# add legend and axis titles (main title and subtitle are added automatically to the print version)
g <- g + labs(x = '', y = '')
if(is.hsp.brp.grp() & !is.hsp.brp.fct())
g <- g + labs(fill = clear.label(input$cbo_hsp_brpG))
# g <- g + scale_fill_discrete(name = clear.label(input$cbo_hsp_brpG))
if(input$chk_hsp_brp_xlt)
g <- g + labs(x = var.hsp.geo(), y = paste(metrics[label == input$cbo_hsp_brpY, title], if(is.pct){'(%)'} ) )
# calculate angle rotation for centres labels
labels.rotation <- ifelse(length(input$sld_hsp_brp_lbr), input$sld_hsp_brp_lbr, 45)
labels.rotation <- if(input$rdb_hsp_brp_orn == 'Vertical'){ c(labels.rotation, 0) } else { c(0, labels.rotation) }
# apply general theme
g <- my.ggtheme(g,
xaxis.draw = input$chk_hsp_brp_xlx, yaxis.draw = input$chk_hsp_brp_xly, ticks.draw = input$chk_hsp_brp_xtk,
axis.colour = input$col_hsp_brp_xsc, axis.size = as.numeric(input$sld_hsp_brp_xsz) / 10,
hgrid.draw = ('Horizontal' %in% input$chg_hsp_brp_grd), vgrid.draw = ('Vertical' %in% input$chg_hsp_brp_grd),
grids.colour = input$col_hsp_brp_gdc, grids.size = as.numeric(input$sld_hsp_brp_gdz) / 10, grids.type = input$cbo_hsp_brp_gdt,
labels.rotation = labels.rotation,
bkg.colour = input$col_hsp_brp_bkg, font.size = input$sld_hsp_brp_xlz,
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,
font.family = input$cbo_hsp_brp_ffm
)
g
})
output$out_hsp_brp <- renderggiraph({
gg.to.ggiraph(hsp_brp_plt(), gg.width = input$sld_hsp_brp_ggw / 10)
})
### BOXPLOT (bxp) -----------------------------------------------------------------------------------------------------------------
hsp.bxp.title <- reactive({
build.title(
var.Y = input$cbo_hsp_bxpY,
is.Y.ref = FALSE,
var.X = var.hsp.geo(),
var.G1 = input$cbo_hsp_bxpG,
var.G2 = input$cbo_hsp_bxpG2,
var.F = input$cbo_hsp_bxpF,
val.F = input$cbo_hsp_bxp_flt
)
})
output$out_hsp_bxx <- renderUI({
HTML(paste0('<h3>', hsp.bxp.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
})
is.hsp.bxp.grp <- reactive( input$cbo_hsp_bxpG != 'NONE' )
is.hsp.bxp.fct <- reactive( is.hsp.bxp.grp() & input$rdb_hsp_bxp_grp == 'facet' )
is.hsp.bxp.bfc <- reactive( is.hsp.bxp.fct() & input$cbo_hsp_bxpG2 != 'NONE')
hsp_bxp_tbl <- reactive({
get.dt.bxp(dt_hsp(),
var.Y = input$cbo_hsp_bxpY,
grp1 = if(is.hsp.bxp.grp()){ input$cbo_hsp_bxpG } else { NA },
grp2 = if(is.hsp.bxp.bfc()){ input$cbo_hsp_bxpG2 } else { NA },
tt = var.hsp.geo(),
flt.var = if(input$cbo_hsp_bxpF != 'NONE'){ input$cbo_hsp_bxpF } else { NA },
flt.val = if(input$cbo_hsp_bxpF != 'NONE'){ input$cbo_hsp_bxp_flt } else { NA }
)
})
hsp_bxp_plt <- reactive({
y <- hsp_bxp_tbl()[[1]]
# detect number of units to plot
yg <- trim.dt.X.bxp(y, input$sld_hsp_bxp_cnt, input$cbo_hsp_bxp_ord)
# build the first layer of the plot according to the desired order for the bars
g <- ggplot(yg[[1]], aes(x = X, y = Y, tooltip = ttip, data_id = ttip) ) + scale_x_discrete(limits = yg[[2]])
# boxes attributes
bxs.col <- input$col_hsp_bxp_boc
bxs.width <- input$sld_hsp_bxp_bxw / 10
bxs.size <- input$sld_hsp_bxp_bbw / 30
bxs.ltype <- input$cbo_hsp_bxp_bbt
# build the second layer (= geometry with colour/palette) according to group
if(is.hsp.bxp.grp() & !is.hsp.bxp.fct()){
g <- g + geom_boxplot_interactive(
aes(fill = G),
position = position_dodge(input$sld_hsp_bxp_gdd / 10),
color = bxs.col,
size = bxs.size,
width = bxs.width,
linetype = bxs.ltype,
outlier.shape = NA
)
bars.pal <- ifelse(length(input$pal_hsp_bxp), input$pal_hsp_bxp, pal.default['cat'])
bars.pal <-
if(brewer.pal.info[bars.pal,]$maxcolors > length(unique(y$G))){
rep_len(brewer.pal(length(unique(y$G)), bars.pal), length(unique(y$G)))
} else {
brewer.pal(length(unique(y$G)), bars.pal)
}
if(input$chk_hsp_bxp_rvc) bars.pal <- rev(bars.pal)
g <- g + scale_fill_manual(values = bars.pal)
# g <- g + scale_fill_brewer(palette = ifelse(length(input$pal_hsp_bxp) == 0 , 'Dark2', input$pal_hsp_bxp) )
} else {
g <- g + geom_boxplot_interactive(
fill = ifelse(length(input$col_hsp_bxp), input$col_hsp_bxp, pal.default['col']),
color = bxs.col,
size = bxs.size,
width = bxs.width,
linetype = bxs.ltype,
outlier.shape = NA
)
if(is.hsp.bxp.fct()){
if(is.hsp.bxp.bfc()){
g <- g + facet_grid(G~G2)
} else {
g <- g + facet_wrap(~G, ncol = input$sld_hsp_bxp_fct)
}
}
}
# Control axis limits and formats, Add OUTLIERS tooltip to the plot, OR remove Outliers and change plot limits to whiskers values
if(input$chk_hsp_bxp_out){
out.limits <- boxplot.stats(y$Y)$stats
g <- g + scale_y_continuous(
labels = comma,
limits = c(
quantile(y$Y, na.rm = TRUE)[2] - IQR(y$Y, na.rm = TRUE) * 1.5,
quantile(y$Y, na.rm = TRUE)[4] + IQR(y$Y, na.rm = TRUE) * 1.5
)
)
} else {
y.out <- hsp_bxp_tbl()[[2]]
g <- g + scale_y_continuous(expand = c(0, 0), labels = comma)
if(is.hsp.bxp.grp() & !is.hsp.bxp.fct()){
g <- g + geom_point_interactive(data = y.out,
aes(fill = G, tooltip = ttip),
size = input$sld_hsp_bxp_otz / 5,
colour = input$col_hsp_bxp_otb,
shape = as.numeric(input$cbo_hsp_bxp_out),
alpha = 1 - input$sld_hsp_bxp_ott / 10
)
} else {
g <- g + geom_point_interactive(data = y.out,
aes(tooltip = ttip),
fill = input$col_hsp_bxp_otf,
size = input$sld_hsp_bxp_otz / 5,
colour = input$col_hsp_bxp_otb,
shape = as.numeric(input$cbo_hsp_bxp_out),
alpha = 1 - input$sld_hsp_bxp_ott / 10
)
}
g <- g + coord_cartesian(ylim = c(ifelse(input$chk_hsp_bxp_yzr, 0, pretty(min(y$Y))[1]), pretty(max(y$Y))[2]) )
}
# Add mean point and st.dev line in boxes
if(input$chk_hsp_bxp_avg){
g <- g + stat_summary(
fun.y = mean,
geom = 'point',
fill = input$col_hsp_bxp_avc,
size = input$sld_hsp_bxp_avz/3,
shape = as.numeric(input$cbo_hsp_bxp_avs),
alpha = 1 - input$sld_hsp_bxp_avt / 10,
show.legend = FALSE
)
}
# Flip chart in a horizontal way
if(input$rdb_hsp_bxp_orn == 'Horizontal') g <- g + coord_flip()
# if grouped, add legend title
if(is.hsp.bxp.grp()) g <- g + labs( fill = clear.label(input$cbo_hsp_bxpG) )
# add axis titles (main title and subtitle are added automatically to the print version)
g <- g + labs(x = '', y = '')
if(input$chk_hsp_bxp_xlt)
g <- g + labs(x = var.hsp.geo(), y = clear.label(input$cbo_hsp_bxpY) )
# calculate angle rotation for centres labels
labels.rotation <- ifelse(length(input$sld_hsp_bxp_lbr), input$sld_hsp_bxp_lbr, 45)
labels.rotation <- if(input$rdb_hsp_bxp_orn == 'Vertical'){ c(labels.rotation, 0) } else { c(0, labels.rotation) }
# add theme and style options
g <- my.ggtheme(g,
xaxis.draw = input$chk_hsp_bxp_xlx, yaxis.draw = input$chk_hsp_bxp_xly, ticks.draw = input$chk_hsp_bxp_xtk,
axis.colour = input$col_hsp_bxp_xsc, axis.size = as.numeric(input$sld_hsp_bxp_xsz) / 10,
hgrid.draw = ('Horizontal' %in% input$chg_hsp_bxp_grd), vgrid.draw = ('Vertical' %in% input$chg_hsp_bxp_grd),
grids.colour = input$col_hsp_bxp_gdc, grids.size = as.numeric(input$sld_hsp_bxp_gdz) / 10, grids.type = input$cbo_hsp_bxp_gdt,
labels.rotation = labels.rotation,
bkg.colour = input$col_hsp_bxp_bkg, font.size = input$sld_hsp_bxp_xlz,
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,
font.family = input$cbo_hsp_bxp_ffm
)
g
})
output$out_hsp_bxp <- renderggiraph({
gg.to.ggiraph(hsp_bxp_plt(), gg.width = input$sld_hsp_bxp_ggw / 10)
})
### HEATMAP (hmp) -----------------------------------------------------------------------------------------------------------------
is.hsp.hmp.msr <- reactive( metrics[label == input$cbo_hsp_hmpY, type] == 2 )
is.hsp.hmp.grp <- reactive( input$cbo_hsp_hmpG != 'NONE' )
is.hsp.hmp.bfc <- reactive( is.hsp.hmp.grp() & input$cbo_hsp_hmpG2 != 'NONE')
var.hsp.hmp <- reactive( names(timeref[which(timeref == input$cbo_hsp_hmpX2)]) )
hsp.hmp.title <- reactive({
build.title(
var.Y = input$cbo_hsp_hmpY,
var.X = var.hsp.geo(),
var.X2 = names(timeref[which(timeref == input$cbo_hsp_hmpX2)]),
has.pct = ifelse(is.hsp.hmp.msr(), input$chk_hsp_hmp_pct, FALSE),
var.G1 = input$cbo_hsp_hmpG,
var.G2 = input$cbo_hsp_hmpG2,
var.F = input$cbo_hsp_hmpF,
val.F = input$cbo_hsp_hmp_flt
)
})
output$out_hsp_hmx <- renderUI({
HTML(paste0('<h3>', hsp.hmp.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
})
hsp_hmp_tbl <- reactive({
get.dt.hmp(dt_hsp(),
var.Y = input$cbo_hsp_hmpY,
var.X2 = input$cbo_hsp_hmpX2,
grp1 = ifna(is.hsp.hmp.grp(), input$cbo_hsp_hmpG),
grp2 = ifna(is.hsp.hmp.bfc(), input$cbo_hsp_hmpG2),
pct = ifelse(is.hsp.hmp.msr(), input$chk_hsp_hmp_pct, FALSE),
tt = c(var.hsp.geo(), var.hsp.hmp()),
flt.var = ifna(input$cbo_hsp_hmpF != 'NONE', input$cbo_hsp_hmpF),
flt.val = ifna(input$cbo_hsp_hmpF != 'NONE', input$cbo_hsp_hmp_flt),
mtc.rescale = ifna(input$chk_hsp_hmp_rvv, input$rdb_hsp_hmp_rvc),
ordering = as.numeric(input$cbo_hsp_hmp_ord),
show.NA = input$chk_hsp_hmp_sna
)
})
hsp_hmp_plt <- reactive({
is.pct <- ifelse(is.hsp.hmp.msr(), input$chk_hsp_hmp_pct, FALSE)
y <- hsp_hmp_tbl()[[1]]
# detect number of units to plot
yg <- trim.dt.X(y, input$sld_hsp_hmp_cnt)
# build first layer
g <- ggplot(yg, aes(x = X, y = X2, tooltip = ttip, data_id = ttip ) ) +
geom_tile_interactive(
aes(fill = Y),
alpha = 1 - input$sld_hsp_hmp_trp / 10,
color = input$col_hsp_hmp_bbc, # ifelse(length(input$col_hsp_hmp_bbc), input$col_hsp_hmp_bbc, 'white'),
linetype = input$cbo_hsp_hmp_bbt,
size = input$sld_hsp_hmp_bbz / 20
)
# grouping (=Faceting)
if(is.hsp.hmp.grp()){
if(is.hsp.hmp.bfc()){
g <- g + facet_grid(G1~G2)
} else {
g <- g + facet_wrap(~G, ncol = input$sld_hsp_hmp_fct)
}
}
# palette
boxes.pal <- ifelse(length(input$pal_hsp_hmp), input$pal_hsp_hmp, pal.default['seq'])
boxes.pal <- brewer.pal(max(3, min(nlevels(y$G), brewer.pal.info[boxes.pal, 'maxcolors'])), boxes.pal)
if(input$chk_hsp_hmp_rvc) boxes.pal <- rev(boxes.pal)
# format the values in the legend as comma/pct, plus NAs colour
g <- g + scale_fill_gradientn(
colours = boxes.pal,
# limits = c(pretty(min(y$Y))[1], pretty(max(y$Y))[2]),
labels = ifelse(is.pct, percent, comma),
na.value = input$col_hsp_hmp_nas
)
# Flip chart in a horizontal way
if(input$chk_hsp_hmp_orn) g <- g + coord_flip()
# Square boxes (does NOT work if coord_flip() is present)
if(input$chk_hsp_hmp_sqb) g <- g + coord_fixed(ratio = 1)
# Add axis and legend titles (main title and subtitle are added automatically to the print version)
g <- g + labs(x = '', y = '', fill = input$cbo_hsp_hmpY)
if(input$chk_hsp_hmp_xlt) g <- g + labs(x = var.hsp.geo(), y = var.hsp.hmp() )
# When dayOfMonth / hour let X2-axis draw all labels through 1-31 / 0-23
if(input$cbo_hsp_hmpX2 == 'day_nid') g <- g + scale_y_continuous(breaks = 1:31)
if(input$cbo_hsp_hmpX2 == 'date.hour') g <- g + scale_y_continuous(breaks = 0:23)
# calculate angle rotation for centres labels
labels.rotation <- ifelse(length(input$sld_hsp_hmp_lbr), input$sld_hsp_hmp_lbr, 45)
labels.rotation <- if(input$chk_hsp_hmp_orn){ c(0, labels.rotation, 0) } else { c(labels.rotation, 0) }
# add theme and style options
g <- my.ggtheme(g,
ticks.draw = input$chk_hsp_hmp_xtk, axis.size = as.numeric(input$sld_hsp_hmp_bbz) / 10,
labels.rotation = labels.rotation, font.size = input$sld_hsp_hmp_xlz,
ttl.font.size.mult = as.numeric(input$sld_hsp_hmp_xlt)/100, ttl.face = input$cbo_hsp_hmp_xlt,
font.family = input$cbo_hsp_hmp_ffm
)
g
})
output$out_hsp_hmp <- renderggiraph({
gg.to.ggiraph(hsp_hmp_plt(), gg.width = input$sld_hsp_hmp_ggw / 10)
})
### FUNNELPLOT (fnl) ------------------------------------------------------------------------------------------------------------
hsp.fnl.title <- reactive({
build.title(
var.Y = input$cbo_hsp_fnlY,
var.X = metrics[label == input$cbo_hsp_fnlX, title],
fnl.area = var.hsp.geo(),
has.pct = is.hsp.fnl.pct(),
var.G1 = 'NONE',
var.F = input$cbo_hsp_fnlF,
val.F = input$cbo_hsp_fnl_flt
)
})
output$out_hsp_scx <- renderUI({
HTML(paste0('<h3>', hsp.fnl.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
})
dt_hsp_fnl <- reactive({
y <- dt_hsp()[ eval( parse(text = fnl.ref()[['X']][1] ) )]
if(is.hsp.fnl.flt()){
flt.lbl <- lookups[domain_id == gsub('X', '', input$cbo_hsp_fnlF) & lookup_id == input$cbo_hsp_fnl_flt, description]
y <- y[ get(input$cbo_hsp_fnlF) == flt.lbl ]
}
y
})
hsp_fnl_tbl <- reactive({
if(length(dt_hsp_fnl()) == 0) return()
# calculate total effect size
dtx <- dt_hsp_fnl()[,
.( X = eval(parse(text = fnl.ref()[['X']][2])) ),
.( LW = get(input$cbo_hsp_geo), W = get(paste0(input$cbo_hsp_geo, '_id')) )
]
# calculate counting for reference metric/measure
dtyn <- dt_hsp_fnl()[
eval(parse(text = fnl.ref()[['Y']][1]) ),
.( Y = eval(parse(text = fnl.ref()[['Y']][2])) ),
.( W = get(paste0(input$cbo_hsp_geo, '_id')) )
]
# merge the above
y <- dtyn[dtx, on = 'W'][is.na(Y), Y := 0]
if(is.hsp.fnl.msr()){
# calculate percentage for reference measure
dtyp <- dt_hsp_fnl()[
eval( parse(text = fnl.ref()[['Y']][3] ) ),
.( YP = eval(parse(text = fnl.ref()[['Y']][4])) ),
.( W = get(paste0(input$cbo_hsp_geo, '_id')) )
]
# merge percentage with previous counts
y <- y[dtyp, on = 'W']
# calculate total counting for reference measure
yt <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][1] ) ), .(eval(parse(text = paste(fnl.ref()[['Y']][2])))) ])
# calculate total percentage for reference measure for binomial funnel
ytp <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][3] ) ), .(eval(parse(text = paste(fnl.ref()[['Y']][4])))) ])
# sd is not requested for measure
yt.sd <- NA
# calculate index vs national
y[, IDX := round(YP/ytp, 3)]
} else {
# calculate total counting for reference metric
yt <- as.numeric(dt_hsp_fnl()[eval( parse(text = fnl.ref()[['Y']][1] ) ), .(eval(parse(text = paste(fnl.ref()[['Y']][2])))) ])
# percentage is not requested for metric
ytp <- NA
# calculate total standard deviation for reference metric for normal funnel
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])) ) ])
# calculate index vs national
y[, IDX := round(Y/yt, 3)]
}
# calculate the tooltip
y[, ttip := paste0(
var.hsp.geo(), ': <b>', LW, '</b><br/>',
metrics[label == input$cbo_hsp_fnlX, title], ': <b>', prettyNum(X, big.mark = ','), '</b><br/>',
metrics[label == input$cbo_hsp_fnlY, label], ':<br/>',
'<ul>',
'<li>', ifelse(metrics[label == input$cbo_hsp_fnlY, type] <= 2, 'Counting', 'Value'), ': <b>', prettyNum(Y, big.mark = ','), '</b></li>',
if(is.hsp.fnl.msr()){ paste0('<li>Percentage: <b>', round(100*YP, 2), '%</b></li>') },
'<li>Index: <b>', IDX, '</b></li>',
'</ul>'
)]
# add the code to pass when points are clicked
y[, clk := W]
if(is.hsp.fnl.pct()){
# change fields names for Y if measure and percentage
setnames(y, c('Y', 'YP'), c('YN', 'Y') ) # y[, YN := Y][, Y := YP][, YP := NULL]
# change fields names for X if reduced size
if(input$chk_hsp_fnl_pcY) setnames(y, c('X', 'YN'), c('XT', 'X') )
}
# return as a list of 1) main dataset and 2) total summaries
list(y, c(yt, ytp, yt.sd) )
})
hsp_fnl_plt <- reactive({
y <- hsp_fnl_tbl()[[1]]
# initialize plot (assuming ALL stored effect sizes are simply counts)
g <- ggplot(y, aes(x = X, y = Y))
# add geometry
g <- g + geom_point_interactive(
aes(tooltip = ttip, data_id = clk),
size = input$sld_hsp_fnl_pnz / 3,
shape = as.numeric(input$cbo_hsp_fnl_pnh),
colour = input$col_hsp_fnl_pnc,
fill = input$col_hsp_fnl_pnf,
alpha = input$sld_hsp_fnl_pno / 10
)
# add labels
g <- g + geom_text_repel(
aes(label = W),
# labels
family = input$cbo_hsp_fnl_ffm,
size = input$sld_hsp_fnl_lbz / 2,
color = input$col_hsp_fnl_lbc,
alpha = input$sld_hsp_fnl_lbo / 10,
# segments
segment.color = input$col_hsp_fnl_sgc,
segment.size = input$sld_hsp_fnl_sgz / 8,
segment.alpha = input$sld_hsp_fnl_sgt / 10,
min.segment.length = unit(input$sld_hsp_fnl_sgm, 'lines'),
arrow = arrow(length = unit(input$chk_hsp_fnl_sgr * 0.01, 'npc'))
)
# add average line
yt <- hsp_fnl_tbl()[[2]][1 + is.hsp.fnl.pct()]
if(input$chk_hsp_fnl_avg){
g <- g + geom_hline(
yintercept = yt,
linetype = input$cbo_hsp_fnl_avt,
color = input$col_hsp_fnl_avc,
size = input$sld_hsp_fnl_avz / 8
)
if(input$chk_hsp_fnl_avl){
ytl <- ifelse(is.hsp.fnl.pct(), paste0(round(100 * yt, 2), '%'), yt)
g <- g + geom_text(aes(pretty(max(y$X))[2], yt), label = ytl, vjust = -0.5, size = 3, color = input$col_hsp_fnl_avc)
}
}
# add funnel control limits
if(input$chk_hsp_fnl_fnl){
yt.sd <- hsp_fnl_tbl()[[2]][3]
if(length(input$cbo_hsp_fnl_flm) > 0){
fnl.lims <- sort(input$cbo_hsp_fnl_flm)
fnl.nlims <- length(fnl.lims)
fnl.cols <- if(length(input$cbo_hsp_fnl_fnc) == 0) { 'black' } else { input$cbo_hsp_fnl_fnc }
if(length(fnl.cols) < fnl.nlims)
fnl.cols <- c(fnl.cols, rep(fnl.cols[length(fnl.cols)], fnl.nlims - length(fnl.cols)) )
fnl.types <- if(length(input$cbo_hsp_fnl_fnt) == 0) { 'solid' } else { input$cbo_hsp_fnl_fnt }
if(length(fnl.types) < fnl.nlims)
fnl.types <- c(fnl.types, rep(fnl.types[length(fnl.types)], fnl.nlims - length(fnl.types)) )
for(idx in 1:fnl.nlims){
if(is.hsp.fnl.msr()){
funnel.limits <- get.funnel.limits(as.numeric(fnl.lims[idx]), max(y$X), yt)
} else {
funnel.limits <- get.funnel.limits(as.numeric(fnl.lims[idx]), max(y$X), yt, yt.sd)
}
g <- g + geom_line(
data = funnel.limits,
aes(x = x, y = liminf),
color = fnl.cols[idx],
linetype = fnl.types[idx],
size = input$sld_hsp_fnl_fnz / 8
)
g <- g + geom_line(
data = funnel.limits,
aes(x = x, y = limsup),
color = fnl.cols[idx],
linetype = fnl.types[idx],
size = input$sld_hsp_fnl_fnz / 8
)
if(input$chk_hsp_fnl_fnv){
g <- g + geom_text(
data = funnel.limits,
aes(pretty(max(y$X))[2], min(limsup)),
label = paste0(100*as.numeric(fnl.lims[idx]), '%'),
size = 2,
hjust = -0.05,
color = fnl.cols[idx]
)
}
}
}
}
# format x-axis and trim effect size to desired details
g <- g + scale_x_continuous(labels = comma, limits = input$sld_hsp_fnl_tmz )
# format y-axis (if measure format percentage) and trim metric values to desired details
if(length(input$sld_hsp_fnl_tmt) > 0)
g <- g + scale_y_continuous(
labels = if(is.hsp.fnl.pct()){ percent } else { comma },
limits = input$sld_hsp_fnl_tmt/if(is.hsp.fnl.pct()){ 100 } else { 1 }
)
# if selected, add axis titles (main title and subtitle are added automatically to the print version)
g <- g + labs(x = '', y = '')
if(input$chk_hsp_fnl_xlt)
g <- g + labs(x = paste(metrics[label == input$cbo_hsp_fnlX, title], 'in', var.hsp.geo()), y = metrics[label == input$cbo_hsp_fnlY, title] )
# add theme and style options
g <- my.ggtheme(g,
xaxis.draw = input$chk_hsp_fnl_xlx, yaxis.draw = input$chk_hsp_fnl_xly, ticks.draw = input$chk_hsp_fnl_xtk,
axis.colour = input$col_hsp_fnl_xsc, axis.size = as.numeric(input$sld_hsp_fnl_xsz) / 10,
hgrid.draw = ('Horizontal' %in% input$chg_hsp_fnl_grd), vgrid.draw = ('Vertical' %in% input$chg_hsp_fnl_grd),
grids.colour = input$col_hsp_fnl_gdc, grids.size = as.numeric(input$sld_hsp_fnl_gdz) / 10, grids.type = input$cbo_hsp_fnl_gdt,
labels.rotation = c(0, 0), bkg.colour = input$col_hsp_fnl_bkg, font.size = input$sld_hsp_fnl_xlz,
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,
font.family = input$cbo_hsp_fnl_ffm
)
g
})
output$out_hsp_fnl <- renderggiraph({
gg.to.ggiraph(hsp_fnl_plt(), sel.type = 'multiple', gg.width = input$sld_hsp_fnl_ggw / 10 )
})
# Handle dot(s) selection
observeEvent(input$btn_hsp_fnl_rst, {
session$sendCustomMessage(type = 'out_hsp_fnl_set', message = character(0))
})
sel_hsp_fnl <- reactive({
if(is.null(input$out_hsp_fnl_selected)) return(character(0))
input$out_hsp_fnl_selected
})
output$out_hsp_sel <- renderText({
paste0('Centres Selected: ', length(sel_hsp_fnl()), '. ', paste(sort(sel_hsp_fnl()), collapse = ', ') )
})
# Build timeseries from selection
output$ui_hsp_scl_flt <- renderUI({
if(is.null(input$out_hsp_fnl_selected)) return()
selectInput('cbo_hsp_scl_flt', 'TIME REFERENCE:',
choices = c('Year' = 'date.year', 'Quarter' = 'date.quarter', 'Month' = 'date.month', 'Week' = 'date.week', 'Day' = 'date.day' ),
selected = 'date.month'
)
})
# If checked, display an additional line being the TOTAL UK
output$ui_hsp_scl_tuk <- renderUI({
if( length(sel_hsp_fnl()) < 1 ) return()
checkboxInput('chk_hsp_scl_tuk', 'Add Total Line', value = FALSE)
})
# Should the metric be calculated on all records as a sngle entity ? (Only if selection > 1 dot)
output$ui_hsp_scl_agg <- renderUI({
if( length(sel_hsp_fnl()) <= 1 ) return()
checkboxInput('chk_hsp_scl_agg', 'Aggregate selected', value = FALSE)
})
# Display the time series
output$out_hsp_scl <- renderDygraph({
# Check if at least one dot is selected
if( length(sel_hsp_fnl()) < 1 ) return()
# Check if when having multiple dots shoudl return the dots as a single aggregated entity
calc.aggregate <- FALSE
if( length(sel_hsp_fnl()) > 1 )
if(input$chk_hsp_scl_agg) calc.aggregate <- TRUE
# Query the dataset vs selected dot(s)
y <- dt_hsp_fnl()[ get( paste0(input$cbo_hsp_geo, '_id') ) %in% sel_hsp_fnl() ]
# Query the formula to be applied
if(metrics[label == input$cbo_hsp_fnlY, type] == 2){
YM <- metrics[label == input$cbo_hsp_fnlY, mutate_pct]
} else {
YM <- metrics[label == input$cbo_hsp_fnlY, mutate_as]
}
# transform the dataset correpsonding to the selected options
if(calc.aggregate){
y <- y[, .(Y = eval(parse(text = YM)) ), .(X = get(input$cbo_hsp_scl_flt) ) ]
} else {
y <- y[, .(Y = eval(parse(text = YM)) ), .(X = get(input$cbo_hsp_scl_flt), W = get( paste0(input$cbo_hsp_geo, '_id') ) ) ]
y <- dcast.data.table(y, X~W, value.var = 'Y')
}
if(input$cbo_hsp_scl_flt == 'date.year') y[, X := as.Date(paste0(X, '1231'), '%Y%m%d') ]
# build the correct time object
y <- as.data.frame(y)
y <- xts(y[, -1], order.by = y[, 1])
# build the chart object
dg <- dygraph(y) %>%
dyAxis('y', label = metrics[label == input$cbo_hsp_fnlY, title], drawGrid = TRUE) %>%
dyHighlight(
highlightCircleSize = 4,
highlightSeriesBackgroundAlpha = 0.4,
hideOnMouseOut = TRUE,
highlightSeriesOpts = list(strokeWidth = 2)
) %>%
dyRangeSelector(
dateWindow = unname(c(date.range['start'], date.range['max'])),
height = 30,
strokeColor = 'black',
retainDateWindow = TRUE
) %>%
dyRoller(rollPeriod = 1)
# if(!is.hsp.grp()){
# dg <- dg %>% dySeries('V1', label = input$cbo_tms_Y, color = input$cbo_tms_plq)
# dg <- dg %>% dyLegend(show = 'follow')
# html('lgn_tms_lns', '')
# } else {
# dg <- dg %>% dyLegend(show = 'always', hideOnMouseOut = FALSE, labelsSeparateLines = TRUE, labelsDiv = 'lgn_tms_lns')
# dg <- dg %>% dyOptions(axisLineWidth = 1.25, colors = brewer.pal(ncol(y) -1, input$cbo_tms_plq))
# if(input$chk_tms_stg) dg <- dg %>% dyOptions(stackedGraph = TRUE)
# }
dg
})
# If checked, display an additional table with all records related to above selections
output$ui_hsp_fnl_tbl <- renderUI({
if( length(sel_hsp_fnl()) < 1 ) return()
checkboxInput('chk_hsp_fnl_tbl', 'Display all records', value = FALSE)
})
# Build the dataset for the table
output$ui_hsp_sct_flt <- renderUI({
if( length(sel_hsp_fnl()) < 1 ) return()
if( !input$chk_hsp_fnl_tbl ) return()
selectInput('cbo_hsp_sct_flt', 'FIELDS:',
choices = build_uiV( c('CAT', 'NUM', 'LGC', 'DTM') ),
multiple = TRUE,
selected = fields.selection,
width = '100%'
)
})
# Display the table
output$out_hsp_sct <- renderDataTable({
if( length(sel_hsp_fnl()) < 1 ) return()
if( !input$chk_hsp_fnl_tbl ) return()
y <- get.dt.renamed(input$cbo_hsp_sct_flt, sel_hsp_fnl() )
t <- datatable(y,
rownames = FALSE,
selection = 'none',
class = 'cell-border stripe hover nowrap',
extensions = c('Buttons', 'FixedColumns'),
options = list(
pageLength = 15,
lengthMenu = c(5, 10, 15, 20, 25, 30, 50, 100),
scrollX = TRUE,
searchHighlight = TRUE,
buttons = c('copy', 'csv', 'excel', 'pdf', 'print'),
fixedColumns = list(leftColumns = 2),
columnDefs = list(list(
targets = 1,
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data.length > 9 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 9) + '...</span>' : data;",
"}"
)
)),
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});",
"}"
),
dom = 'Biftlp'
)
)
})
### CHOROPLET + POINTS (map) ------------------------------------------------------------------------------------------------------------
is.map.flt <- reactive({
if(input$cbo_hsp_mapF != 'NONE')
if(input$cbo_hsp_map_flt != 'NONE') return(TRUE)
return(FALSE)
})
is.hsp.map.msr <- reactive({
metrics[label == input$cbo_hsp_mapY, type] == 2
})
hsp.map.title <- reactive({
ttl <- paste(metrics[label == input$cbo_hsp_mapY, title], 'by', var.hsp.geo() )
if(is.map.flt())
ttl <- paste0(ttl,
', filtered by ', clear.label(input$cbo_hsp_mapF), ' = <i>',
lookups[domain_id == gsub('X', '', input$cbo_hsp_mapF) & lookup_id == input$cbo_hsp_map_flt, description], '</i>'
)
if(input$chk_hsp_map_hsp){
if(input$cbo_hsp_mapZ1 != 'NONE' | input$cbo_hsp_mapZ2 != 'NONE')
ttl <- paste(ttl, '<br/>',
if(input$cbo_hsp_mapZ1 != 'NONE'){ clear.label(input$cbo_hsp_mapZ1) },
if( (input$cbo_hsp_mapZ1 != 'NONE') & (input$cbo_hsp_mapZ2 != 'NONE') ){ 'and' },
if(input$cbo_hsp_mapZ2 != 'NONE'){ clear.label(input$cbo_hsp_mapZ2) },
'by Hospitals'
)
}
ttl
})
output$out_hsp_mpx <- renderUI({
HTML(paste0('<h3>', hsp.map.title(), '<br/>', hsp.subtitle(), '</h3>' ) )
})
dt_hsp_map_plg <- reactive({
if(input$cbo_hsp_mapY == 'NONE') return(NULL)
mtc <- input$cbo_hsp_mapY
geo <- input$cbo_hsp_geo
# flag for measure (ie, calculate percentage)
is.hsp.map.msr <- (metrics[label == mtc, type] == 2)
# determine dataset: YF = formula for filter, YM = formula for measure / metric
if(is.hsp.map.msr){
YF <- metrics[label == mtc, filter_pct]
YM <- metrics[label == mtc, mutate_pct]
} else {
YF <- metrics[label == mtc, filter_by]
YM <- metrics[label == mtc, mutate_as]
}
y <- dt_hsp()[eval(parse(text = YF))]
if(input$cbo_hsp_mapF != 'NONE'){
if(input$cbo_hsp_map_flt != 'NONE'){
flt.map.lbl <- lookups[domain_id == gsub('X', '', input$cbo_hsp_mapF) & lookup_id == input$cbo_hsp_map_flt, description]
y <- y[ get(input$cbo_hsp_mapF) == flt.map.lbl ]
}
}
y <- y[, .( N = .N, Y = eval(parse(text = paste(YM))) ), .( LW = get(geo), W = get(paste0(geo, '_id')) ) ]
yt <-
if(input$cbo_hsp_fnlF == 'NONE'){
dt_hsp()[, .(T = .N), .(W = get( paste0(geo, '_id'))) ]
} else {
dt_hsp()[get(input$cbo_hsp_mapF) == flt.map.lbl, .(T = .N), .(W = get( paste0(geo, '_id'))) ]
}
setkey(y, 'W')
setkey(yt, 'W')
y <- y[yt][, C := N/T]
y[, ttip := paste0(
var.hsp.geo(), ': <b>', LW, '</b><br/>',
if(input$cbo_hsp_fnlF == 'NONE'){ paste0('') },
'N. Procedures: <b>', T, '</b><br/>',
'Completeness: <b>', formatC(100*C, digits = 2, format = 'f'), '%</b> (', round(N), ')', '<br/>',
metrics[label == mtc, label], ': <b>',
if(is.hsp.map.msr){ paste0(formatC(100*Y, digits = 2, format = 'f'), '%</b> (', round(N*Y), ')') } else { Y }, '<br/>'
)]
setkey(y, 'W')
setkey(areas, 'nhs_id')
areas[, .(nhs_id, Wo = ons_id)][y]
})
# observeEvent(input$cbo_hsp_geo,
# {
# updateSelectInput(session, 'cbo_hsp_mapY', 'AREA METRIC:', choices = c('NONE', build_uiY('map')))
# # updateSelectInput(session, )
# }
# )
# Initial Layer
output$out_hsp_map <- renderLeaflet({
bnd <- boundaries[[loca.ini]]
if(length(boundaries[[input$cbo_hsp_geo]]) > 0) bnd <- boundaries[[input$cbo_hsp_geo]]
bnd.void <- subset(bnd, is.na(bnd$H))
bnd.ok <- subset(bnd, !is.na(bnd$H))
pal <- colorNumeric(palette = brewer.pal(3, pal.ini), domain = 1:max(bnd.ok$H, na.rm = TRUE), na.color = 'grey')
leaflet(bnd) %>%
fitBounds(lng1 = 1.8, lat1 = 49.9, lng2 = -8.3, lat2 = 58.0 ) %>%
addTiles(tile.ini) %>%
addPolygons(data = bnd.void, group = 'poly.void',
stroke = TRUE,
color = '#444444',
opacity = 1.0,
weight = 0.6,
smoothFactor = 0.5,
fill = TRUE,
fillColor = 'grey',
fillOpacity = 0.4,
highlightOptions = highlightOptions(
color = 'red',
weight = 3,
bringToFront = TRUE
),
label = lapply(1:length(bnd.void), function(x) HTML(paste0(bnd.void$name[x], ' (', bnd.void$nhs_id[x], '). ', '<b>Not Supported</b>') ) ),
labelOptions = labelOptions(
textsize = '12px',
direction = 'auto',
style = list('font-weight' = 'normal', 'padding' = '2px 6px')
)
) %>%
addPolygons(data = bnd.ok, group = 'poly.ok',
stroke = TRUE,
color = '#444444',
opacity = 1.0,
weight = 0.6,
smoothFactor = 0.5,
fill = TRUE,
fillColor = ~pal(H),
fillOpacity = 0.4,
highlightOptions = highlightOptions(
color = 'white',
weight = 5,
bringToFront = TRUE
),
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>') ) ),
labelOptions = labelOptions(
textsize = '12px',
direction = 'auto',
style = list('font-weight' = 'normal', 'padding' = '2px 6px')
)
) %>%
addLegend(
pal = pal,
values = ~H,
title = 'N Centres',
position = 'bottomright',
opacity = 0.8
)
})
# Merge boundaries with chosen data. ===>>> NEEDS tweak for names when missing data <<<===
hsp_map_bnd <- reactive({
bnd <- boundaries[[input$cbo_hsp_geo]]
bnd <- subset(bnd, !is.na(bnd$H))
merge(bnd, dt_hsp_map_plg(), by.x = 'id', by.y = 'Wo', all.x = FALSE)
})
# Determine the number of different classes
n.col <- reactive({
min(length(unique(hsp_map_bnd()$Y)), input$sld_hsp_map_Ycn, brewer.pal.info[input$pal_hsp_mapY, 'maxcolors'])
})
# Determine the values for the bins
brks <- reactive({
classIntervals(hsp_map_bnd()$Y, n = n.col(), style = input$cbo_hsp_map_Ycl)
})
# Determine the colors to use
col_codes <- reactive({
y <- brewer.pal(n = n.col(), name = input$pal_hsp_mapY)[1:n.col()]
if(input$chk_hsp_mapY_rvc) y <- rev(y)
y
})
# associate colors and classes
colorpal <- reactive({
findColours(brks(), col_codes())
})
# Update changes in Tiles
observe({
proxy <- leafletProxy('out_hsp_map')
proxy %>% clearTiles()
proxy %>% addTiles(input$cbo_hsp_map_tls)
})
# Update changes In Polygons
observe({
if(input$cbo_hsp_mapY != 'NONE'){
pal <- colorpal()
bnd <- hsp_map_bnd()
leafletProxy('out_hsp_map') %>%
clearGroup('poly.ok') %>%
addPolygons(data = bnd, group ='poly.ok',
stroke = TRUE,
color = input$col_hsp_mapY_bcl,
opacity = 1.0,
weight = as.integer(input$sld_hsp_mapY_bsz) / 10,
smoothFactor = 0.5,
fill = TRUE,
fillColor = pal,
fillOpacity = 1 - as.integer(input$sld_hsp_mapY_trp) / 10,
highlightOptions = highlightOptions(
color = 'white',
weight = 3,
bringToFront = TRUE
),
label = lapply(bnd$ttip, HTML),
labelOptions = labelOptions(
textsize = '15px',
direction = 'auto',
style = list('font-weight' = 'normal', 'padding' = '3px 8px')
)
)
}
})
# Draw / Clear Polygons Legend
observe({
if(input$cbo_hsp_mapY != 'NONE'){
pal <- colorpal()
bnd <- hsp_map_bnd()
proxy <- leafletProxy('out_hsp_map')
proxy %>% clearControls()
if(input$chk_hsp_map_lgn){
# mtc.type <- metrics[label == input$cbo_hsp_mapY, type]
# lbl.brks <- brks()[[2]]
# if(mtc.type == 1){
# lbl.brks <- format(round(lbl.brks, 0), big.mark = ',')
# } else if(mtc.type == 2){
# lbl.brks <- format(round(100*lbl.brks, 2), nsmall = 2)
# } else {
# lbl.brks <- format(round(lbl.brks, 1), nsmall = 1)
# }
# lbl.text <- sapply(2:n.col(),
# function(x)
# paste0(
# lbl.brks[x-1], ' \u2264 n < ', lbl.brks[x],
# ' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[x-1])) & bnd$Y < as.numeric(gsub(',', '', lbl.brks[x])) ] ), ')'
# )
# )
# lbl.text <- c(lbl.text,
# paste0(
# lbl.brks[n.col()], ' \u2264 n \u2264 ', lbl.brks[n.col() + 1],
# ' (', length(bnd$Y[bnd$Y >= as.numeric(gsub(',', '', lbl.brks[n.col()])) & bnd$Y <= as.numeric(gsub(',', '', lbl.brks[n.col() + 1])) ] ), ')'
# )
# )
lbl.text <- get.legend.colnames(bnd, metrics[label == input$cbo_hsp_mapY, type], brks()[[2]], n.col())
proxy %>%
addLegend(
colors = col_codes(),
labels = lbl.text,
title = metrics[label == input$cbo_hsp_mapY, title],
position = input$cbo_hsp_map_lgn,
opacity = 1 - as.integer(input$sld_hsp_mapY_trp) / 10
)
}
}
})
# Update Markers: Hospitals points / icons, with correspondin Size / Colours Metrics
observe({
proxy <- leafletProxy('out_hsp_map')
proxy %>% clearMarkers()
if(input$chk_hsp_map_hsp){
proxy %>%
addAwesomeMarkers(data = centres,
lng = ~X_lon, lat = ~Y_lat,
label = ~as.character(HSP_id),
labelOptions = labelOptions(
opacity = 0.8
),
popup = ~as.character(paste(HSP_id, '-', HSP)),
popupOptions = labelOptions(
opacity = 0.8
),
icon = hsp.icons
)
}
})
### DOWNLOAD (dwn) ----------------------------------------------------------------------------------------------------------------
# DATASET
output$out_hsp_dwn <- renderText({
paste('The dataset contains', format(nrow(dt_hsp()), big.mark = ','), 'records')
})
output$dwn_hsp_dta <- downloadHandler(
filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.csv') },
content <- function(file){
write.table(
dt.for.export(
switch(input$cbo_hsp_tmp,
'1' = dataset[ date.year >= input$sld_hsp_tmp[1] & date.year <= input$sld_hsp_tmp[2] ],
'2' = dataset[
daten.month >= as.numeric(paste0(substr(input$dts_hsp[1], 1, 4), substr(input$dts_hsp[1], 6, 7))) &
daten.month <= as.numeric(paste0(substr(input$dts_hsp[2], 1, 4), substr(input$dts_hsp[2], 6, 7)))
],
'3' = dataset[ date.day >= input$dts_hsp[1] & date.day <= input$dts_hsp[2] ]
)
),
file, sep = ',', row.names = FALSE
)
}
)
# TABLES
output$dwn_hsp_tbl <- downloadHandler(
filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.csv') },
content <- function(file){
write.table(
switch(input$tabs_hsp,
'barplot' = dt.csv.output(hsp_brp_tbl()[[1]]),
'boxplot' = dt.csv.output(hsp_bxp_tbl()[[1]]),
'heatmap' = dt.csv.output(hsp_hmp_tbl()[[1]]),
'funnelplot' = dt.csv.output(hsp_fnl_tbl()[[1]]),
'maps' = dt.csv.output(hsp_map_tbl())
),
file, sep = ',', row.names = FALSE
)
}
)
# PLOTS
output$dwn_hsp_plt <- downloadHandler(
filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.png') },
content = function(file) ggsave(file, plot = {
switch(input$tabs_hsp,
'barplot' = {
hsp_brp_plt() + labs(
title = plot.title.clean(hsp.brp.title()),
subtitle = plot.title.clean(hsp.subtitle()),
caption = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
)
},
'boxplot' = {
hsp_bxp_plt() + labs(
title = plot.title.clean(hsp.bxp.title()),
subtitle = plot.title.clean(hsp.subtitle()),
caption = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
)
},
'heatmap' = {
hsp_hmp_plt() + labs(
title = plot.title.clean(hsp.hmp.title()),
subtitle = plot.title.clean(hsp.subtitle()),
caption = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
)
},
'funnelplot' = {
hsp_fnl_plt() + labs(
title = plot.title.clean(hsp.fnl.title()),
subtitle = plot.title.clean(hsp.subtitle()),
caption = if(input$chk_hsp_cpt){ input$txt_hsp_cpt }
)
}
)
}, type = 'cairo-png')
)
# MAPS - STATIC
output$dwn_hsp_mpp <- downloadHandler(
filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.jpg') },
content = function(file) mapview(hsp_map_plt(), filename)
)
# MAPS - INTERACTIVE
output$dwn_hsp_mph <- downloadHandler(
filename <- function(){ paste0(filename.clean(input$txt_hsp_dwn), '.html') },
content = function(file) saveWidget(hsp_map_plt(), filename)
)
Comments
0 B
|👍
/👎
0 B
|👍
/👎