Package maintenance and bug fix

OHDSI · Sep 30, 2024 · a05d448 · a05d448
1 parent 98cbffa
commit a05d448
Show file tree

Hide file tree

Showing 52 changed files with 475 additions and 328 deletions.
diff --git a/R/ConvertConceptSetDataFrameToExpression.R b/R/ConvertConceptSetDataFrameToExpression.R
@@ -35,6 +35,8 @@
 #'
 #' @template VocabularyDatabaseSchema
 #'
+#' @template TempEmulationSchema
+#'
 #' @return
 #' Returns a R list object
 #'
@@ -45,7 +47,8 @@ convertConceptSetDataFrameToExpression <-
            updateVocabularyFields = FALSE,
            connectionDetails = NULL,
            connection = NULL,
-           vocabularyDatabaseSchema = NULL) {
+           vocabularyDatabaseSchema = NULL,
+           tempEmulationSchema = getOption("sqlRenderTempEmulationSchema")) {
     if (!"includeMapped" %in% colnames(conceptSetExpressionDataFrame)) {
       conceptSetExpressionDataFrame$includeMapped <- FALSE
     }
@@ -92,25 +95,35 @@ convertConceptSetDataFrameToExpression <-
       }
       if (is.null(connection)) {
         connection <- DatabaseConnector::connect(connectionDetails)
-        on.exit(DatabaseConnector::disconnect(connection))
+        on.exit(
+          DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+        )
+        on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
       }
 
       conceptIds <-
         conceptSetExpressionDataFrame$conceptId |> unique()
       conceptIdDetails <- getConceptIdDetails(
         conceptIds = conceptIds,
         connection = connection,
-        vocabularyDatabaseSchema = vocabularyDatabaseSchema
+        vocabularyDatabaseSchema = vocabularyDatabaseSchema,
+        tempEmulationSchema = tempEmulationSchema
       )
 
       conceptSetExpressionDataFrame <-
         conceptSetExpressionDataFrame |>
         dplyr::select(
-          -.data$conceptName, -.data$standardConcept, -.data$standardConceptCaption, -.data$invalidReason, -.data$invalidReasonCaption, -.data$conceptCode, -.data$domainId, -.data$vocabularyId, -.data$conceptClassId
-        ) |>
-        dplyr::left_join(conceptIdDetails,
-          by = "conceptId"
+          -.data$conceptName,
+          -.data$standardConcept,
+          -.data$standardConceptCaption,
+          -.data$invalidReason,
+          -.data$invalidReasonCaption,
+          -.data$conceptCode,
+          -.data$domainId,
+          -.data$vocabularyId,
+          -.data$conceptClassId
         ) |>
