diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R
index b3076a33..3e01a8b3 100644
--- a/R/characterization-incidence.R
+++ b/R/characterization-incidence.R
@@ -1,6 +1,6 @@
-# @file characterization-timeToEvent.R
+# @file characterization-incidence.R
#
-# Copyright 2022 Observational Health Data Sciences and Informatics
+# Copyright 2023 Observational Health Data Sciences and Informatics
#
# This file is part of OhdsiShinyModules
#
@@ -17,6 +17,92 @@
# limitations under the License.
+as_ggplot <- function(x){
+ # Open null device to avoid blank page before plot------
+ # see cowplot:::as_grob.ggplot
+ null_device <- base::getOption(
+ "ggpubr.null_device",
+ default = cowplot::pdf_null_device
+ )
+ cur_dev <- grDevices::dev.cur()
+ # Open null device to avoid blank page before plot
+ null_device(width = 6, height = 6)
+ null_dev <- grDevices::dev.cur()
+ on.exit({
+ grDevices::dev.off(null_dev)
+ if (cur_dev > 1) grDevices::dev.set(cur_dev)
+ })
+ # Convert to ggplot-------------
+ cowplot::ggdraw() +
+ cowplot::draw_grob(grid::grobTree(x))
+}
+
+# Custom function that takes a ggplotly figure and its facets as arguments.
+# The upper x-values for each domain is set programmatically, but you can adjust
+# the look of the figure by adjusting the width of the facet domain and the
+# corresponding annotations labels through the domain_offset variable
+fixfacets <- function(figure, facets, domain_offset){
+
+ fig <- figure
+
+ # split x ranges from 0 to 1 into
+ # intervals corresponding to number of facets
+ # xHi = highest x for shape
+ xHi <- seq(0, 1, len = length(facets)+1)
+ xHi <- xHi[2:length(xHi)]
+
+ xOs <- domain_offset
+
+ # Shape manipulations, identified by dark grey backround: "rgba(217,217,217,1)"
+ # structure: p$x$layout$shapes[[2]]$
+ shp <- fig$x$layout$shapes
+ j <- 1
+ for (i in seq_along(shp)){
+ if (shp[[i]]$fillcolor=="rgba(217,217,217,1)" & (!is.na(shp[[i]]$fillcolor))){
+ #$x$layout$shapes[[i]]$fillcolor <- 'rgba(0,0,255,0.5)' # optionally change color for each label shape
+ fig$x$layout$shapes[[i]]$x1 <- xHi[j]
+ fig$x$layout$shapes[[i]]$x0 <- (xHi[j] - xOs)
+ #fig$x$layout$shapes[[i]]$y <- -0.05
+ j<-j+1
+ }
+ }
+
+ # annotation manipulations, identified by label name
+ # structure: p$x$layout$annotations[[2]]
+ ann <- fig$x$layout$annotations
+ annos <- facets
+ j <- 1
+ for (i in seq_along(ann)){
+ if (ann[[i]]$text %in% annos){
+ # but each annotation between high and low x,
+ # and set adjustment to center
+ fig$x$layout$annotations[[i]]$x <- (((xHi[j]-xOs)+xHi[j])/2)
+ fig$x$layout$annotations[[i]]$xanchor <- 'center'
+ #print(fig$x$layout$annotations[[i]]$y)
+ #fig$x$layout$annotations[[i]]$y <- -0.05
+ j<-j+1
+ }
+ }
+
+ # domain manipulations
+ # set high and low x for each facet domain
+ xax <- names(fig$x$layout)
+ j <- 1
+ for (i in seq_along(xax)){
+ if (!is.na(pmatch('xaxis', xax[i]))){
+ #print(p[['x']][['layout']][[lot[i]]][['domain']][2])
+ fig[['x']][['layout']][[xax[i]]][['domain']][2] <- xHi[j]
+ fig[['x']][['layout']][[xax[i]]][['domain']][1] <- xHi[j] - xOs
+ j<-j+1
+ }
+ }
+
+ return(fig)
+}
+
+
+
+
#' The module viewer for exploring incidence results
#'
#' @details
@@ -31,14 +117,7 @@
characterizationIncidenceViewer <- function(id) {
ns <- shiny::NS(id)
shiny::div(
- #shinydashboard::box(
- # collapsible = TRUE,
- # collapsed = TRUE,
- # title = "Incidence Rates",
- # width = "100%",
- # shiny::htmlTemplate(system.file("characterization-www", "help-incidenceRate.html", package = utils::packageName()))
- # ),
-
+
infoHelperViewer(
id = "helper",
helpLocation= system.file("characterization-www", "help-incidenceRate.html", package = utils::packageName())
@@ -63,7 +142,23 @@ characterizationIncidenceViewer <- function(id) {
),
shiny::tabPanel(
title = "Incidence Rate Plots",
- #code to view plot here
+ shiny::tabsetPanel(
+ type = 'pills',
+ id = ns('incPlotPanel'),
+ shiny::tabPanel(
+ title = "Custom Plot",
+ shinycssloaders::withSpinner(
+ plotly::plotlyOutput(ns('incidencePlot'),
+ height = "1600px",
+ width = "90%")
+ ),
+ shiny::plotOutput(ns('incidencePlotLegend'),
+ width="100%",
+ height="300px"
+ )
+
+ )
+ )
)
)
)
@@ -93,497 +188,829 @@ characterizationIncidenceServer <- function(
) {
shiny::moduleServer(
id,
+ #' Title
+ #'
+ #' @param input
+ #' @param output
+ #' @param session
+ #'
+ #' @return
+ #' @export
+ #'
+ #' @examples
function(input, output, session) {
- cohorts <- getTargetOutcomes(
- connectionHandler,
- resultDatabaseSettings
- )
- # input selection component
- inputSelected <- inputSelectionServer(
- id = "input-selection",
- inputSettingList = list(
- createInputSetting(
- rowNumber = 1,
- columnWidth = 6,
- varName = 'targetIds',
- uiFunction = 'shinyWidgets::pickerInput',
- uiInputs = list(
- label = 'Target: ',
- choices = cohorts$targetIds,
- selected = cohorts$targetIds[1],
- multiple = T,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
+ ## ns <- session$ns
+
+ options <- getIncidenceOptions( # written using getTargetOutcomes
+ connectionHandler,
+ resultDatabaseSettings
+ )
+
+ # input selection component
+ inputSelected <- inputSelectionServer(
+ id = "input-selection",
+ inputSettingList = list(
+ createInputSetting(
+ rowNumber = 1,
+ columnWidth = 12,
+ varName = 'firsttext',
+ inputReturn = F,
+ uiFunction = 'shiny::div',
+ uiInputs = list(
+ "Select Your Results",
+ style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px;"
)
- )
- ),
- createInputSetting(
- rowNumber = 1,
- columnWidth = 6,
- varName = 'outcomeIds',
- uiFunction = 'shinyWidgets::pickerInput',
- uiInputs = list(
- label = 'Outcome: ',
- choices = cohorts$outcomeIds,
- selected = cohorts$outcomeIds[1],
- multiple = T,
- options = shinyWidgets::pickerOptions(
- actionsBox = TRUE,
- liveSearch = TRUE,
- size = 10,
- liveSearchStyle = "contains",
- liveSearchPlaceholder = "Type here to search",
- virtualScroll = 50
+ ),
+ createInputSetting(
+ rowNumber = 2,
+ columnWidth = 6,
+ varName = 'targetIds',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Target: ',
+ choices = options$targetIds,
+ selected = options$targetIds[1],
+ multiple = T,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+ createInputSetting(
+ rowNumber = 2,
+ columnWidth = 6,
+ varName = 'outcomeIds',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Outcome: ',
+ choices = options$outcomeIds,
+ selected = options$outcomeIds[1],
+ multiple = T,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ # third row
+ createInputSetting(
+ rowNumber = 3,
+ columnWidth = 4,
+ varName = 'incidenceRateAgeFilter',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ collapse = T,
+ uiInputs = list(
+ label = 'Filter By Age: ',
+ choices = options$ageGroupName,
+ selected = options$ageGroupName,
+ multiple = T,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+
+ createInputSetting(
+ rowNumber = 3,
+ columnWidth = 4,
+ varName = 'incidenceRateGenderFilter',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ collapse = T,
+ uiInputs = list(
+ label = 'Filter By Sex: ',
+ choices = options$genderName,
+ selected = options$genderName,
+ multiple = T,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ createInputSetting(
+ rowNumber = 3,
+ columnWidth = 4,
+ varName = 'incidenceRateCalendarFilter',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ collapse = T,
+ uiInputs = list(
+ label = 'Filter By Start Year: ',
+ choices = options$startYear,
+ selected = options$startYear,
+ multiple = T,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ # 4th row text
+ createInputSetting(
+ rowNumber = 4,
+ columnWidth = 12,
+ varName = 'secondtext',
+ inputReturn = F,
+ uiFunction = 'shiny::div',
+ uiInputs = list(
+ "Configure Your Plot",
+ style = "font-weight: bold; font-size: 20px; text-align: center; margin-bottom: 20px; margin-top: 20px; "
+ )
+ ),
+
+ # plotting settings 5th row
+
+ createInputSetting(
+ rowNumber = 5,
+ columnWidth = 3,
+ varName = 'plotYAxis',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Y Axis (Numeric) ',
+ choices = options$irPlotNumericChoices,
+ selected = "incidenceRateP100py",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ createInputSetting(
+ rowNumber = 5,
+ columnWidth = 3,
+ varName = 'plotXAxis',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'X Axis (Categorical) ',
+ choices = options$irPlotCategoricalChoices,
+ selected = "startYear",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ createInputSetting(
+ rowNumber = 5,
+ columnWidth = 3,
+ varName = 'plotXTrellis',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Row Trellis (Categorical) ',
+ choices = options$irPlotCategoricalChoices,
+ selected = "targetName",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ createInputSetting(
+ rowNumber = 5,
+ columnWidth = 3,
+ varName = 'plotYTrellis',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Column Trellis (Categorical)',
+ choices = options$irPlotCategoricalChoices,
+ selected = "outcomeName",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ # row 6
+
+ createInputSetting(
+ rowNumber = 6,
+ columnWidth = 4,
+ varName = 'plotColor',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Color (Categorical)',
+ choices = options$irPlotCategoricalChoices,
+ selected = "cdmSourceAbbreviation",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+ createInputSetting(
+ rowNumber = 6,
+ columnWidth = 4,
+ varName = 'plotSize',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Plot Point Size (Numeric)',
+ choices = options$irPlotNumericChoices,
+ selected = "outcomes",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
)
+ ),
+ createInputSetting(
+ rowNumber = 6,
+ columnWidth = 4,
+ varName = 'plotShape',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Plot Point Shape (Categorical)',
+ choices = options$irPlotCategoricalChoices,
+ selected = "genderName",
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ # row 7
+
+ createInputSetting(
+ rowNumber = 7,
+ columnWidth = 8,
+ varName = 'incidenceRateTarFilter',
+ uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
+ uiInputs = list(
+ label = 'Select Time at risk (TAR)',
+ choices = options$tar,
+ selected = options$tar[1],
+ multiple = F,
+ options = shinyWidgets::pickerOptions(
+ actionsBox = TRUE,
+ liveSearch = TRUE,
+ size = 10,
+ dropupAuto = TRUE,
+ liveSearchStyle = "contains",
+ liveSearchPlaceholder = "Type here to search",
+ virtualScroll = 50
+ )
+ )
+ ),
+
+ createInputSetting(
+ rowNumber = 7,
+ columnWidth = 4,
+ varName = 'irYscaleFixed',
+ uiFunction = 'shiny::checkboxInput',
+ uiInputs = list(
+ label = "Use same y-axis scale across plots?"
+ )
+ )
+
+
+
)
- )
)
- )
-
-
-
- # allDataDownload <- shiny::reactiveVal(data.frame())
- # selectedInputs <- shiny::reactiveVal()
- # output$IRinputsText <- shiny::renderUI(selectedInputs())
-
- #if generate is pushed, extract the data
- allData <- shiny::reactive({
- getIncidenceData(targetIds = inputSelected()$targetIds,
- outcomeIds = inputSelected()$outcomeIds,
- connectionHandler = connectionHandler,
- resultDatabaseSettings = resultDatabaseSettings
- ) %>%
- dplyr::relocate(.data$tar, .before = .data$outcomes) %>%
- dplyr::mutate(dplyr::across(dplyr::where(is.numeric), round, 4))
- })
-
- create_select_input <- function(values, name) {
- shiny::tags$select(
- # Set to undefined to clear the filter
- onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # "All" has an empty value to clear the filter, and is the default option
- shiny::tags$option(value = "", "All"),
- lapply(unique(values), shiny::tags$option),
- "aria-label" = sprintf("Filter %s", name),
- style = "width: 100%; height: 28px;"
- )
- }
- js_code <- "
- // Custom range filter with value label
- function rangeFilter(column, state) {
- // Get min and max values from raw table data
- let min = Infinity;
- let max = 0;
- state.data.forEach(function(row) {
- const value = row[column.id];
- if (value < min) {
- min = Math.floor(value);
- } else if (value > max) {
- max = Math.ceil(value);
+ filteredData <- shiny::reactive(
+ {
+ if (is.null(inputSelected()$targetIds) |
+ is.null(inputSelected()$outcomeIds)) {
+ return(data.frame())
}
- });
-
- const filterValue = column.filterValue || min;
- const input = React.createElement('input', {
- type: 'range',
- value: filterValue,
- min: min,
- max: max,
- onChange: function(event) {
- // Set to undefined to clear the filter
- column.setFilter(event.target.value || undefined);
- },
- style: { width: '100%', marginRight: '8px' },
- 'aria-label': 'Filter ' + column.name
- });
-
- return React.createElement(
- 'div',
- { style: { display: 'flex', alignItems: 'center', height: '100%' } },
- [input, filterValue]
- );
- }
-
- // Filter method that filters numeric columns by minimum value
- function filterMinValue(rows, columnId, filterValue) {
- return rows.filter(function(row) {
- return row.values[columnId] >= filterValue;
- });
- }
- "
+
+ getIncidenceData(targetIds = inputSelected()$targetIds,
+ outcomeIds = inputSelected()$outcomeIds,
+ connectionHandler = connectionHandler,
+ resultDatabaseSettings = resultDatabaseSettings
+ ) %>%
+ dplyr::relocate(tar, .before = outcomes) %>%
+ dplyr::mutate(incidenceProportionP100p = as.numeric(incidenceProportionP100p),
+ incidenceRateP100py = as.numeric(incidenceRateP100py),
+ dplyr::across(dplyr::where(is.numeric), round, 4),
+ targetIdShort = paste("C", targetCohortDefinitionId, sep = ":"),
+ outcomeIdShort = paste("C", outcomeCohortDefinitionId, sep = ":")) %>%
+ dplyr::filter(ageGroupName %in% inputSelected()$incidenceRateAgeFilter &
+ genderName %in% inputSelected()$incidenceRateGenderFilter &
+ startYear %in% inputSelected()$incidenceRateCalendarFilter
+ )
+ }
+ )
+
+
+ incidenceColList <- ParallelLogger::loadSettingsFromJson(
+ system.file("components-columnInformation",
+ "characterization-incidence-colDefs.json",
+ package = "OhdsiShinyModules"
+ )
+ )
+ ##class(incidenceColList$genderName$filterMethod) <- "JS_EVAL"
+ renderIrTable <- shiny::reactive(
+ {
+ filteredData()
+ }
+ )
+ resultTableServer(
+ id = "incidenceRateTable",
+ df = renderIrTable,
+ selectedCols = c("cdmSourceAbbreviation", "targetName", "outcomeName",
+ "ageGroupName", "genderName", "startYear", "tar", "outcomes",
+ "incidenceProportionP100p", "incidenceRateP100py"),
+ sortedCols = c("ageGroupName", "genderName", "startYear", "incidenceRateP100py"),
+ elementId = "incidence-select",
+ colDefsInput = incidenceColList,
+ downloadedFileName = "incidenceRateTable-"
+ )
- #read in custom column name colDef list from rds file, generated by
- #heplers-componentsCreateCustomColDefList.R
+ #ir plots - TODO edit to reactive
+ renderIrPlot <- shiny::reactive(
+ {
+ if (is.null(inputSelected()$targetIds) |
+ is.null(inputSelected()$outcomeIds)) {
+ return(data.frame())
+ }
+
+ plotData <- filteredData() %>%
+ dplyr::filter(tar %in% inputSelected()$incidenceRateTarFilter)
+
+ # Take the specific tar value you want to plot
+ tar_value <- unique(plotData$tar)[1]
+
+ # Create a column for the tooltip text
+ plotData$tooltip <- with(plotData, paste(
+ "Incidence Rate:", incidenceRateP100py, "
",
+ "Incidence Proportion:", incidenceProportionP100p, "
",
+ "Outcome ID:", outcomeIdShort, "
",
+ "Outcome Name:", outcomeName, "
",
+ "Target ID:", targetIdShort, "
",
+ "Target Name:", targetName, "
",
+ "Data Source:", cdmSourceAbbreviation, "
",
+ "Calendar Year:", startYear, "
",
+ "Age Group:", ageGroupName, "
",
+ "Sex:", genderName, "
",
+ "Clean Window:", cleanWindow, "
",
+ "Persons at Risk:", personsAtRisk, "
",
+ "Person Days:", personDays, "
",
+ "Outcomes:", outcomes
+ ))
+
+
+ # Check if color, size, shape, and trellis variables are selected, and set aesthetics accordingly
+ color_aesthetic <- NULL
+ size_aesthetic <- NULL
+ shape_aesthetic <- NULL
+ trellis_aesthetic_x <- NULL
+ trellis_aesthetic_y <- NULL
+
+ if (inputSelected()$plotColor == "Target Cohort" | inputSelected()$plotColor == "Outcome Cohort") {
+ color_aesthetic <- if (inputSelected()$plotColor == "Target Cohort") {
+ dplyr::vars(targetIdShort)
+ } else if (inputSelected()$plotColor == "Outcome Cohort") {
+ dplyr::vars(outcomeIdShort)
+ }
+ }
+
+ if (inputSelected()$plotShape == "Target Cohort" | inputSelected()$plotShape == "Outcome Cohort") {
+ shape_aesthetic <- if (inputSelected()$plotShape == "Target Cohort") {
+ dplyr::vars(targetIdShort)
+ } else if (inputSelected()$plotShape == "Outcome Cohort") {
+ dplyr::vars(outcomeIdShort)
+ }
+ }
+
+ max_length <- max(nchar(unique(inputSelected()$plotXAxis)))
+
+ if (inputSelected()$plotXTrellis != inputSelected()$plotYTrellis){
+
+ # Create the base plot with conditional aesthetics
+ base_plot <- ggplot2::ggplot(
+ data = plotData,
+ ggplot2::aes(x = .data[[inputSelected()$plotXAxis]],
+ y = .data[[inputSelected()$plotYAxis]],
+ shape = if(inputSelected()$plotShape != "None" & inputSelected()$plotShape != "Target Cohort" &
+ inputSelected()$plotShape != "Outcome Cohort") .data[[inputSelected()$plotShape]]
+ else shape_aesthetic,
+ color = if(inputSelected()$plotColor != "None" & inputSelected()$plotColor != "Target Cohort" &
+ inputSelected()$plotColor != "Outcome Cohort") .data[[inputSelected()$plotColor]]
+ else color_aesthetic,
+ text = tooltip
+ )
+ ) +
+ ggplot2::geom_point(ggplot2::aes(size = if(inputSelected()$plotSize != "None") .data[[inputSelected()$plotSize]] else NULL,
+ alpha = 0.6)
+ )
+
+ # Rotate x-axis labels if the maximum length is greater than 10
+ if (max_length > 10) {
+ base_plot <- base_plot +
+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1))
+ }
+
+ # Add trellising if it's not NULL
+ if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(.data[[inputSelected()$plotXTrellis]]),
+ cols = vars(.data[[inputSelected()$plotYTrellis]]),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis=="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(targetIdShort),
+ cols = vars(.data[[inputSelected()$plotYTrellis]]),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis=="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(outcomeIdShort),
+ cols = vars(.data[[inputSelected()$plotYTrellis]]),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis=="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(.data[[inputSelected()$plotXTrellis]]),
+ cols = vars(targetIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis=="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(.data[[inputSelected()$plotXTrellis]]),
+ cols = vars(outcomeIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis=="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis=="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(targetIdShort),
+ cols = vars(targetIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis=="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis=="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(targetIdShort),
+ cols = vars(outcomeIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis=="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis=="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(outcomeIdShort),
+ cols = vars(targetIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis=="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis=="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(outcomeIdShort),
+ cols = vars(outcomeIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis=="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis=="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = NULL,
+ cols = vars(outcomeIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis=="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis=="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = NULL,
+ cols = vars(targetIdShort),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis=="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis!="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = NULL,
+ cols = vars(.data[[inputSelected()$plotYTrellis]]),
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis=="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(.data[[inputSelected()$plotXTrellis]]),
+ cols = NULL,
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis=="targetName" & inputSelected()$plotXTrellis!="outcomeName" &
+ inputSelected()$plotYTrellis=="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(targetIdShort),
+ cols = NULL,
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+ else if (inputSelected()$plotXTrellis!="None" & inputSelected()$plotXTrellis!="targetName" & inputSelected()$plotXTrellis=="outcomeName" &
+ inputSelected()$plotYTrellis=="None" & inputSelected()$plotYTrellis!="targetName" & inputSelected()$plotYTrellis!="outcomeName") {
+ base_plot <- base_plot + ggplot2::facet_grid(
+ rows = vars(outcomeIdShort),
+ cols = NULL,
+ scales = if (inputSelected()$irYscaleFixed) "fixed" else "free_y"
+ ) +
+ ggplot2::theme(strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(size = NULL, color = NULL, face="bold")
+ ) +
+ ggh4x::force_panelsizes(rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in"))
+ }
+
+
+ # Rest of your ggplot code remains the same
+ base_plot <- base_plot + ggplot2::labs(
+ title = paste("Incidence Rate for TAR:", tar_value),
+ x = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% inputSelected()$plotXAxis]),
+ y = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% inputSelected()$plotYAxis]),
+ color = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% inputSelected()$plotColor]),
+ size = names(options$irPlotNumericChoices[options$irPlotNumericChoices %in% inputSelected()$plotSize]),
+ shape = names(options$irPlotCategoricalChoices[options$irPlotCategoricalChoices %in% inputSelected()$plotShape]
+ )
+ ) +
+ ggplot2::guides(alpha = "none") + # Remove the alpha legend
+ ggplot2::theme_bw() +
+ ggplot2::theme(
+ title = ggplot2::element_text(hjust = 0.5),
+ plot.title = ggplot2::element_text(margin = ggplot2::margin(b = 10)),
+ axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 10)),
+ axis.title.y = ggplot2::element_text(margin = ggplot2::margin(r = 10)),
+ legend.box = "horizontal",
+ panel.spacing = ggplot2::unit(1, "lines"),
+ strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(face="bold")
+ ) +
+ ggh4x::force_panelsizes(
+ rows = ggplot2::unit(4, "in"), cols = ggplot2::unit(3, "in")
+ )
+
+ #
+ # # Create a custom color scale
+ # color_scale <- RColorBrewer::colorRampPalette(brewer.pal(9, "YlOrRd"))(100)
+ #
+ # # Create a faceted heatmap by outcome and data source
+ # p <- ggplot2::ggplot(data = plotData, aes(x = targetIdShort, y = ageGroupName,
+ # text = paste("Outcome ID:", outcomeIdShort, "
Outcome:", outcomeName,
+ # "
Target ID:", targetIdShort, "
Target:", targetName,
+ # "
TAR:", tar, "
Age:", ageGroupName, "
Sex:", genderName,
+ # "
TAR:",
+ # "
Incidence Rate:", incidenceRateP100py))) +
+ # ggplot2::geom_tile(aes(fill = incidenceRateP100py), color = "white") +
+ # ggplot2::scale_fill_gradient(colors = color_scale, name = "Incidence Rate") +
+ # ggplot2::labs(title = "Incidence Rate by Strata Variables",
+ # x = "Target Population Cohort",
+ # y = "Age Category") +
+ # ggplot2::theme_minimal() +
+ # ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1),
+ # plot.title = element_text(hjust = 0.5)) +
+ # ggplot2::facet_grid(outcome ~ data_source, scales = "free_x", space = "free_x")
+ #
+ # # Convert the ggplot plot to a Plotly plot
+ # p <- plotly::ggplotly(p)
+ #
+ #
+
+ }
+
+
+ else {
+
+ shiny::validate("Cannout use the same trellis for row and column, please make another selection.")
+
+ }
+
+ return(base_plot)
+ }
+ )
- # customColDefs <- createCustomColDefList(
- # rawColNames = names(incidenceColList),
- # niceColNames = c("Database",
- # "Ref ID",
- # "Database ID",
- # "Source ID",
- # "Target ID",
- # "Target Name",
- # "Subgroup ID",
- # "Outcome ID",
- # "Outcome Def ID",
- # "Outcome Name",
- # "Clean Window",
- # "Age ID",
- # "Age Group",
- # "Gender ID",
- # "Gender",
- # "Year",
- # "Persons At Risk PE",
- # "Persons At Risk",
- # "Person Days PE",
- # "Person Days",
- # "Person Outcomes PE",
- # "Person Outcomes",
- # "Total Outcomes PE",
- # "Total Outcomes",
- # "Inc. Proportion Per 100P",
- # "Inc. Rate Per 100PY",
- # "Time At Risk"),
- # tooltipText = c("The name of the database",
- # "The reference ID",
- # "The database ID",
- # "The source ID",
- # "The cohort definition ID of the target",
- # "The name of the target cohort",
- # "The name of the subgroup",
- # "The cohort definition ID of the outcome",
- # "The cohort definition ID of the outcome (duplicated)",
- # "The name of the outcome cohort",
- # "The clean window (in days)",
- # "The age ID",
- # "The age group category (in years)",
- # "The gender ID",
- # "The gender category",
- # "The start year of the analysis period",
- # "The distinct persons at risk before removing excluded time (pre-exclude) from TAR",
- # "The distinct persons at risk after removing excluded time from TAR",
- # "Total TAR (in days) before excluded time was removed (pre-exclude)",
- # "Total TAR (in days) after excluded time was removed",
- # "The distinct persons with the outcome before removing excluded time (pre-exclude) from TAR",
- # "The distinct persons with the outcome after removing excluded time from TAR",
- # "Total outcomes before removing excluded time (pre-exclude) from TAR",
- # "Total outcomes after removing excluded time from TAR",
- # "The incidence proportion (per 100 people), calculated by personOutcomes/personsAtRisk*100",
- # "The incidence rate (per 100 person years), calculated by outcomes/personDays/365.25*100",
- # "The TAR window (in days)"
- # ),
- # customColDefOptions = list(
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(show = F),
- # list(show = F),
- # list(show = F),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(show = F),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(show = F),
- # list(defaultSortOrder = "desc",
- # filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }
- # ),
- # list(show = F),
- # list(defaultSortOrder = "asc",
- # filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(defaultSortOrder = "desc",
- # filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # }),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(NULL),
- # list(defaultSortOrder = "desc",
- # filterMethod = htmlwidgets::JS('filterMinValue'),
- # filterInput = htmlwidgets::JS('rangeFilter')),
- # list(filterInput = function(values, name) {
- # tags$select(
- # # Set to undefined to clear the filter
- # onchange = sprintf("Reactable.setFilter('incidence-select', '%s', event.target.value || undefined)", name),
- # # "All" has an empty value to clear the filter, and is the default option
- # tags$option(value = "", "All"),
- # lapply(unique(values), tags$option),
- # "aria-label" = sprintf("Filter %s", name),
- # style = "width: 100%; height: 28px;"
- # )
- # })
- # )
- # )
- #
- # # use the below as a guide to save named colDef list as JSON then read it back!
- # ParallelLogger::saveSettingsToJson(customColDefs, "./inst/components-columnInformation/characterization-incidence-colDefs.json")
- # loadTest <- ParallelLogger::loadSettingsFromJson("./inst/components-columnInformation/characterization-incidence-colDefs.json")
+ #render the event reactive incidence plot without legend
+ renderIrPlotNoLegend <- shiny::reactive(
+ {
+ if (is.null(inputSelected()$targetIds) |
+ is.null(inputSelected()$outcomeIds)) {
+ return(data.frame())
+ }
+
+ plotData <- filteredData() %>%
+ dplyr::filter(tar %in% inputSelected()$incidenceRateTarFilter)
+
+ # Get the number of facets in both rows and columns
+ num_rows <- length(unique(plotData[[inputSelected()$plotXTrellis]]))
+ num_cols <- length(unique(plotData[[inputSelected()$plotYTrellis]]))
+
+ max_length <- max(nchar(unique(inputSelected()$plotXAxis)))
+
+ base_plot <- renderIrPlot()
+
+ p <- base_plot +
+ ggplot2::guides(shape = FALSE, color = FALSE, size = FALSE)
+
+ # Convert the ggplot to a plotly object
+ p <- plotly::ggplotly(p, tooltip = "text")
+
+ # Center the main plot title
+ p <- p %>% plotly::layout(title = list(x = 0.5, xanchor = "center"),
+ margin = list(t = 100),
+ xaxis = list(tickangle = 45,
+ title =list(standoff = 40)
+ ),
+ yaxis = list(title =list(standoff = 40)
+ )
+ )
+
+ return(p)
+
+ }
+ )
+ #render the event reactive incidence plot legend only
+ renderIrPlotLegend <- shiny::reactive(
+ {
+ base_plot <- renderIrPlot()
+
+ p <- as_ggplot(cowplot::get_legend(base_plot))
+
+ return(p)
+ }
+ )
- incidenceColList <- ParallelLogger::loadSettingsFromJson(system.file("components-columnInformation",
- "characterization-incidence-colDefs.json",
- package = "OhdsiShinyModules")
- )
+ output$incidencePlot <-
+ plotly::renderPlotly({
+ renderIrPlotNoLegend()
+ })
- resultTableServer(id = "incidenceRateTable",
- df = allData,
- selectedCols = c("cdmSourceAbbreviation", "targetName", "outcomeName",
- "ageGroupName", "genderName", "startYear", "tar", "outcomes",
- "incidenceProportionP100p", "incidenceRateP100py"),
- sortedCols = c("ageGroupName", "genderName", "startYear", "incidenceRateP100py"),
- elementId = "incidence-select",
- colDefsInput = incidenceColList,
- downloadedFileName = "incidenceRateTable-")
+ output$incidencePlotLegend <-
+ shiny::renderPlot({
+ renderIrPlotLegend()
+ })
+
return(invisible(NULL))
})
}
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-#allDataDownload(allData)
-
-# do the plots reactively
-# output$incTable <- reactable::renderReactable(
-# {
-# reactable::reactable(
-# data = allData %>%
-# dplyr::relocate("tar", .after = "cdmSourceAbbreviation") %>%
-# dplyr::relocate("personsAtRisk", .after = "tar") %>%
-# dplyr::relocate("personDays", .after = "personsAtRisk") %>%
-# dplyr::relocate("personOutcomes", .after = "personDays") %>%
-# dplyr::relocate("incidenceProportionP100p", .after = "personOutcomes") %>%
-# dplyr::relocate("incidenceRateP100py", .after = "incidenceProportionP100p")
-# ,
-# filterable = TRUE,
-# showPageSizeOptions = TRUE,
-# pageSizeOptions = c(10, 50, 100,1000),
-# defaultPageSize = 50,
-# striped = TRUE,
-# highlight = TRUE,
-# elementId = "desc-incidence-select",
-#
-# columns = list(
-# cdmSourceAbbreviation = reactable::colDef(
-# name = 'Database',
-# sticky = "left",
-# filterInput = function(values, name) {
-# shiny::tags$select(
-# # Set to undefined to clear the filter
-# onchange = sprintf("Reactable.setFilter('desc-incidence-select', '%s', event.target.value || undefined)", name),
-# # "All" has an empty value to clear the filter, and is the default option
-# shiny::tags$option(value = "", "All"),
-# lapply(unique(values), shiny::tags$option),
-# "aria-label" = sprintf("Filter %s", name),
-# style = "width: 100%; height: 28px;"
-# )
-# }
-# ),
-# tar = reactable::colDef(
-# filterInput = function(values, name) {
-# shiny::tags$select(
-# # Set to undefined to clear the filter
-# onchange = sprintf("Reactable.setFilter('desc-incidence-select', '%s', event.target.value || undefined)", name),
-# # "All" has an empty value to clear the filter, and is the default option
-# shiny::tags$option(value = "", "All"),
-# lapply(unique(values), shiny::tags$option),
-# "aria-label" = sprintf("Filter %s", name),
-# style = "width: 100%; height: 28px;"
-# )
-# }
-# ),
-# refId = reactable::colDef(show = F),
-# databaseId = reactable::colDef(show = F),
-# sourceName = reactable::colDef(show = F),
-# targetCohortDefinitionId = reactable::colDef(show = F),
-# targetName = reactable::colDef(show = F),
-# outcomeId = reactable::colDef(show = F),
-# outcomeCohortDefinitionId = reactable::colDef(show = F),
-# outcomeName = reactable::colDef(show = F),
-# outcomeId = reactable::colDef(show = F),
-# ageId = reactable::colDef(show = F),
-# genderId = reactable::colDef(show = F),
-# subgroupId = reactable::colDef(show = F),
-# incidenceProportionP100p = reactable::colDef(
-# format = reactable::colFormat(digits = 4)
-# ),
-# incidenceRateP100py = reactable::colDef(
-# format = reactable::colFormat(digits = 4)
-# )
-# )
-#
-#
-#
-#
-# )
-# }
-# )
-#
-# }
-# )
-#
-# # download
-# output$downloadInc <- shiny::downloadHandler(
-# filename = function() {
-# paste('incidence-data-', Sys.Date(), '.csv', sep='')
-# },
-# content = function(con) {
-# utils::write.csv(allDataDownload(), con)
-# }
-# )
-#
-#
-# return(invisible(NULL))
-#
-# }
-# )
-# }
-
+
+
getIncidenceData <- function(
targetIds,
outcomeIds,
@@ -591,85 +1018,199 @@ getIncidenceData <- function(
resultDatabaseSettings
){
- #shiny::withProgress(message = 'Getting incidence data', value = 0, {
-
- sql <- 'select d.cdm_source_abbreviation, i.*
+ if(!is.null(targetIds) & !is.null(outcomeIds)){
+
+ #shiny::withProgress(message = 'Getting incidence data', value = 0, {
+
+ sql <- 'select d.cdm_source_abbreviation, i.*
from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY i
inner join @result_schema.@database_table_name d
on d.database_id = i.database_id
where target_cohort_definition_id in (@target_ids)
and outcome_cohort_definition_id in (@outcome_ids)
;'
+
+ #shiny::incProgress(1/2, detail = paste("Created SQL - Extracting..."))
+
+ resultTable <- connectionHandler$queryDb(
+ sql = sql,
+ result_schema = resultDatabaseSettings$schema,
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix,
+ target_ids = paste(as.double(targetIds), collapse = ','),
+ outcome_ids = paste(as.double(outcomeIds), collapse = ','),
+ database_table_name = resultDatabaseSettings$databaseTable
+ )
+
+ #shiny::incProgress(2/2, detail = paste("Done..."))
+
+ #})
+
+ # format the tar
+ resultTable$tar <- paste0('(',resultTable$tarStartWith, " + ", resultTable$tarStartOffset, ') - (', resultTable$tarEndWith, " + ", resultTable$tarEndOffset, ')')
+ resultTable <- resultTable %>%
+ dplyr::select(-c("tarStartWith","tarStartOffset","tarEndWith","tarEndOffset", "tarId", "subgroupName"))
+
+ resultTable[is.na(resultTable)] <- 'All'
+ resultTable <- unique(resultTable)
+
+ return(resultTable)
+ } else{
+ return(NULL)
+ }
+}
+
+
+getIncidenceOptions <- function(
+ connectionHandler,
+ resultDatabaseSettings
+){
+
+ # shiny::withProgress(message = 'Getting incidence inputs', value = 0, {
+
+ sql <- 'select distinct target_cohort_definition_id, target_name
+ from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;'
- #shiny::incProgress(1/2, detail = paste("Created SQL - Extracting..."))
+ #shiny::incProgress(1/3, detail = paste("Created SQL - Extracting targets"))
- resultTable <- connectionHandler$queryDb(
+ targets <- connectionHandler$queryDb(
sql = sql,
result_schema = resultDatabaseSettings$schema,
- incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix,
- target_ids = paste(as.double(targetIds), collapse = ','),
- outcome_ids = paste(as.double(outcomeIds), collapse = ','),
- database_table_name = resultDatabaseSettings$databaseTable
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
)
+ targetIds <- targets$targetCohortDefinitionId
+ names(targetIds) <- targets$targetName
- #shiny::incProgress(2/2, detail = paste("Done..."))
+ sql <- 'select distinct outcome_cohort_definition_id, outcome_name
+ from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;'
- #})
+ #shiny::incProgress(2/3, detail = paste("Created SQL - Extracting outcomes"))
- # format the tar
- resultTable$tar <- paste0('(',resultTable$tarStartWith, " + ", resultTable$tarStartOffset, ') - (', resultTable$tarEndWith, " + ", resultTable$tarEndOffset, ')')
- resultTable <- resultTable %>%
- dplyr::select(-c("tarStartWith","tarStartOffset","tarEndWith","tarEndOffset", "tarId", "subgroupName"))
+ outcomes <- connectionHandler$queryDb(
+ sql = sql,
+ result_schema = resultDatabaseSettings$schema,
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
+ )
- resultTable[is.na(resultTable)] <- 'All'
- resultTable <- unique(resultTable)
+ outcomeIds <- outcomes$outcomeCohortDefinitionId
+ names(outcomeIds) <- outcomes$outcomeName
- return(resultTable)
-}
-
-
-getTargetOutcomes <- function(
- connectionHandler,
- resultDatabaseSettings
-){
+ sql <- 'select distinct tar_id, tar_start_with, tar_start_offset, tar_end_with, tar_end_offset
+ from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;'
- shiny::withProgress(message = 'Getting incidence inputs', value = 0, {
-
- sql <- 'select distinct target_cohort_definition_id, target_name
+ #shiny::incProgress(1/3, detail = paste("Created SQL - Extracting targets"))
+
+ tars <- connectionHandler$queryDb(
+ sql = sql,
+ result_schema = resultDatabaseSettings$schema,
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
+ )
+ tar <- tars$tarId
+ names(tar) <- paste0('(',tars$tarStartWith, " + ", tars$tarStartOffset, ') - (', tars$tarEndWith, " + ", tars$tarEndOffset, ')')
+
+ sql <- 'select distinct age_group_name
from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;'
-
- shiny::incProgress(1/3, detail = paste("Created SQL - Extracting targets"))
-
- targets <- connectionHandler$queryDb(
- sql = sql,
- result_schema = resultDatabaseSettings$schema,
- incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
- )
- targetIds <- targets$targetCohortDefinitionId
- names(targetIds) <- targets$targetName
-
- sql <- 'select distinct outcome_cohort_definition_id, outcome_name
+
+ result <- connectionHandler$queryDb(
+ sql = sql,
+ result_schema = resultDatabaseSettings$schema,
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
+ )
+
+ ageGroupName <- result$ageGroupName
+ ageGroupName[is.na(ageGroupName)] <- 'All'
+ ageGroupName <- sort(ageGroupName)
+
+ sql <- 'select distinct gender_name
+ from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;'
+
+ result <- connectionHandler$queryDb(
+ sql = sql,
+ result_schema = resultDatabaseSettings$schema,
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
+ )
+
+ genderName <- result$genderName
+ genderName[is.na(genderName)] <- 'All'
+ genderName <- sort(genderName)
+
+ sql <- 'select distinct start_year
from @result_schema.@incidence_table_prefixINCIDENCE_SUMMARY;'
-
- shiny::incProgress(2/3, detail = paste("Created SQL - Extracting outcomes"))
-
- outcomes <- connectionHandler$queryDb(
- sql = sql,
- result_schema = resultDatabaseSettings$schema,
- incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
- )
-
- outcomeIds <- outcomes$outcomeCohortDefinitionId
- names(outcomeIds) <- outcomes$outcomeName
-
- shiny::incProgress(3/3, detail = paste("Done"))
- })
+
+ result <- connectionHandler$queryDb(
+ sql = sql,
+ result_schema = resultDatabaseSettings$schema,
+ incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix
+ )
+
+ startYear <- result$startYear
+ startYear[is.na(startYear)] <- 'All'
+ startYear <- sort(startYear)
+
+ # shiny::incProgress(3/3, detail = paste("Done"))
+ # })
+
+ irPlotCategoricalChoices <- list(
+ "cdmSourceAbbreviation",
+ "ageGroupName",
+ "genderName",
+ "startYear",
+ "targetName",
+ "outcomeName",
+ "tar",
+ "cleanWindow",
+ "None"
+ )
+ names(irPlotCategoricalChoices) <- c(
+ "Data Source",
+ "Age Group",
+ "Sex",
+ "Calendar Year",
+ "Target Cohort",
+ "Outcome Cohort",
+ "TAR",
+ "Clean Window",
+ "None"
+ )
+
+ irPlotNumericChoices <- list(
+ "incidenceRateP100py",
+ "incidenceProportionP100p",
+ "outcomes",
+ "outcomesPe",
+ "personOutcomes",
+ "personOutcomesPe",
+ "personsAtRisk",
+ "personsAtRiskPe",
+ "personDays",
+ "personDaysPe",
+ "None"
+ )
+ names(irPlotNumericChoices) <- c(
+ "Incidence Rate (per 100PY)",
+ "Incidence Proportion (per 100P)",
+ "Outcomes",
+ "Outcomes PE",
+ "Person Outcomes",
+ "Person Outcomes PE",
+ "Persons At Risk",
+ "Persons At Risk PE",
+ "Person Days",
+ "Person Days PE",
+ "None"
+ )
return(
list(
targetIds = targetIds,
- outcomeIds = outcomeIds
+ outcomeIds = outcomeIds,
+ tar = tar,
+ irPlotNumericChoices = irPlotNumericChoices,
+ irPlotCategoricalChoices = irPlotCategoricalChoices,
+ ageGroupName = ageGroupName,
+ genderName = genderName,
+ startYear = startYear
)
)
}
+
diff --git a/R/components-inputselection.R b/R/components-inputselection.R
index 85265418..40a438a9 100644
--- a/R/components-inputselection.R
+++ b/R/components-inputselection.R
@@ -34,22 +34,27 @@ createInputSetting <- function(
rowNumber,
columnWidth = 4,
varName = '',
+ inputReturn = T,
uiFunction = 'shinyWidgets::pickerInput',
uiInputs = list(
label = 'Input: ',
choices = list(),
multiple = F,
options = shinyWidgets::pickerOptions()
- )
-
+ ),
+ updateFunction = NULL,
+ collapse = F
){
result <- list(
rowNumber = rowNumber,
columnWidth = columnWidth,
varName = varName,
+ inputReturn = inputReturn,
uiFunction = uiFunction,
- uiInputs = uiInputs
+ uiInputs = uiInputs,
+ updateFunction = updateFunction,
+ collapse = collapse
)
class(result) <- 'inputSetting'
@@ -78,7 +83,11 @@ inputSelectionServer <- function(
lapply(which(rowNumbers == i), function(x){
inputs <- inputSettingList[[x]]$uiInputs
- inputs$inputId <- session$ns(paste0('input_',x))
+ if(inputSettingList[[x]]$inputReturn){
+ # if using a function that has no return (e.g., div) set
+ # inputReturn = F
+ inputs$inputId <- session$ns(paste0('input_',x))
+ }
shiny::column(
width = inputSettingList[[x]]$columnWidth,
@@ -93,6 +102,12 @@ inputSelectionServer <- function(
label = 'Generate Report'
)
+ # add reset here
+ rows[[length(rows)+1]] <- shiny::actionButton(
+ inputId = session$ns('reset'),
+ label = 'Reset'
+ )
+
output$inputs <- shiny::renderUI({
shiny::fluidPage(rows)
})
@@ -130,9 +145,25 @@ inputSelectionServer <- function(
if(is.null(names(inputSettingList[[x]]$uiInputs$choices))){
names(inputSettingList[[x]]$uiInputs$choices) <- inputSettingList[[x]]$uiInputs$choices
}
- paste(names(inputSettingList[[x]]$uiInputs$choices)[inputSettingList[[x]]$uiInputs$choices %in% input[[paste0('input_',x)]]], collapse = ',')
+
+ # add selections on new row unless collapse is F
+ if(!inputSettingList[[x]]$collapse){
+ shiny::HTML(
+ paste("", names(inputSettingList[[x]]$uiInputs$choices)[inputSettingList[[x]]$uiInputs$choices %in% input[[paste0('input_',x)]]], '
')
+ )
+ } else{
+ paste(names(inputSettingList[[x]]$uiInputs$choices)[inputSettingList[[x]]$uiInputs$choices %in% input[[paste0('input_',x)]]], collapse = ', ')
+ }
} else{
- paste(input[[paste0('input_',x)]], collapse = ',')
+
+ # add selections on new row unless collapse is F
+ if(!inputSettingList[[x]]$collapse){
+ shiny::HTML(
+ paste("", input[[paste0('input_',x)]], '
')
+ )
+ } else{
+ paste(input[[paste0('input_',x)]], collapse = ', ')
+ }
}
)
}
@@ -142,6 +173,28 @@ inputSelectionServer <- function(
selectedInputText(shiny::div(otext))
})
+
+ # do the reset stuff
+ shiny::observeEvent(
+ eventExpr = input$reset,
+ {
+ # code to reset to default
+
+ for(i in 1:length(inputSettingList)){
+ if(!is.null(inputSettingList[[i]]$updateFunction)){
+
+ # need to test for non-picker inputs
+ do.call(eval(parse(text = inputSettingList[[i]]$updateFunction)),
+ list(
+ session = session,
+ inputId = paste0('input_',i),
+ selected = inputSettingList[[i]]$uiInputs$selected
+ ))
+
+ }
+ }
+ })
+
return(selectedInput)
}
diff --git a/R/patient-level-prediction-designSummary.R b/R/patient-level-prediction-designSummary.R
index 772c9fe8..bde3ddc8 100644
--- a/R/patient-level-prediction-designSummary.R
+++ b/R/patient-level-prediction-designSummary.R
@@ -82,6 +82,7 @@ patientLevelPredictionDesignSummaryServer <- function(
columnWidth = 6,
varName = 'targetIds',
uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
uiInputs = list(
label = 'Target: ',
choices = targetIds,
@@ -102,6 +103,7 @@ patientLevelPredictionDesignSummaryServer <- function(
columnWidth = 6,
varName = 'outcomeIds',
uiFunction = 'shinyWidgets::pickerInput',
+ updateFunction = 'shinyWidgets::updatePickerInput',
uiInputs = list(
label = 'Outcome: ',
choices = outcomeIds,