Adding phevaluator and datasources modules to develop. Also improving tests and components module.

.gitignore

@@ -3,3 +3,5 @@
 .RData
 .Ruserdata
 /.idea/
+rsconnect/rconnect.jnj.com/NHall6/phevaluator_v01.dcf
+errorReportSql.txt

DESCRIPTION

@@ -36,6 +36,7 @@ Imports:
     shinydashboard,
     shinyWidgets,
     SqlRender,
+    stringi,
     stringr,
     tibble,
     tidyr,

NAMESPACE

@@ -16,6 +16,7 @@ export(cohortOverlapView)
 export(compareCohortCharacterizationView)
 export(conceptsInDataSourceView)
 export(createCdDatabaseDataSource)
+export(createCustomColDefList)
 export(dataDiagnosticDrillServer)
 export(dataDiagnosticDrillViewer)
 export(dataDiagnosticHelperFile)
@@ -24,6 +25,9 @@ export(dataDiagnosticSummaryServer)
 export(dataDiagnosticSummaryViewer)
 export(dataDiagnosticViewer)
 export(databaseInformationView)
+export(datasourcesHelperFile)
+export(datasourcesServer)
+export(datasourcesViewer)
 export(descriptionAggregateFeaturesServer)
 export(descriptionAggregateFeaturesViewer)
 export(descriptionDechallengeRechallengeServer)
@@ -72,6 +76,7 @@ export(getLogoImage)
 export(incidenceRatesView)
 export(inclusionRulesView)
 export(indexEventBreakdownView)
+export(makeButtonLabel)
 export(orpahanConceptsView)
 export(phevaluatorHelperFile)
 export(phevaluatorServer)
@@ -99,6 +104,8 @@ export(predictionSettingsViewer)
 export(predictionValidationServer)
 export(predictionValidationViewer)
 export(predictionViewer)
+export(resultTableServer)
+export(resultTableViewer)
 export(sccsDiagnosticsSummaryServer)
 export(sccsDiagnosticsSummaryViewer)
 export(sccsHelperFile)

R/cohort-generator-main.R

@@ -226,7 +226,7 @@
 
       format_yesorno <- function(value) {
         # Render as an X mark or check mark
         if (value == "COMPLETE") "\u2714\ufe0f Yes" #if generation complete then green check mark with "yes"
         else "\u274c No" #if not then red x with "no"
       }
 
@@ -427,21 +427,21 @@
       # download buttons - counts
       output$downloadCohortCountsFull <- shiny::downloadHandler(
         filename = function() {
           paste('cohort-count-data-full', Sys.Date(), '.csv', sep='')
         },
         content = function(con) {
           utils::write.csv(getCohortGeneratorCohortCounts(
             connectionHandler = connectionHandler, 
             resultsSchema = resultsSchema,
             tablePrefix = resultDatabaseSettings$tablePrefix,
             databaseTable = resultDatabaseSettings$databaseTable,
             databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix
           ) %>%
             dplyr::select("cdmSourceName",
                           "cohortId",
                           "cohortName",
                           "cohortSubjects",
                           "cohortEntries"), con)
         }
       )
 
@@ -505,7 +505,7 @@
                                    "Generation Start Time", 
                                    "The time and date the cohort started generating"
                                  ),
