updating phevaluator module and adding datasources module skeleton

R/components-data-viewer.R

@@ -76,9 +76,6 @@ withTooltip <- function(value, tooltip, ...) {
 # )
 
 
-
-
-
 create_colDefs_list <- function(df, customColDefs = NULL) {
   # Get the column names of the input data frame
   col_names <- colnames(df)
@@ -116,93 +113,6 @@ create_colDefs_list <- function(df, customColDefs = NULL) {
   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",

R/datasources-main.R

@@ -0,0 +1,151 @@
+# @file datasources-main.R
+#
+# Copyright 2022 Observational Health Data Sciences and Informatics
+#
+# This file is part of OhdsiShinyModules
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+
+
+#' The location of the datasources module helper file
+#' 
+#' @details Returns the location of the datasources helper file
+#' 
+#' @return String location of the datasources helper file
+#' 
+#' @export 
+#'
+datasourcesHelperFile <- function() {
+  fileLoc <-
+    system.file('datasources-www', "datasources.html", package = "OhdsiShinyModules")
+  return(fileLoc)
+}
+
+
+#' The viewer of the datasources module
+#'
+#' @param id The unique reference id for the module
+#'
+#' @return The user interface to the datasources results viewer
+#' 
+#' @export
+#'
+datasourcesViewer <- function(id) {
+  ns <- shiny::NS(id)
+
+  shinydashboard::box(
+    status = 'info',
+    width = "100%",
+    title =  shiny::span(shiny::icon("database"), "Data Sources"),
+    solidHeader = TRUE,
+
+    shinydashboard::box(
+      collapsible = TRUE,
+      collapsed = FALSE,
+      title = shiny::span( shiny::icon("circle-question"), "Help & Information"),
+      width = "100%",
+      shiny::htmlTemplate(system.file("datasources-www", "datasources.html", package = utils::packageName()))
+    ),
+
+      shiny::tabsetPanel(
+        type = 'pills',
+        id = ns('mainPanel'),
+
+        shiny::tabPanel(
+          title = "Data Source Information",
+          resultTableViewer(ns("datasourcesTable"))
+        )
+       )
+      )
+}
+
+
+#' The module server for the main datasources module
+#'
+#' @param id The unique reference id for the module
+#' @param connectionHandler A connection to the database with the results
+#' @param resultDatabaseSettings A named list containing the datasources results database details (schema, table prefix) 
+#'
+#' @return The datasourcesmain module server
+#' 
+#' @export
+#'
+
+phevaluatorServer <- function(
+  id, 
+  connectionHandler, 
+  resultDatabaseSettings
+) {
+
+  shiny::moduleServer(
+    id,
+    function(input, output, session) {
+
+      withTooltip <- function(value, tooltip, ...) {
+        shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help",
+                   tippy::tippy(value, tooltip, ...))
+      }
+
+
+      dataTestSubjectsCovars <- getPhevalTestSubjectsCovars(
+            connectionHandler = connectionHandler,
+            resultsSchema = resultDatabaseSettings$schema,
+            tablePrefix = resultDatabaseSettings$tablePrefix,
+            databaseIds = input$selectedDatabaseIds,
+            phenotypes = input$selectedPhenoypes
+          ) 
+
+      #read in custom column name colDef list from rds file, generated by 
+      #heplers-componentsCreateCustomColDefList.R
+
+      phevalColList <- ParallelLogger::loadSettingsFromJson(system.file("components-columnInformation",
+                                                                        "phevaluator-colDefs.json",
+                                                                        package = "OhdsiShinyModules")
+      )
+
+      #define custom colDefs for SQL and JSON buttons
+      buttonColDefs <- list(
+        buttonSQL = reactable::colDef(header = withTooltip("SQL", "Downloads SQL code for the cohort"),
+                                      html = T
+        ),
+        buttonJSON = reactable::colDef(header = withTooltip("JSON", "Downloads JSON code for the cohort"),
+                                       html = T
+        ),
+        sql = reactable::colDef(show = F),
+        json = reactable::colDef(show = F)
+      )
+
+      #define custom column definitions and render the result table
+      customColDefs <- modifyList(phevalColList, buttonColDefs)
+
+
+      resultTableServer(id = "algorithmPerformanceResultsTable",
+                        df = dataAlgorithmPerformance,
+                        colDefsInput = customColDefs)
+
+      return(invisible(NULL))
+
+
+
+
+    })
+}
+
+
+
+
+
+
+
+

R/description-incidence.R

@@ -21,7 +21,7 @@
 #'
 #' @details
 #' The user specifies the id for the module
-#'
+#'+
 #' @param id  the unique reference id for the module
 #' 
 #' @return

R/evidence-synth-main.R

@@ -62,6 +62,9 @@ evidenceSynthesisViewer <- function(id=1) {
         ),
         shiny::tabPanel("SCCS Table",
                         reactable::reactableOutput(ns('esSccsTable'))
+        ),
+        shiny::tabPanel("Diagnostics Dashboard",
+                        reactable::reactableOutput(ns('diagnosticsTable'))
         )
       )
     #)
@@ -339,7 +342,6 @@ evidenceSynthesisServer <- function(
           )
         )
       )
