passing R check

- passing tests 78% coverage
- cleaning checks but still some notes

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: OhdsiShinyModules
 Type: Package
 Title: Repository of Shiny Modules for OHDSI Result Viewers
-Version: 2.1.5.9000
+Version: 2.2.0
 Author: Jenna Reps
 Maintainer: Jenna Reps <[email protected]>
 Description: Install this package to access useful shiny modules for building shiny apps to explore results using the OHDSI tools .

NAMESPACE

@@ -57,9 +57,6 @@ export(datasourcesViewer)
 export(estimationHelperFile)
 export(estimationServer)
 export(estimationViewer)
-export(evidenceSynthesisHelperFile)
-export(evidenceSynthesisServer)
-export(evidenceSynthesisViewer)
 export(getEnabledCdReports)
 export(getExampleConnectionDetails)
 export(getLogoImage)
@@ -104,3 +101,5 @@ export(reportServer)
 export(reportViewer)
 export(timeDistributionsView)
 export(visitContextView)
+importFrom(dplyr,"%>%")
+importFrom(rlang,.data)

NEWS.md

@@ -1,3 +1,11 @@
+OhdsiShinyModules v2.2.0
+========================
+- Combined cohort method, sccs and evidence synthesis into one estimation module with shared target and outcome ids
+- Characterizations now share the target id 
+- Updated tests to get them all working
+- Cleaned R check (but cohort incidence still has many notes)
+
+
 OhdsiShinyModules v2.1.5
 ========================
 Fixed bug of orphan concepts report not displaying

R/OhdsiShinyModules.R

@@ -20,8 +20,8 @@
 #' 
 #' @description A selection of shiny modules for exploring standardized OHDSI results 
 #'
-#' @docType package
 #' @name OhdsiShinyModules
+#' @keywords internal
 #' @importFrom dplyr %>%
 #' @importFrom rlang .data
-
+"_PACKAGE"

R/characterization-dechallengeRechallenge.R

@@ -52,6 +52,8 @@ characterizationDechallengeRechallengeViewer <- function(id) {
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
+#' @param targetId a reactive integer specifying the targetId of interest
+#' @param outcomeId a reactive integer specifying the outcomeId of interest
 #' 
 #' @return
 #' The server to the Dechallenge Rechallenge module
@@ -283,7 +285,7 @@ characterizationDechallengeRechallengeServer <- function(
               )
             )
             } else{
-              showNotification("No fails to display")
+              shiny::showNotification("No fails to display")
             }
           }
         }

R/characterization-incidence.R

@@ -50,12 +50,6 @@ custom_age_sort <- function(age_categories) {
   return(custom_order)
 }
 
-base_breaks <- function(n = 10){
-  function(x) {
-    axisTicks(log10(range(x, na.rm = TRUE)), log = TRUE, n = n)
-  }
-}
-
 break_setter = function(n = 5) {
   function(lims) {pretty(x = as.numeric(lims), n = n)}
 }
