Skip to content

Commit

Permalink
argument sample added
Browse files Browse the repository at this point in the history
test is missing
  • Loading branch information
cecicampanile committed Dec 17, 2024
1 parent 48f1f02 commit 41a6886
Showing 5 changed files with 55 additions and 21 deletions.
3 changes: 2 additions & 1 deletion R/summariseAllConceptCounts.R
Original file line number Diff line number Diff line change
@@ -63,6 +63,7 @@ summariseAllConceptCounts <- function(cdm,
year = FALSE,
sex = FALSE,
ageGroup = NULL,
sample = 1000000,
dateRange = NULL){

omopgenerics::validateCdmArgument(cdm)
@@ -93,7 +94,7 @@ summariseAllConceptCounts <- function(cdm,
}

omopTable <- restrictStudyPeriod(omopTable, dateRange)

omopTable <- sampleOmopTable(omopTable, sample)

indexDate <- startDate(omopgenerics::tableName(omopTable))

5 changes: 4 additions & 1 deletion R/summariseClinicalRecords.R
Original file line number Diff line number Diff line change
@@ -55,6 +55,7 @@ summariseClinicalRecords <- function(cdm,
typeConcept = TRUE,
sex = FALSE,
ageGroup = NULL,
sample = 1000000,
dateRange = NULL) {
# Initial checks ----
omopgenerics::validateCdmArgument(cdm)
@@ -93,6 +94,7 @@ summariseClinicalRecords <- function(cdm,
typeConcept = typeConcept,
sex = sex,
ageGroup = ageGroup,
sample = sample,
dateRange = dateRange
)
}) |>
@@ -112,6 +114,7 @@ summariseClinicalRecord <- function(omopTableName,
typeConcept,
sex,
ageGroup,
sample,
dateRange,
call = parent.frame(3)) {

@@ -124,8 +127,8 @@ summariseClinicalRecord <- function(omopTableName,

omopTable <- cdm[[omopTableName]] |>
dplyr::ungroup()

omopTable <- restrictStudyPeriod(omopTable, dateRange)
omopTable <- sampleOmopTable(omopTable, sample)
if(omopgenerics::isTableEmpty(omopTable)) {
return(omopgenerics::emptySummarisedResult(settings = createSettings(result_type = "summarise_clinical_records", study_period = dateRange)))
}
42 changes: 26 additions & 16 deletions R/summariseConceptSetCounts.R
Original file line number Diff line number Diff line change
@@ -37,6 +37,7 @@ summariseConceptSetCounts <- function(cdm,
interval = "overall",
sex = FALSE,
ageGroup = NULL,
sample = 1000000,
dateRange = NULL){

omopgenerics::validateCdmArgument(cdm)
@@ -74,6 +75,7 @@ summariseConceptSetCounts <- function(cdm,
unitInterval = unitInterval,
sex = sex,
ageGroup = ageGroup,
sample = sample,
dateRange = dateRange)
Sys.sleep(i/length(conceptSet))
cli::cli_progress_update()
@@ -107,6 +109,7 @@ getCodeUse <- function(x,
unitInterval,
sex,
ageGroup,
sample,
dateRange,
call = parent.frame()){

@@ -150,7 +153,9 @@ getCodeUse <- function(x,
records <- getRelevantRecords(cdm = cdm,
tableCodelist = tableCodelist,
intermediateTable = intermediateTable,
tablePrefix = tablePrefix)
tablePrefix = tablePrefix,
sample = sample, dateRange = dateRange)

if(is.null(records)){
cc <- dplyr::tibble()
cli::cli_inform(c(
@@ -159,17 +164,16 @@ getCodeUse <- function(x,
return(omopgenerics::emptySummarisedResult(settings = createSettings(result_type = "summarise_concept_set_counts", study_period = dateRange)))
}

if (!is.null(dateRange))
{
records <- records |>
dplyr::filter(
as.Date(date) >= !!dateRange[1]& as.Date(date) <= !!dateRange[2]
)
if (is.null(warningEmptyStudyPeriod(records))){
return(tibble::tibble())
}

}
# if (!is.null(dateRange))
# {
# records <- records |>
# dplyr::filter(
# as.Date(date) >= !!dateRange[1]& as.Date(date) <= !!dateRange[2]
# )
# if (is.null(warningEmptyStudyPeriod(records))){
# return(tibble::tibble())
# }
# }
records <- addStrataToOmopTable(records, "date", ageGroup, sex)
strata <- getStrataList(sex, ageGroup)

@@ -238,7 +242,8 @@ getCodeUse <- function(x,
getRelevantRecords <- function(cdm,
tableCodelist,
intermediateTable,
tablePrefix){
tablePrefix,
sample, dateRange){

codes <- cdm[[tableCodelist]] |> dplyr::collect()

@@ -248,9 +253,11 @@ getRelevantRecords <- function(cdm,
dateName <- purrr::discard(unique(codes$start_date), is.na)

if(length(tableName)>0){
codeRecords <- cdm[[tableName[[1]]]]
codeRecords <- cdm[[tableName[[1]]]]|>
restrictStudyPeriod(dateRange)|>
sampleOmopTable(sample)

if(is.null(codeRecords)){return(NULL)}
if(is.null(codeRecords) || omopgenerics::isTableEmpty(codeRecords)){return(NULL)}

tableCodes <- paste0(tablePrefix, "table_codes")

@@ -290,7 +297,10 @@ getRelevantRecords <- function(cdm,
# get for any additional domains and union
if(length(tableName) > 1) {
for(i in 1:(length(tableName)-1)) {
workingRecords <- cdm[[tableName[[i+1]]]]
workingRecords <- cdm[[tableName[[i+1]]]] |>
restrictStudyPeriod(dateRange)|>
sampleOmopTable(sample)
if(is.null(workingRecords) || omopgenerics::isTableEmpty(workingRecords)){return(NULL)}

workingRecords <- workingRecords %>%
dplyr::mutate(date = !!dplyr::sym(dateName[[i+1]])) %>%
13 changes: 10 additions & 3 deletions R/summariseRecordCount.R
Original file line number Diff line number Diff line change
@@ -35,7 +35,9 @@ summariseRecordCount <- function(cdm,
interval = "overall",
ageGroup = NULL,
sex = FALSE,
dateRange = NULL) {
sample = 1000000,
dateRange = NULL
) {

# Initial checks ----
omopgenerics::validateCdmArgument(cdm)
@@ -48,6 +50,7 @@ summariseRecordCount <- function(cdm,
omopgenerics::assertLogical(sex, length = 1)
dateRange <- validateStudyPeriod(cdm, dateRange)


result <- purrr::map(omopTableName,
function(x) {
omopgenerics::assertClass(cdm[[x]], "omop_table", call = parent.frame())
@@ -66,7 +69,9 @@ summariseRecordCount <- function(cdm,
original_interval,
ageGroup = ageGroup,
sex = sex,
dateRange = dateRange)
sample = sample,
dateRange = dateRange
)
}
) |>
dplyr::bind_rows()
@@ -76,10 +81,12 @@ summariseRecordCount <- function(cdm,

#' @noRd
summariseRecordCountInternal <- function(omopTableName, cdm, interval, unitInterval,
original_interval, ageGroup, sex, dateRange) {
original_interval, ageGroup, sex, sample, dateRange) {

prefix <- omopgenerics::tmpPrefix()
omopTable <- cdm[[omopTableName]] |> dplyr::ungroup()
omopTable <- restrictStudyPeriod(omopTable, dateRange)
omopTable <- sampleOmopTable(omopTable, sample)

# Create initial variables ----

13 changes: 13 additions & 0 deletions R/utilities.R
Original file line number Diff line number Diff line change
@@ -83,4 +83,17 @@ createSettings <- function(result_type, result_id = 1L, package_name = "OmopSket
return(settings)
}

sampleOmopTable <- function(omopTable, sample){
sampling <- !is.null(sample) & !is.infinite(sample)

if (sampling & omopTable |> dplyr::tally() |> dplyr::pull() <= sample) {
sampling <- FALSE
}

if (sampling){
omopTable <- omopTable |>
dplyr::slice_sample(n = sample)
}
return(omopTable)
}

0 comments on commit 41a6886

Please sign in to comment.