################################################################################################### # 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(''), onStatus = 'primary', offLabel = paste0(''), 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('

', hsp.tbl.title(), '
', hsp.subtitle(), '

' ) ) }) 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('

', hsp.brp.title(), '
', hsp.subtitle(), '

' ) ) }) 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('

', hsp.bxp.title(), '
', hsp.subtitle(), '

' ) ) }) 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('

', hsp.hmp.title(), '
', hsp.subtitle(), '

' ) ) }) 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('

', hsp.fnl.title(), '
', hsp.subtitle(), '

' ) ) }) 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(), ': ', LW, '
', metrics[label == input$cbo_hsp_fnlX, title], ': ', prettyNum(X, big.mark = ','), '
', metrics[label == input$cbo_hsp_fnlY, label], ':
', '' )] # 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 ?", "'' + data.substr(0, 9) + '...' : 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), ' = ', lookups[domain_id == gsub('X', '', input$cbo_hsp_mapF) & lookup_id == input$cbo_hsp_map_flt, description], '' ) if(input$chk_hsp_map_hsp){ if(input$cbo_hsp_mapZ1 != 'NONE' | input$cbo_hsp_mapZ2 != 'NONE') ttl <- paste(ttl, '
', 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('

', hsp.map.title(), '
', hsp.subtitle(), '

' ) ) }) 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(), ': ', LW, '
', if(input$cbo_hsp_fnlF == 'NONE'){ paste0('') }, 'N. Procedures: ', T, '
', 'Completeness: ', formatC(100*C, digits = 2, format = 'f'), '% (', round(N), ')', '
', metrics[label == mtc, label], ': ', if(is.hsp.map.msr){ paste0(formatC(100*Y, digits = 2, format = 'f'), '% (', round(N*Y), ')') } else { Y }, '
' )] 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], '). ', 'Not Supported') ) ), 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:', bnd.ok$H[x], '') ) ), 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) )