@@ -236,6 +230,10 @@ characterizationIncidenceViewer <- function(id) {
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
+#' @param parents a list of parent cohorts
+#' @param parentIndex an integer specifying the parent index of interest
+#' @param outcomes a reactive object specifying the outcomes of interest
+#' @param targetIds a reactive vector of integer specifying the targetIds of interest
 #' 
 #' @return
 #' The server to the prediction incidence module
@@ -245,7 +243,7 @@ characterizationIncidenceServer <- function(
     id, 
     connectionHandler,
     resultDatabaseSettings,
-    options, # this gets overwritten in code below - why here?
+    #options, # this gets overwritten in code below - why here?
     parents,
     parentIndex, # reactive
     outcomes, # reactive
@@ -648,8 +646,9 @@ characterizationIncidenceServer <- function(
           extractedData() %>%
             dplyr::relocate("tar", .before = "outcomes") %>%
             dplyr::select(-c("targetName", "outcomeName")) %>%
-            dplyr::rename(targetName = targetCohortName,
-                          outcomeName = outcomeCohortName) %>%
+            dplyr::rename(targetName = "targetCohortName",
+                          outcomeName = "outcomeCohortName"
+                          ) %>%
             dplyr::mutate(incidenceProportionP100p = as.numeric(.data$incidenceProportionP100p),
                           incidenceRateP100py = as.numeric(.data$incidenceRateP100py),
                           dplyr::across(dplyr::where(is.numeric), round, 4),
@@ -742,8 +741,8 @@ characterizationIncidenceServer <- function(
           ifelse(incidenceRateTarFilter() %in% filteredData()$tar,
           plotData <- filteredData() %>%
             dplyr::filter(.data$tar %in% incidenceRateTarFilter()) %>%
-            dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName),
-                          outcomeLabel = paste(outcomeIdShort, " = ", outcomeName)
+            dplyr::mutate(targetLabel = paste(.data$targetIdShort, " = ", .data$targetName),
+                          outcomeLabel = paste(.data$outcomeIdShort, " = ", .data$outcomeName)
                           ),
             shiny::validate("Selected TAR is not found in your result data. Revise input selections or select a different TAR.")
           )
@@ -1210,19 +1209,15 @@ characterizationIncidenceServer <- function(
 
           plotData <- plotData %>%
             dplyr::filter(#ageGroupName != "Any" & 
-                            genderName == "Any" & 
-                            startYear == "Any") %>%
-            dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName),
-                          outcomeLabel = paste(outcomeIdShort, " = ", outcomeName),
-                          ageGroupName = factor(ageGroupName, levels = custom_age_sort(ageGroupName), ordered = TRUE)
+                            .data$genderName == "Any" & 
+                              .data$startYear == "Any") %>%
+            dplyr::mutate(targetLabel = paste(.data$targetIdShort, " = ", .data$targetName),
+                          outcomeLabel = paste(.data$outcomeIdShort, " = ", .data$outcomeName),
+                          ageGroupName = factor(.data$ageGroupName, levels = custom_age_sort(.data$ageGroupName), ordered = TRUE)
             ) %>%
-            dplyr::rename("Target" = targetIdShort,
-                          "Outcome" = outcomeIdShort,
-                          "Age" = ageGroupName)
-
-          # plotHeightStandardAgeSex <- shiny::reactive({
-          #   paste(sum(length(unique(plotData$targetLabel)), length(unique(plotData$Age)), -3)*100, "px", sep="")
-          # })
+            dplyr::rename("Target" = "targetIdShort",
+                          "Outcome" = "outcomeIdShort",
+                          "Age" = "ageGroupName")
 
           # Get unique target and outcome labels
           unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300)
@@ -1241,9 +1236,9 @@ characterizationIncidenceServer <- function(
 
           base_plot <- ggplot2::ggplot(
             data = plotData,
-            ggplot2::aes(x = Age,
-                         y = incidenceRateP100py,
-                         color = cdmSourceAbbreviation
+            ggplot2::aes(x = .data$Age,
+                         y = .data$incidenceRateP100py,
+                         color = .data$cdmSourceAbbreviation
             )
           ) + 
             ggplot2::geom_point(

R/characterization-main.R

@@ -512,7 +512,7 @@ characterizationServer <- function(
               id = 'cohortIncidenceTab',
               connectionHandler = connectionHandler, 
               resultDatabaseSettings = resultDatabaseSettings,
-              options = options,
+              #options = options,
               parents = parents,
               parentIndex = parentIndex, # reactive
               outcomes = outcomes, # reactive

R/characterization-timeToEvent.R

@@ -73,6 +73,8 @@ characterizationTimeToEventViewer <- function(id) {
 #' @param id  the unique reference id for the module
 #' @param connectionHandler the connection to the prediction result database
 #' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix
+#' @param targetId a reactive integer specifying the targetId of interest
+#' @param outcomeId a reactive integer specifying the outcomeId of interest
 #' 
 #' @return
 #' The server to the prediction time to event module
@@ -107,9 +109,9 @@ characterizationTimeToEventServer <- function(
         ) %>%
           dplyr::mutate(targetName = options()$targetName,
                         outcomeName = options()$outcomeName) %>%
-          dplyr::relocate(databaseName, .before = databaseId) %>%
-          dplyr::relocate(targetName, .after = databaseName) %>%
-          dplyr::relocate(outcomeName, .after = targetName)
+          dplyr::relocate("databaseName", .before = "databaseId") %>%
+          dplyr::relocate("targetName", .after = "databaseName") %>%
+          dplyr::relocate("outcomeName", .after = "targetName")
       })
 
 
@@ -248,8 +250,8 @@ characterizationTimeToEventServer <- function(
             timeToEventData = allData, # reactive
             databases = input$databases,
             times = input$times,
-            outcomeType = input$outcomeTypes,
-            targetOutcomeType = input$targetOutcomeTypes
+            outcomeTypes = input$outcomeTypes,
+            targetOutcomeTypes = input$targetOutcomeTypes
           )
         )
 
@@ -355,17 +357,8 @@ plotTimeToEvent <- function(
       )
     ) +
     ggplot2::geom_bar(
-      #position="stacked",
       stat = "identity"
       ) +
-    #ggplot2::geom_text(
-    #  ggplot2::aes(
-    #    label = .data$numEvents
-    #    ), 
-    #  vjust = 1.6, 
-    #  color = "white", 
-    #  size = 3.5
-    #  ) +
     ggplot2::facet_wrap(ncol = nDatabases ,
       .data$timeScale ~ .data$databaseName , scales = 'free'
         ) +

R/components-data-viewer.R

@@ -9,7 +9,7 @@
 #'
 #' @param id string
 #' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used
-#'
+#' @param boxTitle the title added to the box 
 #' @return shiny module UI
 #'
 resultTableViewer <- function(

R/estimation-cohort-method-covariateBalance.R

@@ -85,7 +85,8 @@ cohortMethodCovariateBalanceServer <- function(
     selectedRow, 
     connectionHandler, 
     resultDatabaseSettings,
-    metaAnalysisDbIds = NULL) {
+    metaAnalysisDbIds = NULL
+    ) {
 
   shiny::moduleServer(
     id,
@@ -96,35 +97,6 @@ cohortMethodCovariateBalanceServer <- function(
         resultDatabaseSettings
       )
 
-      # input selection component -- could be added later if desired
-      # inputSelectedResults <- inputSelectionServer(
-      #   id = "input-selection-results", 
-      #   inputSettingList = list(
-      #     createInputSetting(
-      #       rowNumber = 1,                           
-      #       columnWidth = 12,
-      #       varName = 'covariateAnalysisId',
-      #       uiFunction = 'shinyWidgets::pickerInput',
-      #       updateFunction = 'shinyWidgets::updatePickerInput',
-      #       uiInputs = list(
-      #         label = 'Covariate Analysis Name: ',
-      #         choices = options$covariateAnalysisId,
-      #         selected = options$covariateAnalysisId, #
-      #         multiple = T,
-      #         options = shinyWidgets::pickerOptions(
-      #           actionsBox = TRUE,
-      #           liveSearch = TRUE,
-      #           size = 10,
-      #           liveSearchStyle = "contains",
-      #           liveSearchPlaceholder = "Type here to search",
-      #           virtualScroll = 50
-      #         )
-      #       )
-      #     )
-      #   )
-      # )
-
-
       balance <- shiny::reactive({
         row <- selectedRow()
         if(is.null(row$targetId)){
@@ -137,9 +109,6 @@ cohortMethodCovariateBalanceServer <- function(
           targetId = row$targetId,
           comparatorId = row$comparatorId,
           databaseId = row$databaseId,
-          # covariateAnalysisId = ifelse(is.null(inputSelectedResults()$covariateAnalysisId),
-          #                              -1,
-          #                              inputSelectedResults()$covariateAnalysisId),
           analysisId = row$analysisId)},
           error = function(e){return(data.frame())}
         )
@@ -299,8 +268,8 @@ cohortMethodCovariateBalanceServer <- function(
           dbNames <- getDatabaseName(connectionHandler = connectionHandler,
                                      resultDatabaseSettings = resultDatabaseSettings)
           comb <- dplyr::inner_join(balance, dbNames) %>%
-            dplyr::relocate(cdmSourceAbbreviation, .after = databaseId) %>% 
-            dplyr::select(-c(databaseId))
+            dplyr::relocate("cdmSourceAbbreviation", .after = "databaseId") %>% 
+            dplyr::select(-c("databaseId"))
         }
       )
 
@@ -322,11 +291,6 @@ cohortMethodCovariateBalanceServer <- function(
       resultTableServer(
         id = "balanceTable",
         df = renderBalanceTable,
-        # selectedCols = c("cdmSourceAbbreviation", "targetName", "targetIdShort", "outcomeName", "outcomeIdShort",
-        #                  "ageGroupName", "genderName", "startYear", "tar", "outcomes",
-        #                  "incidenceProportionP100p", "incidenceRateP100py"),
-        # sortedCols = c("ageGroupName", "genderName", "startYear", "incidenceRateP100py"),
-        # elementId = "incidence-select",
         colDefsInput = cmBalanceColList,
         downloadedFileName = "covariateBalanceTable-"
       )

R/estimation-cohort-method-results.R

@@ -468,3 +468,29 @@ estimationGetCMMetaEstimation <- function(
 
   return(unique(result))
 }
+
+
+# Function to format results
+# used by both cm and sccs
+computeTraditionalP <- function(
+    logRr, 
+    seLogRr, 
+    twoSided = TRUE, 
+    upper = TRUE
+) 
+{
+  z <- logRr/seLogRr
+
+  pUpperBound <- 1 - stats::pnorm(z)
+  pLowerBound <- stats::pnorm(z)
+
+  if (twoSided) {
+    return(2 * pmin(pUpperBound, pLowerBound))
+  }
+  else if (upper) {
+    return(pUpperBound)
+  }
+  else {
+    return(pLowerBound)
+  }
+}

R/estimation-main.R

@@ -207,6 +207,7 @@ estimationServer <- function(
           )
         }
       })
+      # end observed targetId
 
       output$targetSelection <- shiny::renderUI({
         shiny::fluidRow(
@@ -245,7 +246,7 @@ estimationServer <- function(
             ), 
             style = 'margin-left: 2%; width: 78%; display: inline-block; vertical-align: middle;'
           ),
-          div(
+          shiny::div(
             shiny::actionButton(
               inputId = session$ns('targetSelect'), 
               label = 'Select',
@@ -257,10 +258,10 @@ estimationServer <- function(
       })
 
 
-      targetSelected <- shiny::reactiveVal()
-      comparatorIds <- shiny::reactiveVal()
-      targetIds <- shiny::reactiveVal()
-      outcomeId <- shiny::reactiveVal()
+      targetSelected <- shiny::reactiveVal(NULL)
+      comparatorIds <- shiny::reactiveVal(NULL)
+      targetIds <- shiny::reactiveVal(NULL)
+      outcomeId <- shiny::reactiveVal(NULL)
 
       shiny::observeEvent(input$targetSelect, {
 
@@ -395,10 +396,17 @@ getEstimationTypes <- function(
   }
 
   # Evidence Synthesis
-  if(paste0(
+  if(
+    paste0(
     resultDatabaseSettings$esTablePrefix,
-    'result'
-  ) %in% tbls){
+    'cm_result'
+  ) %in% tbls ||
+  paste0(
+    resultDatabaseSettings$esTablePrefix,
+    'sccs_result'
+  ) %in% tbls
+
+  ){
     results <- c(results, "Evidence Synthesis")
   }