From aa45ca6d17b6a489278d678ae22c25e89e5f5331 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Fri, 7 Jul 2023 13:28:35 -0700 Subject: [PATCH 01/13] Tests and fully operational tables --- R/components-largeTableViewer.R | 147 ++++++++++++++---- extras/examples/largeTable.R | 20 +-- testApp.R | 51 ++++++ .../test-components-largeTableViewer.R | 74 +++++++++ 4 files changed, 253 insertions(+), 39 deletions(-) create mode 100644 testApp.R create mode 100644 tests/testthat/test-components-largeTableViewer.R diff --git a/R/components-largeTableViewer.R b/R/components-largeTableViewer.R index 46b4ec1d..82abf529 100644 --- a/R/components-largeTableViewer.R +++ b/R/components-largeTableViewer.R @@ -41,19 +41,17 @@ LargeDataTable <- R6::R6Class( checkmate::assertString(countQuery, null.ok = TRUE) checkmate::assertList(columnDefs, null.ok = TRUE, types = "colDef") # Cannot use multiple statments in a base query - stopifnot(length(strsplit(baseQuery, ";")) == 1) + stopifnot(length(strsplit(baseQuery, ";")[[1]]) == 1) self$connectionHandler <- connectionHandler self$baseQuery <- baseQuery self$columnDefs <- columnDefs if (!is.null(countQuery)) { + stopifnot(length(strsplit(countQuery, ";")[[1]]) == 1) self$countQuery <- countQuery } else { - self$countQuery <- SqlRender::render("SELECT COUNT(*) as count FROM (@sub_query);", - sub_query = self$baseQuery) + self$countQuery <- SqlRender::render("SELECT COUNT(*) as count FROM (@sub_query);", sub_query = self$baseQuery) } - - self }, #' get column defs @@ -85,7 +83,7 @@ LargeDataTable <- R6::R6Class( getPage = function(pageNum, pageSize = self$pageSize, ...) { mainQuery <- SqlRender::render(sql = self$baseQuery, ...) - pageOffset <- ((pageNum - 1) * pageSize) + 1 + pageOffset <- ((pageNum - 1) * pageSize) self$connectionHandler$queryDb("@main_query LIMIT @page_size OFFSET @page_offset", main_query = mainQuery, page_size = pageSize, @@ -112,33 +110,51 @@ LargeDataTable <- R6::R6Class( #' #' @param id Shiny module id. Must match largeTableServer #' @param pageSizeChoices numeric selection options for pages -largeTableView <- function(id, pageSizeChoices = c(10,20,50,100)) { +#' @param selectedPageSize numeric selection options for pages +#' @param fullDownloads allow download button of full dataset from query +largeTableView <- function(id, pageSizeChoices = c(10,25,50,100), selectedPageSize = 10, fullDownloads = TRUE) { ns <- shiny::NS(id) - checkmate::assertNumeric(pageSizeChoices) + checkmate::assertNumeric(pageSizeChoices, min.len = 1, finite = TRUE, lower = 1) + checkmate::assertTRUE(selectedPageSize %in% pageSizeChoices) + + inlineStyle <- ".inline-tv label{ display: table-cell; text-align: center; vertical-align: middle; padding-right: 1em; } + .inline-tv .selectize-input { min-width:70px;} + .inline-tv .form-group { display: table-row;}" + shiny::div( id = ns("display-table"), - shiny::fluidRow( - shiny::column( - width = 9 - ), - shiny::column( - width = 3, - shiny::selectInput(ns("pageSize"), choices = pageSizeChoices, label = "Page Size") - ) + shiny::tags$head( + shiny::tags$style(type = "text/css", inlineStyle) ), + shiny::fluidRow( + if (fullDownloads) { + shiny::column( + width = 4, + shiny::downloadButton(ns("downloadFull"), + label = "Download (Full)", + icon = shiny::icon("download")) + ) + } + ), shinycssloaders::withSpinner(reactable::reactableOutput(ns("tableView"))), shiny::fluidRow( shiny::column( - width = 1, - shiny::actionButton(ns("previousButton"), label = "Previous") + width = 4, + class = "inline-tv", + shiny::textOutput(ns("pageNumber")), + shiny::selectInput(ns("pageSize"), + choices = pageSizeChoices, + selected = selectedPageSize, + label = "show", + width = "90px") ), shiny::column( - width = 1, - shiny::actionButton(ns("nextButton"), label = "Next") + width = 2 ), shiny::column( - width = 3, - shiny::p(shiny::textOutput(ns("pageNumber"))) + width = 6, + style = "text-align:right;", + shiny::uiOutput(ns("pageActionButtons")) ) ) ) @@ -158,24 +174,46 @@ largeTableServer <- function(id, inputParams, modifyData = NULL) { checkmate::assertR6(ldt, "LargeDataTable") - checkmate::assertClass(inputParams, "reactive") + + if (!is.list(inputParams)) + checkmate::assertClass(inputParams, "reactive") + shiny::moduleServer(id, function(input, output, session) { + + if (is.list(inputParams)) { + realParams <- inputParams + inputParams <- shiny::reactive(realParams) + } + + ns <- session$ns pageNum <- shiny::reactiveVal(1) pageSize <- shiny::reactive(as.integer(input$pageSize)) + rowCount <- shiny::reactive({ + do.call(ldt$getCount, inputParams()) + }) + pageCount <- shiny::reactive({ - count <- do.call(ldt$getCount, inputParams()) - ceiling(count/pageSize()) + ceiling(rowCount()/pageSize()) }) - shiny::observeEvent(input$nextButton, pageNum(min(pageNum() + 1, pageCount()))) + shiny::observeEvent(input$nextButton, pageNum(min(pageNum() + 1, rowCount()))) shiny::observeEvent(input$previousButton, pageNum(max(pageNum() - 1, 1))) + + shiny::observeEvent(input$pageNum, pageNum(input$pageNum)) + # Reset page on page size change shiny::observeEvent(input$pageSize, { pageNum(1) }) - output$pageNumber <- shiny::renderText(paste("Page", pageNum(), "of", format(pageCount(), big.mark = ","))) + output$pageNumber <- shiny::renderText({ - output$tableView <- reactable::renderReactable({ + minNum <- format(((pageNum() - 1) * pageSize()) + 1, big.mark = ",", scientific = FALSE) + maxNum <- format((pageNum() - 1) * pageSize() + pageSize(), big.mark = ",", scientific = FALSE) + rc <- format(rowCount(), big.mark = ",", scientific = FALSE) + paste(minNum, "-", maxNum, "of", rc, "rows") + }) + + dataPage <- shiny::reactive({ params <- inputParams() checkmate::assertList(params) params$pageNum <- pageNum() @@ -186,12 +224,63 @@ largeTableServer <- function(id, if (is.function(modifyData)) { dataPage <- dataPage %>% modifyData(pageNum(), pageSize()) } + dataPage + }) - reactable::reactable(dataPage, + output$tableView <- reactable::renderReactable({ + reactable::reactable(dataPage(), columns = ldt$getColumnDefs(), searchable = FALSE, sortable = FALSE, + resizable = TRUE, + outlined = TRUE, + showSortIcon = TRUE, + striped = TRUE, + highlight = TRUE, + defaultColDef = reactable::colDef(align = "left"), pagination = FALSE) }) + + output$pageActionButtons <- shiny::renderUI({ + pc <- pageCount() + if (pc == 1) { + return(shiny::span(style="width:80px;", shiny::HTML(" "))) + } + + createPageLink <- function(pageLink) { + js <- sprintf("Shiny.setInputValue('%s', %s);", ns("pageNum"), pageLink) + shiny::tags$a(onclick = js, style = "cursor:pointer;", format(pageLink, big.mark = ",", scientific = FALSE)) + } + + linkNums <- unique(c(1, max(2, pageNum() - 2):min(pageCount() - 1, pageNum() + 3))) + links <- lapply(linkNums, createPageLink) + + ## render action buttons + # Always show 1 + # Show row up to 5 + # Always show max + shiny::tagList( + shiny::actionLink(ns("previousButton"), label = "Previous"), + links, + if (pageCount() != pageNum()) { + shiny::span("...") + }, + createPageLink(pageCount()), + shiny::actionLink(ns("nextButton"), label = "Next") + ) + }) + + output$downloadFull <- shiny::downloadHandler( + filename = function() { + paste0('result-data-full-', id, Sys.Date(), '.csv') + }, + content = function(con) { + shiny::withProgress( + message = "preparing download", + value = 15, + readr::write_csv(do.call(ldt$getAllResults, inputParams()), con) + ) + } + ) }) } \ No newline at end of file diff --git a/extras/examples/largeTable.R b/extras/examples/largeTable.R index 66c47366..18025785 100644 --- a/extras/examples/largeTable.R +++ b/extras/examples/largeTable.R @@ -6,7 +6,7 @@ # # http://shiny.rstudio.com/ # -library(OhdisShinyModules) +devtools::load_all() library(shiny) ui <- fluidPage( @@ -17,25 +17,25 @@ ui <- fluidPage( ) ###--- Fill in connection details with a real db ---### -connectionDetails <- DatabaseConnector::createConnectionDetails() +connectionDetails <- DatabaseConnector::createConnectionDetails(dbms = "sqlite", server = ":memory:") +ch <- ResultModelManager::ConnectionHandler$new(connectionDetails) +# 1 million random rows +bigData <- data.frame(row_id = 1:1e6, value = stats::runif(1e6)) +DatabaseConnector::insertTable(ch$getConnection(), data = bigData, tableName = "big_table") -ch <- ResultModelManager::ConnectionHandler$new(connectionDetails = connectionDetails) -# Define server logic required to draw a histogram server <- function(input, output) { - # Set to schema you are using - testSchema <- "ase_004" - baseQuery <- "SELECT * FROM @test_schema.cd_temporal_covariate_value" - countQuery <- "SELECT count(*) as count FROM @test_schema.cd_temporal_covariate_value" + baseQuery <- "SELECT * FROM main.big_table WHERE row_id >= @min_row" + countQuery <- "SELECT count(*) FROM main.big_table WHERE row_id >= @min_row" ldt <- LargeDataTable$new(ch, baseQuery, countQuery = countQuery, columnDefs = list( - "cohortId" = reactable::colDef(name = "cohort id") + "rowId" = reactable::colDef(name = "row id") )) - largeTableServer("tblView", ldt, reactive(list(test_schema = testSchema))) + largeTableServer("tblView", ldt, reactive(list(min_row = 1))) } # Run the application diff --git a/testApp.R b/testApp.R new file mode 100644 index 00000000..ae496baf --- /dev/null +++ b/testApp.R @@ -0,0 +1,51 @@ +devtools::load_all() + +config <- ShinyAppBuilder::initializeModuleConfig() |> + + # about module + ShinyAppBuilder::addModuleConfig( + ShinyAppBuilder::createDefaultAboutConfig(useKeyring = F, + resultDatabaseDetails = list()) + ) |> + + # cohort generator module + ShinyAppBuilder::addModuleConfig( + ShinyAppBuilder::createDefaultCohortGeneratorConfig(useKeyring = F, + resultDatabaseDetails = list(dbms = "postgresql", dbms = "postgresql", + tablePrefix = "cg_", + cohortTablePrefix = "cg_", + databaseTablePrefix = "cg_", + incidenceTablePrefix = "ci_", + schema = "epi_1025")) + ) |> + + # cohort diagnostics module + ShinyAppBuilder::addModuleConfig( + ShinyAppBuilder::createDefaultCohortDiagnosticsConfig(useKeyring = TRUE, + resultDatabaseDetails = list(dbms = "postgresql", + tablePrefix = "cd_", + vocabularyDatabaseSchema = "epi_1025", + schema = "epi_1025")) + ) |> + + # cohort characterization module + ShinyAppBuilder::addModuleConfig( + ShinyAppBuilder::createDefaultCharacterizationConfig(useKeyring = F, + resultDatabaseDetails = list(dbms = "postgresql", + tablePrefix = "c_", + cohortTablePrefix = "cg_", + databaseTablePrefix = "cd", + schema = "epi_1025", + databaseTable = "database_meta_data", + incidenceTablePrefix = "ci_")) + ) + + +connectionDetails <- DatabaseConnector::createConnectionDetails(dbms = "postgresql", + server = "reward.cterqq54xyuu.us-east-1.rds.amazonaws.com/strategus_test", + user = "reward_user", + password = "4GAnEA~m6-Hk", + port = 5432) + +connection <- ResultModelManager::ConnectionHandler$new(connectionDetails) +ShinyAppBuilder::viewShiny(config, connection) diff --git a/tests/testthat/test-components-largeTableViewer.R b/tests/testthat/test-components-largeTableViewer.R new file mode 100644 index 00000000..4d30d74c --- /dev/null +++ b/tests/testthat/test-components-largeTableViewer.R @@ -0,0 +1,74 @@ +# Create Tables +test_that("Large Data Table R6 Class works", { + # Create connection handler + cdTest <- DatabaseConnector::createConnectionDetails(dbms = "sqlite", server = ":memory:") + ch <- ResultModelManager::ConnectionHandler$new(cdTest) + on.exit(ch$finalize()) + # 1 million random rows + bigData <- data.frame(row_id = 1:1e6, value = stats::runif(1e6)) + DatabaseConnector::insertTable(ch$getConnection(), data = bigData, tableName = "big_table") + + query <- "SELECT * FROM main.big_table WHERE row_id >= @min_row" + countQuery <- "SELECT count(*) FROM main.big_table WHERE row_id >= @min_row" + + ldt <- LargeDataTable$new(ch, query, countQuery, columnDefs = list(row_id = reactable::colDef("row id"))) + + checkmate::expect_r6(ldt, "LargeDataTable") + + expect_equal(ldt$getAllResults(min_row = 1) %>% nrow(), bigData %>% nrow()) + expect_equal(ldt$getCount(min_row = 2), bigData %>% nrow() - 1) + expect_equal(ldt$getCount(min_row = 1), bigData %>% nrow()) + checkmate::expect_data_frame(ldt$getPage(2, 10, min_row = 1)) + expect_equal(ldt$getPage(2, 10, min_row = 1) %>% nrow(), 10) + checkmate::expect_list(ldt$getColumnDefs()) + expect_error(LargeDataTable$new(ch, "SELECT 1; SELECT 2;")) + expect_error(LargeDataTable$new(ch, query, "SELECT 1; SELECT 2;")) + expect_error(LargeDataTable$new(ch, query, columnDefs = list(1, 2, 3))) + + ldt2 <- LargeDataTable$new(ch, query, countQuery = NULL, columnDefs = list(row_id = reactable::colDef("row id"))) + checkmate::expect_string(ldt2$countQuery) + + checkmate::expect_class(largeTableView("foo"), "shiny.tag") + checkmate::expect_class(largeTableView("foo", fullDownloads = FALSE), "shiny.tag") + + shiny::testServer( + app = largeTableServer, + args = list( + id = "foo", + ldt = ldt, + inputParams = list(min_row = 1), + modifyData = function(df, pageNum, pageSize) { + df %>% dplyr::mutate(fizzBuzz = ifelse(.data$rowId %% 3 == 0, "fizz", "buzz")) + } + ), + expr = { + + session$setInputs(pageSize = 10) + + expect_equal(rowCount(), ldt$getCount(min_row = 1)) + expect_equal(pageNum(), 1) + expect_equal(pageCount(), ceiling(ldt$getCount(min_row = 1) / 10)) + + + session$setInputs(pageSize = 100) + expect_equal(pageNum(), 1) + expect_equal(pageCount(), ceiling(ldt$getCount(min_row = 1) / 100)) + + session$setInputs(pageNum = 5) + expect_equal(pageNum(), 5) + expect_equal(output$pageNumber, "401 - 500 of 1,000,000 rows") + + checkmate::expect_data_frame(dataPage(), nrow = 100, ncols = 3) + checkmate::expect_names(colnames(dataPage()), must.include = c("rowId", "value", "fizzBuzz")) + expect_true(all(dataPage()$fizzBuzz == ifelse(dataPage()$rowId %% 3 == 0, "fizz", "buzz"))) + + checkmate::expect_class(output$tableView, "json") + checkmate::expect_class(output$pageActionButtons , "list") + + session$setInputs(pageSize = 1e6) + expect_equal(pageCount(), 1) + checkmate::expect_class(output$pageActionButtons , "list") + checkmate::expect_file_exists(output$downloadFull) + } + ) +}) \ No newline at end of file From b821fb2c2a469324e2bdb9c537f62d01a81ca3c1 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Fri, 7 Jul 2023 13:29:06 -0700 Subject: [PATCH 02/13] docs --- man/largeTableView.Rd | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/man/largeTableView.Rd b/man/largeTableView.Rd index e850a608..247b5c0b 100644 --- a/man/largeTableView.Rd +++ b/man/largeTableView.Rd @@ -4,12 +4,21 @@ \alias{largeTableView} \title{Large Table Component Viewer} \usage{ -largeTableView(id, pageSizeChoices = c(10, 20, 50, 100)) +largeTableView( + id, + pageSizeChoices = c(10, 25, 50, 100), + selectedPageSize = 10, + fullDownloads = TRUE +) } \arguments{ \item{id}{Shiny module id. Must match largeTableServer} \item{pageSizeChoices}{numeric selection options for pages} + +\item{selectedPageSize}{numeric selection options for pages} + +\item{fullDownloads}{allow download button of full dataset from query} } \description{ Componenet for results sets with many thousands of rows From d4391bb72abb338e7ccafd59a061438293d632db Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Fri, 7 Jul 2023 13:30:56 -0700 Subject: [PATCH 03/13] example fixed --- extras/examples/largeTable.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extras/examples/largeTable.R b/extras/examples/largeTable.R index 18025785..82bfc8ca 100644 --- a/extras/examples/largeTable.R +++ b/extras/examples/largeTable.R @@ -6,7 +6,7 @@ # # http://shiny.rstudio.com/ # -devtools::load_all() +library(OhdisShinyModules) library(shiny) ui <- fluidPage( From eac448e0235a8ebe9bd53664b5fbbe4436803514 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Fri, 7 Jul 2023 13:40:28 -0700 Subject: [PATCH 04/13] example fixed --- extras/examples/largeTable.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extras/examples/largeTable.R b/extras/examples/largeTable.R index 82bfc8ca..f2f7a2e8 100644 --- a/extras/examples/largeTable.R +++ b/extras/examples/largeTable.R @@ -6,7 +6,7 @@ # # http://shiny.rstudio.com/ # -library(OhdisShinyModules) +library(OhdsiShinyModules) library(shiny) ui <- fluidPage( From 6dd8d98d51a75ed2a20ed6b34d04109c2fb4605a Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Tue, 11 Jul 2023 16:14:25 -0700 Subject: [PATCH 05/13] Changes to appearance --- R/components-largeTableViewer.R | 37 +++++++++++++++++++++++---------- man/LargeDataTable.Rd | 21 +++---------------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/R/components-largeTableViewer.R b/R/components-largeTableViewer.R index 82abf529..1d3edaa0 100644 --- a/R/components-largeTableViewer.R +++ b/R/components-largeTableViewer.R @@ -32,9 +32,6 @@ LargeDataTable <- R6::R6Class( #' @param columnDefs list of #' #' @return self - #' @export - #' - #' @examples initialize = function(connectionHandler, baseQuery, countQuery = NULL, columnDefs = list()) { checkmate::assertR6(connectionHandler, "ConnectionHandler") checkmate::assertString(baseQuery) @@ -54,8 +51,7 @@ LargeDataTable <- R6::R6Class( } }, - #' get column defs - #' + #' @title get column defs #' @return columnDefs getColumnDefs = function() { self$columnDefs @@ -119,7 +115,20 @@ largeTableView <- function(id, pageSizeChoices = c(10,25,50,100), selectedPageSi inlineStyle <- ".inline-tv label{ display: table-cell; text-align: center; vertical-align: middle; padding-right: 1em; } .inline-tv .selectize-input { min-width:70px;} - .inline-tv .form-group { display: table-row;}" + .inline-tv .form-group { display: table-row;} + + .link-bt { + background-color: transparent; + border: none; + border-radius: 3px; + cursor: pointer; + outline-style: solid; + outline-width: 0; + padding: 6px 12px; + text-decoration:none; + } + + " shiny::div( id = ns("display-table"), @@ -249,10 +258,12 @@ largeTableServer <- function(id, createPageLink <- function(pageLink) { js <- sprintf("Shiny.setInputValue('%s', %s);", ns("pageNum"), pageLink) - shiny::tags$a(onclick = js, style = "cursor:pointer;", format(pageLink, big.mark = ",", scientific = FALSE)) + shiny::tags$a(onclick = js, + class = "link-bt", + style = "cursor:pointer;", format(pageLink, big.mark = ",", scientific = FALSE)) } - linkNums <- unique(c(1, max(2, pageNum() - 2):min(pageCount() - 1, pageNum() + 3))) + linkNums <- unique(c(max(2, pageNum() - 2):min(pageCount() - 1, pageNum() + 3))) links <- lapply(linkNums, createPageLink) ## render action buttons @@ -260,13 +271,17 @@ largeTableServer <- function(id, # Show row up to 5 # Always show max shiny::tagList( - shiny::actionLink(ns("previousButton"), label = "Previous"), + shiny::actionLink(ns("previousButton"), label = "Previous", class = "link-bt"), + createPageLink(1), + if (!pageNum() %in% c(1, 2)) { + shiny::span("...", class = "link-bt") + }, links, if (pageCount() != pageNum()) { - shiny::span("...") + shiny::span("...", class = "link-bt") }, createPageLink(pageCount()), - shiny::actionLink(ns("nextButton"), label = "Next") + shiny::actionLink(ns("nextButton"), label = "Next", class = "link-bt") ) }) diff --git a/man/LargeDataTable.Rd b/man/LargeDataTable.Rd index 25da8e9b..f3975eea 100644 --- a/man/LargeDataTable.Rd +++ b/man/LargeDataTable.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/components-largeTableViewer.R \name{LargeDataTable} \alias{LargeDataTable} -\title{Large Data Table} +\title{get column defs} \description{ Large data table R6 class. @@ -14,14 +14,8 @@ as this method uses limit and offset for the queries Alternatively, you might want to subclass this class. For example, if your backend query is against an API such as and ATLAS instance or ATHENA } -\examples{ - -## ------------------------------------------------ -## Method `LargeDataTable$new` -## ------------------------------------------------ - -get column defs - +\details{ +Large Data Table } \section{Public fields}{ \if{html}{\out{
}} @@ -79,15 +73,6 @@ initialize} \subsection{Returns}{ self } -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{get column defs - -} -\if{html}{\out{
}} - -} - } \if{html}{\out{
}} \if{html}{\out{}} From 444aef4a709af528fb903cb3acaf67809f6b3b52 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Thu, 13 Jul 2023 14:26:30 -0700 Subject: [PATCH 06/13] Minor fixes for appearance --- R/components-largeTableViewer.R | 63 +++++++++++++++++++++------------ 1 file changed, 41 insertions(+), 22 deletions(-) diff --git a/R/components-largeTableViewer.R b/R/components-largeTableViewer.R index 1d3edaa0..2d5241f0 100644 --- a/R/components-largeTableViewer.R +++ b/R/components-largeTableViewer.R @@ -113,22 +113,32 @@ largeTableView <- function(id, pageSizeChoices = c(10,25,50,100), selectedPageSi checkmate::assertNumeric(pageSizeChoices, min.len = 1, finite = TRUE, lower = 1) checkmate::assertTRUE(selectedPageSize %in% pageSizeChoices) - inlineStyle <- ".inline-tv label{ display: table-cell; text-align: center; vertical-align: middle; padding-right: 1em; } - .inline-tv .selectize-input { min-width:70px;} - .inline-tv .form-group { display: table-row;} - - .link-bt { - background-color: transparent; - border: none; - border-radius: 3px; - cursor: pointer; - outline-style: solid; - outline-width: 0; - padding: 6px 12px; - text-decoration:none; - } - - " + inlineStyle <- " + .inline-tv label{ display: table-cell; text-align: center; vertical-align: middle; padding-right: 1em; } + .inline-tv .selectize-input { min-width:70px;} + .inline-tv .form-group { display: table-row;} + + .pagination-buttons { + margin-top: 1em; + } + + .link-bt { + background-color: transparent; + border: none; + border-radius: 3px; + cursor: pointer; + outline-style: solid; + outline-width: 0; + padding: 6px 12px; + text-decoration:none; + } + .link-bt:hover{ + background-color: #eee; + } + .pagination-buttons a { + text-decoration:none; + color: #000!important; + }" shiny::div( id = ns("display-table"), @@ -203,7 +213,7 @@ largeTableServer <- function(id, }) pageCount <- shiny::reactive({ - ceiling(rowCount()/pageSize()) + max(1, ceiling(rowCount()/pageSize())) }) shiny::observeEvent(input$nextButton, pageNum(min(pageNum() + 1, rowCount()))) @@ -211,15 +221,23 @@ largeTableServer <- function(id, shiny::observeEvent(input$pageNum, pageNum(input$pageNum)) - # Reset page on page size change + # Reset page on page size change or any input variable that could impact row count + shiny::observe({ + inputParams() + pageNum(1) + }) shiny::observeEvent(input$pageSize, { pageNum(1) }) output$pageNumber <- shiny::renderText({ + rc <- format(rowCount(), big.mark = ",", scientific = FALSE) + if (pageCount() < 2) { + return(paste(rc, "rows")) + } + minNum <- format(((pageNum() - 1) * pageSize()) + 1, big.mark = ",", scientific = FALSE) maxNum <- format((pageNum() - 1) * pageSize() + pageSize(), big.mark = ",", scientific = FALSE) - rc <- format(rowCount(), big.mark = ",", scientific = FALSE) - paste(minNum, "-", maxNum, "of", rc, "rows") + return(paste(minNum, "-", maxNum, "of", rc, "rows")) }) dataPage <- shiny::reactive({ @@ -252,7 +270,7 @@ largeTableServer <- function(id, output$pageActionButtons <- shiny::renderUI({ pc <- pageCount() - if (pc == 1) { + if (pc < 2) { return(shiny::span(style="width:80px;", shiny::HTML(" "))) } @@ -270,7 +288,8 @@ largeTableServer <- function(id, # Always show 1 # Show row up to 5 # Always show max - shiny::tagList( + shiny::div( + class = "pagination-buttons", shiny::actionLink(ns("previousButton"), label = "Previous", class = "link-bt"), createPageLink(1), if (!pageNum() %in% c(1, 2)) { From e8cca012dffe3d9ef63f433c0fdea27bea94a013 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Thu, 13 Jul 2023 16:08:56 -0700 Subject: [PATCH 07/13] Columns now parameter to compnenent not data object, convenient creation function for ldts --- R/components-largeTableViewer.R | 66 ++++++++++++++----- extras/examples/largeTable.R | 25 ++++--- man/LargeDataTable.Rd | 33 ++-------- man/createLargeSqlQueryDt.Rd | 27 ++++++++ man/largeTableServer.Rd | 13 +++- .../test-components-largeTableViewer.R | 10 +-- 6 files changed, 115 insertions(+), 59 deletions(-) create mode 100644 man/createLargeSqlQueryDt.Rd diff --git a/R/components-largeTableViewer.R b/R/components-largeTableViewer.R index 2d5241f0..5e0d60ee 100644 --- a/R/components-largeTableViewer.R +++ b/R/components-largeTableViewer.R @@ -11,10 +11,13 @@ #' Alternatively, you might want to subclass this class. For example, if your backend query is against an API such #' as and ATLAS instance or ATHENA #' +#' If subclassing use inheritance and treat this class as an interface to implement - implementing the methods: +#' +#' get +#' #' @field baseQuery query string sql #' @field countQuery count query string (should match query). Can be auto generated with sub query (default) but #' this will likely result in slow results -#' @field columnDefs reactable Coulmn definitions #' @field connectionHandler ResultModelManager connection handler to execute query inside LargeDataTable <- R6::R6Class( classname = "LargeDataTable", @@ -22,26 +25,22 @@ LargeDataTable <- R6::R6Class( connectionHandler = NULL, baseQuery = NULL, countQuery = NULL, - columnDefs = NULL, #' initialize #' #' @param connectionHandler ResultModelManager connectionHandler instance #' @param baseQuery base sql query #' @param countQuery count query string (should match query). Can be auto generated with sub query #' (default) but this will likely result in slow results - #' @param columnDefs list of #' #' @return self - initialize = function(connectionHandler, baseQuery, countQuery = NULL, columnDefs = list()) { + initialize = function(connectionHandler, baseQuery, countQuery = NULL) { checkmate::assertR6(connectionHandler, "ConnectionHandler") checkmate::assertString(baseQuery) checkmate::assertString(countQuery, null.ok = TRUE) - checkmate::assertList(columnDefs, null.ok = TRUE, types = "colDef") # Cannot use multiple statments in a base query stopifnot(length(strsplit(baseQuery, ";")[[1]]) == 1) self$connectionHandler <- connectionHandler self$baseQuery <- baseQuery - self$columnDefs <- columnDefs if (!is.null(countQuery)) { stopifnot(length(strsplit(countQuery, ";")[[1]]) == 1) @@ -51,12 +50,6 @@ LargeDataTable <- R6::R6Class( } }, - #' @title get column defs - #' @return columnDefs - getColumnDefs = function() { - self$columnDefs - }, - #' get count #' @description #' execute count query with specified parameters @@ -92,11 +85,36 @@ LargeDataTable <- R6::R6Class( #' #' @return data.frame of all results. Used for large file downloads getAllResults = function(...) { - self$connectionHandler$queryDb(self$baseQuery, ...) + self$connectionHandler$queryDb(self$baseQuery, ..., snakeCaseToCamelCase = FALSE) } ) ) +#' Create Large Sql Query Data Table +#' +#' @description +#' Construct an instance of a LargeDataTable R6 instance for use inside largeTableServer +#' +#' This should pass a parameterized sql query that can be used to iteratively return data from a table +#' rather than returning the entire object. +#' +#' @param connectionHandler ResultModelManager connectionHandler instance +#' @param baseQuery base sql query +#' @param countQuery count query string (should match query). Can be auto generated with sub query +#' (default) but this will likely result in slow results +createLargeSqlQueryDt <- function(connectionHandler = NULL, + connectionDetails = NULL, + baseQuery, + countQuery = NULL) { + if (is.null(connectionHandler)) { + checkmate::assertClass(connectionDetails, "ConnectionDetails") + } + + LargeDataTable$new(connectionHandler = connectionHandler, + baseQuery = baseQuery, + countQuery = countQuery) +} + #' Large Table Component Viewer #' @description #' Componenet for results sets with many thousands of rows @@ -188,15 +206,23 @@ largeTableView <- function(id, pageSizeChoices = c(10,25,50,100), selectedPageSi #' @param inputParams reactive that returns list of parameters to be passed to ldt #' @param modifyData optional callback function that takes the data page, page number, page size as parameters #' must return data.frame compatable instance +#' +#' @param columns List or reactable returning list of reactable::columnDef objects +#' @param ... Additional reactable options (searchable, sortable largeTableServer <- function(id, ldt, inputParams, - modifyData = NULL) { + modifyData = NULL, + columns = shiny::reactive(list()), + ...) { checkmate::assertR6(ldt, "LargeDataTable") if (!is.list(inputParams)) checkmate::assertClass(inputParams, "reactive") + if (!is.list(columns)) + checkmate::assertClass(columns, "reactive") + shiny::moduleServer(id, function(input, output, session) { if (is.list(inputParams)) { @@ -204,6 +230,11 @@ largeTableServer <- function(id, inputParams <- shiny::reactive(realParams) } + if (is.list(columns)) { + realColumns <- columns + columns <- shiny::reactive(realColumns) + } + ns <- session$ns pageNum <- shiny::reactiveVal(1) pageSize <- shiny::reactive(as.integer(input$pageSize)) @@ -255,8 +286,10 @@ largeTableServer <- function(id, }) output$tableView <- reactable::renderReactable({ + cols <- columns() + checkmate::assertList(cols, null.ok = TRUE, types = "colDef") reactable::reactable(dataPage(), - columns = ldt$getColumnDefs(), + columns = cols, searchable = FALSE, sortable = FALSE, resizable = TRUE, @@ -265,7 +298,8 @@ largeTableServer <- function(id, striped = TRUE, highlight = TRUE, defaultColDef = reactable::colDef(align = "left"), - pagination = FALSE) + pagination = FALSE, + ...) }) output$pageActionButtons <- shiny::renderUI({ diff --git a/extras/examples/largeTable.R b/extras/examples/largeTable.R index f2f7a2e8..21fb5639 100644 --- a/extras/examples/largeTable.R +++ b/extras/examples/largeTable.R @@ -9,11 +9,14 @@ library(OhdsiShinyModules) library(shiny) +if (FALSE) + RSQLite::rsqliteVersion() + ui <- fluidPage( - # Application title - titlePanel("Big table example"), - largeTableView("tblView") + # Application title + titlePanel("Big table example"), + largeTableView("tblView") ) ###--- Fill in connection details with a real db ---### @@ -28,14 +31,16 @@ server <- function(input, output) { baseQuery <- "SELECT * FROM main.big_table WHERE row_id >= @min_row" countQuery <- "SELECT count(*) FROM main.big_table WHERE row_id >= @min_row" - ldt <- LargeDataTable$new(ch, - baseQuery, - countQuery = countQuery, - columnDefs = list( - "rowId" = reactable::colDef(name = "row id") - )) + ldt <- createLargeSqlQueryDt(connectionHandler = connectionHandler, + baseQuery = baseQuery, + countQuery = countQuery) - largeTableServer("tblView", ldt, reactive(list(min_row = 1))) + largeTableServer(id = "tblView", + ldt = ldt, + inputParams = reactive(list(min_row = 1)), + columns = list( + "rowId" = reactable::colDef(name = "row id") + )) } # Run the application diff --git a/man/LargeDataTable.Rd b/man/LargeDataTable.Rd index f3975eea..10a9d869 100644 --- a/man/LargeDataTable.Rd +++ b/man/LargeDataTable.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/components-largeTableViewer.R \name{LargeDataTable} \alias{LargeDataTable} -\title{get column defs} +\title{Large Data Table} \description{ Large data table R6 class. @@ -13,9 +13,10 @@ as this method uses limit and offset for the queries Alternatively, you might want to subclass this class. For example, if your backend query is against an API such as and ATLAS instance or ATHENA -} -\details{ -Large Data Table + +If subclassing use inheritance and treat this class as an interface to implement - implementing the methods: + + get } \section{Public fields}{ \if{html}{\out{
}} @@ -25,8 +26,6 @@ Large Data Table \item{\code{countQuery}}{count query string (should match query). Can be auto generated with sub query (default) but this will likely result in slow results} -\item{\code{columnDefs}}{reactable Coulmn definitions} - \item{\code{connectionHandler}}{ResultModelManager connection handler to execute query inside initialize} } @@ -36,7 +35,6 @@ initialize} \subsection{Public methods}{ \itemize{ \item \href{#method-LargeDataTable-new}{\code{LargeDataTable$new()}} -\item \href{#method-LargeDataTable-getColumnDefs}{\code{LargeDataTable$getColumnDefs()}} \item \href{#method-LargeDataTable-getCount}{\code{LargeDataTable$getCount()}} \item \href{#method-LargeDataTable-getPage}{\code{LargeDataTable$getPage()}} \item \href{#method-LargeDataTable-getAllResults}{\code{LargeDataTable$getAllResults()}} @@ -48,12 +46,7 @@ initialize} \if{latex}{\out{\hypertarget{method-LargeDataTable-new}{}}} \subsection{Method \code{new()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{LargeDataTable$new( - connectionHandler, - baseQuery, - countQuery = NULL, - columnDefs = list() -)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{LargeDataTable$new(connectionHandler, baseQuery, countQuery = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -65,25 +58,11 @@ initialize} \item{\code{countQuery}}{count query string (should match query). Can be auto generated with sub query (default) but this will likely result in slow results} - -\item{\code{columnDefs}}{list of} } \if{html}{\out{
}} } \subsection{Returns}{ self -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-LargeDataTable-getColumnDefs}{}}} -\subsection{Method \code{getColumnDefs()}}{ -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{LargeDataTable$getColumnDefs()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -columnDefs get count } } diff --git a/man/createLargeSqlQueryDt.Rd b/man/createLargeSqlQueryDt.Rd new file mode 100644 index 00000000..30c1d1c0 --- /dev/null +++ b/man/createLargeSqlQueryDt.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/components-largeTableViewer.R +\name{createLargeSqlQueryDt} +\alias{createLargeSqlQueryDt} +\title{Create Large Sql Query Data Table} +\usage{ +createLargeSqlQueryDt( + connectionHandler = NULL, + connectionDetails = NULL, + baseQuery, + countQuery = NULL +) +} +\arguments{ +\item{connectionHandler}{ResultModelManager connectionHandler instance} + +\item{baseQuery}{base sql query} + +\item{countQuery}{count query string (should match query). Can be auto generated with sub query +(default) but this will likely result in slow results} +} +\description{ +Construct an instance of a LargeDataTable R6 instance for use inside largeTableServer + +This should pass a parameterized sql query that can be used to iteratively return data from a table +rather than returning the entire object. +} diff --git a/man/largeTableServer.Rd b/man/largeTableServer.Rd index 5b923f27..f69e018c 100644 --- a/man/largeTableServer.Rd +++ b/man/largeTableServer.Rd @@ -4,7 +4,14 @@ \alias{largeTableServer} \title{Large Table Component Server} \usage{ -largeTableServer(id, ldt, inputParams, modifyData = NULL) +largeTableServer( + id, + ldt, + inputParams, + modifyData = NULL, + columns = shiny::reactive(list()), + ... +) } \arguments{ \item{id}{Shiny module id. Must match Large Table Viewer} @@ -15,6 +22,10 @@ largeTableServer(id, ldt, inputParams, modifyData = NULL) \item{modifyData}{optional callback function that takes the data page, page number, page size as parameters must return data.frame compatable instance} + +\item{columns}{List or reactable returning list of reactable::columnDef objects} + +\item{...}{Additional reactable options (searchable, sortable} } \description{ Display large data tables in a consistent way - server side pagination for reactable objects diff --git a/tests/testthat/test-components-largeTableViewer.R b/tests/testthat/test-components-largeTableViewer.R index 4d30d74c..8748be6d 100644 --- a/tests/testthat/test-components-largeTableViewer.R +++ b/tests/testthat/test-components-largeTableViewer.R @@ -11,7 +11,7 @@ test_that("Large Data Table R6 Class works", { query <- "SELECT * FROM main.big_table WHERE row_id >= @min_row" countQuery <- "SELECT count(*) FROM main.big_table WHERE row_id >= @min_row" - ldt <- LargeDataTable$new(ch, query, countQuery, columnDefs = list(row_id = reactable::colDef("row id"))) + ldt <- LargeDataTable$new(ch, query, countQuery) checkmate::expect_r6(ldt, "LargeDataTable") @@ -20,12 +20,11 @@ test_that("Large Data Table R6 Class works", { expect_equal(ldt$getCount(min_row = 1), bigData %>% nrow()) checkmate::expect_data_frame(ldt$getPage(2, 10, min_row = 1)) expect_equal(ldt$getPage(2, 10, min_row = 1) %>% nrow(), 10) - checkmate::expect_list(ldt$getColumnDefs()) expect_error(LargeDataTable$new(ch, "SELECT 1; SELECT 2;")) expect_error(LargeDataTable$new(ch, query, "SELECT 1; SELECT 2;")) - expect_error(LargeDataTable$new(ch, query, columnDefs = list(1, 2, 3))) + expect_error(LargeDataTable$new(ch, query)) - ldt2 <- LargeDataTable$new(ch, query, countQuery = NULL, columnDefs = list(row_id = reactable::colDef("row id"))) + ldt2 <- LargeDataTable$new(ch, query, countQuery = NULL)) checkmate::expect_string(ldt2$countQuery) checkmate::expect_class(largeTableView("foo"), "shiny.tag") @@ -39,7 +38,8 @@ test_that("Large Data Table R6 Class works", { inputParams = list(min_row = 1), modifyData = function(df, pageNum, pageSize) { df %>% dplyr::mutate(fizzBuzz = ifelse(.data$rowId %% 3 == 0, "fizz", "buzz")) - } + }, + columns = list(row_id = reactable::colDef("row id") ), expr = { From 2748b84c626a5ea3a323a1572822800777c60bcc Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Thu, 13 Jul 2023 16:10:30 -0700 Subject: [PATCH 08/13] first CD ldt now mostly working - just some minor tweaks on first table to add --- R/cohort-diagnostics-characterization.R | 274 ++++++++++++++++++++---- 1 file changed, 231 insertions(+), 43 deletions(-) diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index dda8fded..00c06e46 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -143,37 +143,7 @@ characterizationView <- function(id) { ) ) ) - ) - ), - shiny::conditionalPanel( - ns = ns, - condition = "input.charType == 'Pretty'", - shiny::actionButton(label = "Generate Table", inputId = ns("generateReport")) - ), - shiny::conditionalPanel( - ns = ns, - condition = "input.charType == 'Raw'", - shiny::actionButton(label = "Generate Table", inputId = ns("generateRaw")) - ), - ), - shiny::conditionalPanel( - condition = "input.generateReport > 0 && input.charType == 'Pretty'", - ns = ns, - shiny::uiOutput(outputId = ns("selections")), - shinydashboard::box( - width = NULL, - shinycssloaders::withSpinner( - reactable::reactableOutput(outputId = ns("characterizationTable")) ), - reactableCsvDownloadButton(ns, "characterizationTable") - ) - ), - shiny::conditionalPanel( - condition = "input.generateRaw > 0 && input.charType == 'Raw'", - ns = ns, - shiny::uiOutput(outputId = ns("selectionsRaw")), - shinydashboard::box( - width = NULL, shiny::fluidRow( shiny::column( width = 4, @@ -212,11 +182,52 @@ characterizationView <- function(id) { ) ) ) + ) + ), + shiny::conditionalPanel( + ns = ns, + condition = "input.charType == 'Pretty'", + shiny::actionButton(label = "Generate Table", inputId = ns("generateReport")) + ), + shiny::conditionalPanel( + ns = ns, + condition = "input.charType == 'Raw'", + shiny::actionButton(label = "Generate Table", inputId = ns("generateRaw")) + ), + ), + shiny::conditionalPanel( + condition = "input.generateReport > 0 && input.charType == 'Pretty'", + ns = ns, + shiny::uiOutput(outputId = ns("selections")), + shinydashboard::box( + width = NULL, + shinycssloaders::withSpinner( + reactable::reactableOutput(outputId = ns("characterizationTable")) ), + reactableCsvDownloadButton(ns, "characterizationTable") + ) + ), + shiny::conditionalPanel( + condition = "input.generateRaw > 0 && input.charType == 'Raw'", + ns = ns, + shiny::uiOutput(outputId = ns("selectionsRaw")), + shinydashboard::box( + width = NULL, shiny::tabsetPanel( type = "pills", shiny::tabPanel( title = "Group by Database", + shiny::fluidRow( + shiny::column(width = 8), + shiny::column(width = 4, + shiny::textInput(inputId = ns("generalSearchString"), + label = "", + placeholder = "Search covariates")) + ), + largeTableView(id = ns("rawCharTbl"), selectedPageSize = 100) + ), + shiny::tabPanel( + title = "Group by Database OLD", shinycssloaders::withSpinner( reactable::reactableOutput(outputId = ns("characterizationTableRaw")) ), @@ -544,7 +555,9 @@ characterizationModule <- function( getFilteredConceptIds <- shiny::reactive({ shiny::validate(shiny::need(hasData(selectedDatabaseIds()), "No data sources chosen")) shiny::validate(shiny::need(hasData(targetCohortId()), "No cohort chosen")) - shiny::validate(shiny::need(hasData(conceptSetIds()), "No concept set id chosen")) + if (!hasData(conceptSetIds())) + return(NULL) + resolved <- getResolvedConcepts() mapped <- getMappedConcepts() output <- c() @@ -775,11 +788,11 @@ characterizationModule <- function( sql = "SELECT tcv.*, ref.covariate_name, ref.analysis_id, ref.concept_id, aref.analysis_name, aref.is_binary, aref.domain_id, - tref.start_day, tref.end_day + ttr.start_day, ttr.end_day FROM @results_database_schema.@table_name tcv INNER JOIN @results_database_schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id INNER JOIN @results_database_schema.@analysis_ref_table_name aref ON aref.analysis_id = ref.analysis_id - LEFT JOIN @results_database_schema.@temporal_time_ref tref ON tref.time_id = tcv.time_id + LEFT JOIN @results_database_schema.@temporal_time_ref ttr ON ttr.time_id = tcv.time_id WHERE ref.covariate_id IS NOT NULL {@analysis_ids != \"\"} ? { AND ref.analysis_id IN (@analysis_ids)} {@domain_ids != \"\"} ? { AND aref.domain_id IN (@domain_ids)} @@ -805,11 +818,11 @@ characterizationModule <- function( dplyr::mutate(temporalChoices = ifelse(is.na(.data$startDay), "Time Invariant", paste0("T (", .data$startDay, "d to ", .data$endDay, "d)"))) - return(data) + return(data) }) - ## cohortCharacterizationDataFiltered ---- - cohortCharacterizationDataFiltered <- shiny::eventReactive(input$generateRaw, { + + shiny::observeEvent(input$targetCohort, { cohortConcepSets <- getCohortConceptSets() cohortConcepSetOptions <- c("", cohortConcepSets$id) names(cohortConcepSetOptions) <- c("None selected", cohortConcepSets$name) @@ -817,7 +830,10 @@ characterizationModule <- function( inputId = "selectedConceptSet", selected = NULL, choices = cohortConcepSetOptions) + }) + ## cohortCharacterizationDataFiltered ---- + cohortCharacterizationDataFiltered <- shiny::eventReactive(input$generateRaw, { data <- rawCharacterizationOutput() if (!hasData(data)) { return(NULL) @@ -966,12 +982,12 @@ characterizationModule <- function( "mean", "sd" ) %>% - tidyr::pivot_wider( - id_cols = dplyr::all_of(keyColumns), - names_from = "temporalChoices", - values_from = "mean", - names_sep = "_" - ) %>% + tidyr::pivot_wider( + id_cols = dplyr::all_of(keyColumns), + names_from = "temporalChoices", + values_from = "mean", + names_sep = "_" + ) %>% dplyr::relocate(dplyr::all_of(c(keyColumns, temporalChoicesVar))) %>% dplyr::arrange(dplyr::desc(dplyr::across(dplyr::starts_with("T (")))) @@ -997,10 +1013,182 @@ characterizationModule <- function( ) }) + + # Params when user presses button + inputButtonParams <- shiny::eventReactive(input$generateRaw, { + conceptIds <- getFilteredConceptIds() + if (is.null(conceptIds) || is.na(conceptIds)) { + conceptIds <- "" + } + + binary <- "" + if (input$proportionOrContinuous == "Proportion") { + binary <- "y" + } else if (input$proportionOrContinuous == "Continuous") { + binary <- "n" + } + + list( + analysis_ids = input$selectedRawAnalysisIds %>% unique(), + time_id = selectedTimeIds() %>% unique(), + use_database_id = !is.null(selectedDatabaseIds()), + database_id = quoteLiterals(selectedDatabaseIds()), + domain_ids = quoteLiterals(input$characterizationDomainIdFilter %>% unique()), + table_prefix = dataSource$tablePrefix, + cohort_id = targetCohortId(), + results_database_schema = dataSource$resultsDatabaseSchema, + is_binary = binary, + concept_ids = conceptIds + ) + }) + + getSearchStr <- shiny::reactive({ + if (input$generalSearchString == "" || + is.na(input$generalSearchString) || + is.null(input$generalSearchString)) + return('') + + return(input$generalSearchString) + }) + # params with default reactive behaviour + inputParams <- shiny::reactive({ + params <- inputButtonParams() + params$search_str <- getSearchStr() + return(params) + }) + + # Set real query from dynamic data + # The following is a lot of dynamically generated sql to create a pivoted table to allow + # Side by side view af covariate means + shiny::observeEvent(input$generateRaw, { + databaseIds <- selectedDatabaseIds() + dbId1 <- databaseIds[1] + if (!is.null(dbId1)) { + columnDefinitions <- list( + covariateName = reactable::colDef(name = "Covariate Name"), + analysisName = reactable::colDef(name = "Analysis Name"), + temporalChoices = reactable::colDef(name = "Temporal Choices"), + conceptId = reactable::colDef(name = "Concept Id") + ) + + columnGroups <- list() + + for (dbi in databaseIds) { + columnIdent <- SqlRender::snakeCaseToCamelCase(paste0("mean_", dbi)) + # TODO: display as percentage and any nice graphics for view + columnDefinitions[[columnIdent]] <- reactable::colDef(name = "Mean") + + columnIdentSd <- SqlRender::snakeCaseToCamelCase(paste0("sd_", dbi)) + columnDefinitions[[columnIdentSd]] <- reactable::colDef(name = "sd") + + databaseName <- databaseTable %>% + dplyr::filter(.data$databaseId == dbi) %>% + dplyr::select("databaseName") %>% + dplyr::pull() + + columnGroups[[length(columnGroups) + 1]] <- reactable::colGroup(name = databaseName, + columns = c(columnIdent, columnIdentSd), + align = "center") + } + + sql <- " + SELECT @select_stament + + FROM @results_database_schema.@table_prefixtemporal_covariate_ref tcr + INNER JOIN @results_database_schema.@table_prefixtemporal_analysis_ref tar ON tar.analysis_id = tcr.analysis_id + LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t1 ON ( + tcr.covariate_id = t1.covariate_id AND t1.database_id = '@db_id_1' + ) + INNER JOIN @results_database_schema.@table_prefixtemporal_time_ref ttr ON ttr.time_id = t1.time_id + + @join_string + + WHERE tcr.covariate_id IS NOT NULL + @where_clasuses" + + selectSt <- " + tcr.covariate_name, + tar.analysis_name, + CASE + WHEN ttr.start_day IS NULL THEN 'Time Invariant' + ELSE CONCAT('T (', ttr.start_day, 'd to ', ttr.end_day, 'd)') + END as temporal_choices, + + t1.mean as mean_@db_id_1, + t1.sd as sd_@db_id_1 " + + + joinTemplate <- + "LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t@i ON ( + t1.cohort_id = t@i.cohort_id AND t1.time_id = t@i.time_id AND t1.covariate_id = t@i.covariate_id + AND t2.database_id = '@db_id_i' + )" + + whereStment <- c("t1.cohort_id IS NOT NULL") + tplSql <- c() + + if (length(databaseIds) > 1) { + for (i in 2:min(2, length(databaseIds))) { + dbIdi <- databaseIds[i] + tplSql <- c(tplSql, SqlRender::render(joinTemplate, i = i, db_id_i = dbIdi)) + whereStment <- c(whereStment, sprintf("t%s.cohort_id IS NOT NULL", i)) + selects <- SqlRender::render(", + --DB t@i @dbIdi + t@i.mean as mean_@db_id_i, + t@i.sd as sd_@db_id_i", i = i, db_id_i = dbIdi) + } + selectSt <- paste(selectSt, paste(selects, collapse = " ")) + } + tplSql <- paste(tplSql, collapse = "\n") + whereStment <- paste("AND (", paste(whereStment, collapse = " OR "), ")") + + + paramSql <- + " + {@analysis_ids != \"\"} ? { AND tcr.analysis_id IN (@analysis_ids)} + {@domain_ids != \"\"} ? { AND tar.domain_id IN (@domain_ids)} + {@cohort_id != \"\"} ? { AND t1.cohort_id IN (@cohort_id)} + {@time_id != \"\"} ? { AND (ttr.time_id IN (@time_id) OR ttr.time_id IS NULL OR ttr.time_id = 0)} + {@use_database_id} ? { AND t1.database_id IN (@database_id)} + {@is_binary != ''} ? {AND lower(is_binary) = '@is_binary'} + {@concept_ids != ''} ? {AND tcr.concept_id IN (@concept_ids)} + {@search_str != ''} ? {AND lower(CONCAT(tcr.covariate_name, tar.analysis_name)) LIKE lower('%@search_str%')} + " + + baseQuery <- SqlRender::render(sql, + select_stament = selectSt, + db_id_1 = dbId1, + join_string = tplSql, + where_clasuses = whereStment, + warnOnMissingParameters = FALSE) + countQuery <- SqlRender::render(sql, + select_stament = "count(*)", + db_id_1 = dbId1, + join_string = tplSql, + where_clasuses = whereStment, + warnOnMissingParameters = FALSE) + + baseQuery <- paste(baseQuery, paramSql) + countQuery <- paste(countQuery, paramSql) + + ldt <- LargeDataTable$new(connectionHandler = dataSource$connectionHandler, + baseQuery = baseQuery, + countQuery = countQuery) + largeTableServer(id = "rawCharTbl", + ldt, + inputParams = inputParams, + columns = columnDefinitions, + columnGroups = columnGroups) + } + }) + + output$characterizationTableRawGroupedByTime <- reactable::renderReactable(expr = { data <- rawTableTimeIdReactable() shiny::validate(shiny::need(hasData(data), "No data for selected combination")) return(data) }) - }) + } + + ) } From d714c64179dc2c6a6ecb7a2395517b4de1eba4b6 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Tue, 18 Jul 2023 08:49:59 -0700 Subject: [PATCH 09/13] fixed typo in tests --- tests/testthat/test-components-largeTableViewer.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-components-largeTableViewer.R b/tests/testthat/test-components-largeTableViewer.R index 8748be6d..015e1cf3 100644 --- a/tests/testthat/test-components-largeTableViewer.R +++ b/tests/testthat/test-components-largeTableViewer.R @@ -24,7 +24,7 @@ test_that("Large Data Table R6 Class works", { expect_error(LargeDataTable$new(ch, query, "SELECT 1; SELECT 2;")) expect_error(LargeDataTable$new(ch, query)) - ldt2 <- LargeDataTable$new(ch, query, countQuery = NULL)) + ldt2 <- LargeDataTable$new(ch, query, countQuery = NULL) checkmate::expect_string(ldt2$countQuery) checkmate::expect_class(largeTableView("foo"), "shiny.tag") From 1a7f5db413532596aaf7af8513ba956a4db61a99 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Tue, 18 Jul 2023 08:51:37 -0700 Subject: [PATCH 10/13] fixed typo in tests --- inst/cohort-diagnostics-ref/migrations.csv | 2 +- .../test-components-largeTableViewer.R | 46 +++++++++---------- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/inst/cohort-diagnostics-ref/migrations.csv b/inst/cohort-diagnostics-ref/migrations.csv index 1c3fdda5..01b71c47 100644 --- a/inst/cohort-diagnostics-ref/migrations.csv +++ b/inst/cohort-diagnostics-ref/migrations.csv @@ -2,4 +2,4 @@ migrationFile,migrationOrder Migration_1-v3_1_0_time_id.sql,1 Migration_2-v3_1_0_ir_person_years.sql,2 Migration_3-v3_2_0_suport_cohort_subsets.sql,3 -Migration_4-v3_2_1_cohort_name_field.sql,4 \ No newline at end of file +Migration_4-v3_2_1_cohort_name_field.sql,4 diff --git a/tests/testthat/test-components-largeTableViewer.R b/tests/testthat/test-components-largeTableViewer.R index 015e1cf3..2b7e5609 100644 --- a/tests/testthat/test-components-largeTableViewer.R +++ b/tests/testthat/test-components-largeTableViewer.R @@ -40,35 +40,35 @@ test_that("Large Data Table R6 Class works", { df %>% dplyr::mutate(fizzBuzz = ifelse(.data$rowId %% 3 == 0, "fizz", "buzz")) }, columns = list(row_id = reactable::colDef("row id") - ), - expr = { + ), + expr = { - session$setInputs(pageSize = 10) + session$setInputs(pageSize = 10) - expect_equal(rowCount(), ldt$getCount(min_row = 1)) - expect_equal(pageNum(), 1) - expect_equal(pageCount(), ceiling(ldt$getCount(min_row = 1) / 10)) + expect_equal(rowCount(), ldt$getCount(min_row = 1)) + expect_equal(pageNum(), 1) + expect_equal(pageCount(), ceiling(ldt$getCount(min_row = 1) / 10)) - session$setInputs(pageSize = 100) - expect_equal(pageNum(), 1) - expect_equal(pageCount(), ceiling(ldt$getCount(min_row = 1) / 100)) + session$setInputs(pageSize = 100) + expect_equal(pageNum(), 1) + expect_equal(pageCount(), ceiling(ldt$getCount(min_row = 1) / 100)) - session$setInputs(pageNum = 5) - expect_equal(pageNum(), 5) - expect_equal(output$pageNumber, "401 - 500 of 1,000,000 rows") + session$setInputs(pageNum = 5) + expect_equal(pageNum(), 5) + expect_equal(output$pageNumber, "401 - 500 of 1,000,000 rows") - checkmate::expect_data_frame(dataPage(), nrow = 100, ncols = 3) - checkmate::expect_names(colnames(dataPage()), must.include = c("rowId", "value", "fizzBuzz")) - expect_true(all(dataPage()$fizzBuzz == ifelse(dataPage()$rowId %% 3 == 0, "fizz", "buzz"))) + checkmate::expect_data_frame(dataPage(), nrow = 100, ncols = 3) + checkmate::expect_names(colnames(dataPage()), must.include = c("rowId", "value", "fizzBuzz")) + expect_true(all(dataPage()$fizzBuzz == ifelse(dataPage()$rowId %% 3 == 0, "fizz", "buzz"))) - checkmate::expect_class(output$tableView, "json") - checkmate::expect_class(output$pageActionButtons , "list") + checkmate::expect_class(output$tableView, "json") + checkmate::expect_class(output$pageActionButtons, "list") - session$setInputs(pageSize = 1e6) - expect_equal(pageCount(), 1) - checkmate::expect_class(output$pageActionButtons , "list") - checkmate::expect_file_exists(output$downloadFull) - } - ) + session$setInputs(pageSize = 1e6) + expect_equal(pageCount(), 1) + checkmate::expect_class(output$pageActionButtons, "list") + checkmate::expect_file_exists(output$downloadFull) + } + ) }) \ No newline at end of file From aa067cffb9259d189bd7182c3e3324fc1e18c955 Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Thu, 20 Jul 2023 15:07:10 -0700 Subject: [PATCH 11/13] Minor changes to table --- R/cohort-diagnostics-characterization.R | 180 ++++++++---------------- R/cohort-diagnostics-cohort-overlap.R | 1 + R/cohort-diagnostics-shared.R | 25 ++++ R/components-largeTableViewer.R | 20 +-- 4 files changed, 98 insertions(+), 128 deletions(-) diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index 00c06e46..55802eb2 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -218,21 +218,24 @@ characterizationView <- function(id) { shiny::tabPanel( title = "Group by Database", shiny::fluidRow( - shiny::column(width = 8), + shiny::column(width = 6, + shiny::selectInput(inputId = ns("sortByRaw"), + label = "Sort By", + choices = NULL) + ), + shiny::column(width = 2, + shiny::radioButtons(inputId = ns("shortByRawAsc"), + choices = c(ascending = "ASC", descending = "DESC"), + label = "order") + ), shiny::column(width = 4, shiny::textInput(inputId = ns("generalSearchString"), label = "", - placeholder = "Search covariates")) + placeholder = "Search covariates") + ), ), largeTableView(id = ns("rawCharTbl"), selectedPageSize = 100) ), - shiny::tabPanel( - title = "Group by Database OLD", - shinycssloaders::withSpinner( - reactable::reactableOutput(outputId = ns("characterizationTableRaw")) - ), - reactableCsvDownloadButton(ns, "characterizationTableRaw") - ), shiny::tabPanel( title = "Group by Time ID", shinycssloaders::withSpinner( @@ -480,7 +483,7 @@ characterizationModule <- function( targetCohortId <- shiny::reactive(input$targetCohort) getCohortConceptSets <- shiny::reactive({ - if (!hasData(input$targetCohort)) { + if (!hasData(input$targetCohort) | nrow(dataSource$conceptSets) == 0) { return(NULL) } @@ -841,95 +844,6 @@ characterizationModule <- function( return(data) }) - rawTableReactable <- shiny::reactive({ - data <- cohortCharacterizationDataFiltered() - if (is.null(data)) { - return(NULL) - } - - progress <- shiny::Progress$new() - on.exit(progress$close()) - progress$set( - message = "Post processing: Rendering table", - value = 0 - ) - - keyColumnFields <- - c("covariateName", "analysisName", "temporalChoices", "conceptId") - - if (input$characterizationColumnFilters == "Mean and Standard Deviation") { - dataColumnFields <- c("mean", "sd") - } else { - dataColumnFields <- c("mean") - } - countLocation <- 1 - - - if (!hasData(data)) { - return(NULL) - } - - countsForHeader <- - getDisplayTableHeaderCount( - dataSource = dataSource, - databaseIds = data$databaseId %>% unique(), - cohortIds = data$cohortId %>% unique(), - source = "cohort", - fields = "Persons" - ) - - data <- data %>% - dplyr::select( - "covariateName", - "analysisName", - "startDay", - "endDay", - "conceptId", - "isBinary", - "mean", - "sd", - "cohortId", - "databaseId", - "temporalChoices" - ) - showAsPercentage <- any(input$proportionOrContinuous == "Proportion", all(data$isBinary == "Y")) - if (input$proportionOrContinuous == "Proportion") { - data <- data %>% - dplyr::filter(.data$isBinary == "Y") %>% - dplyr::select(-"isBinary") - } else if (input$proportionOrContinuous == "Continuous") { - data <- data %>% - dplyr::filter(.data$isBinary == "N") %>% - dplyr::select(-"isBinary") - } - - if (hasData(selectedConceptSets())) { - if (hasData(conceptSetIds())) { - data <- data %>% - dplyr::filter(.data$conceptId %in% getFilteredConceptIds()) - } - } - shiny::validate(shiny::need(hasData(data), "No data for selected combination")) - - getDisplayTableGroupedByDatabaseId( - data = data, - databaseTable = databaseTable, - headerCount = countsForHeader, - keyColumns = keyColumnFields, - countLocation = countLocation, - dataColumns = dataColumnFields, - showDataAsPercent = showAsPercentage, - sort = TRUE, - pageSize = 100 - ) - }) - - output$characterizationTableRaw <- reactable::renderReactable(expr = { - data <- rawTableReactable() - shiny::validate(shiny::need(hasData(data), "No data for selected combination")) - return(data) - }) - rawTableTimeIdReactable <- shiny::reactive({ @@ -1038,7 +952,8 @@ characterizationModule <- function( cohort_id = targetCohortId(), results_database_schema = dataSource$resultsDatabaseSchema, is_binary = binary, - concept_ids = conceptIds + concept_ids = conceptIds, + time_invariant_search = -1 %in% selectedTimeIds() ) }) @@ -1050,10 +965,17 @@ characterizationModule <- function( return(input$generalSearchString) }) + + getOrderbyCol <- shiny::reactive({ + input$sortByRaw + }) + # params with default reactive behaviour inputParams <- shiny::reactive({ params <- inputButtonParams() params$search_str <- getSearchStr() + params$order_by_col <- getOrderbyCol() + params$order_desc <- input$shortByRawAsc == "DESC" return(params) }) @@ -1065,21 +987,37 @@ characterizationModule <- function( dbId1 <- databaseIds[1] if (!is.null(dbId1)) { columnDefinitions <- list( - covariateName = reactable::colDef(name = "Covariate Name"), + covariateName = reactable::colDef(name = "Covariate Name", minWidth = 200), analysisName = reactable::colDef(name = "Analysis Name"), temporalChoices = reactable::colDef(name = "Temporal Choices"), - conceptId = reactable::colDef(name = "Concept Id") + conceptId = reactable::colDef(name = "Concept Id"), + isBinary = reactable::colDef(show = FALSE) ) columnGroups <- list() - for (dbi in databaseIds) { + sortChoices <- list( + "Concept Id" = "tcr.concept_id", + "Analysis Name" = "tar.analysis_name", + "Covaraiate Name" = "tcr.covariate_name", + "Temporal Choices" = "ttr.time_id" + ) + + for (i in 1:length(databaseIds)) { + dbi <- databaseIds[i] columnIdent <- SqlRender::snakeCaseToCamelCase(paste0("mean_", dbi)) - # TODO: display as percentage and any nice graphics for view - columnDefinitions[[columnIdent]] <- reactable::colDef(name = "Mean") + columnDefinitions[[columnIdent]] <- reactable::colDef(name = "Mean", + cell = formatCellByBinaryType()) + columnIdentSd <- SqlRender::snakeCaseToCamelCase(paste0("sd_", dbi)) - columnDefinitions[[columnIdentSd]] <- reactable::colDef(name = "sd") + columnDefinitions[[columnIdentSd]] <- reactable::colDef(name = "sd", + show = input$characterizationColumnFilters == "Mean and Standard Deviation", + cell = formatDataCellValueInDisplayTable(showDataAsPercent = FALSE)) + groupCols <- c(columnIdent) + if (input$characterizationColumnFilters == "Mean and Standard Deviation") + groupCols <- c(columnIdent, columnIdentSd) + databaseName <- databaseTable %>% dplyr::filter(.data$databaseId == dbi) %>% @@ -1087,10 +1025,14 @@ characterizationModule <- function( dplyr::pull() columnGroups[[length(columnGroups) + 1]] <- reactable::colGroup(name = databaseName, - columns = c(columnIdent, columnIdentSd), - align = "center") + columns = groupCols, + align = "center") + + sortChoices[[paste(databaseName, "mean")]] <- paste0("t", i, ".mean") } + updateSelectInput(inputId = "sortByRaw", choices = sortChoices) + sql <- " SELECT @select_stament @@ -1099,7 +1041,7 @@ characterizationModule <- function( LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t1 ON ( tcr.covariate_id = t1.covariate_id AND t1.database_id = '@db_id_1' ) - INNER JOIN @results_database_schema.@table_prefixtemporal_time_ref ttr ON ttr.time_id = t1.time_id + LEFT JOIN @results_database_schema.@table_prefixtemporal_time_ref ttr ON ttr.time_id = t1.time_id @join_string @@ -1113,9 +1055,10 @@ characterizationModule <- function( WHEN ttr.start_day IS NULL THEN 'Time Invariant' ELSE CONCAT('T (', ttr.start_day, 'd to ', ttr.end_day, 'd)') END as temporal_choices, - + tcr.concept_id, + is_binary, t1.mean as mean_@db_id_1, - t1.sd as sd_@db_id_1 " + t1.sd as sd_@db_id_1" joinTemplate <- @@ -1132,10 +1075,7 @@ characterizationModule <- function( dbIdi <- databaseIds[i] tplSql <- c(tplSql, SqlRender::render(joinTemplate, i = i, db_id_i = dbIdi)) whereStment <- c(whereStment, sprintf("t%s.cohort_id IS NOT NULL", i)) - selects <- SqlRender::render(", - --DB t@i @dbIdi - t@i.mean as mean_@db_id_i, - t@i.sd as sd_@db_id_i", i = i, db_id_i = dbIdi) + selects <- SqlRender::render(", t@i.mean as mean_@db_id_i, t@i.sd as sd_@db_id_i", i = i, db_id_i = dbIdi) } selectSt <- paste(selectSt, paste(selects, collapse = " ")) } @@ -1145,16 +1085,20 @@ characterizationModule <- function( paramSql <- " + {DEFAULT @order_by_col = tcr.covariate_name} {@analysis_ids != \"\"} ? { AND tcr.analysis_id IN (@analysis_ids)} {@domain_ids != \"\"} ? { AND tar.domain_id IN (@domain_ids)} {@cohort_id != \"\"} ? { AND t1.cohort_id IN (@cohort_id)} - {@time_id != \"\"} ? { AND (ttr.time_id IN (@time_id) OR ttr.time_id IS NULL OR ttr.time_id = 0)} + {@time_id != \"\"} ? { AND (ttr.time_id IN (@time_id) {@time_invariant_search} ? {OR ttr.time_id IS NULL OR ttr.time_id = 0})} {@use_database_id} ? { AND t1.database_id IN (@database_id)} {@is_binary != ''} ? {AND lower(is_binary) = '@is_binary'} {@concept_ids != ''} ? {AND tcr.concept_id IN (@concept_ids)} - {@search_str != ''} ? {AND lower(CONCAT(tcr.covariate_name, tar.analysis_name)) LIKE lower('%@search_str%')} + {@search_str != ''} ? {AND lower(CONCAT(tcr.covariate_name, tar.analysis_name, tcr.concept_id)) LIKE lower('%@search_str%')} + + --- ORDER + {@order_by_col != ''} ? {ORDER BY @order_by_col {@order_desc} ? {DESC} : {ASC}} " - + baseQuery <- SqlRender::render(sql, select_stament = selectSt, db_id_1 = dbId1, diff --git a/R/cohort-diagnostics-cohort-overlap.R b/R/cohort-diagnostics-cohort-overlap.R index 31793571..f22500e9 100644 --- a/R/cohort-diagnostics-cohort-overlap.R +++ b/R/cohort-diagnostics-cohort-overlap.R @@ -577,6 +577,7 @@ cohortOverlapModule <- function(id, pagination = TRUE, showPagination = TRUE, showPageInfo = TRUE, + defaultExpanded = TRUE, highlight = TRUE, striped = TRUE, compact = TRUE, diff --git a/R/cohort-diagnostics-shared.R b/R/cohort-diagnostics-shared.R index 6292c503..509342b5 100644 --- a/R/cohort-diagnostics-shared.R +++ b/R/cohort-diagnostics-shared.R @@ -36,6 +36,31 @@ hasData <- function(data) { return(TRUE) } +# Useful if you want to include isBinary in an invisible column and then have the result display as a percentage or +# Not depending on this value +formatCellByBinaryType <- function() { + reactable::JS( + "function(data) { + let binaryCol = data.allCells.find(x => x.column.id == 'isBinary') + if (binaryCol !== undefined) { + if(binaryCol.value == 'Y') { + if (isNaN(parseFloat(data.value))) return data.value; + if (Number.isInteger(data.value) && data.value > 0) return (100 * data.value).toFixed(0).toString().replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,') + '%'; + if (data.value > 999) return (100 * data.value).toFixed(2).replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,') + '%'; + if (data.value < 0) return '<' + (Math.abs(data.value) * 100).toFixed(2) + '%'; + return (100 * data.value).toFixed(1) + '%'; + } + } + if (isNaN(parseFloat(data.value))) return data.value; + if (Number.isInteger(data.value) && data.value > 0) return data.value.toFixed(0).toString().replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,'); + if (data.value > 999) return data.value.toFixed(1).toString().replace(/(\\d)(?=(\\d{3})+(?!\\d))/g, '$1,'); + if (data.value < 0) return '<' + Math.abs(data.value.toFixed(3)); + + return data.value.toFixed(1); + }") +} + + formatDataCellValueInDisplayTable <- function(showDataAsPercent = FALSE) { if (showDataAsPercent) { diff --git a/R/components-largeTableViewer.R b/R/components-largeTableViewer.R index 5e0d60ee..dc9235d8 100644 --- a/R/components-largeTableViewer.R +++ b/R/components-largeTableViewer.R @@ -163,16 +163,16 @@ largeTableView <- function(id, pageSizeChoices = c(10,25,50,100), selectedPageSi shiny::tags$head( shiny::tags$style(type = "text/css", inlineStyle) ), - shiny::fluidRow( - if (fullDownloads) { - shiny::column( - width = 4, - shiny::downloadButton(ns("downloadFull"), - label = "Download (Full)", - icon = shiny::icon("download")) - ) - } - ), + shiny::fluidRow( + if (fullDownloads) { + shiny::column( + width = 4, + shiny::downloadButton(ns("downloadFull"), + label = "Download", + icon = shiny::icon("download")) + ) + } + ), shinycssloaders::withSpinner(reactable::reactableOutput(ns("tableView"))), shiny::fluidRow( shiny::column( From ee09c18b7b4855c227eba94741bf4f2cb6b8c2dd Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Mon, 24 Jul 2023 11:03:30 -0700 Subject: [PATCH 12/13] SOlution for query that works but not if database t1 is empty --- R/cohort-diagnostics-characterization.R | 402 +++++++++--------- ...test-cohort-diagnostics-characterization.R | 5 - 2 files changed, 212 insertions(+), 195 deletions(-) diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index 55802eb2..b1c6e474 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -237,11 +237,25 @@ characterizationView <- function(id) { largeTableView(id = ns("rawCharTbl"), selectedPageSize = 100) ), shiny::tabPanel( - title = "Group by Time ID", - shinycssloaders::withSpinner( - reactable::reactableOutput(outputId = ns("characterizationTableRawGroupedByTime")) + title = "Group by Time Windows", + shiny::fluidRow( + shiny::column(width = 6, + shiny::selectInput(inputId = ns("sortByRawTemporal"), + label = "Sort By", + choices = NULL) + ), + shiny::column(width = 2, + shiny::radioButtons(inputId = ns("shortByRawAscTemporal"), + choices = c(ascending = "ASC", descending = "DESC"), + label = "order") + ), + shiny::column(width = 4, + shiny::textInput(inputId = ns("generalSearchStringTemporal"), + label = "", + placeholder = "Search covariates") + ), ), - reactableCsvDownloadButton(ns, "characterizationTableRawGroupedByTime") + largeTableView(id = ns("rawCharTblTemporal"), selectedPageSize = 100) ) ) ) @@ -769,62 +783,6 @@ characterizationModule <- function( return(data) }) - # Temporal characterization ------------ - rawCharacterizationOutput <- shiny::reactive({ - shiny::validate(shiny::need(length(selectedDatabaseIds()) > 0, "At least one data source must be selected")) - shiny::validate(shiny::need(length(targetCohortId()) == 1, "One target cohort must be selected")) - - progress <- shiny::Progress$new() - on.exit(progress$close()) - progress$set( - message = paste0( - "Retrieving characterization output for cohort id ", - targetCohortId(), - " cohorts and ", - length(selectedDatabaseIds()), - " data sources." - ), - value = 20 - ) - - data <- dataSource$connectionHandler$queryDb( - sql = "SELECT tcv.*, - ref.covariate_name, ref.analysis_id, ref.concept_id, - aref.analysis_name, aref.is_binary, aref.domain_id, - ttr.start_day, ttr.end_day - FROM @results_database_schema.@table_name tcv - INNER JOIN @results_database_schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id - INNER JOIN @results_database_schema.@analysis_ref_table_name aref ON aref.analysis_id = ref.analysis_id - LEFT JOIN @results_database_schema.@temporal_time_ref ttr ON ttr.time_id = tcv.time_id - WHERE ref.covariate_id IS NOT NULL - {@analysis_ids != \"\"} ? { AND ref.analysis_id IN (@analysis_ids)} - {@domain_ids != \"\"} ? { AND aref.domain_id IN (@domain_ids)} - {@cohort_id != \"\"} ? { AND tcv.cohort_id IN (@cohort_id)} - {@time_id != \"\"} ? { AND (tcv.time_id IN (@time_id) OR tcv.time_id IS NULL OR tcv.time_id = 0)} - {@use_database_id} ? { AND database_id IN (@database_id)} - ", - snakeCaseToCamelCase = TRUE, - analysis_ids = input$selectedRawAnalysisIds %>% unique(), - time_id = selectedTimeIds() %>% unique(), - use_database_id = !is.null(selectedDatabaseIds()), - database_id = quoteLiterals(selectedDatabaseIds()), - domain_ids = quoteLiterals(input$characterizationDomainIdFilter %>% unique()), - table_name = dataSource$prefixTable("temporal_covariate_value"), - ref_table_name = dataSource$prefixTable("temporal_covariate_ref"), - analysis_ref_table_name = dataSource$prefixTable("temporal_analysis_ref"), - temporal_time_ref = dataSource$prefixTable("temporal_time_ref"), - cohort_id = targetCohortId(), - results_database_schema = dataSource$resultsDatabaseSchema - ) %>% - dplyr::tibble() %>% - tidyr::replace_na(replace = list(timeId = -1)) %>% - dplyr::mutate(temporalChoices = ifelse(is.na(.data$startDay), - "Time Invariant", - paste0("T (", .data$startDay, "d to ", .data$endDay, "d)"))) - return(data) - }) - - shiny::observeEvent(input$targetCohort, { cohortConcepSets <- getCohortConceptSets() cohortConcepSetOptions <- c("", cohortConcepSets$id) @@ -835,99 +793,6 @@ characterizationModule <- function( choices = cohortConcepSetOptions) }) - ## cohortCharacterizationDataFiltered ---- - cohortCharacterizationDataFiltered <- shiny::eventReactive(input$generateRaw, { - data <- rawCharacterizationOutput() - if (!hasData(data)) { - return(NULL) - } - return(data) - }) - - - rawTableTimeIdReactable <- shiny::reactive({ - - data <- cohortCharacterizationDataFiltered() - - if (is.null(data)) { - return(NULL) - } - - progress <- shiny::Progress$new() - on.exit(progress$close()) - progress$set( - message = "Post processing: Rendering table", - value = 0 - ) - - showAsPercentage <- any(input$proportionOrContinuous == "Proportion", all(data$isBinary == "Y")) - if (input$proportionOrContinuous == "Proportion") { - data <- data %>% - dplyr::filter(.data$isBinary == "Y") %>% - dplyr::select(-"isBinary") - } else if (input$proportionOrContinuous == "Continuous") { - data <- data %>% - dplyr::filter(.data$isBinary == "N") %>% - dplyr::select(-"isBinary") - } - - temporalChoicesVar <- data$temporalChoices %>% unique() - - data <- - data %>% dplyr::inner_join(databaseTable %>% - dplyr::select("databaseId", "databaseName"), - by = "databaseId") - - if (hasData(selectedConceptSets())) { - if (hasData(conceptSetIds())) { - data <- data %>% - dplyr::filter(.data$conceptId %in% getFilteredConceptIds()) - } - } - - keyColumns <- c("covariateName", "analysisName", "conceptId", "databaseName") - data <- data %>% - dplyr::select( - "covariateName", - "analysisName", - "databaseName", - "temporalChoices", - "conceptId", - "mean", - "sd" - ) %>% - tidyr::pivot_wider( - id_cols = dplyr::all_of(keyColumns), - names_from = "temporalChoices", - values_from = "mean", - names_sep = "_" - ) %>% - dplyr::relocate(dplyr::all_of(c(keyColumns, temporalChoicesVar))) %>% - dplyr::arrange(dplyr::desc(dplyr::across(dplyr::starts_with("T (")))) - - if (any(stringr::str_detect( - string = colnames(data), - pattern = stringr::fixed("T (0") - ))) { - data <- data %>% - dplyr::arrange(dplyr::desc(dplyr::across(dplyr::starts_with("T (0")))) - } - dataColumns <- temporalChoicesVar - progress$set( - message = "Rendering table", - value = 80 - ) - - getDisplayTableSimple( - data = data, - keyColumns = keyColumns, - dataColumns = dataColumns, - showDataAsPercent = showAsPercentage, - pageSize = 100 - ) - }) - - # Params when user presses button inputButtonParams <- shiny::eventReactive(input$generateRaw, { conceptIds <- getFilteredConceptIds() @@ -971,7 +836,7 @@ characterizationModule <- function( }) # params with default reactive behaviour - inputParams <- shiny::reactive({ + inputParamsRaw <- shiny::reactive({ params <- inputButtonParams() params$search_str <- getSearchStr() params$order_by_col <- getOrderbyCol() @@ -979,6 +844,30 @@ characterizationModule <- function( return(params) }) + getSearchStrTemporal <- shiny::reactive({ + if (input$generalSearchStringTemporal == "" || + is.na(input$generalSearchStringTemporal) || + is.null(input$generalSearchStringTemporal)) + return('') + + return(input$generalSearchStringTemporal) + }) + + getOrderbyColTemporal <- shiny::reactive({ + input$sortByRawTemporal + }) + + + # params with default reactive behaviour + inputParamsRawTemporal <- shiny::reactive({ + params <- inputButtonParams() + params$search_str <- getSearchStrTemporal() + params$order_by_col <- getOrderbyColTemporal() + params$order_desc <- input$shortByRawAscTemporal == "DESC" + params$time_id <- "" + return(params) + }) + # Set real query from dynamic data # The following is a lot of dynamically generated sql to create a pivoted table to allow # Side by side view af covariate means @@ -1005,12 +894,12 @@ characterizationModule <- function( for (i in 1:length(databaseIds)) { dbi <- databaseIds[i] - columnIdent <- SqlRender::snakeCaseToCamelCase(paste0("mean_", dbi)) + columnIdent <- paste0("mean", i) columnDefinitions[[columnIdent]] <- reactable::colDef(name = "Mean", cell = formatCellByBinaryType()) - columnIdentSd <- SqlRender::snakeCaseToCamelCase(paste0("sd_", dbi)) + columnIdentSd <- paste0("sd", i) columnDefinitions[[columnIdentSd]] <- reactable::colDef(name = "sd", show = input$characterizationColumnFilters == "Mean and Standard Deviation", cell = formatDataCellValueInDisplayTable(showDataAsPercent = FALSE)) @@ -1028,25 +917,24 @@ characterizationModule <- function( columns = groupCols, align = "center") - sortChoices[[paste(databaseName, "mean")]] <- paste0("t", i, ".mean") + sortChoices[[paste(databaseName, "mean")]] <- paste0("mean", i) } - - updateSelectInput(inputId = "sortByRaw", choices = sortChoices) + updateSelectInput(inputId = "sortByRaw", choices = sortChoices, selected = "mean1") sql <- " - SELECT @select_stament + SELECT @select_stament - FROM @results_database_schema.@table_prefixtemporal_covariate_ref tcr - INNER JOIN @results_database_schema.@table_prefixtemporal_analysis_ref tar ON tar.analysis_id = tcr.analysis_id - LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t1 ON ( - tcr.covariate_id = t1.covariate_id AND t1.database_id = '@db_id_1' - ) - LEFT JOIN @results_database_schema.@table_prefixtemporal_time_ref ttr ON ttr.time_id = t1.time_id + FROM @results_database_schema.@table_prefixtemporal_covariate_ref tcr + INNER JOIN @results_database_schema.@table_prefixtemporal_analysis_ref tar ON tar.analysis_id = tcr.analysis_id + LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t1 ON ( + tcr.covariate_id = t1.covariate_id AND t1.database_id = '@db_id_1' + ) + LEFT JOIN @results_database_schema.@table_prefixtemporal_time_ref ttr ON ttr.time_id = t1.time_id - @join_string + @join_string - WHERE tcr.covariate_id IS NOT NULL - @where_clasuses" + WHERE tcr.covariate_id IS NOT NULL + @where_clasuses" selectSt <- " tcr.covariate_name, @@ -1057,27 +945,28 @@ characterizationModule <- function( END as temporal_choices, tcr.concept_id, is_binary, - t1.mean as mean_@db_id_1, - t1.sd as sd_@db_id_1" - + t1.mean as mean1, + t1.sd as sd1" joinTemplate <- - "LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t@i ON ( + " + -- db @db_id_i + LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t@i ON ( t1.cohort_id = t@i.cohort_id AND t1.time_id = t@i.time_id AND t1.covariate_id = t@i.covariate_id - AND t2.database_id = '@db_id_i' + AND t@i.database_id = '@db_id_i' )" whereStment <- c("t1.cohort_id IS NOT NULL") tplSql <- c() if (length(databaseIds) > 1) { - for (i in 2:min(2, length(databaseIds))) { + for (i in 2:length(databaseIds)) { dbIdi <- databaseIds[i] tplSql <- c(tplSql, SqlRender::render(joinTemplate, i = i, db_id_i = dbIdi)) whereStment <- c(whereStment, sprintf("t%s.cohort_id IS NOT NULL", i)) - selects <- SqlRender::render(", t@i.mean as mean_@db_id_i, t@i.sd as sd_@db_id_i", i = i, db_id_i = dbIdi) + colSelects <- SqlRender::render(",t@i.mean as mean@i, t@i.sd as sd@i", i = i) + selectSt <- paste(selectSt, colSelects) } - selectSt <- paste(selectSt, paste(selects, collapse = " ")) } tplSql <- paste(tplSql, collapse = "\n") whereStment <- paste("AND (", paste(whereStment, collapse = " OR "), ")") @@ -1086,6 +975,7 @@ characterizationModule <- function( paramSql <- " {DEFAULT @order_by_col = tcr.covariate_name} + {DEFAULT @order_desc = TRUE} {@analysis_ids != \"\"} ? { AND tcr.analysis_id IN (@analysis_ids)} {@domain_ids != \"\"} ? { AND tar.domain_id IN (@domain_ids)} {@cohort_id != \"\"} ? { AND t1.cohort_id IN (@cohort_id)} @@ -1094,45 +984,177 @@ characterizationModule <- function( {@is_binary != ''} ? {AND lower(is_binary) = '@is_binary'} {@concept_ids != ''} ? {AND tcr.concept_id IN (@concept_ids)} {@search_str != ''} ? {AND lower(CONCAT(tcr.covariate_name, tar.analysis_name, tcr.concept_id)) LIKE lower('%@search_str%')} + " - --- ORDER + orderClause <- " + --- ORDER {@order_by_col != ''} ? {ORDER BY @order_by_col {@order_desc} ? {DESC} : {ASC}} " baseQuery <- SqlRender::render(sql, select_stament = selectSt, - db_id_1 = dbId1, + db_id_1 = databaseIds[1], join_string = tplSql, where_clasuses = whereStment, warnOnMissingParameters = FALSE) + countQuery <- SqlRender::render(sql, select_stament = "count(*)", - db_id_1 = dbId1, + db_id_1 = databaseIds[1], join_string = tplSql, where_clasuses = whereStment, warnOnMissingParameters = FALSE) - baseQuery <- paste(baseQuery, paramSql) + baseQuery <- paste(baseQuery, paramSql, orderClause) countQuery <- paste(countQuery, paramSql) ldt <- LargeDataTable$new(connectionHandler = dataSource$connectionHandler, baseQuery = baseQuery, countQuery = countQuery) + largeTableServer(id = "rawCharTbl", ldt, - inputParams = inputParams, + inputParams = inputParamsRaw, columns = columnDefinitions, columnGroups = columnGroups) } - }) + timeIds <- selectedTimeIds() + if (length(timeIds) > 0) { - output$characterizationTableRawGroupedByTime <- reactable::renderReactable(expr = { - data <- rawTableTimeIdReactable() - shiny::validate(shiny::need(hasData(data), "No data for selected combination")) - return(data) - }) - } + columnDefinitionsT <- list( + covariateName = reactable::colDef(name = "Covariate Name", minWidth = 200), + analysisName = reactable::colDef(name = "Analysis Name"), + temporalChoices = reactable::colDef(name = "Temporal Choices"), + conceptId = reactable::colDef(name = "Concept Id"), + isBinary = reactable::colDef(show = FALSE) + ) - ) + columnGroupsT <- list() + + sortChoices <- list( + "Concept Id" = "tcr.concept_id", + "Analysis Name" = "tar.analysis_name", + "Covaraiate Name" = "tcr.covariate_name", + "Temporal Choices" = "ttr.time_id" + ) + + for (i in 1:length(timeIds)) { + timeIdi <- timeIds[i] + columnIdent <- paste0("mean", i) + columnDefinitionsT[[columnIdent]] <- reactable::colDef(name = "Mean", + cell = formatCellByBinaryType()) + + + columnIdentSd <- paste0("sd", i) + columnDefinitionsT[[columnIdentSd]] <- reactable::colDef(name = "sd", + show = input$characterizationColumnFilters == "Mean and Standard Deviation", + cell = formatDataCellValueInDisplayTable(showDataAsPercent = FALSE)) + groupCols <- c(columnIdent) + if (input$characterizationColumnFilters == "Mean and Standard Deviation") + groupCols <- c(columnIdent, columnIdentSd) + + + temporalChoiceName <- timeIdOptions %>% + dplyr::distinct() %>% + dplyr::filter(.data$primaryTimeId == 1) %>% + dplyr::filter(.data$isTemporal == 1) %>% + dplyr::filter(.data$timeId == timeIdi) %>% + dplyr::arrange(.data$sequence) %>% + dplyr::pull("temporalChoices") + + columnGroupsT[[length(columnGroups) + 1]] <- reactable::colGroup(name = temporalChoiceName, + columns = groupCols, + align = "center") + + sortChoices[[paste(temporalChoiceName, "mean")]] <- paste0("mean", i) + } + updateSelectInput(inputId = "sortByRawTemporal", choices = sortChoices, selected = "mean1") + + sqlt <- " + SELECT @select_stament + + FROM @results_database_schema.@table_prefixtemporal_covariate_ref tcr + INNER JOIN @results_database_schema.@table_prefixtemporal_analysis_ref tar ON tar.analysis_id = tcr.analysis_id + LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t1 ON ( + {@time_id_1 != -1} ? {t1.time_id = @time_id_1} : {(t1.time_id IS NULL OR t1.time_id IN (0, -1))} + AND tcr.covariate_id = t1.covariate_id + ) + @join_string + + WHERE tcr.covariate_id IS NOT NULL + @where_clasuses + " + + selectSt <- " + t1.database_id, + tcr.covariate_name, + tar.analysis_name, + tcr.concept_id, + t1.mean as mean1, + t1.sd as sd1 + " + + temporalPivotJoinTpl <- " + LEFT JOIN @results_database_schema.@table_prefixtemporal_covariate_value t@i ON ( + {@time_id_i != -1} ? {t@i.time_id = @time_id_i} : {t@i.time_id IS NULL OR tcv@i.time_id = 0 OR tcv@i.time_id = -1} + AND t@i.cohort_id = t1.cohort_id + AND t@i.database_id = t1.database_id + AND t1.covariate_id = t@i.covariate_id + ) + " + + whereStment <- c("t1.cohort_id IS NOT NULL") + tplSql <- c() + + + if (length(timeIds) > 1) { + for (i in 2:length(timeIds)) { + timeIdi <- timeIds[i] + tplSql <- c(tplSql, SqlRender::render(temporalPivotJoinTpl, i = i, time_id_i = timeIdi)) + whereStment <- c(whereStment, sprintf("t%s.cohort_id IS NOT NULL", i)) + colSelects <- SqlRender::render(",t@i.mean as mean@i, t@i.sd as sd@i", i = i) + selectSt <- paste(selectSt, colSelects) + } + } + + tplSql <- paste(tplSql, collapse = "\n") + whereStment <- paste("AND (", paste(whereStment, collapse = " OR "), ")") + + + orderClause <- " + --- ORDER + {@order_by_col != ''} ? {ORDER BY @order_by_col {@order_desc} ? {DESC} : {ASC}} + " + + baseQueryTemporal <- SqlRender::render(sqlt, + select_stament = selectSt, + time_id_1 = timeIds[1], + join_string = tplSql, + where_clasuses = whereStment, + warnOnMissingParameters = FALSE) + + countQueryTemporal <- SqlRender::render(sqlt, + select_stament = "count(*)", + time_id_1 = timeIds[1], + join_string = tplSql, + where_clasuses = whereStment, + warnOnMissingParameters = FALSE) + + baseQueryTemporal <- paste(baseQueryTemporal, paramSql, orderClause) + countQueryTemporal <- paste(countQueryTemporal, paramSql) + + ldtTemporal <- LargeDataTable$new(connectionHandler = dataSource$connectionHandler, + baseQuery = baseQueryTemporal, + countQuery = countQueryTemporal) + + ## do the same for the temporal table + rawCharTblTemporal <- largeTableServer(id = "rawCharTblTemporal", + ldtTemporal, + inputParams = inputParamsRawTemporal, + columns = columnDefinitionsT, + columnGroups = columnGroupsT) + } + }) + }) } diff --git a/tests/testthat/test-cohort-diagnostics-characterization.R b/tests/testthat/test-cohort-diagnostics-characterization.R index 6754cdcc..8f730eb9 100644 --- a/tests/testthat/test-cohort-diagnostics-characterization.R +++ b/tests/testthat/test-cohort-diagnostics-characterization.R @@ -28,9 +28,6 @@ shiny::testServer(characterizationModule, args = list( checkmate::expect_list(selectionsPanel()) - rawTableTimeIdReactable() - rawTableReactable() - session$setInputs( targetCohort = 18347, targetDatabase = "Eunomia", @@ -38,7 +35,5 @@ shiny::testServer(characterizationModule, args = list( proportionOrContinuous = "Continuous", characterizationColumnFilters = "Mean and Standard Deviation" ) - rawTableTimeIdReactable() - rawTableReactable() cohortCharacterizationPrettyTable() }) \ No newline at end of file From fe55d30c0fc377d7c3c9a1cea0557c6f3776923d Mon Sep 17 00:00:00 2001 From: Jamie Gilbert Date: Tue, 25 Jul 2023 13:58:09 -0700 Subject: [PATCH 13/13] selected descedning results by default --- R/cohort-diagnostics-characterization.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index b1c6e474..4bd9f720 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -226,6 +226,7 @@ characterizationView <- function(id) { shiny::column(width = 2, shiny::radioButtons(inputId = ns("shortByRawAsc"), choices = c(ascending = "ASC", descending = "DESC"), + selected = "DESC", label = "order") ), shiny::column(width = 4, @@ -247,6 +248,7 @@ characterizationView <- function(id) { shiny::column(width = 2, shiny::radioButtons(inputId = ns("shortByRawAscTemporal"), choices = c(ascending = "ASC", descending = "DESC"), + selected = "DESC", label = "order") ), shiny::column(width = 4,