+        dplyr::left_join(conceptIdDetails, by = "conceptId") |>
         dplyr::select(
           .data$conceptId,
           .data$conceptName,
@@ -165,7 +178,11 @@ convertConceptSetDataFrameToExpression <-
         conceptSetExpression$items[[i]] <- list()
         conceptSetExpression$items[[i]]$concept <-
           conceptSetExpressionDataFrame[i, ] |>
-          dplyr::select(-.data$INCLUDE_DESCENDANTS, -.data$INCLUDE_MAPPED, -.data$IS_EXCLUDED) |>
+          dplyr::select(
+            -.data$INCLUDE_DESCENDANTS,
+            -.data$INCLUDE_MAPPED,
+            -.data$IS_EXCLUDED
+          ) |>
           as.list()
         conceptSetExpression$items[[i]]$isExcluded <-
           conceptSetExpressionDataFrame$IS_EXCLUDED[i]

diff --git a/R/ConvertConceptSetExpressionToDataFrame.R b/R/ConvertConceptSetExpressionToDataFrame.R
@@ -118,7 +118,10 @@ convertConceptSetExpressionToDataFrame <-
       }
       if (is.null(connection)) {
         connection <- DatabaseConnector::connect(connectionDetails)
-        on.exit(DatabaseConnector::disconnect(connection))
+        on.exit(
+          DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+        )
+        on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
       }
 
       details <- getConceptIdDetails(

diff --git a/R/ExtractConceptSetsInCohortDefinition.R b/R/ExtractConceptSetsInCohortDefinition.R
@@ -57,7 +57,7 @@ extractConceptSetsInCohortDefinition <-
     primaryCriterias <-
       expression$PrimaryCriteria$CriteriaList
     codeSetsIdsInPrimaryCriteria <- c()
-    
+
     codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria <- c()
 
     for (i in (1:length(primaryCriterias))) {
@@ -72,36 +72,36 @@ extractConceptSetsInCohortDefinition <-
             unique() |>
             sort()
         }
-        
+
         # Find the name of the item containing 'SourceConcept'
-        sourceConceptName <- names(codesets)[sapply(names(codesets), function(x)
-          grepl("SourceConcept", x)) &
-            !sapply(codesets, is.null)]
-
+        sourceConceptName <- names(codesets)[sapply(names(codesets), function(x) {
+          grepl("SourceConcept", x)
+        }) &
+          !sapply(codesets, is.null)]
+
         if (length(sourceConceptName) > 0) {
           codeSetsIdsInPrimaryCriteria <- c(codeSetsIdsInPrimaryCriteria, codesets[[sourceConceptName]]) |>
             unique() |>
             sort()
         }
-        
+
         sourceConceptName <- NULL
-        
+
         codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria <- c(
           codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria,
           codeSetsIdsInPrimaryCriteria
         )
-
       } else {
         if (any(
           names(codesets) == "CodesetId",
-          stringr::str_detect(string = names(codesets), pattern = 'SourceConcept')
+          stringr::str_detect(string = names(codesets), pattern = "SourceConcept")
         )) {
-          #is substring of name 'SourceConcept'
+          # is substring of name 'SourceConcept'
           codeSetsIdsInPrimaryCriteria <- c(codeSetsIdsInPrimaryCriteria, as.double(codesets)) |>
             unique() |>
             sort()
-          
-          if (!names(codesets) == 'CodesetId') {
+
+          if (!names(codesets) == "CodesetId") {
             codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria <- c(
               codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria,
               codeSetsIdsInPrimaryCriteria
@@ -365,32 +365,33 @@ extractConceptSetsInCohortDefinition <-
 
     conceptSetExpression <-
       dplyr::bind_rows(conceptSetExpression2) |>
-      dplyr::mutate(conceptSetUsedInEntryEvent = 0) |> 
+      dplyr::mutate(conceptSetUsedInEntryEvent = 0) |>
       dplyr::mutate(conceptSetUsedInEntryEventToQuerySource = 0)
 
     if (length(codeSetsIdsInPrimaryCriteria) > 0) {
-
       conceptSetExpression <- conceptSetExpression |>
-        dplyr::select(-dplyr::all_of(c("conceptSetUsedInEntryEvent",
-                                       "conceptSetUsedInEntryEventToQuerySource"))) |>
+        dplyr::select(-dplyr::all_of(c(
+          "conceptSetUsedInEntryEvent",
+          "conceptSetUsedInEntryEventToQuerySource"
+        ))) |>
         dplyr::left_join(
           dplyr::tibble(conceptSetId = codeSetsIdsInPrimaryCriteria) |>
             dplyr::distinct() |>
             dplyr::mutate(conceptSetUsedInEntryEvent = 1),
           by = "conceptSetId"
-        ) 
-      
-        if (length(codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria) > 0) {
-          conceptSetExpression <- conceptSetExpression |> 
-            dplyr::left_join(
-              dplyr::tibble(conceptSetId = codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria) |> 
-                dplyr::distinct() |> 
-                dplyr::mutate(conceptSetUsedInEntryEventToQuerySource = 1),
-              by = ("conceptSetId")
-            )
-        } else {
-          conceptSetExpression$conceptSetUsedInEntryEventToQuerySource <- as.integer(0)
-        }
+        )
+
+      if (length(codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria) > 0) {
+        conceptSetExpression <- conceptSetExpression |>
+          dplyr::left_join(
+            dplyr::tibble(conceptSetId = codeSetsIdsUsedToQuerySourceConceptsInPrimaryCriteria) |>
+              dplyr::distinct() |>
+              dplyr::mutate(conceptSetUsedInEntryEventToQuerySource = 1),
+            by = ("conceptSetId")
+          )
+      } else {
+        conceptSetExpression$conceptSetUsedInEntryEventToQuerySource <- as.integer(0)
+      }
     }
 
     uniqueConceptSets <- conceptSetExpression |>
@@ -411,8 +412,10 @@ extractConceptSetsInCohortDefinition <-
     )
 
     data <- data |>
-      tidyr::replace_na(replace = list(conceptSetUsedInEntryEvent = 0,
-                                       conceptSetUsedInEntryEventToQuerySource = 0))
+      tidyr::replace_na(replace = list(
+        conceptSetUsedInEntryEvent = 0,
+        conceptSetUsedInEntryEventToQuerySource = 0
+      ))
 
     data <- data |>
       dplyr::left_join(conceptSetExpressionMetaData,

diff --git a/R/ExtractConceptSetsInCohortDefinitionSet.R b/R/ExtractConceptSetsInCohortDefinitionSet.R
@@ -32,16 +32,18 @@
 extractConceptSetsInCohortDefinitionSet <-
   function(cohortDefinitionSet) {
     # cohorts should be a dataframe with at least cohortId and json
-    
+
     conceptSets <- list()
     for (i in (1:nrow(cohortDefinitionSet))) {
       cohort <- cohortDefinitionSet[i, ]
       cohortJsonAsList <- RJSONIO::fromJSON(content = cohort$json, digits = 23)
       conceptSetsInCohortDefinition <- NULL
       conceptSetsInCohortDefinition <-
-        try(expr = extractConceptSetsInCohortDefinition(cohortExpression = cohortJsonAsList),
-            silent = TRUE)
-
+        try(
+          expr = extractConceptSetsInCohortDefinition(cohortExpression = cohortJsonAsList),
+          silent = TRUE
+        )
+
       if (all(
         !is.null(conceptSetsInCohortDefinition),
         !class(conceptSetsInCohortDefinition) == "try-error"
@@ -55,13 +57,13 @@ extractConceptSetsInCohortDefinitionSet <-
     }
     conceptSets <- dplyr::bind_rows(conceptSets) |>
       dplyr::arrange("cohortId", "conceptSetId")
-    
+
     conceptSetSig <- list()
     for (i in (1:nrow(conceptSets))) {
       conceptSetSig[[i]] <- conceptSets[i, ]
       conceptSetExpressionSignature <-
         convertConceptSetExpressionToDataFrame(conceptSetExpression = conceptSetSig[[i]]$conceptSetExpression |>
-                                                 RJSONIO::fromJSON(digits = 23)) |>
+          RJSONIO::fromJSON(digits = 23)) |>
         dplyr::select(
           .data$conceptId,
           .data$includeDescendants,
@@ -74,30 +76,36 @@ extractConceptSetsInCohortDefinitionSet <-
       conceptSetSig[[i]]$conceptSetExpressionSignature <-
         conceptSetExpressionSignature
       conceptSetSig[[i]] <- conceptSetSig[[i]] |>
-        dplyr::select(.data$cohortId,
-                      .data$conceptSetId,
-                      .data$conceptSetExpressionSignature) |>
+        dplyr::select(
+          .data$cohortId,
+          .data$conceptSetId,
+          .data$conceptSetExpressionSignature
+        ) |>
         dplyr::distinct()
     }
     conceptSetSig <- dplyr::bind_rows(conceptSetSig)
     uniqueConceptSets <- conceptSetSig |>
       dplyr::select(.data$conceptSetExpressionSignature) |>
       dplyr::distinct() |>
       dplyr::mutate(uniqueConceptSetId = dplyr::row_number())
-    
+
     conceptSetSig <- conceptSetSig |>
       dplyr::inner_join(uniqueConceptSets, by = "conceptSetExpressionSignature") |>
       dplyr::select(-.data$conceptSetExpressionSignature)
-    
+
     conceptSets <- conceptSets |>
-      dplyr::select(-uniqueConceptSetId) |>
+      dplyr::select(-"uniqueConceptSetId") |>
       dplyr::left_join(conceptSetSig, by = c("cohortId", "conceptSetId")) |>
       dplyr::distinct() |>
-      dplyr::relocate(.data$uniqueConceptSetId,
-                      .data$cohortId,
-                      .data$conceptSetId) |>
-      dplyr::arrange(.data$uniqueConceptSetId,
-                     .data$cohortId,
-                     .data$conceptSetId)
+      dplyr::relocate(
+        .data$uniqueConceptSetId,
+        .data$cohortId,
+        .data$conceptSetId
+      ) |>
+      dplyr::arrange(
+        .data$uniqueConceptSetId,
+        .data$cohortId,
+        .data$conceptSetId
+      )
     return(conceptSets)
   }
diff --git a/R/FindOrphanConcepts.R b/R/FindOrphanConcepts.R
@@ -39,7 +39,10 @@ findOrphanConcepts <- function(connectionDetails = NULL,
                                conceptIds) {
   if (is.null(connection)) {
     connection <- DatabaseConnector::connect(connectionDetails)
-    on.exit(DatabaseConnector::disconnect(connection))
+    on.exit(
+      DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+    )
+    on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
   }
 
   tempTableName <- loadTempConceptTable(

diff --git a/R/GetConceptAncestor.R b/R/GetConceptAncestor.R
@@ -40,7 +40,10 @@ getConceptAncestor <-
            vocabularyDatabaseSchema = "vocabulary") {
     if (is.null(connection)) {
       connection <- DatabaseConnector::connect(connectionDetails)
-      on.exit(DatabaseConnector::disconnect(connection))
+      on.exit(
+        DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+      )
+      on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
     }
 
     tempTableName <- loadTempConceptTable(

diff --git a/R/GetConceptDescendant.R b/R/GetConceptDescendant.R
@@ -40,7 +40,10 @@ getConceptDescendant <-
            vocabularyDatabaseSchema = "vocabulary") {
     if (is.null(connection)) {
       connection <- DatabaseConnector::connect(connectionDetails)
-      on.exit(DatabaseConnector::disconnect(connection))
+      on.exit(
+        DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+      )
+      on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
     }
 
     tempTableName <- loadTempConceptTable(

diff --git a/R/GetConceptIdDetails.R b/R/GetConceptIdDetails.R
@@ -40,7 +40,10 @@ getConceptIdDetails <-
            tempEmulationSchema = getOption("sqlRenderTempEmulationSchema")) {
     if (is.null(connection)) {
       connection <- DatabaseConnector::connect(connectionDetails)
-      on.exit(DatabaseConnector::disconnect(connection))
+      on.exit(
+        DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+      )
+      on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
     }
 
     tempTableName <- loadTempConceptTable(

diff --git a/R/GetConceptPrevalenceCounts.R b/R/GetConceptPrevalenceCounts.R
@@ -40,7 +40,10 @@ getConceptPrevalenceCounts <- function(conceptIds = NULL,
                                        tempEmulationSchema = getOption("sqlRenderTempEmulationSchema")) {
   if (is.null(connection)) {
     connection <- DatabaseConnector::connect(connectionDetails)
-    on.exit(DatabaseConnector::disconnect(connection))
+    on.exit(
+      DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+    )
+    on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
   }
 
   conceptPrevalenceTables <-

diff --git a/R/GetConceptRecordCount.R b/R/GetConceptRecordCount.R
@@ -90,7 +90,10 @@ getConceptRecordCount <- function(conceptIds = NULL,
                                   )) {
   if (is.null(connection)) {
     connection <- DatabaseConnector::connect(connectionDetails)
-    on.exit(DatabaseConnector::disconnect(connection))
+    on.exit(
+      DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+    )
+    on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
   }
 
   uploadedConceptTable <- ""

diff --git a/R/GetConceptRelationship.R b/R/GetConceptRelationship.R
@@ -37,7 +37,10 @@ getConceptRelationship <-
            vocabularyDatabaseSchema = "vocabulary") {
     if (is.null(connection)) {
       connection <- DatabaseConnector::connect(connectionDetails)
-      on.exit(DatabaseConnector::disconnect(connection))
+      on.exit(
+        DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+      )
+      on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
     }
 
     tempTableName <- loadTempConceptTable(

diff --git a/R/GetConceptSynonym.R b/R/GetConceptSynonym.R
@@ -37,7 +37,10 @@ getConceptSynonym <-
            vocabularyDatabaseSchema = "vocabulary") {
     if (is.null(connection)) {
       connection <- DatabaseConnector::connect(connectionDetails)
-      on.exit(DatabaseConnector::disconnect(connection))
+      on.exit(
+        DatabaseConnector::dropEmulatedTempTables(connection = connection, tempEmulationSchema = tempEmulationSchema)
+      )
+      on.exit(DatabaseConnector::disconnect(connection), add = TRUE)
     }
 
     tempTableName <- loadTempConceptTable(