-                                 format = reactable::colFormat(datetime = TRUE
+                                 format = reactable::colFormat(suffix = " mins"
                                  )),
                                endTime = reactable::colDef( 
                                  header = withTooltip(
@@ -533,19 +533,19 @@
       # download button - generation
       output$downloadCohortGeneration <- shiny::downloadHandler(
         filename = function() {
           paste('cohort-generation-data-', Sys.Date(), '.csv', sep='')
         },
         content = function(con) {
           utils::write.csv(getCohortGeneratorCohortMeta(
             connectionHandler = connectionHandler, 
             resultsSchema = resultsSchema,
             tablePrefix = resultDatabaseSettings$tablePrefix
           ) %>%
             dplyr::select("cohortId",
                           "cohortName",
                           "generationStatus",
                           "startTime",
                           "endTime"), con)
         }
       )
 
@@ -574,8 +574,8 @@
       cohortNames <- unique(inputVals$cohortName)
       databaseIds <- unique(inputVals$cdmSourceName)
       inputValsClean <- dplyr::ungroup(inputVals) %>%
-        dplyr::mutate(modeId = dplyr::case_when(
-          modeId==1 ~ "Subject",
+        dplyr::mutate('modeId' = dplyr::case_when(
+          .data$modeId==1 ~ "Subject",
           TRUE ~ "Record"
         )
         )
@@ -645,32 +645,32 @@
           #   return(invisible(NULL))
           # }
 
           selectedInputs(
             shinydashboard::box(
               status = 'warning', 
               width = "100%",
               title = 'Selected:',
               collapsible = T,
               collapsed = F,
               shiny::div(
                 shiny::fluidRow(
                   shiny::column(
                     width = 8,
                     shiny::tags$b("Cohort:"),
                     #unique(inputVals$cohortName[inputVals$cohortName %in% input$selectedCohortName])
                     input$selectedCohortName
                   ),
                   shiny::column(
                     width = 4,
                     shiny::tags$b("Database:"),
                     #unique(inputVals$cdmSourceName[inputVals$cdmSourceName == input$selectedDatabaseId])
                     input$selectedDatabaseId
                   ),
                   shiny::column(
                     width = 4,
                     shiny::tags$b("Level:"),
                     #unique(inputValsClean$modeId)[inputValsClean$modeId == input$selectedModeId]
                     input$selectedModeId
                   )
                 )
               )
@@ -678,102 +678,102 @@
           )
 
 
           data <- inputValsClean %>%
             dplyr::filter(cdmSourceName %in% input$selectedDatabaseId & 
                             cohortName %in% input$selectedCohortName &
                             modeId %in% input$selectedModeId
             )
 
           reactiveData <- shiny::reactive(data)
 
           if(!is.null(data)){
 
             output$attritionTable <- reactable::renderReactable(
               reactable::reactable(
                 data =  reactiveData() %>%
                   dplyr::select(c("cdmSourceName", "cohortName", "ruleName",
                                   "personCount", "dropCount",
                                   "dropPerc", "retainPerc")
                   )
 
                 ,
                 rownames = FALSE, 
                 defaultPageSize = 5,
                 showPageSizeOptions = T, 
                 striped = T,
                 columns = list(
                   cdmSourceName = reactable::colDef( 
                     filterable = TRUE,
                     header = withTooltip(
                       "Database Name", 
                       "The name of the database"
                     )),
                   cohortName = reactable::colDef( 
                     filterable = TRUE,
                     header = withTooltip(
                       "Cohort Name", 
                       "The name of the cohort"
                     )),
                   ruleName = reactable::colDef( 
                     header = withTooltip(
                       "Inclusion Rule Name", 
                       "The name of the inclusion rule"
                     )),
                   personCount = reactable::colDef( 
                     format = reactable::colFormat(separators = TRUE),
                     header = withTooltip(
                       "Subject/Record Count", 
                       "The number of subjects or records (depending on your selection) remaining after the inclusion rule was applied"
                     )),
                   dropCount = reactable::colDef( 
                     format = reactable::colFormat(separators = TRUE),
                     header = withTooltip(
                       "Number Lost", 
                       "The number of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied"
                     )),
                   dropPerc = reactable::colDef( 
                     format = reactable::colFormat(separators = TRUE),
                     header = withTooltip(
                       "Percentage Lost", 
                       "The percentage of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied compared to the previous rule count"
                     )),
                   retainPerc = reactable::colDef( 
                     format = reactable::colFormat(separators = TRUE),
                     header = withTooltip(
                       "Number Retained", 
                       "The number of subjects or records (depending on your selection) retained after the inclusion rule was applied compared to the previous rule count"
                     ))
                 ),
 
                 filterable = TRUE,
                 sortable = TRUE,
                 defaultColDef = reactable::colDef(
                   align = "left"
                 )
               )
             )
 
             #attrition plot
             output$attritionPlot <- plotly::renderPlotly(
               getCohortAttritionPlot(
                 data
               )
             )
 
             # download button
             output$downloadAttritionTable <- shiny::downloadHandler(
               filename = function() {
                 paste('cohort-attrition-data-', Sys.Date(), '.csv', sep='')
               },
               content = function(con) {
                 utils::write.csv(data()
                                  , con)
               }
             )
           }
 
           else{
             shiny::showNotification('data NULL')
           }
 
         }

R/components-data-viewer.R

@@ -9,11 +9,13 @@
 #' Result Table Viewer
 #'
 #' @param id string
+#' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used
 #'
 #' @return shiny module UI
 #' @export
 #'
-resultTableViewer <- function(id = "result-table") {
+resultTableViewer <- function(id = "result-table",
+                              downloadedFileName = NULL) {
   ns <- shiny::NS(id)
   shiny::div(# UI
     shinydashboard::box(
@@ -41,6 +43,7 @@
                 "Reactable.downloadDataCSV('",
                 ns('resultData'),
                 "', 'result-data-filtered-",
+                downloadedFileName,
                 Sys.Date(),
                 ".csv')"
               )
@@ -76,133 +79,43 @@
 # )
 
 
-
-
-
 create_colDefs_list <- function(df, customColDefs = NULL) {
   # Get the column names of the input data frame
   col_names <- colnames(df)
-
+  
   # Create an empty list to store the colDefs
   colDefs_list <- vector("list", length = length(col_names))
   names(colDefs_list) <- col_names
-
+  
   # Define custom colDefs for each column if provided
   if (!is.null(customColDefs)) {
     for (col in seq_along(col_names)) {
       if (col_names[col] %in% names(customColDefs)) {
         colDefs_list[[col]] <- customColDefs[[col_names[col]]]
       } else {
         colDefs_list[[col]] <- reactable::colDef(name = col_names[col])
       }
-
+      
       if (!is.null(customColDefs[[col_names[col]]]$header)) {
         colDefs_list[[col]]$header <- customColDefs[[col_names[col]]]$header
       }
-
+      
       if (!is.null(customColDefs[[col_names[col]]]$tooltip)) {
         colDefs_list[[col]]$header <-
           withTooltip(colDefs_list[[col]]$header, customColDefs[[col_names[col]]]$tooltip)
       }
     }
   } else {
     # Define default colDefs if customColDefs is not provided
     for (col in seq_along(col_names)) {
       colDefs_list[[col]] <- reactable::colDef(name = col_names[col])
     }
   }
-
+  
   # Return the list of colDefs
   return(colDefs_list)
 }
 
-# Function to check if a column is formatted like a JSON file
-# is_JSON_column <- function(column) {
-#   all(sapply(column, function(value) {
-#     suppressWarnings(jsonlite::fromJSON(value))
-#     !is.null(jsonlite::validate(value))
-#   }))
-# }
-# 
-# downloadJSON <- function(jsonData) {
-#   json <- jsonlite::fromJSON(jsonData)
-#   filename <- paste0("data-", Sys.Date(), ".json")
-#   jsonlite::write_json(json, file = filename)
-#   shiny::downloadHandler(
-#     filename = filename,
-#     content = function(file) {
-#       file.copy(filename, file)
-#     },
-#     contentType = "application/json"
-#   )
-# }
-
-# create_colDefs_list <- function(df, customColDefs = NULL) {
-#   # Get the column names of the input data frame
-#   col_names <- colnames(df)
-#   
-#   # Create an empty list to store the colDefs
-#   colDefs_list <- vector("list", length = length(col_names))
-#   names(colDefs_list) <- col_names
-#   
-#   # Define custom colDefs for each column if provided
-#   if (!is.null(customColDefs)) {
-#     for (col in seq_along(col_names)) {
-#       if (col_names[col] %in% names(customColDefs)) {
-#         colDefs_list[[col]] <- customColDefs[[col_names[col]]]
-#       } else {
-#         colDefs_list[[col]] <- reactable::colDef(name = col_names[col])
-#       }
-#       
-#       if (!is.null(customColDefs[[col_names[col]]]$header)) {
-#         colDefs_list[[col]]$header <- customColDefs[[col_names[col]]]$header
-#       }
-#       
-#       if (!is.null(customColDefs[[col_names[col]]]$tooltip)) {
-#         colDefs_list[[col]]$header <-
-#           withTooltip(colDefs_list[[col]]$header, customColDefs[[col_names[col]]]$tooltip)
-#       }
-#       
-#       # Check if the column is formatted like a JSON file
-#       if (is_JSON_column(df[[col_names[col]]])) {
-#         colDefs_list[[col]]$cell <- function(value) {
-#           tags$button(
-#             "Download JSON",
-#             onclick = paste0("downloadJSON('", value, "')")
-#           )
-#         }
-#       }
-#     }
-#   } else {
-#     # Define default colDefs if customColDefs is not provided
-#     for (col in seq_along(col_names)) {
-#       colDefs_list[[col]] <- reactable::colDef(name = col_names[col])
-#       
-#       # Check if the column is formatted like a JSON file
-#       if (is_JSON_column(df[[col_names[col]]])) {
-#         colDefs_list[[col]]$cell <- function(value) {
-#           tags$button(
-#             "Download JSON",
-#             onclick = paste0("downloadJSON('", value, "')")
-#           )
-#         }
-#       }
-#     }
-#   }
-#   
-#   # Return the list of colDefs
-#   return(colDefs_list)
-# }
-
-
-
-
-
-
-
-
-
-
 
 ohdsiReactableTheme <- reactable::reactableTheme(
   color = "white",
@@ -226,13 +139,15 @@
 #' @param id string, table id must match resultsTableViewer function
 #' @param df reactive that returns a data frame
 #' @param colDefsInput named list of reactable::colDefs
+#' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used
 #'
 #' @return shiny module server
 #' @export
 #'
 resultTableServer <- function(id, #string
                               df, #data.frame
-                              colDefsInput
+                              colDefsInput, #named list
+                              downloadedFileName = NULL #string
 ) #list of colDefs, can use checkmate::assertList, need a check that makes sure names = columns) {
   shiny::moduleServer(id,
                       function(input, output, session) {
@@ -258,18 +173,23 @@
                         })
 
                         #need to try adding browser() to all reactives to see why selected cols isnt working
+
 
                         colDefs <-
-                          shiny::reactive(create_colDefs_list(df = df()[, input$dataCols],
-                                                              customColDefs = colDefsInput))
+                          shiny::reactive({
+                            create_colDefs_list(df = df()[, input$dataCols],
+                                                              customColDefs = colDefsInput)
+                          })
 
-                        fullData <- shiny::reactive(df())
+                        fullData <- shiny::reactive({
+                          df()
+                          })
 
 
                         output$resultData <-
                           reactable::renderReactable({
 
-                            data = df()[, input$dataCols]
+                            data = df()[, input$dataCols, drop = F]
 
                             tryCatch({
 
@@ -289,18 +209,14 @@
                                 defaultColDef = reactable::colDef(align = "left")
                                 #, experimental
                                 #theme = ohdsiReactableTheme
-                              )},
-
-                              warning = function(w){
-                                shiny::showNotification("Select at least 2 columns!"); return(NULL)
-
-                              },
-
+                              )}
+                              ,
+
                               error = function(e){
-                                shiny::showNotification("Select at least 2 columns!"); return(NULL)
-
+                             #   shiny::showNotification("No columns selected!"); 
+                                return(NULL)
+
                               }
-
                             )
 
 
@@ -309,10 +225,10 @@
                         # download full data button
                         output$downloadDataFull <- shiny::downloadHandler(
                           filename = function() {
-                            paste('data-full-', Sys.Date(), '.csv', sep = '')
+                            paste('result-data-full-', downloadedFileName, Sys.Date(), '.csv', sep = '')
                           },
                           content = function(con) {
                             utils::write.csv(fullData(), con,
                                              row.names = F)
                           }
                         )