inst/shiny/server.R

In PhenotypeR: Assess Study Cohorts Using a Common Data Model

# Generated by OmopViewer 0.1.0
# Be careful editing this file

server <- function(input, output, session) {
  # download raw data -----
  output$download_raw <- shiny::downloadHandler(
    filename = "results.csv",
    content = function(file) {
      rawData <- omopgenerics::importSummarisedResult(file.path(getwd(),"data", "raw"))
      omopgenerics::exportSummarisedResult(rawData, fileName = file)
    }
  )
  # fill selectise variables ----
  shiny::observe({
    for (k in seq_along(choices)) {
      shiny::updateSelectizeInput(
        session,
        inputId = names(choices)[k],
        choices = choices[[k]],
        selected = selected[[k]],
        server = TRUE
      )

      shinyWidgets::updatePickerInput(session,
                                      inputId = names(choices)[k],
                                      choices = choices[[k]],
                                      selected = selected[[k]])
    }
  })

  # summarise_omop_snapshot -----
  ## Table summarise_omop_snapshot ----
  createTableOmopSnapshot <- shiny::reactive({
    if (is.null(dataFiltered$summarise_omop_snapshot)) {
      validate("No snapshot in results")
    }

    OmopSketch::tableOmopSnapshot(
      dataFiltered$summarise_omop_snapshot
    ) %>%
      tab_header(
        title = "Database metadata",
        subtitle = "Overview of data source"
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_omop_snapshot_gt <- gt::render_gt({
    createTableOmopSnapshot()
  })
  output$summarise_omop_snapshot_gt_download <- shiny::downloadHandler(
    filename = "summarise_omop_snapshot_gt.docx",
    content = function(file) {
      gt::gtsave(data = createTableOmopSnapshot(), filename = file)
    }
  )


  # summarise_observation_period -----
  ## Table summarise_observation_period -----
  createTableObservationPeriod <- shiny::reactive({
    if (is.null(dataFiltered$summarise_observation_period)) {
      validate("No observation period summary in results")
    }
    OmopSketch::tableObservationPeriod(
      dataFiltered$summarise_observation_period
    )%>%
      tab_header(
        title = "Summary of observation periods",
        subtitle = "Observation periods are used to define time under observation for individuals in the data source."
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_observation_period_gt <- gt::render_gt({
    createTableObservationPeriod()
  })
  output$summarise_observation_period_gt_download <- shiny::downloadHandler(
    filename = "summarise_observation_period_gt.docx",
    content = function(file) {
      obj <- createTableObservationPeriod()
      gt::gtsave(data = obj, filename = file)
    }
  )


  # achilles_code_use -----
  filterAchillesCodeUse <- shiny::reactive({
    if (is.null(dataFiltered$achilles_code_use)) {
      validate("No achilles code use in results")
    }
    achillesFiltered <- dataFiltered$achilles_code_use  |>
      filterData("achilles_code_use", input)

    if (is.null(dataFiltered$achilles_code_use)) {
      validate("No achilles code use in results")
    }
    achillesFiltered <- dataFiltered$achilles_code_use  |>
      filterData("achilles_code_use", input)

    if(isFALSE(input$achilles_person_count)){
      achillesFiltered <- achillesFiltered  |>
        filter(estimate_name != "person_count")
    }
    if(isFALSE(input$achilles_record_count)){
      achillesFiltered <- achillesFiltered  |>
        filter(estimate_name != "record_count")
    }

    if (nrow(achillesFiltered) == 0) {
      validate("No results found for selected inputs")
    }

    return(achillesFiltered)
  })

  ## Table achilles_code_use ----
  createAchillesCodeUseGT <- shiny::reactive({
    tbl <- CodelistGenerator::tableAchillesCodeUse(filterAchillesCodeUse(),
                                                   header = input$achilles_code_use_header,
                                                   groupColumn = input$achilles_code_use_groupColumn,
                                                   hide = input$achilles_code_use_hide) |>
      tab_header(
        title = "Summary of achilles codes",
        subtitle = "Codes from codelist observed in achilles tables."
      ) |>
      tab_options(
        heading.align = "left"
      )

    return(tbl)
  })
  createAchillesCodeUseInteractive <- shiny::reactive({
    tbl <- CodelistGenerator::tableAchillesCodeUse(filterAchillesCodeUse(),
                                                   header = input$achilles_code_use_header,
                                                   groupColumn = input$achilles_code_use_groupColumn,
                                                   hide = input$achilles_code_use_hide,
                                                   type = "tibble")
    names(tbl) <- stringr::str_remove_all(names(tbl),
                                          "\\[header_name\\]Database name\\n\\[header_level\\]")
    names(tbl) <- stringr::str_remove_all(names(tbl),
                                          "Estimate name\n\\[header_level\\]")
    names(tbl) <- stringr::str_replace_all(names(tbl),
                                           "\n\\[header_name\\]",
                                           ": ")
    return(tbl)
  })

  output$achilles_code_use_tbl <- shiny::renderUI({


    if(isFALSE(input$achilles_interactive)){
      tbl <- createAchillesCodeUseGT()
      return(tbl)

    } else {

      tbl <- createAchillesCodeUseInteractive()

      # column ordering by codelist and first column with a count
      order <- list("Codelist name"  = "asc",
                    "count" = "desc")
      names(order)[2] <- names(tbl)[7]

      # suppressed to NA
      tbl <- tbl |>
        purrr::map_df(~ ifelse(grepl("^<", .), NA, .)) |>
        dplyr::mutate(dplyr::across(c(ends_with("count")),
                                    ~ gsub(",", "", .))) |>
        dplyr::mutate(dplyr::across(c(ends_with("count")),
                                    ~ suppressWarnings(as.numeric(.))))

      tbl <- reactable::reactable(tbl,
                                  defaultSorted = order,
                                  columns = getColsForTbl(tbl),
                                  filterable = TRUE,
                                  searchable = TRUE,
                                  defaultPageSize = 25,
                                  highlight = TRUE,
                                  striped = TRUE,
                                  compact = TRUE,
                                  showSortable = TRUE) |>
        reactablefmtr::add_title("Summary of achilles codes",
                                 font_size = 25,
                                 font_weight = "normal") |>
        reactablefmtr::add_subtitle("Codes from codelist observed in achilles tables.",
                                    font_size = 15,
                                    font_weight = "normal")

      return(tbl)
    }
  })

  output$achilles_code_use_download <- shiny::downloadHandler(
    filename = function(){
      if(isFALSE(input$achilles_interactive)){
        "summarise_achilles_code_use_gt.docx"
      }else{
        "summarise_achilles_code_use_tbl.csv"
      }
    },
    content = function(file){
      if(isFALSE(input$achilles_interactive)){
        gt::gtsave(data = createAchillesCodeUseGT(), filename = file)
      }else{
        readr::write_csv(createAchillesCodeUseInteractive(), file = file)
      }
    }
  )


  # orphan_codes -----
  filterOrphanCodes <-  shiny::reactive({

    if (is.null(dataFiltered$orphan_code_use)) {
      validate("No orphan codes in results")
    }

    result <- dataFiltered$orphan_code_use |>
      dplyr::filter(cdm_name %in% input$orphan_grouping_cdm_name,
                    group_level %in% input$orphan_grouping_codelist_name)

    if(isFALSE(input$orphan_person_count)){
      result <- result  |>
        filter(estimate_name != "person_count")
    }
    if(isFALSE(input$orphan_record_count)){
      result <- result  |>
        filter(estimate_name != "record_count")
    }

    if (nrow(result) == 0) {
      validate("No orphan codes in results")
    }

    return(result)
  })

  ## Table orphan_codes -----
  createOrphanCodesGT <- shiny::reactive({
    tbl <- CodelistGenerator::tableOrphanCodes(
      filterOrphanCodes(),
      header = input$orphan_codes_gt_header,
      groupColumn = input$orphan_codes_gt_groupColumn,
      hide = input$orphan_codes_gt_hide
    )
    tbl %>%
      tab_header(
        title = "Summary of orphan codes",
        subtitle = "Orphan codes refer to concepts present in the database that are not in a codelist but are related to included codes."
      ) %>%
      tab_options(
        heading.align = "left"
      )

    return(tbl)
  })
  createOrphanCodesInteractive <- shiny::reactive({
    tbl <- CodelistGenerator::tableOrphanCodes(
      filterOrphanCodes(),
      header = input$orphan_codes_gt_header,
      groupColumn = input$orphan_codes_gt_groupColumn,
      hide = input$orphan_codes_gt_hide,
      type = "tibble"
    )
    names(tbl) <-stringr::str_remove_all(names(tbl),
                                         "\\[header_name\\]Database name\\n\\[header_level\\]")
    names(tbl) <- stringr::str_remove_all(names(tbl),
                                          "Estimate name\n\\[header_level\\]")
    names(tbl) <- stringr::str_replace_all(names(tbl),
                                           "\n\\[header_name\\]",
                                           ": ")

    return(tbl)
  })
  output$orphan_codes_tbl <- shiny::renderUI({

    if(isFALSE(input$orphan_interactive)){
      tbl <- createOrphanCodesGT()
      return(tbl)
    } else {
      tbl <- createOrphanCodesInteractive()
      # column ordering by codelist and first column with a count
      order <- list("Codelist name"  = "asc",
                    "count" = "desc")
      names(order)[2] <- names(tbl)[7]

      # suppressed to NA
      tbl <- tbl |>
        purrr::map_df(~ ifelse(grepl("^<", .), NA, .)) |>
        dplyr::mutate(dplyr::across(c(ends_with("count")),
                                    ~ gsub(",", "", .))) |>
        dplyr::mutate(dplyr::across(c(ends_with("count")),
                                    ~ suppressWarnings(as.numeric(.))))

      tbl <- reactable(tbl,
                       columns = getColsForTbl(tbl),
                       defaultSorted = order,
                       filterable = TRUE,
                       searchable = TRUE,
                       defaultPageSize = 25,
                       highlight = TRUE,
                       striped = TRUE,
                       compact = TRUE,
                       showSortable = TRUE) |>
        reactablefmtr::add_title("Summary of orphan codes",
                                 font_size = 25,
                                 font_weight = "normal") |>
        reactablefmtr::add_subtitle("Orphan codes refer to concepts present in the database that are not in a codelist but are related to included codes.",
                                    font_size = 15,
                                    font_weight = "normal")

      return(tbl)
    }
  })

  output$orphan_codes_download <- shiny::downloadHandler(
    filename = function(){
      if(isFALSE(input$orphan_interactive)){
        "summarise_orphan_codes_gt.docx"
      }else{
        "summarise_orphan_codes_tbl.csv"
      }
    },
    content = function(file){
      if(isFALSE(input$orphan_interactive)){
        gt::gtsave(data = createOrphanCodesGT(), filename = file)
      }else{
        readr::write_csv(createOrphanCodesInteractive(), file = file)
      }
    }
  )

  # unmapped codes -----
  # createOutputUnmapped <- shiny::reactive({
  #   if (is.null(dataFiltered$unmapped_codes)) {
  #     validate("No unmapped codes in results")
  #   }
  #
  #   CodelistGenerator::tableUnmappedCodes(
  #     dataFiltered$unmapped_codes |>
  #       dplyr::filter(cdm_name %in% input$unmapped_grouping_cdm_name,
  #                     group_level %in% input$unmapped_grouping_codelist_name),
  #     header = input$unmapped_header,
  #     groupColumn = input$unmapped_groupColumn,
  #     hide = input$unmapped_hide
  #   ) %>%
  #     tab_header(
  #       title = "Summary of unmapped codes",
  #       subtitle = "These codes are recorded as source concepts that are mapped to 0"
  #     ) %>%
  #     tab_options(
  #       heading.align = "left"
  #     )
  # })
  # output$unmapped_formatted <- gt::render_gt({
  #   createOutputUnmapped()
  # })
  # output$unmapped_formatted_download <- shiny::downloadHandler(
  #   filename = "output_gt_orphan.docx",
  #   content = function(file) {
  #     obj <- createOutputUnmapped()
  #     gt::gtsave(data = obj, filename = file)
  #   }
  # )

  # cohort_code_use -----
  filterCohortCodeUse <- shiny::reactive({
    if (is.null(dataFiltered$cohort_code_use)) {
      validate("No cohort code use in results")
    }
    result <- dataFiltered$cohort_code_use |>
      filterData("cohort_code_use", input)

    if(isFALSE(input$cohort_code_use_person_count)){
      result <- result  |>
        filter(estimate_name != "person_count")
    }
    if(isFALSE(input$cohort_code_use_record_count)){
      result <- result  |>
        filter(estimate_name != "record_count")
    }

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }

    return(result)
  })
  ## Table cohort_code_use -----
  createCohortCodeUseGT <- shiny::reactive({
    tbl <- CodelistGenerator::tableCohortCodeUse(
      filterCohortCodeUse(),
      header = input$cohort_code_use_gt_header,
      groupColumn = input$cohort_code_use_gt_groupColumn,
      hide = input$cohort_code_use_gt_hide
    ) %>%
      tab_header(
        title = "Summary of cohort code use",
        subtitle = "Codes from codelist observed on day of cohort entry. Note more than one code could be seen for a person on this day (both of which would have led to inclusion)."
      ) %>%
      tab_options(
        heading.align = "left"
      )

    return(tbl)
  })
  createCohortCodeUseInteractive <- shiny::reactive({
    tbl <-  CodelistGenerator::tableCohortCodeUse(
      filterCohortCodeUse(),
      header = input$cohort_code_use_gt_header,
      groupColumn = input$cohort_code_use_gt_groupColumn,
      hide = input$cohort_code_use_gt_hide,
      type = "tibble"
    )
    names(tbl) <-stringr::str_remove_all(names(tbl),
                                         "\\[header_name\\]Database name\\n\\[header_level\\]")
    names(tbl) <- stringr::str_remove_all(names(tbl),
                                          "Estimate name\n\\[header_level\\]")
    names(tbl) <- stringr::str_replace_all(names(tbl),
                                           "\n\\[header_name\\]",
                                           ": ")
    return(tbl)
  })
  output$cohort_code_use_tbl <- shiny::renderUI({

    if(isFALSE(input$cohort_code_use_interactive)){
      tbl <- createCohortCodeUseGT()
      return(tbl)
    } else {
      tbl <- createCohortCodeUseInteractive() |>
        dplyr::mutate(dplyr::across(c(ends_with("count")),
                                    ~ gsub(",", "", .))) |>
        dplyr::mutate(dplyr::across(c(ends_with("count")),
                                    ~ suppressWarnings(as.numeric(.))))

      # column ordering by codelist and first column with a count
      order <- list("Cohort name"  = "asc",
                    "count" = "desc")
      names(order)[2] <- names(tbl)[9]

      # suppressed to NA
      tbl <- tbl |>
        purrr::map_df(~ ifelse(grepl("^<", .), NA, .))

      tbl <- reactable(tbl,
                       columns = getColsForTbl(tbl,
                                               sortNALast = FALSE,
                                               names = c("Standard concept ID", "Source concept ID")),
                       defaultSorted = order,
                       filterable = TRUE,
                       searchable = TRUE,
                       defaultPageSize = 25,
                       highlight = TRUE,
                       striped = TRUE,
                       compact = TRUE,
                       showSortable = TRUE) |>
        reactablefmtr::add_title("Summary of cohort code use",
                                 font_size = 25,
                                 font_weight = "normal") |>
        reactablefmtr::add_subtitle("Codes from codelist observed on day of cohort entry. Note more than one code could be seen for a person on this day (both of which would have led to inclusion).",
                                    font_size = 15,
                                    font_weight = "normal")

      return(tbl)
    }
  })

  output$cohort_code_use_download <- shiny::downloadHandler(
    filename = function(){
      if(isFALSE(input$cohort_code_use_interactive)){
        file <- "summarise_cohort_code_use_gt.docx"
      }else{
        file <- "summarise_cohort_code_use_tbl.csv"
      }
      return(file)
    },
    content = function(file){
      if(isFALSE(input$cohort_code_use_interactive)){
        gt::gtsave(data = createCohortCodeUseGT(), filename = file)
      }else{
        readr::write_csv(createCohortCodeUseInteractive(), file = file)
      }
    }
  )
  
  # summarise_cohort_count -----
  ## Table summarise_cohort_count ----
  createTableCohortCount <- shiny::reactive({

    result <- dataFiltered$summarise_cohort_count |>
      filterData("summarise_cohort_count", input) 
    
    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }
    
    CohortCharacteristics::tableCohortCount(
      result
    )%>%
      tab_header(
        title = "Cohort count",
        subtitle = "Number of records and subjects in the study cohorts."
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_cohort_count_gt <- gt::render_gt({
    createTableCohortCount()
  })
  output$summarise_cohort_count_gt_download <- shiny::downloadHandler(
    filename = "summarise_cohort_count_gt.docx",
    content = function(file) {
      obj <- createTableCohortCount()
      gt::gtsave(data = obj, filename = file)
    }
  )
  
  # summarise_cohort_attrition -----
  ## Table summarise_cohort_attrition ----
  createTableCohortAttrition <- shiny::reactive({
    result <- dataFiltered$summarise_cohort_attrition |>
      filterData("summarise_cohort_attrition", input)

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }

    CohortCharacteristics::tableCohortAttrition(
      result
    )%>%
      tab_header(
        title = "Cohort attrition",
        subtitle = "Attrition of the study cohorts."
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_cohort_attrition_gt <- gt::render_gt({
    createTableCohortAttrition()
  })
  output$summarise_cohort_attrition_gt_download <- shiny::downloadHandler(
    filename = "summarise_cohort_attrition_gt.docx",
    content = function(file) {
      obj <- createTableCohortAttrition()
      gt::gtsave(data = obj, filename = file)
    }
  )
  ## Diagram summarise_cohort_attrition -----
  createDiagramCohortAttrition <- shiny::reactive({
    result <- dataFiltered$summarise_cohort_attrition |>
      filterData("summarise_cohort_attrition", input)

    n <- result |>
      select(cdm_name, group_level) |>
      distinct() |>
      nrow()

    if(n > 1){
      validate("Please select only one database")
    }

    CohortCharacteristics::plotCohortAttrition(
      result
    )

  })
  output$summarise_cohort_attrition_grViz <- DiagrammeR::renderGrViz({
    createDiagramCohortAttrition()
  })
  output$summarise_cohort_attrition_grViz_download <- shiny::downloadHandler(
    filename = "summarise_cohort_attrition_diagram.png",
    content = function(file) {
      createDiagramCohortAttrition() |>
        DiagrammeRsvg::export_svg() |>
        charToRaw() |>
        rsvg::rsvg_png(file,
                       width = input$summarise_cohort_attrition_grViz_download_width,
                       height = input$summarise_cohort_attrition_grViz_download_height)
    }
  )


  # summarise_characteristics -----
  ## Table summarise_characteristics -----
  createTableSummariseCharacteristics <- shiny::reactive({

    if (is.null(dataFiltered$summarise_characteristics)) {
      validate("No summarised characteristics in results")
    }

    if(isTRUE(input$summarise_characteristics_include_matched)){
      selectedCohorts <- c(
        input$summarise_characteristics_grouping_cohort_name,
        paste0("matched_to_", input$summarise_characteristics_grouping_cohort_name),
        paste0(input$summarise_characteristics_grouping_cohort_name, "_sampled"),
        paste0(input$summarise_characteristics_grouping_cohort_name, "_matched")
      )
    } else {
      selectedCohorts <- input$summarise_characteristics_grouping_cohort_name
    }

    result <- dataFiltered$summarise_characteristics |>
      dplyr::filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name,
                    group_level %in% selectedCohorts)

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }
    CohortCharacteristics::tableCharacteristics(
      result,
      header = input$summarise_characteristics_gt_header,
      groupColumn = input$summarise_characteristics_gt_groupColumn,
      hide = c(input$summarise_characteristics_gt_hide,
               "table_name", "value", "window", "table")
    ) %>%
      tab_header(
        title = "Patient characteristics",
        subtitle = "Summary of patient characteristics relative to cohort entry"
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_characteristics_gt <- gt::render_gt({
    createTableSummariseCharacteristics()
  })
  output$summarise_characteristics_gt_download <- shiny::downloadHandler(
    filename = "summarise_characteristics_gt.docx",
    content = function(file) {
      obj <- createTableSummariseCharacteristics()
      gt::gtsave(data = obj, filename = file)
    }
  )

  ## Plot age_pyramid ----
  createAgePyramid <- shiny::reactive({

    summarise_table <- dataFiltered$summarise_table |>
      filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name)
    summarise_characteristics <-  dataFiltered$summarise_characteristics |>
      filter(cdm_name %in% input$summarise_characteristics_grouping_cdm_name)

    if (nrow(summarise_table) == 0 || nrow(summarise_characteristics) == 0 ) {
      validate("No results found for selected inputs")
    }

    if(isTRUE(input$summarise_characteristics_include_matched)){
      summarise_table <- summarise_table |>
        filter(group_level %in%
                 c(
                   input$summarise_characteristics_grouping_cohort_name,
                   paste0("matched_to_", input$summarise_characteristics_grouping_cohort_name),
                   paste0(input$summarise_characteristics_grouping_cohort_name, "_sampled"),
                   paste0(input$summarise_characteristics_grouping_cohort_name, "_matched")
                 )
        )
      summarise_characteristics <- summarise_characteristics |>
        filter(group_level %in%
                 c(
                   input$summarise_characteristics_grouping_cohort_name,
                   paste0("matched_to_", input$summarise_characteristics_grouping_cohort_name),
                   paste0(input$summarise_characteristics_grouping_cohort_name, "_sampled"),
                   paste0(input$summarise_characteristics_grouping_cohort_name, "_matched")
                 ))
    } else {
      summarise_table <- summarise_table |>
        filter(group_level %in%
                 input$summarise_characteristics_grouping_cohort_name)
      summarise_characteristics <- summarise_characteristics |>
        filter(group_level %in% input$summarise_characteristics_grouping_cohort_name)
    }

    if (nrow(summarise_table) == 0 || nrow(summarise_characteristics) == 0 ) {
      validate("No results found for selected inputs")
    }

    plotAgeDensity(summarise_table, summarise_characteristics, input$summarise_characteristics_add_interquantile_range)

  })

  output$plot_age_pyramid <- shiny::renderPlot({
    createAgePyramid()
  })

  output$plot_age_pyramid_download <- shiny::downloadHandler(
    filename = "age_pyramid_plot.png",
    content = function(file) {
      obj <- createAgePyramid()
      ggplot2::ggsave(
        filename = file,
        plot = obj,
        width = as.numeric(input$plot_age_pyramid_download_width),
        height = as.numeric(input$plot_age_pyramid_download_height),
        units = input$plot_age_pyramid_download_units,
        dpi = as.numeric(input$plot_age_pyramid_download_dpi)
      )
    }
  )

  # summarise_large_scale_characteristics -----
  ## Tidy summarise_large_scale_characteristics -----
  getTidyDataSummariseLargeScaleCharacteristics <- shiny::reactive({

    if (is.null(dataFiltered$summarise_large_scale_characteristics)) {
      validate("No large scale characteristics in results")
    }

    lsc_data <- dataFiltered$summarise_large_scale_characteristics |>
      filter(!is.na(estimate_value)) |>
      filter(estimate_value != "-") |>
      visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain,
                                     analysis %in% input$summarise_large_scale_characteristics_settings_analysis) |>
      dplyr::filter(cdm_name %in% input$summarise_large_scale_characteristics_grouping_cdm_name ) |>
      dplyr::filter(group_level  %in% input$summarise_large_scale_characteristics_grouping_cohort_name) |>
      dplyr::filter(variable_level  %in% input$summarise_large_scale_characteristics_grouping_time_window)

    if (nrow(lsc_data) == 0) {
      validate("No results found for selected inputs")
    }

    tidy(lsc_data) |>
      mutate(concept = paste0(variable_name, " (",
                              concept_id, ")")) |>
      dplyr::select("cdm_name",
                    "cohort_name",
                    "concept",
                    "count",
                    "percentage")

  })

  output$summarise_large_scale_characteristics_tidy <- renderUI({

    tbl_data <- getTidyDataSummariseLargeScaleCharacteristics()
    tbl_data <- tbl_data |>
      rename("CDM name" = "cdm_name",
             "Cohort" = "cohort_name",
             "Concept name (concept ID)" = "concept")
    cols <- list("Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
                                                      cell = function(value){
                                                        value_concept <- gsub(".*\\(|\\)","",value)
                                                        url   <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
                                                        htmltools::tags$a(href = url, target = "_blank", as.character(value))
                                                      }),
                 count = colDef(format = colFormat(separators = TRUE)),
                 percentage = colDef(format = colFormat(percent = TRUE))
    )

    reactable(tbl_data |>
                mutate(percentage = percentage / 100), # to use colFormat
              defaultSorted = list("percentage"  = "desc"),
              columns = cols,
              filterable = TRUE,
              searchable = TRUE,
              defaultPageSize = 25,
              highlight = TRUE,
              striped = TRUE,
              compact = TRUE,
              showSortable = TRUE) |>
      reactablefmtr::add_title("Large scale characteristics",
                               font_size = 25,
                               font_weight = "normal") |>
      reactablefmtr::add_subtitle("Summary of all records from clinical tables within a time window. The sampled cohort represents individuals from the original cohort, the matched cohort comprises individuals of similar age and sex from the database.",
                                  font_size = 15,
                                  font_weight = "normal")

  })

  output$summarise_large_scale_characteristics_tidy_download <- shiny::downloadHandler(
    filename = "summarise_large_scale_characteristics_tidy.csv",
    content = function(file) {
      getTidyDataSummariseLargeScaleCharacteristics() |>
        readr::write_csv(file = file)
    }
  )
  ## Table summarise_large_scale_characteristics -----
  createTableLargeScaleCharacteristics <- shiny::reactive({

    if (is.null(dataFiltered$summarise_large_scale_characteristics)) {
      validate("No large scale characteristics in results")
    }

    lsc_data <- dataFiltered$summarise_large_scale_characteristics |>
      filter(!is.na(estimate_value)) |>
      filter(estimate_value != "-") |>
      visOmopResults::filterSettings(table_name %in% input$summarise_large_scale_characteristics_grouping_domain,
                                     analysis %in% input$summarise_large_scale_characteristics_settings_analysis) |>
      dplyr::filter(cdm_name %in% input$summarise_large_scale_characteristics_grouping_cdm_name ) |>
      dplyr::filter(group_level  %in% input$summarise_large_scale_characteristics_grouping_cohort_name) |>
      dplyr::filter(variable_level %in% input$summarise_large_scale_characteristics_grouping_time_window)

    levels <- lsc_data |>
      dplyr::select("group_level") |>
      dplyr::distinct() |>
      dplyr::pull("group_level")

    if(all(sort(gsub(".*_","",levels)) == sort(rep(c("matched","sampled"),floor(length(levels)/2))))){
      lsc_data <- lsc_data |>
        dplyr::filter(grepl("_sampled",group_level)) |>
        dplyr::arrange(group_level,
                       desc(estimate_type),
                       desc(as.numeric(estimate_value))) |>
        rbind(lsc_data |>
                dplyr::filter(grepl("_matched",group_level)) |>
                dplyr::arrange(group_level))
    }else{
      lsc_data <- lsc_data |>
        dplyr::arrange(desc(estimate_type),
                       desc(as.numeric(estimate_value)))
    }

    lsc_data |>
      CohortCharacteristics::tableLargeScaleCharacteristics(topConcepts = 10) %>%
      tab_header(
        title = "Large scale characteristics",
        subtitle = "Summary of all records from clinical tables within a time window.
                    The sampled cohort represents individuals from the original cohort, the matched cohort comprises individuals of similar age and sex from the database."
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_large_scale_characteristics_gt <- gt::render_gt({
    createTableLargeScaleCharacteristics()
  })
  output$summarise_large_scale_characteristics_gt_download <- shiny::downloadHandler(
    filename = "summarise_large_scale_characteristics_gt.docx",
    content = function(file) {
      obj <- createTableLargeScaleCharacteristics()
      gt::gtsave(data = obj, filename = file)
    }
  )



  # compare large_scale_characteristics ----
  filterLargeScaleCharacteristics <- shiny::reactive({

    if (is.null(dataFiltered$summarise_large_scale_characteristics)) {
      validate("No large scale characteristics in results")
    }
    dataFiltered$summarise_large_scale_characteristics |>
      filter(variable_level %in% input$compare_large_scale_characteristics_grouping_time_window,
             cdm_name %in% input$compare_large_scale_characteristics_grouping_cdm_name) |>
      filterSettings(table_name %in% input$compare_large_scale_characteristics_grouping_domain,
                     analysis %in% input$compare_large_scale_characteristics_settings_analysis)

  })
  ## Tidy large_scale_characteristics ----
  createTidyDataCompareLargeScaleCharacteristics <- shiny::reactive({

    lscFiltered <- filterLargeScaleCharacteristics()

    if (nrow(lscFiltered) == 0) {
      validate("No results found for selected inputs")
    }

    target_cohort     <- input$compare_large_scale_characteristics_grouping_cohort_1
    comparator_cohort <- input$compare_large_scale_characteristics_grouping_cohort_2

    lsc <- lscFiltered |>
      filter(group_level %in% c(target_cohort, comparator_cohort
      )) |>
      filter(estimate_name == "percentage") |>
      omopgenerics::addSettings() |>
      select(database = cdm_name,
             cohort_name = group_level,
             variable_name,
             time_window = variable_level,
             concept_id = additional_level,
             table = table_name,
             percentage = estimate_value) |>
      mutate(percentage = if_else(percentage == "-",
                                  NA, percentage)) |>
      mutate(percentage = as.numeric(percentage)) |>
      pivot_wider(names_from = cohort_name,
                  values_from = percentage)

    if(isTRUE(input$compare_large_scale_characteristics_impute_missings)){
      lsc <- lsc |>
        mutate(across(c(target_cohort, comparator_cohort), ~if_else(is.na(.x), 0, .x)))
    }

    lsc <- lsc |>
      mutate(across(c(target_cohort, comparator_cohort), ~ as.numeric(.x)/100)) |>
      mutate(smd = (!!sym(target_cohort) - !!sym(comparator_cohort))/sqrt((!!sym(target_cohort)*(1-!!sym(target_cohort)) + !!sym(comparator_cohort)*(1-!!sym(comparator_cohort)))/2)) |>
      mutate(smd = round(smd, 2)) |>
      arrange(desc(smd))  |>
      mutate(concept = paste0(variable_name, " (",concept_id, ")")) |>
      select("CDM name" = database,
             "Concept name (concept ID)" = concept,
             "Table" = table,
             "Time window" = time_window,
             target_cohort,
             comparator_cohort,
             "Standardised mean difference" = smd)

    return(lsc)
  })

  output$compare_large_scale_characteristics_tidy <- reactable::renderReactable({
    target_cohort     <- input$compare_large_scale_characteristics_grouping_cohort_1
    comparator_cohort <- input$compare_large_scale_characteristics_grouping_cohort_2

    tbl <- createTidyDataCompareLargeScaleCharacteristics()

    cols <- list(target_cohort = colDef(name = paste0(target_cohort, " percentage"),
                                        format = colFormat(percent = TRUE),
                                        sortNALast = TRUE),
                 comparator_cohort = colDef(name = paste0(comparator_cohort, " percentage"),
                                            format = colFormat(percent = TRUE),
                                            sortNALast = TRUE),
                 "Concept name (concept ID)" = colDef(name = "Concept name (concept ID)",
                                                      cell = function(value){
                                                        value_concept <- gsub(".*\\(|\\)","",value)
                                                        url   <- sprintf("https://athena.ohdsi.org/search-terms/terms/%s", value_concept)
                                                        htmltools::tags$a(href = url, target = "_blank", as.character(value))
                                                      }),
                 "Standardised mean difference" = colDef(name = "Standardised mean difference",
                                                         sortNALast = TRUE)
    )
    names(cols)[1] <- target_cohort
    names(cols)[2] <- comparator_cohort

    reactable::reactable(tbl,
                         defaultSorted = list("Standardised mean difference"  = "desc"),
                         columns = cols,
                         filterable = TRUE,
                         searchable = TRUE,
                         defaultPageSize = 25,
                         highlight = TRUE,
                         striped = TRUE,
                         compact = TRUE,
                         showSortable = TRUE)

  })

  output$compare_large_scale_characteristics_tidy_download <- shiny::downloadHandler(
    filename = "compare_large_scale_characteristics_tidy.csv",
    content = function(file) {
      createTidyDataCompareLargeScaleCharacteristics() |>
        readr::write_csv(file = file)
    }
  )

  ## Plot large_scale_characteristics ----
  getPlotlyCompareLsc <- shiny::reactive({
    if (nrow(filterLargeScaleCharacteristics()) == 0) {
      validate("No data to plot")
    }

    plotComparedLsc(lsc = filterLargeScaleCharacteristics(),
                    cohorts = c(input$compare_large_scale_characteristics_grouping_cohort_1,
                                input$compare_large_scale_characteristics_grouping_cohort_2),
                    colour = c(input$compare_large_scale_characteristics_colour_1),
                    facet  = c(input$compare_large_scale_characteristics_facet_1),
                    imputeMissings = input$compare_large_scale_characteristics_impute_missings
    )
  })

  output$plotly_compare_lsc <- renderPlotly({
    ggplotly(getPlotlyCompareLsc(), tooltip = "Details")
  })

  output$plot_compare_large_scale_characteristics_download <- shiny::downloadHandler(
    filename = "output_ggplot2_compare_large_scale_characteristics.png",
    content = function(file) {
      obj <- getPlotlyCompareLsc()
      ggplot2::ggsave(
        filename = file,
        plot = obj,
        width = as.numeric(input$plot_compare_large_scale_characteristics_download_width),
        height = as.numeric(input$plot_compare_large_scale_characteristics_download_height),
        units = input$plot_compare_large_scale_characteristics_download_units,
        dpi = as.numeric(input$plot_compare_large_scale_characteristics_download_dpi)
      )
    }
  )






  # summarise_cohort_overlap -----
  ## Table cohort_overlap -----
  createTableCohortOverlap <- shiny::reactive({

    if (is.null(dataFiltered$summarise_cohort_overlap)) {
      validate("No cohort overlap in results")
    }

    result <- dataFiltered$summarise_cohort_overlap |>
      filterData("summarise_cohort_overlap", input)

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }

    CohortCharacteristics::tableCohortOverlap(
      result,
      uniqueCombinations = input$summarise_cohort_overlap_gt_uniqueCombinations,
      header = input$summarise_cohort_overlap_gt_header,
      groupColumn = input$summarise_cohort_overlap_gt_groupColumn,
      hide = input$summarise_cohort_overlap_gt_hide
    )%>%
      tab_header(
        title = "Cohort overlap",
        subtitle = "Overlap is where the same individual is in both cohorts. Note their cohort entries do not necessarily overlap."
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_cohort_overlap_gt <- gt::render_gt({
    createTableCohortOverlap()
  })
  output$summarise_cohort_overlap_gt_download <- shiny::downloadHandler(
    filename = "summarise_cohort_overlap_gt.docx",
    content = function(file) {
      obj <- createTableCohortOverlap()
      gt::gtsave(data = obj, filename = file)
    }
  )

  ## Plot cohort_overlap -----
  createPlotCohortOverlap <- shiny::reactive({
    if (is.null(dataFiltered$summarise_cohort_overlap)) {
      validate("No cohort overlap in results")
    }

    result <- dataFiltered$summarise_cohort_overlap |>
      filterData("summarise_cohort_overlap", input)
    CohortCharacteristics::plotCohortOverlap(
      result,
      facet = input$summarise_cohort_overlap_plot_facet,
      uniqueCombinations = input$summarise_cohort_overlap_plot_uniqueCombinations
    )
  })
  output$summarise_cohort_overlap_plot <- plotly::renderPlotly({
    createPlotCohortOverlap()
  })
  output$summarise_cohort_overlap_plot_download <- shiny::downloadHandler(
    filename = "summarise_cohort_overlap_plot.png",
    content = function(file) {
      obj <- createPlotCohortOverlap()
      ggplot2::ggsave(
        filename = file,
        plot = obj,
        width = as.numeric(input$summarise_cohort_overlap_plot_download_width),
        height = as.numeric(input$summarise_cohort_overlap_plot_download_height),
        units = input$summarise_cohort_overlap_plot_download_units,
        dpi = as.numeric(input$summarise_cohort_overlap_plot_download_dpi)
      )
    }
  )


  # summarise_cohort_timing ----
  ## Table cohort_timing -----
  createTableCohortTiming <- shiny::reactive({

    if (is.null(dataFiltered$summarise_cohort_timing)) {
      validate("No cohort timing in results")
    }

    result <- dataFiltered$summarise_cohort_timing |>
      filterData("summarise_cohort_timing", input)

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }

    CohortCharacteristics::tableCohortTiming(
      result,
      timeScale = input$summarise_cohort_timing_gt_time_scale,
      uniqueCombinations = input$summarise_cohort_timing_gt_uniqueCombinations,
    ) %>%
      tab_header(
        title = "Cohort timing",
        subtitle = "Cohort timing refers to the time between an individual entering one cohort and another cohort."
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$summarise_cohort_timing_gt <- gt::render_gt({
    createTableCohortTiming()
  })
  output$summarise_cohort_timing_gt_download <- shiny::downloadHandler(
    filename = "summarise_cohort_timing_gt.docx",
    content = function(file) {
      obj <- createTableCohortTiming()
      gt::gtsave(data = obj, filename = file)
    }
  )

  ## Plot cohort_timing -----
  createPlotCohortTiming <- shiny::reactive({
    if (is.null(dataFiltered$summarise_cohort_timing)) {
      validate("No cohort timing in results")
    }

    dataFiltered$summarise_cohort_timing |>
      filterData("summarise_cohort_timing", input) |>
      CohortCharacteristics::plotCohortTiming(
        plotType = "densityplot",
        facet = input$summarise_cohort_timing_plot_facet,
        uniqueCombinations = input$summarise_cohort_timing_plot_uniqueCombinations,
        timeScale = input$summarise_cohort_timing_gt_time_scale,
      )
  })
  output$summarise_cohort_timing_plot <- plotly::renderPlotly({
    createPlotCohortTiming()
  })
  output$summarise_cohort_timing_plot_download <- shiny::downloadHandler(
    filename = "summarise_cohort_timing_plot.png",
    content = function(file) {
      obj <- createPlotCohortTiming()
      ggplot2::ggsave(
        filename = file,
        plot = obj,
        width = as.numeric(input$summarise_cohort_timing_plot_download_width),
        height = as.numeric(input$summarise_cohort_timing_plot_download_height),
        units = input$summarise_cohort_timing_plot_download_units,
        dpi = as.numeric(input$summarise_cohort_timing_plot_download_dpi)
      )
    }
  )


  # incidence -----
  filterIncidence <- shiny::reactive({
    if (is.null(dataFiltered$incidence)) {
      validate("No incidence in results")
    }

    result <- dataFiltered$incidence |>
      filter(cdm_name %in%
               input$incidence_grouping_cdm_name) |>
      filterGroup(outcome_cohort_name %in%
                    input$incidence_grouping_outcome_cohort_name) |>
      filterSettings(denominator_age_group %in%
                       input$incidence_settings_denominator_age_group,
                     denominator_sex %in%
                       input$incidence_settings_denominator_sex,
                     denominator_days_prior_observation %in%
                       input$incidence_settings_denominator_days_prior_observation) |>
      filterAdditional(analysis_interval %in%
                         input$incidence_settings_analysis_interval)

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }
    return(result)
  })

  ## Table incidence -----
  createTableIncidence <- shiny::reactive({

    IncidencePrevalence::tableIncidence(
      filterIncidence(),
      groupColumn = c("cdm_name", "outcome_cohort_name"),
      hide = "denominator_cohort_name",
      settingsColumn = c("denominator_age_group",
                         "denominator_sex",
                         "denominator_days_prior_observation",
                         "outcome_cohort_name")
    ) %>%
      tab_header(
        title = "Incidence estimates",
        subtitle = "Incidence rates estimated for outcomes of interest"
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$incidence_gt <- gt::render_gt({
    createTableIncidence()
  })
  output$incidence_gt_download <- shiny::downloadHandler(
    filename = "incidence_gt.docx",
    content = function(file) {
      obj <- createTableIncidence()
      gt::gtsave(data = obj, filename = file)
    }
  )
  ## Plot incidence -----
  createPlotIncidence <- shiny::reactive({
    result <- filterIncidence()

    x <- input$incidence_plot_x
    y <- input$incidence_plot_y
    facet      <- input$incidence_plot_facet
    facet_free <- input$incidence_plot_facet_free
    colour     <- input$incidence_plot_colour

    # Plot incidence estimates
    if(y == "Incidence"){
      plot <- IncidencePrevalence::plotIncidence(
        result,
        x = x,
        ribbon = FALSE,
        facet = facet,
        colour = colour
      )
      plot$data <- plot$data |>
        filter(incidence_100000_pys > 0)

      if(!is.null(facet) && isTRUE(facet_free)){
        plot <- plot +
          facet_wrap(facets = facet, scales = "free")
      }
    }else{
      # Plot incidence population
      y_input <- case_when(
        y == "Denominator count" ~ "denominator_count",
        y == "Denominator person years" ~ "person_years",
        y == "Outcome count" ~ "outcome_count"
      )
      if(!is.null(facet) && isTRUE(facet_free)){
        plot <- plotIncidencePopulation(x = x,
                                        y =  y_input,
                                        result = result,
                                        facet  = NULL,
                                        colour = colour

        ) +
          facet_wrap(facets = facet, scales = "free")
      } else {
        plot <- plotIncidencePopulation(x = x,
                                        y =  y_input,
                                        result = result,
                                        facet  = facet,
                                        colour = colour

        )
      }
    }
    return(plot)
  })

  output$incidence_plot <- renderUI({
    if(isTRUE(input$incidence_plot_interactive)){
      plot <- plotly::ggplotly(createPlotIncidence())
    } else {
      plot <- renderPlot(createPlotIncidence())
    }
    plot
  })
  output$incidence_plot_download <- shiny::downloadHandler(
    filename = "incidence_plot.png",
    content = function(file) {
      obj <- createPlotIncidence()
      ggplot2::ggsave(
        filename = file,
        plot = obj,
        width = as.numeric(input$incidence_plot_download_width),
        height = as.numeric(input$incidence_plot_download_height),
        units = input$incidence_plot_download_units,
        dpi = as.numeric(input$incidence_plot_download_dpi)
      )
    }
  )

  # prevalence -----
  filterPrevalence <- shiny::reactive({
    if (is.null(dataFiltered$prevalence)) {
      validate("No prevalence in results")
    }

    result <- dataFiltered$prevalence |>
      filter(cdm_name %in%
               input$prevalence_grouping_cdm_name) |>
      filterGroup(outcome_cohort_name %in%
                    input$prevalence_grouping_outcome_cohort_name) |>
      filterSettings(denominator_age_group %in%
                       input$prevalence_settings_denominator_age_group,
                     denominator_sex %in%
                       input$prevalence_settings_denominator_sex,
                     denominator_days_prior_observation %in%
                       input$prevalence_settings_denominator_days_prior_observation) |>
      filterAdditional(analysis_interval %in%
                         input$prevalence_settings_analysis_interval)

    if (nrow(result) == 0) {
      validate("No results found for selected inputs")
    }

    return(result)
  })
  ## Table prevalence ----
  createTablePrevalence <- shiny::reactive({
    result <- filterPrevalence()

    IncidencePrevalence::tablePrevalence(
      result,
      groupColumn = c("cdm_name", "outcome_cohort_name"),
      hide = "denominator_cohort_name",
      settingsColumn = c("denominator_age_group",
                         "denominator_sex",
                         "denominator_days_prior_observation",
                         "outcome_cohort_name")
    ) %>%
      tab_header(
        title = "Prevalence estimates",
        subtitle = "Prevalence rates estimated for outcomes of interest"
      ) %>%
      tab_options(
        heading.align = "left"
      )
  })
  output$prevalence_gt <- gt::render_gt({
    createTablePrevalence()
  })
  output$prevalence_gt_download <- shiny::downloadHandler(
    filename = "prevalence_gt.docx",
    content = function(file) {
      obj <- createTablePrevalence()
      gt::gtsave(data = obj, filename = file)
    }
  )
  ## Plot prevalence ----
  createPlotPrevalence <- shiny::reactive({
    result <- filterPrevalence()

    x <- input$prevalence_plot_x
    y <- input$prevalence_plot_y
    facet <- input$prevalence_plot_facet
    facet_free <- input$prevalence_plot_facet_free
    colour <- input$prevalence_plot_colour

    if(y == "Prevalence"){
      plot <- IncidencePrevalence::plotPrevalence(
        result,
        x = x,
        ribbon = FALSE,
        facet = facet,
        colour = colour
      )
      plot$data$prevalence_95CI_lower <- round(plot$data$prevalence_95CI_lower, 6)
      plot$data$prevalence_95CI_upper <- round(plot$data$prevalence_95CI_upper, 6)
      plot$data <- plot$data |>
        dplyr::mutate(prevalence = round((outcome_count/denominator_count),6))

      if(!is.null(facet) && isTRUE(facet_free)){
        plot <- plot +
          facet_wrap(facets = facet, scales = "free")
      }
    }else{
      y_input <- case_when(
        y == "Denominator count" ~ "denominator_count",
        y == "Outcome count" ~ "outcome_count"
      )
      if(!is.null(facet) && isTRUE(input$facet_free)){
        plot <- IncidencePrevalence::plotPrevalencePopulation(
          result = result,
          x = x,
          y = y_input,
          facet = NULL,
          colour = colour) +
          facet_wrap(facets = facet, scales = "free")
      } else {
        plot <- IncidencePrevalence::plotPrevalencePopulation(
          result = result,
          x = x,
          y = y_input,
          facet = facet,
          colour = colour
        )
      }
    }

    return(plot)

  })

  output$prevalence_plot <- renderUI({
    if(isTRUE(input$prevalence_plot_interactive)){
      plot <- plotly::ggplotly(createPlotPrevalence())
    } else {
      plot <- renderPlot(createPlotPrevalence())
    }
    plot

  })
  output$prevalence_plot_download <- shiny::downloadHandler(
    filename = "prevalence_plot.png",
    content = function(file) {
      obj <- createPlotPrevalence()
      ggplot2::ggsave(
        filename = file,
        plot = obj,
        width = as.numeric(input$prevalence_plot_download_width),
        height = as.numeric(input$prevalence_plot_download_height),
        units = input$prevalence_plot_download_units,
        dpi = as.numeric(input$prevalence_plot_download_dpi)
      )
    }
  )
}