-
     }
     )
 

R/helpers-componentsCreateCustomColDefList.R

@@ -1,5 +1,4 @@
 
-
 #' Creating a list of custom column definitions for use in reactables
 #'
 #' @param rawColNames The raw column names taken directly from the source
@@ -10,20 +9,27 @@
 #' column in the reactable
 #' @param case Optional argument to convert raw column names to snake or camel case. Defaults to NULL and preserves
 #' whatever raw column names are passed in
+#' @param customColDefOptions A list of lists, where the inner lists are any custom options from
+#' reactable::colDef for each column 
 #'
 #' @return A named list of reactable::colDef objects
-#' @export
-#'
-#' @examples
+#' @export 
 #' 
-#' 
-createCustomColDefList <- function(rawColNames, niceColNames, tooltipText, case = NULL) {
+createCustomColDefList <- function(rawColNames, niceColNames = NULL,
+                                   tooltipText = NULL, case = NULL,
+                                   customColDefOptions = NULL) {
   withTooltip <- function(value, tooltip, ...) {
     shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help",
                tippy::tippy(value, tooltip, ...))
   }
 
-  result <- vector("list", length(rawColNames))
+  if (is.null(niceColNames)) {
+    niceColNames <- rawColNames
+  }
+
+  if (is.null(tooltipText)) {
+    tooltipText <- rep("", length(rawColNames))
+  }
 
   if (!is.null(case)) {
     if (case == "snakeCaseToCamelCase") {
@@ -33,10 +39,22 @@ createCustomColDefList <- function(rawColNames, niceColNames, tooltipText, case
     }
   }
 
-  for (i in 1:length(rawColNames)) {
-    result[[i]] <- reactable::colDef(
-      header = withTooltip(niceColNames[[i]], tooltipText[[i]])
+  result <- vector("list", length(rawColNames))
+
+  if (is.null(customColDefOptions)) {
+    customColDefOptions <- vector("list", length(rawColNames))
+    for (i in seq_along(rawColNames)) {
+      customColDefOptions[[i]] <- list()
+    }
+  }
+
+  for (i in seq_along(rawColNames)) {
+    colDefOptions <- c(
+      list(name = rawColNames[[i]], header = withTooltip(niceColNames[[i]], tooltipText[[i]])),
+      customColDefOptions[[i]]
     )
+
+    result[[i]] <- do.call(reactable::colDef, colDefOptions)
   }
 
   names(result) <- rawColNames
@@ -45,22 +63,31 @@ createCustomColDefList <- function(rawColNames, niceColNames, tooltipText, case
 }
 
 
-
 # examples
-# createCustomColDefList(rawColNames = c("firstName", "lastName"),
-#                        niceColNames = c("First Name", "Last Name"),
-#                        tooltipText = c("The person's first name", "The person's last name"))
-# rawColNames <- c("col1", "col2", "col3")
-# niceColNames <- c("Column 1", "Column 2", "Column 3")
-# tooltipText <- c("Tooltip 1", "Tooltip 2", "Tooltip 3")# Sample data
-# 
-# Call the function
-# colDefs <- createCustomColDefList(rawColNames, niceColNames, tooltipText)
+# Define custom column definitions
+# customColDefs <- createCustomColDefList(
+#   rawColNames = mydf$raw,
+#   niceColNames = c("Name", "Age", "Country"),
+#   tooltipText = c("Person's Name", "Person's Age", "Country"),
+#   customColDefOptions = list(
+#     list(NULL),  # No aggregation for "Name" column
+#     list(aggregate = "mean"),  # Aggregate "Age" column using mean
+#     list(NULL)  # No aggregation for "Country" column
+#   )
+# )
 
 # use the below as a guide to save named colDef list as JSON then read it back!
 # test <- ParallelLogger::saveSettingsToJson(colDefs, "./inst/components-columnInformation/test.json")
 #loadTest <- ParallelLogger::loadSettingsFromJson("./inst/components-columnInformation/test.json")
 
 
-
-ParallelLogger::saveSettingsToJson(phevalColList, "./inst/components-columnInformation/phevaluator-colDefs.json")
+#' Make a label for an html button
+#'
+#' @param label The desired label for hte button
+#'
+#' @return html code to make a button label
+#' @export
+#'
+makeButtonLabel <- function(label) {
+  as.character(htmltools::tags$div(htmltools::tags$button(paste(label))))
+}