From ae92be408a48d5359de11c29721217fc7a30b9f8 Mon Sep 17 00:00:00 2001 From: Borys Date: Tue, 11 Feb 2025 16:32:31 +0100 Subject: [PATCH 01/10] Implements lintr job --- .github/workflows/lint.yaml | 33 +++++++++++++++++++++++++++++++++ .lintr | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 .github/workflows/lint.yaml create mode 100644 .lintr diff --git a/.github/workflows/lint.yaml b/.github/workflows/lint.yaml new file mode 100644 index 0000000..6e757d6 --- /dev/null +++ b/.github/workflows/lint.yaml @@ -0,0 +1,33 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master, dev] + pull_request: + +name: lint.yaml + +permissions: read-all + +jobs: + lint: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::lintr, local::. + needs: lint + + - name: Lint + run: lintr::lint_package() + shell: Rscript {0} + env: + LINTR_ERROR_ON_LINT: true diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..1573038 --- /dev/null +++ b/.lintr @@ -0,0 +1,32 @@ +linters: linters_with_defaults( + any_duplicated_linter(), + any_is_na_linter(), + backport_linter("oldrel-4"), + expect_comparison_linter(), + expect_identical_linter(), + expect_length_linter(), + expect_named_linter(), + expect_not_linter(), + expect_null_linter(), + expect_s3_class_linter(), + expect_s4_class_linter(), + expect_true_false_linter(), + expect_type_linter(), + fixed_regex_linter(), + implicit_integer_linter(), + line_length_linter(120), + missing_argument_linter(), + nested_ifelse_linter(), + numeric_leading_zero_linter(), + outer_negation_linter(), + paste_linter(), + redundant_ifelse_linter(), + sprintf_linter(), + strings_as_factors_linter(), + undesirable_function_linter(c(Sys.setenv = NA_character_, mapply = NA_character_, unique = "use collapse::funique")), + object_name_linter = NULL, + object_usage_linter = NULL, + assignment_linter = assignment_linter(allow_trailing = FALSE), + indentation_linter = indentation_linter(hanging_indent_style = "tidy", assignment_as_infix = FALSE), + ) +encoding: "UTF-8" From ee5c69daf305e4c57758b6fbce8103ce376909fa Mon Sep 17 00:00:00 2001 From: Borys Date: Tue, 11 Feb 2025 16:55:15 +0100 Subject: [PATCH 02/10] Update config .lintr --- .lintr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.lintr b/.lintr index 1573038..5bee459 100644 --- a/.lintr +++ b/.lintr @@ -27,6 +27,6 @@ linters: linters_with_defaults( object_name_linter = NULL, object_usage_linter = NULL, assignment_linter = assignment_linter(allow_trailing = FALSE), - indentation_linter = indentation_linter(hanging_indent_style = "tidy", assignment_as_infix = FALSE), + indentation_linter = indentation_linter(hanging_indent_style = "tidy", assignment_as_infix = FALSE) ) encoding: "UTF-8" From 727e9b08eb35f923f60562187b3da548f587236a Mon Sep 17 00:00:00 2001 From: Borys Date: Tue, 18 Feb 2025 18:41:12 +0100 Subject: [PATCH 03/10] Update tests files --- tests/testthat/test-attrition.R | 69 ++- tests/testthat/test-cohort_methods.R | 479 +++++++++--------- tests/testthat/test-reproducible_code_utils.R | 81 ++- tests/testthat/test-source_methods.R | 136 ++--- tests/testthat/test-step.R | 44 +- 5 files changed, 404 insertions(+), 405 deletions(-) diff --git a/tests/testthat/test-attrition.R b/tests/testthat/test-attrition.R index 71881ac..ce85ede 100644 --- a/tests/testthat/test-attrition.R +++ b/tests/testthat/test-attrition.R @@ -2,67 +2,67 @@ test_that("get_attrition_coords returns a data frame with expected structure and # Example input labels <- c("x", "Step: 1\nFilter: adsa (range = [1, 4])") n_included <- c(`0` = 150L, `1` = 100L) - space <- 1 + space <- 1L percent <- FALSE - # Call the function + result <- get_attrition_coords(labels = labels, n_included = n_included, space = space, percent = percent) - + # Basic structure tests expect_s3_class(result, "data.frame") - + # Check number of rows is equal to length of labels - expect_equal(nrow(result), length(labels)) - + expect_identical(nrow(result), length(labels)) + # Check that space attribute is retained correctly - expect_equal(attr(result, "space"), space) - + expect_identical(attr(result, "space"), space) + # Check label formatting without percent # Construct expected label without percentage expected_label <- c( "x\nN = 150", "Step: 1\nFilter: adsa (range = [1, 4])\nN = 100" ) - + # The exclusion label should have NA in the first row and the computed exclusion # in the second row (excluded = 150 - 100 = 50) expected_label_excl <- c( NA, "Excluded N = 50" ) - - expect_equal(result$label, expected_label) - expect_equal(result$label_excl, expected_label_excl) - + + expect_identical(result$label, expected_label) + expect_identical(result$label_excl, expected_label_excl) + # Check a few numeric values to ensure calculations are done as expected # label_heights counts the number of newline chars in `label`. # "x\nN = 150" has 1 newline, so label_heights[1] should be 1. # "Step: 1\nFilter: adsa (range = [1, 4])\nN = 100" has 2 newlines, so label_heights[2] should be 2. - expect_equal(result$label_heights, c(1, 2)) - + expect_identical(result$label_heights, c(1L, 2L)) + # The positioning should start at 0 and accumulate by label_heights + space. # For the first row: label_position_y = 0. # For the second row: label_position_y = previous (0) + (1 + 1) = 2. - expect_equal(result$label_position_y, c(0, 2)) - + expect_identical(result$label_position_y, c(0L, 2L)) + # arrow_end_position_y for the first row should lead to the second row's position, i.e., 2. # For the second row, since there is no next row, it should be NA. - expect_equal(result$arrow_end_position_y, c(2, NA_real_)) - - # excl_position_y for the first row is calculated using lag(arrow_end_position_y) - (space/2) = NA + expect_identical(result$arrow_end_position_y, c(2L, NA_integer_)) + + # excl_position_y for the first row is calculated using lag(arrow_end_position_y) - (space/2) = NA # since lag of first is NA. # For the second row: excl_position_y = previous arrow_end_position_y (2) - (1/2) = 1.5 - expect_equal(result$excl_position_y, c(NA_real_, 1.5)) + expect_identical(result$excl_position_y, c(NA_real_, 1.5)) }) test_that("get_attrition_coords calculates percentages correctly when percent = TRUE", { labels <- c("A", "B") n_included <- c(`0` = 200L, `1` = 100L) - space <- 1 + space <- 1L percent <- TRUE - + result <- get_attrition_coords(labels = labels, n_included = n_included, space = space, percent = percent) - + # Expected percentage: for label, 100 * (n_included/n_total) # Row 1: 200/200 * 100 = 100% # Row 2: 100/200 * 100 = 50% @@ -70,38 +70,37 @@ test_that("get_attrition_coords calculates percentages correctly when percent = "A\nN = 200 (100%)", "B\nN = 100 (50%)" ) - + # Excluded for row 2 is 200 - 100 = 100 # Percentage: 100/200 * 100 = 50% expected_label_excl <- c( NA, "Excluded N = 100 (50%)" ) - - expect_equal(result$label, expected_label) - expect_equal(result$label_excl, expected_label_excl) + + expect_identical(result$label, expected_label) + expect_identical(result$label_excl, expected_label_excl) }) test_that("get_attrition_plot returns a ggplot object with expected structure", { # Using the provided input data from get_attrition_coords labels <- c("x", "Step: 1\nFilter: adsa (range = [1, 4])") n_included <- c(`0` = 150L, `1` = 100L) - space <- 1 + space <- 1L percent <- FALSE input_data <- get_attrition_coords(labels = labels, n_included = n_included, space = space, percent = percent) - + plot <- get_attrition_plot(input_data) - + # Check that the result is a ggplot object expect_s3_class(plot, "ggplot") - - # The logic of the function involves reversing the y-axis scale. + + # The logic of the function involves reversing the y-axis scale. # Check that a reversed y scale is applied. y_scale <- plot$scales$get_scales("y") expect_identical(y_scale$trans$name, "reverse", info = "Y scale should be reversed.") - + # Confirm that the labs are set to NULL for x and y, as per the logic expect_null(plot$labels$x) expect_null(plot$labels$y) }) - diff --git a/tests/testthat/test-cohort_methods.R b/tests/testthat/test-cohort_methods.R index f436906..1d02949 100644 --- a/tests/testthat/test-cohort_methods.R +++ b/tests/testthat/test-cohort_methods.R @@ -8,14 +8,14 @@ discrete_iris_two <- filter( ) range_iris_one <- filter( type = "range", id = "sepal_l", name = "Sepal.Length", - variable = "Sepal.Length", dataset = "iris", range = c(5, 6) + variable = "Sepal.Length", dataset = "iris", range = c(5L, 6L) ) range_iris_two <- filter( type = "range", id = "sepal_l_two", name = "Sepal.Length.Two", - variable = "Sepal.Length", dataset = "iris", range = c(9, 11) + variable = "Sepal.Length", dataset = "iris", range = c(9L, 11L) ) patients_source <- set_source( - tblist(patients = data.frame(id = 1:2, age = 50:51)) + tblist(patients = data.frame(id = 1L:2L, age = 50L:51L)) ) test_that("Running steps filter raw data properly", { @@ -29,11 +29,11 @@ test_that("Running steps filter raw data properly", { step(discrete_iris_one), step(discrete_iris_two) ) - expect_equal(coh$get_data(1, state = "pre")$iris, iris) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("setosa", "virginica")) - expect_setequal(collapse::funique(coh$get_data(2, state = "post")$iris$Species), c("virginica")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("setosa", "virginica")) + expect_setequal(collapse::funique(coh$get_data(2L, state = "post")$iris$Species), c("virginica")) # Using S3 Cohort method coh <- Cohort$new( @@ -41,11 +41,11 @@ test_that("Running steps filter raw data properly", { step(discrete_iris_one), step(discrete_iris_two) ) - expect_equal(coh$get_data(1, state = "pre")$iris, iris) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris) coh <- coh %>% run() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("setosa", "virginica")) - expect_setequal(collapse::funique(coh$get_data(2, state = "post")$iris$Species), c("virginica")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("setosa", "virginica")) + expect_setequal(collapse::funique(coh$get_data(2L, state = "post")$iris$Species), c("virginica")) }) test_that("Adding source on empty cohort works fine", { @@ -57,10 +57,10 @@ test_that("Adding source on empty cohort works fine", { coh$add_source(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_null(state$source_vars) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) # Using S3 Cohort methods coh <- Cohort$new() @@ -70,10 +70,10 @@ test_that("Adding source on empty cohort works fine", { coh <- coh %>% add_source(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_null(state$source_vars) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) }) test_that("Adding step on source-only cohort works fine", { @@ -89,12 +89,12 @@ test_that("Adding step on source-only cohort works fine", { ) ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("setosa", "virginica")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("setosa", "virginica")) coh <- Cohort$new() iris_source <- set_source( @@ -108,12 +108,12 @@ test_that("Adding step on source-only cohort works fine", { ) ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 2)) - expect_equal(state$steps_structure, list("1" = c("species_filter", "species_filter_two"))) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 2L)) + expect_identical(state$steps_structure, list("1" = c("species_filter", "species_filter_two"))) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("virginica")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("virginica")) # Using S3 Cohort methods coh <- Cohort$new() @@ -127,12 +127,12 @@ test_that("Adding step on source-only cohort works fine", { ) ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) coh <- coh %>% run() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("setosa", "virginica")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("setosa", "virginica")) coh <- Cohort$new() iris_source <- set_source( @@ -141,18 +141,18 @@ test_that("Adding step on source-only cohort works fine", { coh <- coh %>% add_source(iris_source) %>% add_step( - step( - discrete_iris_one, - discrete_iris_two + step( + discrete_iris_one, + discrete_iris_two + ) ) - ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 2)) - expect_equal(state$steps_structure, list("1" = c("species_filter", "species_filter_two"))) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 2L)) + expect_identical(state$steps_structure, list("1" = c("species_filter", "species_filter_two"))) coh <- coh %>% run() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("virginica")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("virginica")) }) test_that("Adding step on existing cohort with step works fine", { @@ -169,12 +169,12 @@ test_that("Adding step on existing cohort with step works fine", { ) ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 2) - expect_equal(state$n_filters, list("1" = 1, "2" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) + expect_identical(state$n_steps, 2L) + expect_identical(state$n_filters, list("1" = 1L, "2" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(2, state = "post")$iris$Species), c("virginica")) + expect_setequal(collapse::funique(coh$get_data(2L, state = "post")$iris$Species), c("virginica")) ## auto-run flow coh <- Cohort$new( @@ -190,10 +190,10 @@ test_that("Adding step on existing cohort with step works fine", { run_flow = TRUE ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 2) - expect_equal(state$n_filters, list("1" = 1, "2" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) - expect_setequal(collapse::funique(coh$get_data(2, state = "post")$iris$Species), c("virginica")) + expect_identical(state$n_steps, 2L) + expect_identical(state$n_filters, list("1" = 1L, "2" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) + expect_setequal(collapse::funique(coh$get_data(2L, state = "post")$iris$Species), c("virginica")) # Using S3 Cohort methods coh <- Cohort$new( @@ -208,12 +208,12 @@ test_that("Adding step on existing cohort with step works fine", { ) ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 2) - expect_equal(state$n_filters, list("1" = 1, "2" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) + expect_identical(state$n_steps, 2L) + expect_identical(state$n_filters, list("1" = 1L, "2" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) coh <- coh %>% run() - expect_setequal(collapse::funique(coh$get_data(2, state = "post")$iris$Species), c("virginica")) + expect_setequal(collapse::funique(coh$get_data(2L, state = "post")$iris$Species), c("virginica")) ## auto-run flow coh <- Cohort$new( @@ -229,10 +229,10 @@ test_that("Adding step on existing cohort with step works fine", { run_flow = TRUE ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 2) - expect_equal(state$n_filters, list("1" = 1, "2" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) - expect_setequal(collapse::funique(coh$get_data(2, state = "post")$iris$Species), c("virginica")) + expect_identical(state$n_steps, 2L) + expect_identical(state$n_filters, list("1" = 1L, "2" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter", "2" = "species_filter_two")) + expect_setequal(collapse::funique(coh$get_data(2L, state = "post")$iris$Species), c("virginica")) }) test_that("Removing step works fine", { @@ -249,11 +249,11 @@ test_that("Removing step works fine", { discrete_iris_two ) ) - coh$remove_step(2) + coh$remove_step(2L) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) ## >1 steps and remove first step coh <- Cohort$new( @@ -267,11 +267,11 @@ test_that("Removing step works fine", { discrete_iris_two ) ) - coh$remove_step(1) + coh$remove_step(1L) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter_two")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter_two")) ## 1 step and removing it coh <- Cohort$new( @@ -282,11 +282,11 @@ test_that("Removing step works fine", { discrete_iris_one ) ) - coh$remove_step(1) + coh$remove_step(1L) state <- coh$sum_up_state() - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) # Using S3 methods on Cohort object ## >1 steps and remove last step @@ -301,11 +301,11 @@ test_that("Removing step works fine", { discrete_iris_two ) ) - coh <- coh %>% rm_step(2) + coh <- coh %>% rm_step(2L) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) ## >1 steps and remove first step coh <- Cohort$new( @@ -319,11 +319,11 @@ test_that("Removing step works fine", { discrete_iris_two ) ) - coh <- coh %>% rm_step(1) + coh <- coh %>% rm_step(1L) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter_two")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter_two")) ## 1 step and removing it coh <- Cohort$new( @@ -334,11 +334,11 @@ test_that("Removing step works fine", { discrete_iris_one ) ) - coh <- coh %>% rm_step(1) + coh <- coh %>% rm_step(1L) state <- coh$sum_up_state() - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) }) test_that("Adding filter works fine", { @@ -352,9 +352,9 @@ test_that("Adding filter works fine", { discrete_iris_one ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # Using S3 Cohort methods coh <- Cohort$new( @@ -368,9 +368,9 @@ test_that("Adding filter works fine", { ) state <- coh$sum_up_state() - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) }) test_that("Removing filter works fine", { @@ -385,10 +385,10 @@ test_that("Removing filter works fine", { discrete_iris_two ) ) - coh$remove_filter(1, "species_filter_two") + coh$remove_filter(1L, "species_filter_two") state <- coh$sum_up_state() - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # >1 filters in the step and removing the first one coh <- Cohort$new( @@ -400,10 +400,10 @@ test_that("Removing filter works fine", { discrete_iris_two ) ) - coh$remove_filter(1, "species_filter") + coh$remove_filter(1L, "species_filter") state <- coh$sum_up_state() - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter_two")) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter_two")) # 1 filter and removing it coh <- cohort( @@ -414,11 +414,11 @@ test_that("Removing filter works fine", { discrete_iris_one ) ) - coh <- coh %>% rm_filter(1, "species_filter") + coh <- coh %>% rm_filter(1L, "species_filter") state <- coh$sum_up_state() - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) # Using S3 Cohort methods ## >1 filters in the step and removing the last one @@ -431,10 +431,10 @@ test_that("Removing filter works fine", { discrete_iris_two ) ) - coh <- coh %>% rm_filter(1, "species_filter_two") + coh <- coh %>% rm_filter(1L, "species_filter_two") state <- coh$sum_up_state() - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # >1 filters in the step and removing the first one coh <- cohort( @@ -446,10 +446,10 @@ test_that("Removing filter works fine", { discrete_iris_two ) ) - coh <- coh %>% rm_filter(1, "species_filter") + coh <- coh %>% rm_filter(1L, "species_filter") state <- coh$sum_up_state() - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter_two")) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter_two")) # 1 filter and removing it coh <- cohort( @@ -460,11 +460,11 @@ test_that("Removing filter works fine", { discrete_iris_one ) ) - coh <- coh %>% rm_filter(1, "species_filter") + coh <- coh %>% rm_filter(1L, "species_filter") state <- coh$sum_up_state() - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) }) test_that("Updating filter works fine", { @@ -478,17 +478,17 @@ test_that("Updating filter works fine", { discrete_iris_two ) ) - coh$update_filter(1, "species_filter_two", value = "setosa") + coh$update_filter(1L, "species_filter_two", value = "setosa") coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), "setosa") + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), "setosa") - coh$update_filter(1, "sepal_l", variable = "Petal.Length", range = c(1, 1.5)) + coh$update_filter(1L, "sepal_l", variable = "Petal.Length", range = c(1.0, 1.5)) coh$run_flow() - var_range <- range(coh$get_data(1, state = "post")$iris$Petal.Length) - expect_true(var_range[1] >= 1 && var_range[2] <= 1.5) + var_range <- range(coh$get_data(1L, state = "post")$iris$Petal.Length) + expect_true(var_range[1L] >= 1L && var_range[2L] <= 1.5) expect_warning( - coh$update_filter(1, "sepal_l", type = "discrete"), + coh$update_filter(1L, "sepal_l", type = "discrete"), label = "Cannot modify filter ‘type’, ‘id’, ‘name’ parameters." ) @@ -502,24 +502,24 @@ test_that("Updating filter works fine", { discrete_iris_two ) ) - coh <- coh %>% update_filter(1, 'species_filter_two', value = "setosa") + coh <- coh %>% update_filter(1L, "species_filter_two", value = "setosa") coh <- coh %>% run() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), "setosa") + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), "setosa") - coh <- coh %>% update_filter(1, "sepal_l", variable = "Petal.Length", range = c(1, 1.5)) + coh <- coh %>% update_filter(1L, "sepal_l", variable = "Petal.Length", range = c(1.0, 1.5)) coh <- coh %>% run() - var_range <- range(coh$get_data(1, state = "post")$iris$Petal.Length) - expect_true(var_range[1] >= 1 && var_range[2] <= 1.5) + var_range <- range(coh$get_data(1L, state = "post")$iris$Petal.Length) + expect_true(var_range[1L] >= 1L && var_range[2L] <= 1.5) expect_warning( - coh$update_filter(1, "sepal_l", type = "discrete"), + coh$update_filter(1L, "sepal_l", type = "discrete"), label = "Cannot modify filter ‘type’, ‘id’, ‘name’ parameters." ) }) test_that("Updating source works fine", { iris2 <- iris - iris2[150, 1] <- 10 + iris2[150L, 1L] <- 10L new_source <- set_source( tblist(iris = iris2) ) @@ -539,11 +539,11 @@ test_that("Updating source works fine", { coh$update_source(new_source, keep_steps = FALSE) state <- coh$sum_up_state() - expect_equal(coh$get_data(1, state = "pre")$iris, iris2) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris2) expect_true(state$source, TRUE) - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) ## setting up new source with keeping steps unchanged coh <- Cohort$new( @@ -558,17 +558,17 @@ test_that("Updating source works fine", { coh$update_source(new_source, keep_steps = TRUE) state <- coh$sum_up_state() - expect_identical(coh$get_data(1, state = "pre")$iris, iris2) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris2) expect_true(state$source, TRUE) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 2)) - expect_equal(state$steps_structure, list("1" = c("species_filter", "sepal_l_two"))) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 2L)) + expect_identical(state$steps_structure, list("1" = c("species_filter", "sepal_l_two"))) coh$run_flow() - expect_equal(coh$get_data(1, state = "post")$iris$Sepal.Length, 10) + expect_identical(coh$get_data(1L, state = "post")$iris$Sepal.Length, 10.0) iris2 <- iris - iris2[150, 1] <- 10 + iris2[150L, 1L] <- 10L new_source <- set_source( tblist(iris = iris2) ) @@ -588,11 +588,11 @@ test_that("Updating source works fine", { coh <- coh %>% update_source(new_source, keep_steps = FALSE) state <- coh$sum_up_state() - expect_identical(coh$get_data(1, state = "pre")$iris, iris2) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris2) expect_true(state$source, TRUE) - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) ## setting up new source with keeping steps unchanged coh <- cohort( @@ -607,14 +607,14 @@ test_that("Updating source works fine", { coh <- coh %>% update_source(new_source, keep_steps = TRUE) state <- coh$sum_up_state() - expect_identical(coh$get_data(1, state = "pre")$iris, iris2) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris2) expect_true(state$source, TRUE) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 2)) - expect_equal(state$steps_structure, list("1" = c("species_filter", "sepal_l_two"))) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 2L)) + expect_identical(state$steps_structure, list("1" = c("species_filter", "sepal_l_two"))) coh <- coh %>% run() - expect_equal(coh$get_data(1, state = "post")$iris$Sepal.Length, 10) + expect_identical(coh$get_data(1L, state = "post")$iris$Sepal.Length, 10.0) }) test_that("Getting filter stats works fine", { @@ -625,10 +625,10 @@ test_that("Getting filter stats works fine", { ), discrete_iris_one ) - expect_equal(coh$get_stats(1, "species_filter", state = "pre")$choices, as.list(table(iris$Species))) + expect_identical(coh$get_stats(1L, "species_filter", state = "pre")$choices, as.list(table(iris$Species))) coh$run_flow() - expect_equal( - coh$get_stats(1, "species_filter", state = "post")$choices, + expect_identical( + coh$get_stats(1L, "species_filter", state = "post")$choices, as.list(table(iris$Species[iris$Species %in% c("setosa", "virginica")])) ) @@ -640,10 +640,10 @@ test_that("Getting filter stats works fine", { discrete_iris_one ) - expect_equal(stat(coh, 1, "species_filter", state = "pre")$choices, as.list(table(iris$Species))) + expect_identical(stat(coh, 1L, "species_filter", state = "pre")$choices, as.list(table(iris$Species))) coh <- coh %>% run() - expect_equal( - stat(coh, 1, "species_filter", state = "post")$choices, + expect_identical( + stat(coh, 1L, "species_filter", state = "post")$choices, as.list(table(iris$Species[iris$Species %in% c("setosa", "virginica")])) ) }) @@ -658,23 +658,25 @@ test_that("Caching works fine", { ) coh$run_flow() - expect_equal(coh$get_cache("1", "species_filter", state = "pre")$choices, list(setosa = 50, versicolor = 50, virginica = 50)) - expect_equal(coh$get_cache("1", "species_filter", state = "pre")$n_data, 150) - expect_equal(coh$get_cache("1", "species_filter", state = "pre")$n_missing, 0) - - expect_equal(coh$get_cache("1", "species_filter", state = "post")$choices, list(setosa = 50, versicolor = 0, virginica = 50)) - expect_equal(coh$get_cache("1", "species_filter", state = "post")$n_data, 100) - expect_equal(coh$get_cache("1", "species_filter", state = "post")$n_missing, 0) + expect_identical(coh$get_cache("1", "species_filter", state = "pre")$choices, + list(setosa = 50L, versicolor = 50L, virginica = 50L)) + expect_identical(coh$get_cache("1", "species_filter", state = "pre")$n_data, 150L) + expect_identical(coh$get_cache("1", "species_filter", state = "pre")$n_missing, 0L) + + expect_identical(coh$get_cache("1", "species_filter", state = "post")$choices, + list(setosa = 50L, versicolor = 0L, virginica = 50L)) + expect_identical(coh$get_cache("1", "species_filter", state = "post")$n_data, 100L) + expect_identical(coh$get_cache("1", "species_filter", state = "post")$n_missing, 0L) }) test_that("Bind keys work fine", { patients <- data.frame( - id = letters[1:3], name = c("a", "b", "b"), - surname = c("A", "A", "B"), surname2 = c("A", "A", "B"), age = 1:3 + id = letters[1L:3L], name = c("a", "b", "b"), + surname = c("A", "A", "B"), surname2 = c("A", "A", "B"), age = 1L:3L ) treatment <- data.frame( - id = letters[1:3], name = c("a", "b", "b"), - surname = c("A", "A", "B"), treatment = LETTERS[1:3] + id = letters[1L:3L], name = c("a", "b", "b"), + surname = c("A", "A", "B"), treatment = LETTERS[1L:3L] ) @@ -686,7 +688,7 @@ test_that("Bind keys work fine", { bind_key(update = data_key("treatment", "id"), data_key("patients", "id")) ) ), - filter("range", id = "patients", name = "Patients", variable = "age", range = c(1, 2), dataset = "patients"), + filter("range", id = "patients", name = "Patients", variable = "age", range = c(1L, 2L), dataset = "patients"), filter("discrete", id = "treatment", name = "Treatment", variable = "treatment", value = NA, dataset = "treatment") ) @@ -694,16 +696,16 @@ test_that("Bind keys work fine", { expect_equal( coh$get_data("1", state = "post")$treatment, - treatment[1:2, ], + treatment[1L:2L, ], ignore_attr = TRUE ) expect_true( attr(coh$get_data("1", state = "post")$treatment, "filtered") ) - expect_equal(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1, "B" = 1)) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_data, 2) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_missing, 0) + expect_identical(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1L, "B" = 1L)) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_data, 2L) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_missing, 0L) # directed relation graph (update != "all"), multi key with same names coh <- Cohort$new( @@ -716,20 +718,20 @@ test_that("Bind keys work fine", { ) ) ), - filter("range", id = "patients", name = "Patients", variable = "age", range = c(1, 2), dataset = "patients"), + filter("range", id = "patients", name = "Patients", variable = "age", range = c(1L, 2L), dataset = "patients"), filter("discrete", id = "treatment", name = "Treatment", variable = "treatment", value = NA, dataset = "treatment") ) coh$run_flow() - expect_equal(coh$get_data("1", state = "post")$treatment, treatment[1:2, ], ignore_attr = TRUE) + expect_equal(coh$get_data("1", state = "post")$treatment, treatment[1L:2L, ], ignore_attr = TRUE) expect_true( attr(coh$get_data("1", state = "post")$treatment, "filtered") ) - expect_equal(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1, "B" = 1)) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_data, 2) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_missing, 0) + expect_identical(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1L, "B" = 1L)) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_data, 2L) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_missing, 0L) # directed relation graph (update != "all"), multi key with different names coh <- Cohort$new( @@ -742,20 +744,20 @@ test_that("Bind keys work fine", { ) ) ), - filter("range", id = "patients", name = "Patients", variable = "age", range = c(1, 2), dataset = "patients"), + filter("range", id = "patients", name = "Patients", variable = "age", range = c(1L, 2L), dataset = "patients"), filter("discrete", id = "treatment", name = "Treatment", variable = "treatment", value = NA, dataset = "treatment") ) coh$run_flow() - expect_equal(coh$get_data("1", state = "post")$treatment, treatment[1:2, ], ignore_attr = TRUE) + expect_equal(coh$get_data("1", state = "post")$treatment, treatment[1L:2L, ], ignore_attr = TRUE) expect_true( attr(coh$get_data("1", state = "post")$treatment, "filtered") ) - expect_equal(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1, "B" = 1)) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_data, 2) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_missing, 0) + expect_identical(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1L, "B" = 1L)) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_data, 2L) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_missing, 0L) # cyclic relation graph, single key coh <- Cohort$new( @@ -772,13 +774,13 @@ test_that("Bind keys work fine", { ) ) ), - filter("range", id = "patients", name = "Patients", variable = "age", range = c(1, 2), dataset = "patients"), + filter("range", id = "patients", name = "Patients", variable = "age", range = c(1L, 2L), dataset = "patients"), filter("discrete", id = "treatment", name = "Treatment", variable = "treatment", value = NA, dataset = "treatment") ) coh$run_flow() - expect_equal(coh$get_data("1", state = "post")$treatment, treatment[1:2, ], ignore_attr = TRUE) + expect_equal(coh$get_data("1", state = "post")$treatment, treatment[1L:2L, ], ignore_attr = TRUE) expect_true( attr(coh$get_data("1", state = "post")$treatment, "filtered") ) @@ -786,15 +788,16 @@ test_that("Bind keys work fine", { attr(coh$get_data("1", state = "post")$patients, "filtered") ) - expect_equal(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1, "B" = 1)) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_data, 2) - expect_equal(coh$get_cache("1", "treatment", state = "post")$n_missing, 0) + expect_identical(coh$get_cache("1", "treatment", state = "post")$choices, list("A" = 1L, "B" = 1L)) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_data, 2L) + expect_identical(coh$get_cache("1", "treatment", state = "post")$n_missing, 0L) }) test_that("Defining and accessing description works fine", { # Using direct Cohort methods species_filter_no_desc <- filter("discrete", id = "species", dataset = "iris", variable = "Species") - species_filter_desc <- filter("discrete", id = "species", dataset = "iris", variable = "Species", description = "Species Filter") + species_filter_desc <- filter("discrete", id = "species", dataset = "iris", + variable = "Species", description = "Species Filter") coh <- Cohort$new( set_source( tblist(iris = iris), @@ -803,45 +806,43 @@ test_that("Defining and accessing description works fine", { step(species_filter_no_desc), step(species_filter_desc) ) - expect_equal( + expect_identical( coh$show_help("iris"), "Iris dataset." ) - expect_equal( + expect_identical( description(coh, "iris"), "Iris dataset." ) - expect_equal( - coh$show_help(filter_id = "species", step_id = "1"), - NULL + expect_null( + coh$show_help(filter_id = "species", step_id = "1") ) - expect_equal( - description(coh, filter_id = "species", step_id = "1"), - NULL + expect_null( + description(coh, filter_id = "species", step_id = "1") ) - expect_equal( + expect_identical( coh$show_help(filter_id = "species", step_id = "2"), "Species Filter" ) - expect_equal( + expect_identical( description(coh, filter_id = "species", step_id = "2"), "Species Filter" ) }) test_that("steps_range returns empty character when from is greater than to", { - expect_equal(steps_range(3,2),character(0)) + expect_identical(steps_range(3L, 2L), character(0L)) }) test_that("eval_step_filters returns empty character when step id is equal", { - expect_equal(eval_step_filters(list(0, id = "2"),patients_source),list()) + expect_identical(eval_step_filters(list(0L, id = "2"), patients_source), list()) }) test_that("next_step returns the next index as a character string", { - expect_equal(next_step("1"),"2") - expect_type(next_step("1"),"character") + expect_identical(next_step("1"), "2") + expect_type(next_step("1"), "character") }) test_that("copy_step with step_id works correctly", { @@ -855,14 +856,14 @@ test_that("copy_step with step_id works correctly", { ) #set last id of step before using the function - pre_last_step_id<- as.integer(coh$last_step_id()) + pre_last_step_id <- as.integer(coh$last_step_id()) #get list of filters in first step - list_of_filters <- get_state(coh, 1)[[1]]$filters + list_of_filters <- get_state(coh, 1L)[[1L]]$filters - coh$copy_step(1) + coh$copy_step(1L) - expect_false(is.null(coh$get_step(pre_last_step_id+1))) - expect_identical(get_state(coh, coh$last_step_id())[[1]]$filters, list_of_filters) + expect_false(is.null(coh$get_step(pre_last_step_id + 1L))) + expect_identical(get_state(coh, coh$last_step_id())[[1L]]$filters, list_of_filters) }) test_that("copy_step without step_id duplicates filters from last step", { @@ -876,14 +877,14 @@ test_that("copy_step without step_id duplicates filters from last step", { ) #set last id of step before using the function - pre_last_step_id<- as.integer(coh$last_step_id()) + pre_last_step_id <- as.integer(coh$last_step_id()) #get list of filters in last step - list_of_filters <- get_state(coh, pre_last_step_id)[[1]]$filters + list_of_filters <- get_state(coh, pre_last_step_id)[[1L]]$filters coh$copy_step() - expect_false(is.null(coh$get_step(pre_last_step_id+1))) - expect_identical(get_state(coh,coh$last_step_id())[[1]]$filters, list_of_filters) + expect_false(is.null(coh$get_step(pre_last_step_id + 1L))) + expect_identical(get_state(coh, coh$last_step_id())[[1L]]$filters, list_of_filters) }) test_that("copy_step duplicate selected filters without step_id", { @@ -895,13 +896,13 @@ test_that("copy_step duplicate selected filters without step_id", { step(discrete_iris_two) ) - pre_last_step_id<- as.integer(coh$last_step_id()) - list_of_filters <- get_state(coh,1)[[1]]$filters + pre_last_step_id <- as.integer(coh$last_step_id()) + list_of_filters <- get_state(coh, 1L)[[1L]]$filters - coh$copy_step(filters=coh$get_filter(1)) + coh$copy_step(filters = coh$get_filter(1L)) - expect_false(is.null(coh$get_step(pre_last_step_id+1))) - expect_identical(get_state(coh,coh$last_step_id())[[1]]$filters, list_of_filters) + expect_false(is.null(coh$get_step(pre_last_step_id + 1L))) + expect_identical(get_state(coh, coh$last_step_id())[[1L]]$filters, list_of_filters) }) test_that("copy_step trigger data calculations works fine", { @@ -913,14 +914,14 @@ test_that("copy_step trigger data calculations works fine", { step(discrete_iris_two) ) - list_of_filters <- get_state(coh,coh$last_step_id())[[1]]$filters + list_of_filters <- get_state(coh, coh$last_step_id())[[1L]]$filters expect_null(get_data(coh)) coh$copy_step(run_flow = TRUE) expect_false(is.null(get_data(coh))) - expect_identical(get_state(coh, coh$last_step_id())[[1]]$filters, list_of_filters) + expect_identical(get_state(coh, coh$last_step_id())[[1L]]$filters, list_of_filters) }) test_that("remove_step with missing step_id remove last step", { @@ -933,19 +934,19 @@ test_that("remove_step with missing step_id remove last step", { ) - pre_last_step_id<- as.integer(coh$last_step_id()) + pre_last_step_id <- as.integer(coh$last_step_id()) #set list of filters to ensure that only the last step is removed - if(pre_last_step_id!=1){ - pre_list_of_filters <- get_state(coh,c(1:pre_last_step_id-1)) + if (pre_last_step_id != 1L) { + pre_list_of_filters <- get_state(coh, c(1L:pre_last_step_id - 1L)) } coh$remove_step() - expect_equal(coh$last_step_id(),as.character(pre_last_step_id-1)) + expect_identical(coh$last_step_id(), as.character(pre_last_step_id - 1L)) expect_null(coh$get_step(pre_last_step_id)) - if(pre_last_step_id!=1) { - expect_identical(get_state(coh,c(1:pre_last_step_id-1)),pre_list_of_filters) + if (pre_last_step_id != 1L) { + expect_identical(get_state(coh, c(1L:pre_last_step_id - 1L)), pre_list_of_filters) } }) @@ -975,7 +976,7 @@ test_that("add_filter trigger data calculations works fine", { expect_null(get_data(coh)) - coh$add_filter(range_iris_one,1,run_flow = TRUE) + coh$add_filter(range_iris_one, 1L, run_flow = TRUE) expect_false(is.null(get_data(coh))) }) @@ -990,7 +991,7 @@ test_that("remove_filter trigger data calculations works fine", { expect_null(get_data(coh)) - coh$remove_filter(1,1,run_flow = TRUE) + coh$remove_filter(1L, 1L, run_flow = TRUE) expect_false(is.null(get_data(coh))) }) @@ -1003,7 +1004,7 @@ test_that("get_state returns state in JSON format correctly", { step(discrete_iris_one) ) - expect_true(jsonlite::validate(get_state(coh,1,json = TRUE))) + expect_true(jsonlite::validate(get_state(coh, 1L, json = TRUE))) }) test_that("Restoring cohort configurations works fine", { @@ -1015,17 +1016,17 @@ test_that("Restoring cohort configurations works fine", { ) # Character type pre_state_character <- get_state(coh) - coh$add_filter(range_iris_one,2) - expect_false(identical(get_state(coh),pre_state_character)) - restore(coh,pre_state_character) - expect_true(identical(get_state(coh),pre_state_character)) + coh$add_filter(range_iris_one, 2L) + expect_false(identical(get_state(coh), pre_state_character)) + restore(coh, pre_state_character) + expect_identical(get_state(coh), pre_state_character) # JSON type pre_state_json <- get_state(coh, json = TRUE) - coh$add_filter(range_iris_one,2) - expect_false(identical(get_state(coh),pre_state_character)) - restore(coh,pre_state_json) - expect_true(identical(get_state(coh),pre_state_character)) + coh$add_filter(range_iris_one, 2L) + expect_false(identical(get_state(coh), pre_state_character)) + restore(coh, pre_state_json) + expect_identical(get_state(coh), pre_state_character) }) test_that("Restoring cohort configurations without state returns invisible FALSE", { @@ -1038,12 +1039,12 @@ test_that("Restoring cohort configurations without state returns invisible FALSE pre_state <- get_state(coh) - coh$add_filter(range_iris_one,2) + coh$add_filter(range_iris_one, 2L) - expect_false(identical(get_state(coh),pre_state)) + expect_false(identical(get_state(coh), pre_state)) expect_invisible(coh$restore(state = NULL)) expect_false(coh$restore(state = NULL)) - expect_false(identical(get_state(coh),pre_state)) + expect_false(identical(get_state(coh), pre_state)) }) test_that("Restoring cohort configurations trigger data calculations works fine", { @@ -1057,15 +1058,15 @@ test_that("Restoring cohort configurations trigger data calculations works fine" run(coh_2) pre_state <- get_state(coh) - coh$add_filter(range_iris_one,2) - expect_false(identical(get_state(coh_2),get_state(coh))) + coh$add_filter(range_iris_one, 2L) + expect_false(identical(get_state(coh_2), get_state(coh))) expect_null(get_data(coh)) restore(coh, pre_state, run_flow = TRUE) expect_false(is.null(get_data(coh))) - expect_identical(get_state(coh),get_state(coh)) - expect_identical(get_data(coh),get_data(coh)) + expect_identical(get_state(coh), get_state(coh)) + expect_identical(get_data(coh), get_data(coh)) }) test_that("restore correctly restore filters filter type date_range and datetime_range", { @@ -1075,33 +1076,33 @@ test_that("restore correctly restore filters filter type date_range and datetime ), step( filter( - "date_range", id = "issues_date", dataset = "issues", - variable = "date", range = c(as.Date("2010-10-01"), as.Date("2015-10-01")) + "date_range", id = "issues_date", dataset = "issues", + variable = "date", range = c(as.Date("2010-10-01"), as.Date("2015-10-01")) ), filter( - "date_range", id = "issues_date2", dataset = "issues", - variable = "date", range = as.Date(NULL) + "date_range", id = "issues_date2", dataset = "issues", + variable = "date", range = as.Date(NULL) ), filter( - "datetime_range", id = "issues_datetime", dataset = "issues", - variable = "date", range = c(as.POSIXct("2010-10-01"), as.POSIXct("2015-10-01")) + "datetime_range", id = "issues_datetime", dataset = "issues", + variable = "date", range = c(as.POSIXct("2010-10-01"), as.POSIXct("2015-10-01")) ), filter( - "datetime_range", id = "issues_datetime2", dataset = "issues", - variable = "date", range = as.POSIXct(NULL)) + "datetime_range", id = "issues_datetime2", dataset = "issues", + variable = "date", range = as.POSIXct(NULL)) ) ) pre_state <- get_state(coh) - coh$add_filter(range_iris_one,2) - coh$remove_filter(1,"issues_datetime") + coh$add_filter(range_iris_one, 2L) + coh$remove_filter(1L, "issues_datetime") - expect_false(identical(get_state(coh),pre_state)) + expect_false(identical(get_state(coh), pre_state)) restore(coh, pre_state) - expect_identical(get_state(coh),pre_state) + expect_identical(get_state(coh), pre_state) }) # if (!covr::in_covr()) { # covr modifies function body so the test doesn't pass diff --git a/tests/testthat/test-reproducible_code_utils.R b/tests/testthat/test-reproducible_code_utils.R index 4465324..e52a79a 100644 --- a/tests/testthat/test-reproducible_code_utils.R +++ b/tests/testthat/test-reproducible_code_utils.R @@ -1,46 +1,46 @@ test_that("parse_func_expr assigns last line to data_object variable", { test_fun_one <- function() { - val <- a + 1 + val <- a + 1L val } - expect_equal( + expect_identical( parse_func_expr(test_fun_one), quote({ - val <- a + 1 + val <- a + 1L data_object <- val }) ) }) test_that("parse_func_expr substitutes environment variables", { - test_fun_one <- function(a = 2) { - val <- a + 1 + test_fun_one <- function(a = 2L) { + val <- a + 1L val } - expect_equal( + expect_identical( parse_func_expr(test_fun_one), quote({ - val <- 2 + 1 + val <- 2L + 1L data_object <- val }) ) }) test_that("parse_func_expr returns an empty expression when func is NULL", { - expect_equal(parse_func_expr(NULL), - quote({})) + expect_identical(parse_func_expr(NULL), + quote({})) }) test_that("combine_expressions merges multiple expressions into a single one", { - test_fun_one <- function(data_object, b = 1) { + test_fun_one <- function(data_object, b = 1L) { data_object <- a + b data_object } - test_fun_two <- function(data_object, d = 2) { + test_fun_two <- function(data_object, d = 2L) { data_object + d } - expect_equal( + expect_identical( combine_expressions( list( parse_func_expr(test_fun_one), @@ -48,60 +48,59 @@ test_that("combine_expressions merges multiple expressions into a single one", { ) ), quote({ - data_object <- a + 1 + data_object <- a + 1L data_object <- data_object - data_object <- data_object + 2 + data_object <- data_object + 2L }) ) }) test_that("pair_seq handles empty input gracefully", { # Given an empty input, expect empty integer vector - result <- pair_seq(integer(0)) - expect_true(is.integer(result)) - expect_identical(result,integer(0)) - expect_length(result, 0) + result <- pair_seq(integer(0L)) + expect_type(result, "integer") + expect_identical(result, integer(0L)) + expect_length(result, 0L) }) test_that("pair_seq requires an even number of indexes", { # If odd length input is provided, function should fail - expect_error(pair_seq(c(1, 2, 3)), regexp ="The lenght of idxs is not even number") + expect_error(pair_seq(c(1L, 2L, 3L)), regexp = "The lenght of idxs is not even number") }) test_that("pair_seq always returns a strictly increasing sequence of integers", { # Check that output is sorted and has no duplicates for a known even-length input - input <- c(3, 1, 7, 5) # Unsorted input + input <- c(3L, 1L, 7L, 5L) # Unsorted input result <- pair_seq(input) - + # Expect numeric output - expect_true(is.numeric(result)) expect_type(result, "double") # Expect output is in strictly ascending order - expect_true(all(diff(result) > 0)) - + expect_true(all(diff(result) > 0L)) + }) test_that("parse_func_expr returns an empty expression when func is NULL", { - expect_equal(parse_func_expr(NULL), - quote({})) + expect_identical(parse_func_expr(NULL), + quote({})) }) test_that("func_to_expr returns an empty expression when func is NULL", { - expect_equal(func_to_expr(NULL,"test"), - quote({})) + expect_identical(func_to_expr(NULL, "test"), + quote({})) }) test_that("func_to_expr returns a language object that includes the specified function name", { test_fun_one <- function() { - val <- a + 1 + val <- a + 1L val } name <- "simple_func_name" result <- func_to_expr(test_fun_one, name) - expect_type(result,"language") - expect_equal(as.character(result[2]), name) + expect_type(result, "language") + expect_identical(as.character(result[2L]), name) }) test_that("parse_filter_expr works fine", { @@ -117,35 +116,35 @@ test_that("parse_filter_expr works fine", { step(discrete_iris_one) ) - result <- parse_filter_expr(coh$get_filter(1,1)) + result <- parse_filter_expr(coh$get_filter(1L, 1L)) expect_type(result, "language") - expect_true(is.call(result)) }) test_that("method_to_expr works fine", { - expect_null(method_to_expr("not_existing_name","not_existing_namespace")) + expect_null(method_to_expr("not_existing_name", "not_existing_namespace")) }) test_that("method_to_expr return function works fine", { name <- ".pre_filtering" namespace <- "tblist" - result <- method_to_expr(name,namespace) + result <- method_to_expr(name, namespace) expect_type(result, "language") - expect_true(is.call(result)) - expect_equal(formals(eval(result)), formals(paste0(name,".",namespace))) + expect_identical(formals(eval(result)), formals(paste0(name, ".", namespace))) }) test_that("assign_expr works fine", { - body_of_function <- quote(function(a=1,b=1) {a+b}) + body_of_function <- quote(function(a = 1L, b = 1L) { + a + b + }) result <- assign_expr(quote(function_name), body_of_function) eval_result <- eval(result) eval_body <- eval(body_of_function) - expect_type(result,"language") - expect_equal(body(eval_result), body(eval_body)) - expect_equal(formals(eval_result), formals(eval_body)) + expect_type(result, "language") + expect_identical(body(eval_result), body(eval_body)) + expect_identical(formals(eval_result), formals(eval_body)) }) diff --git a/tests/testthat/test-source_methods.R b/tests/testthat/test-source_methods.R index cad2497..50fc432 100644 --- a/tests/testthat/test-source_methods.R +++ b/tests/testthat/test-source_methods.R @@ -7,14 +7,14 @@ discrete_filter_species_two <- filter( variable = "Species", dataset = "iris", value = c("setosa", "virginica") ) patients_source <- set_source( - tblist(patients = data.frame(id = 1:2, age = 50:51)), + tblist(patients = data.frame(id = 1L:2L, age = 50L:51L)), extra_param_one = "extra parameter", extra_param_two = "extra parameter" ) test_that("Calling tblist type source returns valid structure list", { - expect_equal(class(patients_source), c("tblist", "Source", "R6")) - expect_equal(names(patients_source$attributes), c("extra_param_one", "extra_param_two")) + expect_s3_class(patients_source, c("tblist", "Source", "R6")) + expect_named(patients_source$attributes, c("extra_param_one", "extra_param_two")) }) test_that("Adding step on source works fine", { @@ -29,10 +29,10 @@ test_that("Adding step on source works fine", { coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # two steps iris_source <- set_source( @@ -49,10 +49,10 @@ test_that("Adding step on source works fine", { coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 2) - expect_equal(state$n_filters, list("1" = 1, "2" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter", "2" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 2L) + expect_identical(state$n_filters, list("1" = 1L, "2" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter", "2" = "species_filter")) }) test_that("Removing step on source works fine", { @@ -66,14 +66,14 @@ test_that("Removing step on source works fine", { ) iris_source <- iris_source %>% - rm_step(1) + rm_step(1L) coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_null(state$source_vars) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) # two steps iris_source <- set_source( @@ -93,31 +93,31 @@ test_that("Removing step on source works fine", { coh <- Cohort$new(no_last_step) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) no_last_step_specified <- iris_source$clone() %>% - rm_step(2) + rm_step(2L) coh <- Cohort$new(no_last_step_specified) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # checking if steps are renamed no_first_step <- iris_source$clone() %>% - rm_step(1) + rm_step(1L) coh <- Cohort$new(no_first_step) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) }) test_that("Adding filter on source works fine and attaches it to correct step", { @@ -130,10 +130,10 @@ test_that("Adding filter on source works fine and attaches it to correct step", coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # step_id provided iris_source <- set_source( @@ -145,10 +145,10 @@ test_that("Adding filter on source works fine and attaches it to correct step", coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) # multiple filters in the same (latest) step iris_source <- set_source( @@ -162,10 +162,10 @@ test_that("Adding filter on source works fine and attaches it to correct step", coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 2)) - expect_equal(state$steps_structure, list("1" = c("species_filter", "species_filter_two"))) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 2L)) + expect_identical(state$steps_structure, list("1" = c("species_filter", "species_filter_two"))) # multiple filters in different steps iris_source <- set_source( @@ -181,10 +181,10 @@ test_that("Adding filter on source works fine and attaches it to correct step", coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 2) - expect_equal(state$n_filters, list("1" = 1, "2" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter", "2" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 2L) + expect_identical(state$n_filters, list("1" = 1L, "2" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter", "2" = "species_filter")) }) test_that("Removing filter on source works fine", { @@ -195,14 +195,14 @@ test_that("Removing filter on source works fine", { ) removed_last_filter <- iris_source$clone() %>% - rm_filter(1, "species_filter") + rm_filter(1L, "species_filter") coh <- Cohort$new(removed_last_filter) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 0) - expect_equal(state$n_filters, 0) - expect_equal(state$steps_structure, list()) + expect_null(state$source_vars) + expect_identical(state$n_steps, 0L) + expect_identical(state$n_filters, 0L) + expect_identical(state$steps_structure, list()) iris_source <- set_source( tblist(iris = iris) @@ -216,20 +216,20 @@ test_that("Removing filter on source works fine", { coh <- Cohort$new(removed_filter_but_not_last_one) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter")) removed_first_filter_in_step <- iris_source$clone() %>% - rm_filter(1, "species_filter") + rm_filter(1L, "species_filter") coh <- Cohort$new(removed_first_filter_in_step) state <- coh$sum_up_state() expect_true(state$source) - expect_equal(state$source_vars, NULL) - expect_equal(state$n_steps, 1) - expect_equal(state$n_filters, list("1" = 1)) - expect_equal(state$steps_structure, list("1" = "species_filter_two")) + expect_null(state$source_vars) + expect_identical(state$n_steps, 1L) + expect_identical(state$n_filters, list("1" = 1L)) + expect_identical(state$steps_structure, list("1" = "species_filter_two")) }) test_that("Updating filter on source works fine", { @@ -239,10 +239,10 @@ test_that("Updating filter on source works fine", { discrete_filter_species ) iris_source <- iris_source %>% - update_filter(1, "species_filter", value = "setosa") + update_filter(1L, "species_filter", value = "setosa") coh <- Cohort$new(iris_source) coh$run_flow() - expect_setequal(coh$get_data(1, state = "post")$iris$Species, "setosa") + expect_setequal(coh$get_data(1L, state = "post")$iris$Species, "setosa") }) test_that("Removing step with ID '0' triggers warning", { @@ -256,21 +256,21 @@ test_that("Removing step with ID '0' triggers warning", { }) test_that("Initialize source with primary key set attribute primary_key", { - key <- 1 + key <- 1L iris_source <- set_source( - tblist(iris = iris), - primary_keys = key) + tblist(iris = iris), + primary_keys = key) type_of_primary_key <- typeof(key) - expect_equal(iris_source$primary_keys, key) + expect_identical(iris_source$primary_keys, key) expect_type(iris_source$primary_keys, type_of_primary_key) expect_false(is.null(iris_source$primary_keys)) }) test_that("get returns attributes of source", { iris_source <- set_source( - tblist(iris = iris), - atribute1 = "test") + tblist(iris = iris), + atribute1 = "test") expect_type(iris_source$get("atribute1"), "character") expect_type(iris_source$get("atribute2"), "NULL") diff --git a/tests/testthat/test-step.R b/tests/testthat/test-step.R index 9390e7b..2e319b5 100644 --- a/tests/testthat/test-step.R +++ b/tests/testthat/test-step.R @@ -1,25 +1,25 @@ discrete_filter <- filter( - type = "discrete", id = "age_filter", name = "Age", variable = "age", dataset = "patients", value = 50 + type = "discrete", id = "age_filter", name = "Age", variable = "age", dataset = "patients", value = 50L ) discrete_filter_two <- filter( - type = "discrete", id = "age_filter_two", name = "Age", variable = "age", dataset = "patients", value = 50 + type = "discrete", id = "age_filter_two", name = "Age", variable = "age", dataset = "patients", value = 50L ) patients_source <- set_source( - tblist(patients = data.frame(id = 1:2, age = 50:51)) + tblist(patients = data.frame(id = 1L:2L, age = 50L:51L)) ) test_that("Registering steps and filters works for various filter-step combinations", { no_source <- register_steps_and_filters() - expect_equal(no_source, list()) + expect_identical(no_source, list()) source_no_steps_and_filters <- register_steps_and_filters(patients_source) - expect_equal(no_source, list()) + expect_identical(no_source, list()) no_step_one_filter <- register_steps_and_filters( patients_source, discrete_filter ) - expect_equal(step_filter_state(no_step_one_filter), list("1" = 1)) + expect_identical(step_filter_state(no_step_one_filter), list("1" = 1L)) expect_error( register_steps_and_filters( @@ -35,7 +35,7 @@ test_that("Registering steps and filters works for various filter-step combinati discrete_filter, discrete_filter_two ) - expect_equal(step_filter_state(no_step_two_filters), list("1" = 2)) + expect_identical(step_filter_state(no_step_two_filters), list("1" = 2L)) one_step_one_filter <- register_steps_and_filters( patients_source, @@ -43,9 +43,9 @@ test_that("Registering steps and filters works for various filter-step combinati discrete_filter ) ) - expect_equal(step_filter_state(one_step_one_filter), list("1" = 1)) + expect_identical(step_filter_state(one_step_one_filter), list("1" = 1L)) expect_setequal(unname(no_step_one_filter), unname(one_step_one_filter)) - expect_equal(names(no_step_one_filter), names(one_step_one_filter)) + expect_named(no_step_one_filter, names(one_step_one_filter)) expect_error( register_steps_and_filters( @@ -65,9 +65,9 @@ test_that("Registering steps and filters works for various filter-step combinati discrete_filter_two ) ) - expect_equal(step_filter_state(one_step_two_filters), list("1" = 2)) + expect_identical(step_filter_state(one_step_two_filters), list("1" = 2L)) expect_setequal(unname(one_step_two_filters), unname(no_step_two_filters)) - expect_equal(names(one_step_two_filters), names(no_step_two_filters)) + expect_named(one_step_two_filters, names(no_step_two_filters)) two_steps <- register_steps_and_filters( patients_source, @@ -77,16 +77,16 @@ test_that("Registering steps and filters works for various filter-step combinati ), step(discrete_filter) ) - expect_equal(step_filter_state(two_steps), list("1" = 2, "2" = 1)) + expect_identical(step_filter_state(two_steps), list("1" = 2L, "2" = 1L)) #?? here filter_in_source <- patients_source$clone() %>% add_filter(discrete_filter) one_filter_in_source <- register_steps_and_filters(filter_in_source) - expect_equal(step_filter_state(one_filter_in_source), list("1" = 1)) + expect_identical(step_filter_state(one_filter_in_source), list("1" = 1L)) expect_setequal(unname(one_filter_in_source), unname(one_step_one_filter)) - expect_equal(names(one_filter_in_source), names(one_step_one_filter)) + expect_named(one_filter_in_source, names(one_step_one_filter)) same_filters_in_source <- patients_source$clone() %>% add_filter(discrete_filter) %>% @@ -101,9 +101,9 @@ test_that("Registering steps and filters works for various filter-step combinati add_filter(discrete_filter_two) two_filters_in_source <- register_steps_and_filters(filters_in_source) - expect_equal(step_filter_state(two_filters_in_source), list("1" = 2)) + expect_identical(step_filter_state(two_filters_in_source), list("1" = 2L)) expect_setequal(unname(two_filters_in_source), unname(one_step_two_filters)) - expect_equal(names(two_filters_in_source), names(one_step_two_filters)) + expect_named(two_filters_in_source, names(one_step_two_filters)) filters_in_two_steps <- patients_source$clone() %>% add_filter(discrete_filter, "1") %>% @@ -111,24 +111,24 @@ test_that("Registering steps and filters works for various filter-step combinati add_filter(discrete_filter, "2") filters_in_two_sources_reg <- register_steps_and_filters(filters_in_two_steps) - expect_equal(step_filter_state(filters_in_two_sources_reg), list("1" = 2, "2" = 1)) + expect_identical(step_filter_state(filters_in_two_sources_reg), list("1" = 2L, "2" = 1L)) expect_setequal(unname(filters_in_two_sources_reg), unname(two_steps)) - expect_equal(names(filters_in_two_sources_reg), names(two_steps)) + expect_named(filters_in_two_sources_reg, names(two_steps)) step_in_source <- patients_source$clone() %>% add_step(step(discrete_filter, discrete_filter_two)) step_in_source_req <- register_steps_and_filters(step_in_source) - expect_equal(step_filter_state(step_in_source_req), list("1" = 2)) + expect_identical(step_filter_state(step_in_source_req), list("1" = 2L)) expect_setequal(unname(step_in_source_req), unname(one_step_two_filters)) - expect_equal(names(step_in_source_req), names(one_step_two_filters)) + expect_named(step_in_source_req, names(one_step_two_filters)) steps_in_source <- patients_source$clone() %>% add_step(step(discrete_filter, discrete_filter_two)) %>% add_step(step(discrete_filter)) steps_in_source_req <- register_steps_and_filters(steps_in_source) - expect_equal(step_filter_state(steps_in_source_req), list("1" = 2, "2" = 1)) + expect_identical(step_filter_state(steps_in_source_req), list("1" = 2L, "2" = 1L)) expect_setequal(unname(steps_in_source_req), unname(two_steps)) - expect_equal(names(steps_in_source_req), names(two_steps)) + expect_named(steps_in_source_req, names(two_steps)) }) From 5e23582b7d1677c6eacbd297bff4a7f9efe5d2ac Mon Sep 17 00:00:00 2001 From: Borys Date: Sun, 23 Feb 2025 19:08:09 +0100 Subject: [PATCH 04/10] Update files --- R/attrition.R | 31 +++++----- R/cohort_methods.R | 17 +++--- R/filter.R | 6 +- R/list_operators.R | 12 ++-- R/repro_code_utils.R | 94 +++++++++++++++--------------- R/source_methods.R | 12 ++-- vignettes/cohort-configuration.Rmd | 2 +- 7 files changed, 86 insertions(+), 88 deletions(-) diff --git a/R/attrition.R b/R/attrition.R index 05dc4f5..f7d3347 100644 --- a/R/attrition.R +++ b/R/attrition.R @@ -1,5 +1,5 @@ -get_attrition_coords <- function(labels, n_included, space = 1, percent = FALSE) { - n_total <- n_included[1] +get_attrition_coords <- function(labels, n_included, space = 1L, percent = FALSE) { + n_total <- n_included[1L] n_excluded <- stats::na.omit(n_included - dplyr::lead(n_included)) label <- glue::glue("{labels}\nN = {n_included}") @@ -16,12 +16,12 @@ get_attrition_coords <- function(labels, n_included, space = 1, percent = FALSE) ) %>% dplyr::mutate( label_heights = nchar(label) - nchar(gsub("\n", "", label)), - label_position_y = dplyr::lag(cumsum(label_heights + space), default = 0), - label_position_x = 0, + label_position_y = dplyr::lag(cumsum(label_heights + space), default = 0L), + label_position_x = 0L, arrow_end_position_y = dplyr::lead(label_position_y), - excl_position_x = 0, - excl_end_position_x = 40, - excl_position_y = dplyr::lag(arrow_end_position_y) - (space / 2) + excl_position_x = 0L, + excl_end_position_x = 40L, + excl_position_y = dplyr::lag(arrow_end_position_y) - (space / 2L) ) attr(dt, "space") <- space dt @@ -31,7 +31,7 @@ get_attrition_plot <- function(attrition_coords) { max_y_lim <- max(attrition_coords$label_position_y) + max(attrition_coords$label_heights) space <- attr(attrition_coords, "space") if (is.null(space)) { - space <- 1 + space <- 1L } ggplot2::ggplot(attrition_coords) + ggplot2::geom_segment( @@ -44,14 +44,14 @@ get_attrition_plot <- function(attrition_coords) { ) + ggplot2::geom_label( ggplot2::aes(label = label, x = label_position_x, y = label_position_y), - label.r = ggplot2::unit(0, "lines"), vjust = "top", size = 12/ggplot2::.pt, na.rm = TRUE + label.r = ggplot2::unit(0L, "lines"), vjust = "top", size = 12L / ggplot2::.pt, na.rm = TRUE ) + ggplot2::geom_label( - ggplot2::aes(label = label_excl, x = excl_end_position_x, y = excl_position_y), label.r = ggplot2::unit(0, "lines"), - hjust = "left", size = 12/ggplot2::.pt, na.rm = TRUE + ggplot2::aes(label = label_excl, x = excl_end_position_x, y = excl_position_y), label.r = ggplot2::unit(0L, "lines"), + hjust = "left", size = 12L / ggplot2::.pt, na.rm = TRUE ) + ggplot2::scale_y_continuous(limits = c(max_y_lim + space, -space), trans = "reverse") + - ggplot2::scale_x_continuous(limits = c(-35, 60)) + + ggplot2::scale_x_continuous(limits = c(-35L, 60L)) + ggplot2::theme( panel.grid.major = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank(), @@ -92,8 +92,8 @@ get_attrition_filter_label <- function(name, value_name, value) { if (is.null(pkey)) { return("Initial dataset") } else { - dataset <- pkey[[1]]$dataset - dataset_pkey <- pkey[[1]]$key + dataset <- pkey[[1L]]$dataset + dataset_pkey <- pkey[[1L]]$key return(glue::glue("{dataset}\n primary key: {paste(dataset_pkey, collapse = ', ')}")) } } @@ -106,7 +106,7 @@ get_attrition_filter_label <- function(name, value_name, value) { purrr::map(~names(.[["data_keys"]])) %>% unlist() %>% collapse::funique() - if (length(dependent_datasets) > 0) { + if (length(dependent_datasets) > 0L) { bind_keys_section <- glue::glue( "\nData linked with external datasets: {paste(dependent_datasets, collapse = ', ')}", .trim = FALSE @@ -134,4 +134,3 @@ get_attrition_filter_label <- function(name, value_name, value) { data_stats %>% purrr::map_int("n_rows") } - diff --git a/R/cohort_methods.R b/R/cohort_methods.R index 72eba17..3479822 100644 --- a/R/cohort_methods.R +++ b/R/cohort_methods.R @@ -89,7 +89,7 @@ Cohort <- R6::R6Class( post = get_hook("post_add_step_hook") )) { - new_step_id <- as.character(as.integer(self$last_step_id()) + 1) + new_step_id <- as.character(as.integer(self$last_step_id()) + 1L) run_hooks(hook$pre, self, private, new_step_id) @@ -121,7 +121,7 @@ Cohort <- R6::R6Class( filters = purrr::map(filters, get_filter_state, extra_fields = NULL) ) } else { - step_config <- self$get_state(step_id, json = FALSE)[[1]] + step_config <- self$get_state(step_id, json = FALSE)[[1L]] step_config$step <- next_step(step_id) } @@ -150,7 +150,7 @@ Cohort <- R6::R6Class( run_hooks(hook$pre, self, private, step_id) step_id <- as.character(step_id) - clear_data_ids <- steps_range(step_id, rev(names(private$steps))[1]) + clear_data_ids <- steps_range(step_id, rev(names(private$steps))[1L]) private$steps[[step_id]] <- NULL private$cache[clear_data_ids] <- NULL private$data_objects[clear_data_ids] <- NULL @@ -191,7 +191,7 @@ Cohort <- R6::R6Class( filter_id <- as.character(filter_id) private$steps[[step_id]]$filters[[filter_id]] <- NULL - if (length(private$steps[[step_id]]$filters) == 0) { + if (length(private$steps[[step_id]]$filters) == 0L) { self$remove_step(step_id, run_flow) } else { if (run_flow) { @@ -341,10 +341,9 @@ Cohort <- R6::R6Class( filter_state$range <- na_fix(filter_state$range) filter_state$range <- as.Date(filter_state$range) } - if (filter_state$type == "datetime_range") { filter_state$range <- na_fix(filter_state$range) - if (length(filter_state$range) == 0) filter_state$range <- NULL + if (length(filter_state$range) == 0L) filter_state$range <- NULL filter_state$range <- as.POSIXct(filter_state$range, origin = "1970-01-01 UTC") } add_filter( @@ -508,7 +507,7 @@ Cohort <- R6::R6Class( include_action = c("pre_filtering", "post_filtering", "run_binding"), modifier = .repro_code_tweak, mark_step = TRUE, ...) { - source_type <- class(private$source)[1] + source_type <- class(private$source)[1L] # todo improve fun_args <- environment() code_params <- c( @@ -620,7 +619,7 @@ Cohort <- R6::R6Class( # todo code include once? res_quote <- combine_expressions(unlist(code_components_df$expr)) formatR::tidy_source( - text = as.character(res_quote)[-1], + text = as.character(res_quote)[-1L], ... ) }, @@ -631,7 +630,7 @@ Cohort <- R6::R6Class( hook = list(pre = get_hook("pre_run_flow_hook"), post = get_hook("post_run_flow_hook"))) { run_hooks(hook$pre, self, private) if (missing(min_step)) { - min_step <- 1 + min_step <- 1L } min_step <- min(length(private$data_objects), as.integer(min_step)) # make sure all steps data is evaluated steps_to_execute <- steps_range(min_step, length(private$steps)) diff --git a/R/filter.R b/R/filter.R index bbbbe43..1881925 100644 --- a/R/filter.R +++ b/R/filter.R @@ -13,8 +13,8 @@ eval_filter <- function(filter_fun, step_id, source) { #' @export .gen_id <- function() { paste0( - paste0(sample(LETTERS, 5, TRUE), collapse = ""), - round(as.numeric(Sys.time()) * 1000) + paste0(sample(LETTERS, 5L, TRUE), collapse = ""), + round(as.numeric(Sys.time()) * 1000L) ) } @@ -315,7 +315,7 @@ filter.datetime_range <- function(type, id, name, ..., description = NULL, environment() %>% as.list() %>% purrr::keep(~ !is.symbol(.x)), list(...) ) - + .as_constructor( function(source) { do.call( diff --git a/R/list_operators.R b/R/list_operators.R index a7ddba2..70d612e 100644 --- a/R/list_operators.R +++ b/R/list_operators.R @@ -1,9 +1,9 @@ adjust_names <- function(list_obj) { - if (length(list_obj) == 0) { + if (length(list_obj) == 0L) { # removed the last existing object return(list()) } - names(list_obj) <- as.character(1:length(list_obj)) + names(list_obj) <- as.character(1L:length(list_obj)) return(list_obj) } @@ -13,14 +13,14 @@ list_names <- function(list_obj) { last_item <- function(list_obj) { list_length <- length(list_obj) - if (list_length == 0) { + if (list_length == 0L) { return(NULL) } list_obj[[list_length]] } step_filter_state <- function(steps, method = length, raw = FALSE) { - if (length(steps) == 0) { + if (length(steps) == 0L) { if (raw) return(steps) return(method(steps)) } @@ -52,12 +52,12 @@ modify_item <- function(list_obj, new_val, what) { #' @export .get_method <- function(name) { found_methods <- utils::getAnywhere(name) - if (length(found_methods$objs) == 0) { + if (length(found_methods$objs) == 0L) { return(NULL) } namespace <- gsub( "namespace:", "", fixed = TRUE, - grep("namespace:", found_methods$where, value = TRUE, fixed = TRUE)[1] + grep("namespace:", found_methods$where, value = TRUE, fixed = TRUE)[1L] ) utils::getFromNamespace(name, namespace) } diff --git a/R/repro_code_utils.R b/R/repro_code_utils.R index 91392a2..49e3b55 100644 --- a/R/repro_code_utils.R +++ b/R/repro_code_utils.R @@ -5,18 +5,18 @@ substitute_q <- function(x, env) { pair_seq <- function(idxs) { - if (length(idxs) == 0) { - return(integer(0)) + if (length(idxs) == 0L) { + return(integer(0L)) } - + if (!identical(length(idxs) %% 2L, 0L)) { stop("The lenght of idxs is not even number") } - + idxs <- sort(idxs) sequence <- c() - for (idx in seq(1, length(idxs), by = 2)) { - sequence <- c(sequence, seq(idxs[idx], idxs[idx + 1], by = 1)) + for (idx in seq(1L, length(idxs), by = 2L)) { + sequence <- c(sequence, seq(idxs[idx], idxs[idx + 1L], by = 1L)) } return(sequence) } @@ -28,8 +28,8 @@ parse_func_expr <- function(func) { } func_body <- utils::capture.output(body(func)) n_lines <- length(func_body) - func_body[n_lines - 1] <- glue::glue("data_object <- {func_body[n_lines - 1]}") - func_expr <- parse(text = func_body)[[1]] + func_body[n_lines - 1L] <- glue::glue("data_object <- {func_body[n_lines - 1]}") + func_expr <- parse(text = func_body)[[1L]] substitute_q( func_expr, @@ -44,9 +44,9 @@ func_to_expr <- function(func, name) { func_expr <- c(paste(name, "<-"), utils::capture.output(func)) # in case function comes from namespace - closing_idx <- rev(which(grepl("}$", func_expr, perl = TRUE)))[1] + closing_idx <- rev(which(grepl("}$", func_expr, perl = TRUE)))[1L] return( - parse(text = func_expr[1:closing_idx])[[1]] + parse(text = func_expr[1L:closing_idx])[[1L]] ) } @@ -87,7 +87,7 @@ parse_filter_expr <- function(filter) { pair_seq(grep("# code eval ", filter_expr, fixed = TRUE)), grep("# code eval$", filter_expr) )) - code_eval_expr <- parse(text = c("{", filter_expr[code_eval_idx], "}"))[[1]] + code_eval_expr <- parse(text = c("{", filter_expr[code_eval_idx], "}"))[[1L]] rlang::eval_bare(code_eval_expr, filter_env) keep_na_ind <- if (keep_na) "keep_na" else "!keep_na" @@ -103,11 +103,11 @@ parse_filter_expr <- function(filter) { grep("# code include$", filter_expr) )) - if (length(sub_expr_idx) == 0) { + if (length(sub_expr_idx) == 0L) { return(str2lang("{}")) } - filter_expr <- parse(text = c("{", filter_expr[sub_expr_idx], "}"))[[1]] + filter_expr <- parse(text = c("{", filter_expr[sub_expr_idx], "}"))[[1L]] sub_vars <- substitute_q(filter_expr, vars_env) sub_syms <- rlang::inject((!!rlang::expr)(!!sub_vars), filter_env) return(sub_syms) @@ -115,8 +115,8 @@ parse_filter_expr <- function(filter) { combine_expressions <- function(expressions_list) { expressions_list <- lapply(expressions_list, function(x) { - if (x[[1]] == as.symbol("{")) { - return(as.list(x)[-1]) + if (x[[1L]] == as.symbol("{")) { + return(as.list(x)[-1L]) } else { return(x) } @@ -152,19 +152,19 @@ type_expr <- function(type, expr, step = NA, ...) { } exclude_first_pipe <- function(expr, after) { - if (expr[[1]] == as.symbol("{")) { - if (identical(expr[[2]][[2]], after) && expr[[2]][[1]] == as.symbol("%>%")) { - expr[[2]] <- expr[[2]][[3]] + if (expr[[1L]] == as.symbol("{")) { + if (identical(expr[[2L]][[2L]], after) && expr[[2L]][[1L]] == as.symbol("%>%")) { + expr[[2L]] <- expr[[2L]][[3L]] } else { - expr[[2]][[2]] <- exclude_first_pipe(expr[[2]][[2]], after) + expr[[2L]][[2L]] <- exclude_first_pipe(expr[[2L]][[2L]], after) } } else { - if (identical(expr[[2]], after) && expr[[1]] == as.symbol("%>%")) { - expr <- expr[[3]] + if (identical(expr[[2L]], after) && expr[[1L]] == as.symbol("%>%")) { + expr <- expr[[3L]] } else { - expr[[2]] <- exclude_first_pipe(expr[[2]], after) + expr[[2L]] <- exclude_first_pipe(expr[[2L]], after) } } return(expr) @@ -172,20 +172,20 @@ exclude_first_pipe <- function(expr, after) { exclude_reassignment <- function(expr, along_with = c("left", "both")) { along_with <- match.arg(along_with) - if (expr[[1]] == as.symbol("{")) { - to_exclude <- expr[[2]][[2]] - if (expr[[2]][[1]] == as.symbol("<-")) { - expr[[2]] <- expr[[2]][[3]] + if (expr[[1L]] == as.symbol("{")) { + to_exclude <- expr[[2L]][[2L]] + if (expr[[2L]][[1L]] == as.symbol("<-")) { + expr[[2L]] <- expr[[2L]][[3L]] if (along_with == "both") { - expr[[2]] <- exclude_first_pipe(expr[[2]], to_exclude) + expr[[2L]] <- exclude_first_pipe(expr[[2L]], to_exclude) } } else { warning("First line of expression is not a reassignment.") } } else { - to_exclude <- expr[[2]] - if (expr[[1]] == as.symbol("<-")) { - expr <- expr[[3]] + to_exclude <- expr[[2L]] + if (expr[[1L]] == as.symbol("<-")) { + expr <- expr[[3L]] if (along_with == "both") { expr <- exclude_first_pipe(expr, to_exclude) } @@ -197,8 +197,8 @@ exclude_reassignment <- function(expr, along_with = c("left", "both")) { } take_first_line <- function(expr) { - if (expr[[1]] == as.symbol("{")) { - return(expr[[2]]) + if (expr[[1L]] == as.symbol("{")) { + return(expr[[2L]]) } return(expr) } @@ -209,17 +209,17 @@ pipe_reassignment <- function(expr_l, expr_r) { nos <- rlang::expr({ a %>% sum() - b <- 1 + b <- 1L }) pipe_filtering <- function(filtering_exprs) { n_exprs <- length(filtering_exprs) - if (n_exprs <= 1) { + if (n_exprs <= 1L) { return(filtering_exprs) } - if (n_exprs > 1) { + if (n_exprs > 1L) { for (expr_id in seq_along(filtering_exprs)) { - if (expr_id > 1) { + if (expr_id > 1L) { filtering_exprs[[expr_id]] <- filtering_exprs[[expr_id]] %>% exclude_reassignment(along_with = "both") } @@ -227,15 +227,15 @@ pipe_filtering <- function(filtering_exprs) { filtering_exprs[[expr_id]] <- filtering_exprs[[expr_id]] %>% take_first_line() } - if (expr_id == 1) { + if (expr_id == 1L) { res_expr <- exclude_reassignment(filtering_exprs[[expr_id]], along_with = "left") } else { - if (filtering_exprs[[expr_id]][[1]] == as.symbol("{")) { + if (filtering_exprs[[expr_id]][[1L]] == as.symbol("{")) { res_expr <- rlang::expr( !!res_expr %>% - !!filtering_exprs[[expr_id]][[2]] + !!filtering_exprs[[expr_id]][[2L]] ) - for (i in setdiff(seq_along(filtering_exprs[[expr_id]]), 1:2)) { + for (i in setdiff(seq_along(filtering_exprs[[expr_id]]), 1L:2L)) { res_expr <- rlang::expr({ !!res_expr !!filtering_exprs[[expr_id]][[i]] @@ -250,9 +250,9 @@ pipe_filtering <- function(filtering_exprs) { } } } - assignment <- rlang::expr(!!filtering_exprs[[1]][[2]] <- x) - if (res_expr[[1]] == as.symbol("{")) { - res_expr[[2]] <- substitute_q(assignment, list(x = res_expr[[2]])) + assignment <- rlang::expr(!!filtering_exprs[[1L]][[2L]] <- x) + if (res_expr[[1L]] == as.symbol("{")) { + res_expr[[2L]] <- substitute_q(assignment, list(x = res_expr[[2L]])) } else { res_expr <- substitute_q(assignment, list(x = res_expr)) } @@ -261,17 +261,17 @@ pipe_filtering <- function(filtering_exprs) { } if_null_default_list <- function(x, y) { - if (is.null(y[[1]])) { + if (is.null(y[[1L]])) { return(x) } return(y) } flatten_listcol <- function(x) { - if (is.null(x[[1]])) { + if (is.null(x[[1L]])) { return(NA) } - return(x[[1]]) + return(x[[1L]]) } pipe_all_filters <- function(expr_df) { @@ -283,7 +283,7 @@ pipe_all_filters <- function(expr_df) { expr_df <- expr_df %>% dplyr::mutate(dataset = purrr::map_chr(dataset, flatten_listcol)) filtering_expr_df <- expr_df %>% dplyr::filter(type == "filtering") - if (nrow(filtering_expr_df) == 0) { + if (nrow(filtering_expr_df) == 0L) { return(dplyr::select(expr_df, type, expr)) } diff --git a/R/source_methods.R b/R/source_methods.R index 4e9a53a..72fc11d 100644 --- a/R/source_methods.R +++ b/R/source_methods.R @@ -22,7 +22,7 @@ Source <- R6::R6Class( initialize = function( dtconn, ..., primary_keys = NULL, binding_keys = NULL, source_code = NULL, description = NULL, options = list(display_binding = TRUE) - ) { + ) { self$dtconn <- dtconn self$attributes <- list(...) @@ -56,7 +56,7 @@ Source <- R6::R6Class( private$steps, stats::setNames( list(step), - as.character(length(private$steps) + 1) + as.character(length(private$steps) + 1L) ) ) }, @@ -74,7 +74,7 @@ Source <- R6::R6Class( } private$steps[[step_id]] <- NULL - if (length(private$steps) >= 1) { + if (length(private$steps) >= 1L) { names(private$steps) <- as.character(seq_len(length(private$steps))) } else { private$steps <- NULL @@ -88,7 +88,7 @@ Source <- R6::R6Class( add_filter = function(filter, step_id) { if (missing(step_id)) { - step_id <- 1 + step_id <- 1L if (!is.null(private$steps)) { step_id <- length(private$steps) } @@ -117,11 +117,11 @@ Source <- R6::R6Class( private$steps[[step_id]]$filters[[to_remove_idx]] <- NULL - if (length(private$steps[[step_id]]$filters) == 0) { + if (length(private$steps[[step_id]]$filters) == 0L) { private$steps[[step_id]] <- NULL # remove step when no more filters } - if (length(private$steps) == 0) { + if (length(private$steps) == 0L) { private$steps <- NULL } }, diff --git a/vignettes/cohort-configuration.Rmd b/vignettes/cohort-configuration.Rmd index 11ad8a0..e6974f3 100644 --- a/vignettes/cohort-configuration.Rmd +++ b/vignettes/cohort-configuration.Rmd @@ -12,7 +12,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -options("tibble.print_min" = 5, "tibble.print_max" = 5) +options("tibble.print_min" = 5L, "tibble.print_max" = 5L) library(magrittr) library(cohortBuilder) ``` From e27dba570151240da683d7b5167097a989dc562d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adam=20Fory=C5=9B?= Date: Tue, 18 Mar 2025 12:27:02 +0100 Subject: [PATCH 05/10] Update code to pass R CMD checks --- .Rbuildignore | 1 + tests/testthat/test-reproducible_code_utils.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index 0df4dd7..c6d1cc6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,4 @@ cran-comments.md .Rprofile meta_data.yaml ^\.github$ +.lintr diff --git a/tests/testthat/test-reproducible_code_utils.R b/tests/testthat/test-reproducible_code_utils.R index e52a79a..8067be2 100644 --- a/tests/testthat/test-reproducible_code_utils.R +++ b/tests/testthat/test-reproducible_code_utils.R @@ -74,7 +74,7 @@ test_that("pair_seq always returns a strictly increasing sequence of integers", result <- pair_seq(input) # Expect numeric output - expect_type(result, "double") + expect_type(result, "integer") # Expect output is in strictly ascending order expect_true(all(diff(result) > 0L)) From e769cbdc42b6fd07c92efef45ba59a44d9b44b5e Mon Sep 17 00:00:00 2001 From: Adam Forys Date: Tue, 18 Mar 2025 12:33:43 +0100 Subject: [PATCH 06/10] Fix build ingore files --- .Rbuildignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index c6d1cc6..52a2a76 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,4 +13,4 @@ cran-comments.md .Rprofile meta_data.yaml ^\.github$ -.lintr +^\.lintr From 88b0bbd99be44bc31bc8ffcd555cf83a222b9fbd Mon Sep 17 00:00:00 2001 From: Adam Forys Date: Tue, 18 Mar 2025 12:41:23 +0100 Subject: [PATCH 07/10] Remove .publish_rpackage --- .publish_rpackage | 1 - 1 file changed, 1 deletion(-) delete mode 100644 .publish_rpackage diff --git a/.publish_rpackage b/.publish_rpackage deleted file mode 100644 index 8b13789..0000000 --- a/.publish_rpackage +++ /dev/null @@ -1 +0,0 @@ - From 3fe91aca504918594eb2f59b39cc68ab1f328e79 Mon Sep 17 00:00:00 2001 From: Borys Date: Thu, 27 Mar 2025 22:02:31 +0100 Subject: [PATCH 08/10] Update files to pass lint check --- R/source_tblist.R | 182 ++++++++++---------- R/step.R | 18 +- tests/testthat/test-cohortBuilder-package.R | 18 +- tests/testthat/test-data_time_filter.R | 80 ++++----- tests/testthat/test-filter.R | 50 +++--- tests/testthat/test-source_methods.R | 8 +- vignettes/custom-extensions.Rmd | 10 +- vignettes/custom-filters.Rmd | 10 +- 8 files changed, 189 insertions(+), 187 deletions(-) diff --git a/R/source_tblist.R b/R/source_tblist.R index 7564356..1174c9b 100644 --- a/R/source_tblist.R +++ b/R/source_tblist.R @@ -18,7 +18,7 @@ tblist <- function(..., names) { tables <- rlang::dots_list(..., .named = TRUE) out_class <- "tblist" - tb_call <- sys.call(1) + tb_call <- sys.call(1L) if (inherits(tables, "data.frame")) { if (!missing(names)) { names(tables) <- names @@ -109,8 +109,8 @@ set_source.tblist <- function(dtconn, primary_keys = NULL, binding_keys = NULL, #' @param keep_na If `TRUE`, NA values are included. #' @export cb_filter.discrete.tblist <- function( - source, type = "discrete", id = .gen_id(), name = id, variable, value = NA, - dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { + source, type = "discrete", id = .gen_id(), name = id, variable, value = NA, + dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { args <- list(...) def_filter( @@ -151,7 +151,7 @@ cb_filter.discrete.tblist <- function( stats::na.omit() %>% length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -161,7 +161,7 @@ cb_filter.discrete.tblist <- function( if (nrow(data_object[[dataset]])) { data_object[[dataset]][[variable]] %>% table %>% prop.table() %>% graphics::barplot() } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { @@ -189,8 +189,8 @@ cb_filter.discrete.tblist <- function( #' @rdname filter-source-types #' @export cb_filter.discrete_text.tblist <- function( - source, type = "discrete_text", id = .gen_id(), name = id, variable, value = NA, - dataset, ..., description = NULL, active = TRUE) { + source, type = "discrete_text", id = .gen_id(), name = id, variable, value = NA, + dataset, ..., description = NULL, active = TRUE) { args <- list(...) def_filter( @@ -207,7 +207,7 @@ cb_filter.discrete_text.tblist <- function( !!sym(variable) %in% !!strsplit( sub(" ", "", value, fixed = TRUE), split = ",", fixed = TRUE - )[[1]] + )[[1L]] ) # keep_na !value_na end, # !keep_na !value_na end } @@ -219,11 +219,13 @@ cb_filter.discrete_text.tblist <- function( name <- c("n_data", "choices", "n_missing") } stats <- list( - choices = if ("choices" %in% name) data_object[[dataset]][[variable]] %>% collapse::funique() %>% paste(collapse = ","), - n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% stats::na.omit() %>% collapse::funique() %>% length(), + choices = if ("choices" %in% name) data_object[[dataset]][[variable]] %>% + collapse::funique() %>% paste(collapse = ","), + n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% + stats::na.omit() %>% collapse::funique() %>% length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -252,14 +254,14 @@ cb_filter.discrete_text.tblist <- function( } get_range_frequencies <- function(data_object, dataset, variable, extra_params) { - step <- 1 - if (length(stats::na.omit(data_object[[dataset]][[variable]])) == 0) { + step <- 1L + if (length(stats::na.omit(data_object[[dataset]][[variable]])) == 0L) { return( data.frame( - level = character(0), - count = numeric(0), - l_bound = numeric(0), - u_bound = numeric(0) + level = character(0L), + count = numeric(0L), + l_bound = numeric(0L), + u_bound = numeric(0L) ) ) } @@ -280,13 +282,13 @@ get_range_frequencies <- function(data_object, dataset, variable, extra_params) step <- extra_params$step } breaks <- seq(min_val, max_val, by = step) - if (rev(breaks)[1] != max_val) { - breaks[length(breaks) + 1] <- max_val + if (rev(breaks)[1L] != max_val) { + breaks[length(breaks) + 1L] <- max_val } - breaks <- round(breaks, 2) + breaks <- round(breaks, 2L) bounds <- breaks - breaks[1] <- breaks[1] - 0.01 + breaks[1L] <- breaks[1L] - 0.01 breaks[length(breaks)] <- breaks[length(breaks)] + 0.01 data_object[[dataset]][, variable, drop = FALSE] %>% @@ -294,19 +296,19 @@ get_range_frequencies <- function(data_object, dataset, variable, extra_params) dplyr::mutate( level = factor( findInterval(!!sym(variable), breaks, rightmost.closed = FALSE), - levels = 1:(length(breaks)), - labels = as.character(1:(length(breaks))) + levels = 1L:(length(breaks)), + labels = as.character(1L:(length(breaks))) ) ) %>% dplyr::group_by(level) %>% dplyr::summarise( count = dplyr::n() ) %>% - tidyr::complete(level, fill = list(count = 0)) %>% + tidyr::complete(level, fill = list(count = 0L)) %>% dplyr::arrange(level) %>% dplyr::mutate( l_bound = bounds, - u_bound = c(bounds[-1], bounds[length(bounds)]) + u_bound = c(bounds[-1L], bounds[length(bounds)]) ) } @@ -314,8 +316,8 @@ get_range_frequencies <- function(data_object, dataset, variable, extra_params) #' @param range Variable range to be applied in filtering. #' @export cb_filter.range.tblist <- function( - source, type = "range", id = .gen_id(), name = id, variable, range = NA, dataset, - keep_na = TRUE, ..., description = NULL, active = TRUE) { + source, type = "range", id = .gen_id(), name = id, variable, range = NA, dataset, + keep_na = TRUE, ..., description = NULL, active = TRUE) { args <- list(...) def_filter( @@ -328,7 +330,7 @@ cb_filter.range.tblist <- function( if (keep_na && !identical(range, NA)) { # keep_na !value_na start data_object[[dataset]] <- data_object[[dataset]] %>% - dplyr::filter((!!sym(variable) <= !!range[2] & !!sym(variable) >= !!range[1]) | is.na(!!sym(variable))) + dplyr::filter((!!sym(variable) <= !!range[2L] & !!sym(variable) >= !!range[1L]) | is.na(!!sym(variable))) # keep_na !value_na end } if (!keep_na && identical(range, NA)) { @@ -340,7 +342,7 @@ cb_filter.range.tblist <- function( if (!keep_na && !identical(range, NA)) { # !keep_na !value_na start data_object[[dataset]] <- data_object[[dataset]] %>% - dplyr::filter(!!sym(variable) <= !!range[2] & !!sym(variable) >= !!range[1]) + dplyr::filter(!!sym(variable) <= !!range[2L] & !!sym(variable) >= !!range[1L]) # !keep_na !value_na end } attr(data_object[[dataset]], "filtered") <- TRUE # code include @@ -359,7 +361,7 @@ cb_filter.range.tblist <- function( n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% stats::na.omit() %>% length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -369,7 +371,7 @@ cb_filter.range.tblist <- function( if (nrow(data_object[[dataset]])) { data_object[[dataset]][[variable]] %>% graphics::hist() } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { @@ -391,8 +393,8 @@ cb_filter.range.tblist <- function( get_defaults = function(data_object, cache_object) { list( range = c( - cache_object$frequencies$l_bound[1], - rev(cache_object$frequencies$u_bound)[1] + cache_object$frequencies$l_bound[1L], + rev(cache_object$frequencies$u_bound)[1L] ) ) } @@ -401,13 +403,13 @@ cb_filter.range.tblist <- function( get_date_range_frequencies <- function(data_object, dataset, variable, extra_params) { step <- "day" - if (length(stats::na.omit(data_object[[dataset]][[variable]])) == 0) { + if (length(stats::na.omit(data_object[[dataset]][[variable]])) == 0L) { return( data.frame( - level = character(0), - count = numeric(0), - l_bound = numeric(0), - u_bound = numeric(0) + level = character(0L), + count = numeric(0L), + l_bound = numeric(0L), + u_bound = numeric(0L) ) ) } @@ -428,8 +430,8 @@ get_date_range_frequencies <- function(data_object, dataset, variable, extra_par step <- extra_params$step } breaks <- seq.Date(min_val, max_val, by = step) - if (rev(breaks)[1] != max_val) { - breaks[length(breaks) + 1] <- max_val + if (rev(breaks)[1L] != max_val) { + breaks[length(breaks) + 1L] <- max_val } data_object[[dataset]][, variable, drop = FALSE] %>% @@ -437,27 +439,27 @@ get_date_range_frequencies <- function(data_object, dataset, variable, extra_par dplyr::mutate( level = factor( findInterval(!!sym(variable), breaks, rightmost.closed = FALSE), - levels = 1:(length(breaks)), - labels = as.character(1:(length(breaks))) + levels = 1L:(length(breaks)), + labels = as.character(1L:(length(breaks))) ) ) %>% dplyr::group_by(level) %>% dplyr::summarise( count = dplyr::n() ) %>% - tidyr::complete(level, fill = list(count = 0)) %>% + tidyr::complete(level, fill = list(count = 0L)) %>% dplyr::arrange(level) %>% dplyr::mutate( l_bound = breaks, - u_bound = c(breaks[-1], breaks[length(breaks)]) + u_bound = c(breaks[-1L], breaks[length(breaks)]) ) } #' @rdname filter-source-types #' @export cb_filter.date_range.tblist <- function( - source, type = "date_range", id = .gen_id(), name = id, variable, range = NA, - dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { + source, type = "date_range", id = .gen_id(), name = id, variable, range = NA, + dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { args <- list(...) def_filter( @@ -470,7 +472,7 @@ cb_filter.date_range.tblist <- function( if (keep_na && !identical(range, NA)) { # keep_na !value_na start data_object[[dataset]] <- data_object[[dataset]] %>% - dplyr::filter((!!sym(variable) <= !!range[2] & !!sym(variable) >= !!range[1]) | is.na(!!sym(variable))) + dplyr::filter((!!sym(variable) <= !!range[2L] & !!sym(variable) >= !!range[1L]) | is.na(!!sym(variable))) # keep_na !value_na end } if (!keep_na && identical(range, NA)) { @@ -482,7 +484,7 @@ cb_filter.date_range.tblist <- function( if (!keep_na && !identical(range, NA)) { # !keep_na !value_na start data_object[[dataset]] <- data_object[[dataset]] %>% - dplyr::filter(!!sym(variable) <= !!range[2] & !!sym(variable) >= !!range[1]) + dplyr::filter(!!sym(variable) <= !!range[2L] & !!sym(variable) >= !!range[1L]) # !keep_na !value_na end } attr(data_object[[dataset]], "filtered") <- TRUE # code include @@ -501,7 +503,7 @@ cb_filter.date_range.tblist <- function( n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% stats::na.omit() %>% length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -511,7 +513,7 @@ cb_filter.date_range.tblist <- function( if (nrow(data_object[[dataset]])) { data_object[[dataset]][[variable]] %>% graphics::hist() } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { @@ -533,8 +535,8 @@ cb_filter.date_range.tblist <- function( get_defaults = function(data_object, cache_object) { list( range = c( - cache_object$frequencies$l_bound[1], - rev(cache_object$frequencies$u_bound)[1] + cache_object$frequencies$l_bound[1L], + rev(cache_object$frequencies$u_bound)[1L] ) ) } @@ -554,20 +556,20 @@ group_stats <- function(vec_stats, name) { calculate_datetime_step <- function(min_date, max_date) { # Define possible steps steps <- c( - "mins" = 60, - "hours" = 3600, - "days" = 86400, - "weeks" = 604800, - "months" = 2592000, - "years" = 31104000 + "mins" = 60L, + "hours" = 3600L, + "days" = 86400L, + "weeks" = 604800L, + "months" = 2592000L, + "years" = 31104000L ) time_span <- as.numeric(max_date) - as.numeric(min_date) num_elements <- as.integer(time_span / steps) - idx <- which(num_elements <= 200)[1] + idx <- which(num_elements <= 200L)[1L] if (!is.na(idx)) { return(steps[idx]) } - + return(steps[length(steps)]) } @@ -576,9 +578,9 @@ calculate_datetime_step <- function(min_date, max_date) { cb_filter.datetime_range.tblist <- function( source, type = "datetime_range", id = .gen_id(), name = id, variable, range = NA, dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { - + args <- list(...) - + def_filter( type = type, id = id, @@ -589,7 +591,7 @@ cb_filter.datetime_range.tblist <- function( # keep_na !value_na start data_object[[dataset]] <- data_object[[dataset]] %>% dplyr::filter( - (!!sym(variable) >= !!range[1] & !!sym(variable) <= !!range[2]) | + (!!sym(variable) >= !!range[1L] & !!sym(variable) <= !!range[2L]) | is.na(!!sym(variable)) ) # keep_na !value_na end @@ -604,11 +606,11 @@ cb_filter.datetime_range.tblist <- function( # !keep_na !value_na start data_object[[dataset]] <- data_object[[dataset]] %>% dplyr::filter( - !!sym(variable) >= !!range[1] & !!sym(variable) <= !!range[2] + !!sym(variable) >= !!range[1L] & !!sym(variable) <= !!range[2L] ) # !keep_na !value_na end } - + attr(data_object[[dataset]], "filtered") <- TRUE return(data_object) }, @@ -617,16 +619,16 @@ cb_filter.datetime_range.tblist <- function( name <- c("n_data", "frequencies", "n_missing") } extra_params <- list(...) - + data_object[[dataset]][[variable]] <- as.numeric(data_object[[dataset]][[variable]]) if (is.null(extra_params$step) && !identical(length(data_object[[dataset]][[variable]]), 0L)) { min <- min(data_object[[dataset]][[variable]], na.rm = TRUE) max <- max(data_object[[dataset]][[variable]], na.rm = TRUE) - + extra_params$step <- calculate_datetime_step(min, max) |> unname() } - + stats <- list( frequencies = if ("frequencies" %in% name) { get_range_frequencies(data_object, dataset, variable, extra_params) @@ -638,8 +640,8 @@ cb_filter.datetime_range.tblist <- function( data_object[[dataset]][[variable]] %>% is.na() %>% sum() } ) - - if (length(name) == 1) { + + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -651,11 +653,11 @@ cb_filter.datetime_range.tblist <- function( min(data_object[[dataset]][[variable]], na.rm = TRUE), max(data_object[[dataset]][[variable]], na.rm = TRUE) ) |> names() - - data_object[[dataset]][[variable]] %>% + + data_object[[dataset]][[variable]] %>% graphics::hist(breaks = breaks) } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { @@ -677,8 +679,8 @@ cb_filter.datetime_range.tblist <- function( get_defaults = function(data_object, cache_object) { list( range = c( - cache_object$frequencies$l_bound[1], - rev(cache_object$frequencies$u_bound)[1] + cache_object$frequencies$l_bound[1L], + rev(cache_object$frequencies$u_bound)[1L] ) ) } @@ -691,8 +693,8 @@ cb_filter.datetime_range.tblist <- function( #' The names should relate to the ones included in `variables` parameter. #' @export cb_filter.multi_discrete.tblist <- function( - source, type = "multi_discrete", id = .gen_id(), name = id, values, - variables, dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { + source, type = "multi_discrete", id = .gen_id(), name = id, values, + variables, dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { args <- list(...) def_filter( @@ -706,7 +708,7 @@ cb_filter.multi_discrete.tblist <- function( col_in_val <- function(vec, value, keep_na) { if (identical(value, NA)) { val_mask <- rep(TRUE, length(vec)) - } else if (is.null(value)){ + } else if (is.null(value)) { val_mask <- rep(FALSE, length(vec)) } else { val_mask <- vec %in% value @@ -741,7 +743,7 @@ cb_filter.multi_discrete.tblist <- function( n_data = if ("n_data" %in% name) data_object[[dataset]][variables] %>% nrow(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][variables] %>% is.na() %>% colSums() %>% as.list() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -755,7 +757,7 @@ cb_filter.multi_discrete.tblist <- function( as.matrix() %>% graphics::barplot() } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { @@ -788,8 +790,8 @@ cb_filter.multi_discrete.tblist <- function( #' @param keep_na If `TRUE`, NA values are included. #' @export cb_filter.query.tblist <- function( - source, type = "query", id = .gen_id(), name = id, variables, value = NA, - dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { + source, type = "query", id = .gen_id(), name = id, variables, value = NA, + dataset, keep_na = TRUE, ..., description = NULL, active = TRUE) { args <- list(...) def_filter( @@ -824,7 +826,7 @@ cb_filter.query.tblist <- function( n_data = if ("n_data" %in% name) data_object[[dataset]][variables] %>% nrow(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][variables] %>% is.na() %>% colSums() %>% as.list() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -838,7 +840,7 @@ cb_filter.query.tblist <- function( as.matrix() %>% graphics::barplot() } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { @@ -876,7 +878,7 @@ cb_filter.query.tblist <- function( } key_values <- NULL - common_key_names <- paste0("key_", seq_along(binding_key$data_keys[[1]]$key)) + common_key_names <- paste0("key_", seq_along(binding_key$data_keys[[1L]]$key)) for (dependent_dataset in dependent_datasets) { key_names <- binding_key$data_keys[[dependent_dataset]]$key tmp_key_values <- collapse::funique(data_object_post[[dependent_dataset]][, key_names, drop = FALSE]) %>% @@ -887,13 +889,13 @@ cb_filter.query.tblist <- function( key_values <- dplyr::inner_join(key_values, tmp_key_values, by = common_key_names) } } - + df <- switch( as.character(binding_key$post), "FALSE" = data_object_pre[[binding_dataset]], "TRUE" = data_object_post[[binding_dataset]] ) - + data_object_post[[binding_dataset]] <- tryCatch({ collapse::join( df, @@ -909,7 +911,7 @@ cb_filter.query.tblist <- function( by = stats::setNames(common_key_names, binding_key$update$key) ) }) - + if (binding_key$activate) { attr(data_object_post[[binding_dataset]], "filtered") <- TRUE } @@ -930,7 +932,7 @@ cb_filter.query.tblist <- function( if (is.null(pkey)) { return(dataset) } else { - dataset_pkey <- .get_item(pkey, "dataset", dataset)[1][[1]]$key + dataset_pkey <- .get_item(pkey, "dataset", dataset)[1L][[1L]]$key if (is.null(dataset_pkey)) return(dataset) return(glue::glue("{dataset}\n primary key: {paste(dataset_pkey, collapse = ', ')}")) } @@ -950,7 +952,7 @@ cb_filter.query.tblist <- function( purrr::map(~names(.[["data_keys"]])) %>% unlist() %>% collapse::funique() - if (length(dependent_datasets) > 0) { + if (length(dependent_datasets) > 0L) { bind_keys_section <- glue::glue( "\nData linked with external datasets: {paste(dependent_datasets, collapse = ', ')}", .trim = FALSE diff --git a/R/step.R b/R/step.R index 3f663bf..44763c6 100644 --- a/R/step.R +++ b/R/step.R @@ -8,12 +8,12 @@ has_steps <- function(source) { structure_steps <- function(steps) { - if (length(steps) == 1) { - single_step <- "cb_step" %in% class(steps[[1]]) + if (length(steps) == 1L) { + single_step <- "cb_step" %in% class(steps[[1L]]) if (single_step) { return(steps) } - return(list(step(steps[[1]]))) + return(list(step(steps[[1L]]))) } else { is_list_of_steps <- all(purrr::map_lgl(steps, ~ "cb_step" %in% class(.))) if (is_list_of_steps) { @@ -26,7 +26,7 @@ structure_steps <- function(steps) { } pull_steps <- function(source, ...) { - if (missing(source) || (!has_steps(source) && length(list(...)) == 0)) { + if (missing(source) || (!has_steps(source) && length(list(...)) == 0L)) { return(NULL) } else if (has_steps(source)) { # steps or raw filters are added as source attributes steps <- get_steps(source, ...) @@ -41,7 +41,7 @@ pull_steps <- function(source, ...) { eval_step_filters <- function(step, source) { - if (length(step$filters) == 0) { + if (length(step$filters) == 0L) { return(list()) } @@ -81,10 +81,10 @@ steps_range <- function(from, to) { from <- as.integer(from) to <- as.integer(to) if (from > to) { - return(character(0)) + return(character(0L)) } as.character( - seq(from = from, to = to, by = 1) + seq(from = from, to = to, by = 1L) ) } @@ -96,11 +96,11 @@ readjust_step <- function(step, new_id) { } prev_step <- function(idx) { - as.character(as.integer(idx) - 1) + as.character(as.integer(idx) - 1L) } next_step <- function(idx) { - as.character(as.integer(idx) + 1) + as.character(as.integer(idx) + 1L) } print_step <- function(step) { diff --git a/tests/testthat/test-cohortBuilder-package.R b/tests/testthat/test-cohortBuilder-package.R index f0a055e..a4f831a 100644 --- a/tests/testthat/test-cohortBuilder-package.R +++ b/tests/testthat/test-cohortBuilder-package.R @@ -5,19 +5,19 @@ test_that("force_import loads necessary functions", { # Test for %:::% operator test_that("%:::% operator retrieves internal function", { - expect_equal("jsonlite" %:::% "toJSON", jsonlite::toJSON) + expect_identical("jsonlite" %:::% "toJSON", jsonlite::toJSON) }) # Test for %in% operator test_that("%in% operator behaves as expected", { - x <- c(1, 2, 3, 4, 5) - table <- c(3, 4, 5, 6, 7) - - expect_equal(`%in%`(x, table), base::`%in%`(x, table)) - + x <- c(1L, 2L, 3L, 4L, 5L) + table <- c(3L, 4L, 5L, 6L, 7L) + + expect_identical(`%in%`(x, table), base::`%in%`(x, table)) + x <- c("apple", "banana", "cherry") table <- c("banana", "cherry", "date") - - expect_equal(`%in%`(x, table), base::`%in%`(x, table)) - expect_equal(x %in% table, base::`%in%`(x, table)) + + expect_identical(`%in%`(x, table), base::`%in%`(x, table)) + expect_identical(x %in% table, base::`%in%`(x, table)) }) diff --git a/tests/testthat/test-data_time_filter.R b/tests/testthat/test-data_time_filter.R index 8b55e5e..0f3f485 100644 --- a/tests/testthat/test-data_time_filter.R +++ b/tests/testthat/test-data_time_filter.R @@ -1,45 +1,45 @@ test_that("calculate_datetime_step selects appropriate step", { # Define min and max dates for different ranges - + # 1. Test for a small range in minutes (expecting "mins" step) min_date <- as.POSIXct("2023-01-01 12:00:00") max_date <- as.POSIXct("2023-01-01 15:00:00") # 3 hours later - expect_equal(calculate_datetime_step(min_date, max_date) |> unname(), 60) - + expect_identical(calculate_datetime_step(min_date, max_date) |> unname(), 60L) + # 2. Test for a range in hours (expecting "hours" step) min_date <- as.POSIXct("2023-01-01 12:00:00") max_date <- as.POSIXct("2023-01-02 12:00:00") # 1 day later - expect_equal(calculate_datetime_step(min_date, max_date) |> unname(), 3600) - + expect_identical(calculate_datetime_step(min_date, max_date) |> unname(), 3600L) + # 3. Test for a range in days (expecting "days" step) min_date <- as.POSIXct("2023-01-01 12:00:00") max_date <- as.POSIXct("2023-03-01 12:00:00") # 7 month later - expect_equal(calculate_datetime_step(min_date, max_date) |> unname(), 86400) - + expect_identical(calculate_datetime_step(min_date, max_date) |> unname(), 86400L) + # 4. Test for a range in weeks (expecting "weeks" step) min_date <- as.POSIXct("2023-01-01 12:00:00") max_date <- as.POSIXct("2023-08-01 12:00:00") # 10 months later - expect_equal(calculate_datetime_step(min_date, max_date) |> unname(), 604800) - + expect_identical(calculate_datetime_step(min_date, max_date) |> unname(), 604800L) + # 5. Test for a range in months (expecting "months" step) min_date <- as.POSIXct("2023-01-01 12:00:00") max_date <- as.POSIXct("2033-01-01 12:00:00") # 10 year later - expect_equal(calculate_datetime_step(min_date, max_date) |> unname(), 2592000) - + expect_identical(calculate_datetime_step(min_date, max_date) |> unname(), 2592000L) + # 6. Test for a range in years (expecting "years" step) min_date <- as.POSIXct("1900-01-01 12:00:00") max_date <- as.POSIXct("2000-01-01 12:00:00") # 100 years later - expect_equal(calculate_datetime_step(min_date, max_date) |> unname(), 31104000) + expect_identical(calculate_datetime_step(min_date, max_date) |> unname(), 31104000L) }) test_that("cb_filter.datetime_range.tblist applies date time range filter correctly", { # Test data data <- data.frame( date_var = as.POSIXct(c("2023-01-01 12:00:00", "2023-01-02 12:00:00", "2023-01-03 00:00:00", NA)), - value = 1:4 + value = 1L:4L ) data_object <- list(dataset_name = data) - + # Helper function to create a filter and apply it to data apply_filter <- function(range, keep_na = TRUE) { filter <- cb_filter.datetime_range.tblist( @@ -48,39 +48,39 @@ test_that("cb_filter.datetime_range.tblist applies date time range filter correc ) filter$filter_data(data_object) } - + # 1. Test filtering within a specific range including NAs result <- apply_filter(range = c(as.POSIXct("2023-01-02"), as.POSIXct("2023-01-03")), keep_na = TRUE) - expect_equal(nrow(result$dataset_name), 3) # Keeps rows in range + NA - + expect_identical(nrow(result$dataset_name), 3L) # Keeps rows in range + NA + # 2. Test filtering within a specific range excluding NAs result <- apply_filter(range = c(as.POSIXct("2023-01-02"), as.POSIXct("2023-01-03")), keep_na = FALSE) - expect_equal(nrow(result$dataset_name), 2) # Only rows in range, no NA - + expect_identical(nrow(result$dataset_name), 2L) # Only rows in range, no NA + # 3. Test filtering with NA range to keep all data including NAs result <- apply_filter(range = NA, keep_na = TRUE) - expect_equal(nrow(result$dataset_name), 4) # All rows including NA - + expect_identical(nrow(result$dataset_name), 4L) # All rows including NA + # 4. Test filtering with NA range to keep only non-NA data result <- apply_filter(range = NA, keep_na = FALSE) - expect_equal(nrow(result$dataset_name), 3) # All rows excluding NA - + expect_identical(nrow(result$dataset_name), 3L) # All rows excluding NA + # 5. Test filtering with c(Inf, -Inf) range to keep only NA values result <- apply_filter(range = c(Inf, -Inf), keep_na = TRUE) - expect_equal(nrow(result$dataset_name), 1) # All rows including NA - + expect_identical(nrow(result$dataset_name), 1L) # All rows including NA + # 6. Test end boundary only (Inf) to include all data with NA result <- apply_filter(range = c(as.POSIXct("2023-01-01"), Inf), keep_na = TRUE) - expect_equal(nrow(result$dataset_name), 4) # All data should remain - + expect_identical(nrow(result$dataset_name), 4L) # All data should remain + # 7. Test `get_stats` function for data counts and missing values stats <- cb_filter.datetime_range.tblist( source = data_object, variable = "date_var", range = c(as.POSIXct("2023-01-01"), Inf), dataset = "dataset_name" )$get_stats(data_object) - expect_equal(stats$n_data, 3) # Count of non-NA entries - expect_equal(stats$n_missing, 1) # Count of NA entries - + expect_identical(stats$n_data, 3L) # Count of non-NA entries + expect_identical(stats$n_missing, 1L) # Count of NA entries + # 8. Test `get_defaults` function for range limits filter <- cb_filter.datetime_range.tblist( source = data_object, variable = "date_var", @@ -89,44 +89,44 @@ test_that("cb_filter.datetime_range.tblist applies date time range filter correc cache_object <- list(frequencies = data.frame(l_bound = min(data$date_var, na.rm = TRUE), u_bound = max(data$date_var, na.rm = TRUE))) defaults <- filter$get_defaults(data_object, cache_object) - expect_equal(defaults$range, c(min(data$date_var, na.rm = TRUE), max(data$date_var, na.rm = TRUE))) - + expect_identical(defaults$range, c(min(data$date_var, na.rm = TRUE), max(data$date_var, na.rm = TRUE))) + # 9. Test if filtered attribute is correctly set on data after filtering result <- apply_filter(range = c(as.POSIXct("2023-01-02"), as.POSIXct("2023-01-03")), keep_na = TRUE) expect_true(attr(result$dataset_name, "filtered")) - + }) test_that("datetime_range high level test", { # Create test data with date and value columns data <- data.frame( date_var = as.POSIXct(c("2023-01-01 12:00:00", "2023-01-02 12:00:00", "2023-01-03 00:00:00", NA)), - value = 1:4 + value = 1L:4L ) - + # Set up source and apply a datetime_range filter from 2023-01-01 12:00:00 to 2023-01-02 12:00:00 source <- set_source( tblist(data = data) ) |> add_step( filter( - "datetime_range", id = "date_var", dataset = "data", + "datetime_range", id = "date_var", dataset = "data", variable = "date_var", range = c("2023-01-01 12:00:00", "2023-01-02 12:00:00"), active = TRUE ) ) - + # Initialize cohort and apply filter steps coh <- cohortBuilder::cohort(source) coh$run_flow() - + # Get filtered data filtered_data <- coh$get_data("1")$data - + # Define expected data (rows in range or NA) expected_data <- data %>% dplyr::filter(date_var >= "2023-01-01 12:00:00" & date_var <= "2023-01-02 12:00:00" | is.na(date_var)) - + # Check if filtered data matches expected data, ignoring attributes expect_equal(filtered_data, expected_data, ignore_attr = TRUE) }) diff --git a/tests/testthat/test-filter.R b/tests/testthat/test-filter.R index 5939236..89a8243 100644 --- a/tests/testthat/test-filter.R +++ b/tests/testthat/test-filter.R @@ -1,17 +1,17 @@ discrete_filter <- filter( - type = "discrete", id = "age_filter", name = "Age", variable = "age", dataset = "patients", value = 50 + type = "discrete", id = "age_filter", name = "Age", variable = "age", dataset = "patients", value = 50L ) patients_source <- set_source( - tblist(patients = data.frame(id = 1:2, age = 50:51)) + tblist(patients = data.frame(id = 1L:2L, age = 50L:51L)) ) variable_filter <- discrete_filter(patients_source) test_that("Calling filter with id returns function of source param, calling valid S3 method", { - expect_equal(names(formals(discrete_filter)), "source") + expect_named(formals(discrete_filter), "source") expect_true(is.function(discrete_filter)) - + skip_on_covr() - expect_equal(as.character(body(discrete_filter)[[2]][[2]]), "cb_filter.discrete") + expect_identical(as.character(body(discrete_filter)[[2L]][[2L]]), "cb_filter.discrete") }) test_that("Calling filter on source returns list with valid methods and parameters", { @@ -23,9 +23,9 @@ test_that("Calling filter on source returns list with valid methods and paramete }) test_that("Filter methods operate correctly based on its definition", { - expect_equal(variable_filter$filter_data(patients_source$dtconn)$patients$age, 50) - expect_equal(variable_filter$get_stats(patients_source$dtconn)$choices, as.list(table(50:51))) - expect_equal(class(variable_filter$plot_data(patients_source$dtconn)), c("matrix", "array")) + expect_identical(variable_filter$filter_data(patients_source$dtconn)$patients$age, 50L) + expect_identical(variable_filter$get_stats(patients_source$dtconn)$choices, as.list(table(50L:51L))) + expect_identical(class(variable_filter$plot_data(patients_source$dtconn)), c("matrix", "array")) }) test_that("Discrete text filter works fine", { @@ -37,10 +37,10 @@ test_that("Discrete text filter works fine", { iris_source, spec_filter ) - expect_equal(coh$get_data(1, state = "pre")$iris, iris) + expect_identical(coh$get_data(1L, state = "pre")$iris, iris) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$iris$Species), c("setosa", "virginica")) - expect_equal( + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$iris$Species), c("setosa", "virginica")) + expect_identical( coh$get_cache("1", "species", state = "post")$choices, "setosa,virginica" ) @@ -60,25 +60,25 @@ test_that("Multi discrete filter works fine", { md_source, md_filter ) - expect_equal(coh$get_data(1, state = "pre")$md_data, md_data) + expect_identical(coh$get_data(1L, state = "pre")$md_data, md_data) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$md_data$col1), c("A")) - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$md_data$col2), c("D")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$md_data$col1), c("A")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$md_data$col2), c("D")) - expect_equal( + expect_identical( coh$get_cache("1", "mcols", state = "pre")$choices$col1, as.list(table(md_data$col1)) ) - expect_equal( + expect_identical( coh$get_cache("1", "mcols", state = "pre")$choices$col2, as.list(table(md_data$col2)) ) - expect_equal( + expect_identical( coh$get_cache("1", "mcols", state = "post")$choices$col1, as.list(table(c("A"))) ) - expect_equal( + expect_identical( coh$get_cache("1", "mcols", state = "post")$choices$col2, as.list(table(c("D"))) ) @@ -104,25 +104,25 @@ test_that("Query discrete filter works fine", { md_source, md_filter ) - expect_equal(coh$get_data(1, state = "pre")$md_data, md_data) + expect_identical(coh$get_data(1L, state = "pre")$md_data, md_data) coh$run_flow() - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$md_data$col1), c("A")) - expect_setequal(collapse::funique(coh$get_data(1, state = "post")$md_data$col2), c("D")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$md_data$col1), c("A")) + expect_setequal(collapse::funique(coh$get_data(1L, state = "post")$md_data$col2), c("D")) - expect_equal( + expect_identical( coh$get_cache("1", "qcols", state = "pre")$specs$col1$values, collapse::funique(md_data$col1) ) - expect_equal( + expect_identical( coh$get_cache("1", "qcols", state = "pre")$specs$col2$values, collapse::funique(md_data$col2) ) - expect_equal( + expect_identical( coh$get_cache("1", "qcols", state = "post")$specs$col1$values, "A" ) - expect_equal( + expect_identical( coh$get_cache("1", "qcols", state = "post")$specs$col2$values, "D" ) diff --git a/tests/testthat/test-source_methods.R b/tests/testthat/test-source_methods.R index 50fc432..1a93da6 100644 --- a/tests/testthat/test-source_methods.R +++ b/tests/testthat/test-source_methods.R @@ -140,7 +140,7 @@ test_that("Adding filter on source works fine and attaches it to correct step", tblist(iris = iris) ) %>% add_filter( discrete_filter_species, - step_id = 1 + step_id = 1L ) coh <- Cohort$new(iris_source) state <- coh$sum_up_state() @@ -172,10 +172,10 @@ test_that("Adding filter on source works fine and attaches it to correct step", tblist(iris = iris) ) %>% add_filter( discrete_filter_species, - step_id = 1 + step_id = 1L ) %>% add_filter( discrete_filter_species, - step_id = 2 + step_id = 2L ) coh <- Cohort$new(iris_source) @@ -212,7 +212,7 @@ test_that("Removing filter on source works fine", { discrete_filter_species_two ) removed_filter_but_not_last_one <- iris_source$clone() %>% - rm_filter(1, "species_filter_two") + rm_filter(1L, "species_filter_two") coh <- Cohort$new(removed_filter_but_not_last_one) state <- coh$sum_up_state() expect_true(state$source) diff --git a/vignettes/custom-extensions.Rmd b/vignettes/custom-extensions.Rmd index 5f2174f..43400ee 100644 --- a/vignettes/custom-extensions.Rmd +++ b/vignettes/custom-extensions.Rmd @@ -12,7 +12,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -options("tibble.print_min" = 5, "tibble.print_max" = 5) +options("tibble.print_min" = 5L, "tibble.print_max" = 5L) library(magrittr) library(cohortBuilder) ``` @@ -56,7 +56,7 @@ Example: ```{r, eval = FALSE} set_source.tblist <- function(dtconn, primary_keys = NULL, binding_keys = NULL, - source_code = NULL, description = NULL, ...) { + source_code = NULL, description = NULL, ...) { Source$new( dtconn, primary_keys = primary_keys, binding_keys = binding_keys, source_code = source_code, description = description, @@ -276,7 +276,7 @@ Examples: } key_values <- NULL - common_key_names <- paste0("key_", seq_along(binding_key$data_keys[[1]]$key)) + common_key_names <- paste0("key_", seq_along(binding_key$data_keys[[1L]]$key)) for (dependent_dataset in dependent_datasets) { key_names <- binding_key$data_keys[[dependent_dataset]]$key tmp_key_values <- collapse::funique(data_object_post[[dependent_dataset]][, key_names, drop = FALSE]) %>% @@ -357,7 +357,7 @@ get_attrition_label.tblist <- function(source, step_id, step_filters, dataset, . if (is.null(pkey)) { return(dataset) } else { - dataset_pkey <- .get_item(pkey, "dataset", dataset)[1][[1]]$key + dataset_pkey <- .get_item(pkey, "dataset", dataset)[1L][[1L]]$key if (is.null(dataset_pkey)) return(dataset) return(glue::glue("{dataset}\n primary key: {paste(dataset_pkey, collapse = ', ')}")) } @@ -377,7 +377,7 @@ get_attrition_label.tblist <- function(source, step_id, step_filters, dataset, . purrr::map(~names(.[["data_keys"]])) %>% unlist() %>% collapse::funique() - if (length(dependent_datasets) > 0) { + if (length(dependent_datasets) > 0L) { bind_keys_section <- glue::glue( "\nData linked with external datasets: {paste(dependent_datasets, collapse = ', ')}", .trim = FALSE diff --git a/vignettes/custom-filters.Rmd b/vignettes/custom-filters.Rmd index f6bc6f5..8fa86e5 100644 --- a/vignettes/custom-filters.Rmd +++ b/vignettes/custom-filters.Rmd @@ -12,7 +12,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -options("tibble.print_min" = 5, "tibble.print_max" = 5) +options("tibble.print_min" = 5L, "tibble.print_max" = 5L) library(magrittr) library(dplyr, exclude = "filter") library(cohortBuilder) @@ -164,8 +164,8 @@ Inside of the method we call `def_filter` completing all of the parameters based ```{r} cb_filter.logical.tblist <- function( - source, type = "logical", id = .gen_id(), name = id, dataset, variable, - value = NA, keep_na = TRUE, description = NULL, ..., active = TRUE) { + source, type = "logical", id = .gen_id(), name = id, dataset, variable, + value = NA, keep_na = TRUE, description = NULL, ..., active = TRUE) { args <- list(...) def_filter( @@ -209,7 +209,7 @@ cb_filter.logical.tblist <- function( length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) - if (length(name) == 1) { + if (length(name) == 1L) { return(stats[[name]]) } else { return(stats[name]) @@ -219,7 +219,7 @@ cb_filter.logical.tblist <- function( if (nrow(data_object[[dataset]])) { data_object[[dataset]][[variable]] %>% table %>% prop.table() %>% graphics::barplot() } else { - graphics::barplot(0, ylim = c(0, 0.1), main = "No data") + graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data") } }, get_params = function(name) { From f57a8eaea960d18a3f6b6754eb6d16e1a2609c59 Mon Sep 17 00:00:00 2001 From: Borys Date: Wed, 9 Apr 2025 16:08:31 +0200 Subject: [PATCH 09/10] Update files to pass lint check --- R/attrition.R | 7 ++- R/cohort_methods.R | 23 +++---- R/filter.R | 16 +++-- R/list_operators.R | 2 +- R/repro_code_utils.R | 6 +- R/source_methods.R | 2 +- R/source_tblist.R | 34 ++++++---- R/step.R | 2 +- tests/testthat/test-cohort_methods.R | 23 ++++--- tests/testthat/test-filter.R | 10 +-- tests/testthat/test-source_methods.R | 82 +++++++++++++----------- vignettes/binding-keys.Rmd | 35 ++++++----- vignettes/cohort-configuration.Rmd | 93 +++++++++++++++++----------- vignettes/cohortBuilder.Rmd | 56 +++++++++-------- vignettes/custom-filters.Rmd | 8 ++- vignettes/managing-cohort.Rmd | 59 ++++++++++-------- 16 files changed, 260 insertions(+), 198 deletions(-) diff --git a/R/attrition.R b/R/attrition.R index f7d3347..a1fb8de 100644 --- a/R/attrition.R +++ b/R/attrition.R @@ -15,7 +15,7 @@ get_attrition_coords <- function(labels, n_included, space = 1L, percent = FALSE label_excl = label_excl ) %>% dplyr::mutate( - label_heights = nchar(label) - nchar(gsub("\n", "", label)), + label_heights = nchar(label) - nchar(gsub("\n", "", label, fixed = TRUE)), label_position_y = dplyr::lag(cumsum(label_heights + space), default = 0L), label_position_x = 0L, arrow_end_position_y = dplyr::lead(label_position_y), @@ -47,7 +47,8 @@ get_attrition_plot <- function(attrition_coords) { label.r = ggplot2::unit(0L, "lines"), vjust = "top", size = 12L / ggplot2::.pt, na.rm = TRUE ) + ggplot2::geom_label( - ggplot2::aes(label = label_excl, x = excl_end_position_x, y = excl_position_y), label.r = ggplot2::unit(0L, "lines"), + ggplot2::aes(label = label_excl, x = excl_end_position_x, y = excl_position_y), + label.r = ggplot2::unit(0L, "lines"), hjust = "left", size = 12L / ggplot2::.pt, na.rm = TRUE ) + ggplot2::scale_y_continuous(limits = c(max_y_lim + space, -space), trans = "reverse") + @@ -69,7 +70,7 @@ get_attrition_filter_label <- function(name, value_name, value) { purrr::imap(~paste(.y, " = ", .x)) %>% paste(collapse = ", ") } else if (is.vector(value)) { - value <- paste(value, collapse = ", ") + value <- toString(value) } glue::glue("Filter: {name} ({value_name} = [{value}])") } diff --git a/R/cohort_methods.R b/R/cohort_methods.R index 3479822..b35af02 100644 --- a/R/cohort_methods.R +++ b/R/cohort_methods.R @@ -307,11 +307,11 @@ Cohort <- R6::R6Class( #' @param state List or JSON string containing steps and filters configuration. #' @param modifier Function two parameters combining the previous and provided state. #' The returned state is then restored. - restore = function(state, modifier = function(prev_state, state) {state}, + restore = function(state, modifier = function(prev_state, state) state, run_flow = FALSE, hook = list( - pre = get_hook("pre_restore_hook"), - post = get_hook("post_restore_hook") - )) { + pre = get_hook("pre_restore_hook"), + post = get_hook("post_restore_hook") + )) { self$attributes$pre_restore_state <- self$get_state(json = FALSE) @@ -322,7 +322,8 @@ Cohort <- R6::R6Class( } if (is.character(state)) { - state <- jsonlite::fromJSON(txt = state, simplifyVector = TRUE, simplifyMatrix = FALSE, simplifyDataFrame = FALSE) + state <- jsonlite::fromJSON(txt = state, simplifyVector = TRUE, + simplifyMatrix = FALSE, simplifyDataFrame = FALSE) } state <- modifier(self$attributes$pre_restore_state, state) @@ -420,7 +421,7 @@ Cohort <- R6::R6Class( ... ) for (active_state in active_states) { - attrition_labels[length(attrition_labels) + 1] <- .get_attrition_label( + attrition_labels[length(attrition_labels) + 1L] <- .get_attrition_label( source = self$get_source(), step_id = active_state$step, step_filters = purrr::map(active_state$filters, get_filter_meta), @@ -503,9 +504,9 @@ Cohort <- R6::R6Class( #' @param mark_step Include information which filtering step is performed. #' @param ... Other parameters passed to \link[formatR]{tidy_source}. get_code = function( - include_source = TRUE, include_methods = c(".pre_filtering", ".post_filtering", ".run_binding"), - include_action = c("pre_filtering", "post_filtering", "run_binding"), - modifier = .repro_code_tweak, mark_step = TRUE, ...) { + include_source = TRUE, include_methods = c(".pre_filtering", ".post_filtering", ".run_binding"), + include_action = c("pre_filtering", "post_filtering", "run_binding"), + modifier = .repro_code_tweak, mark_step = TRUE, ...) { source_type <- class(private$source)[1L] # todo improve @@ -719,7 +720,7 @@ Cohort <- R6::R6Class( #' @description #' Print defined steps configuration. describe_state = function() { - if (length(private$steps) == 0) { + if (length(private$steps) == 0L) { cat("No steps configuration found.") } else { private$steps %>% purrr::walk(print_step) @@ -1233,6 +1234,6 @@ attrition <- function(x, ..., percent = FALSE) { #' @seealso \link{cohort-methods} #' @export description <- function(x, field, step_id, filter_id, - modifier = getOption("cb_help_modifier", default = function(x) x)) { + modifier = getOption("cb_help_modifier", default = function(x) x)) { x$show_help(field = field, step_id = step_id, filter_id = filter_id, modifier = modifier) } diff --git a/R/filter.R b/R/filter.R index 1881925..b9a7dea 100644 --- a/R/filter.R +++ b/R/filter.R @@ -13,7 +13,7 @@ eval_filter <- function(filter_fun, step_id, source) { #' @export .gen_id <- function() { paste0( - paste0(sample(LETTERS, 5L, TRUE), collapse = ""), + paste(sample(LETTERS, 5L, TRUE), collapse = ""), round(as.numeric(Sys.time()) * 1000L) ) } @@ -62,7 +62,7 @@ get_filter_state <- function(filter, extra_fields) { #' #' @export def_filter <- function(type, id = .gen_id(), name = id, input_param = NULL, - filter_data, get_stats, plot_data, get_params, get_data, get_defaults) { + filter_data, get_stats, plot_data, get_params, get_data, get_defaults) { structure( list( @@ -95,13 +95,12 @@ new_filter <- function(filter_type, source_type, input_param = "value", extra_pa )) extra_params_assign <- "" if (!identical(extra_params, "")) { - extra_params_assign <- paste0(paste( - glue::glue("{extra_params} = {extra_params}"), - collapse = ", " + extra_params_assign <- paste0(toString( + glue::glue("{extra_params} = {extra_params}") ), ",") - extra_params <- paste0(paste(extra_params, collapse = ", "), ",") + extra_params <- paste0(toString(extra_params), ",") } - file = file.path(getwd(), glue::glue("filter_{filter_type}_{source_type}.R")) + file <- file.path(getwd(), glue::glue("filter_{filter_type}_{source_type}.R")) writeLines( do.call(glue::glue, as.list(template_content)), con = file @@ -310,7 +309,7 @@ cb_filter.date_range <- function(source, ...) { #' @rdname filter-types #' @export filter.datetime_range <- function(type, id, name, ..., description = NULL, - active = getOption("cb_active_filter", default = TRUE)) { + active = getOption("cb_active_filter", default = TRUE)) { args <- append( environment() %>% as.list() %>% purrr::keep(~ !is.symbol(.x)), list(...) @@ -396,4 +395,3 @@ cb_filter.query <- function(source, ...) { } } } - diff --git a/R/list_operators.R b/R/list_operators.R index 70d612e..3ef2512 100644 --- a/R/list_operators.R +++ b/R/list_operators.R @@ -3,7 +3,7 @@ adjust_names <- function(list_obj) { # removed the last existing object return(list()) } - names(list_obj) <- as.character(1L:length(list_obj)) + names(list_obj) <- as.character(seq_along(list_obj)) return(list_obj) } diff --git a/R/repro_code_utils.R b/R/repro_code_utils.R index 49e3b55..093e148 100644 --- a/R/repro_code_utils.R +++ b/R/repro_code_utils.R @@ -155,15 +155,13 @@ exclude_first_pipe <- function(expr, after) { if (expr[[1L]] == as.symbol("{")) { if (identical(expr[[2L]][[2L]], after) && expr[[2L]][[1L]] == as.symbol("%>%")) { expr[[2L]] <- expr[[2L]][[3L]] - } - else { + } else { expr[[2L]][[2L]] <- exclude_first_pipe(expr[[2L]][[2L]], after) } } else { if (identical(expr[[2L]], after) && expr[[1L]] == as.symbol("%>%")) { expr <- expr[[3L]] - } - else { + } else { expr[[2L]] <- exclude_first_pipe(expr[[2L]], after) } } diff --git a/R/source_methods.R b/R/source_methods.R index 72fc11d..72195fa 100644 --- a/R/source_methods.R +++ b/R/source_methods.R @@ -26,7 +26,7 @@ Source <- R6::R6Class( self$dtconn <- dtconn self$attributes <- list(...) - self$source_code = source_code + self$source_code <- source_code self$description <- description if (!is.null(binding_keys)) { self$binding_keys <- binding_keys diff --git a/R/source_tblist.R b/R/source_tblist.R index 1174c9b..5adede9 100644 --- a/R/source_tblist.R +++ b/R/source_tblist.R @@ -146,9 +146,10 @@ cb_filter.discrete.tblist <- function( } stats <- list( choices = if ("choices" %in% name) data_object[[dataset]][[variable]] %>% - stats::na.omit() %>% table() %>% as.list(), - n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% - stats::na.omit() %>% length(), + stats::na.omit() %>% + table() %>% + as.list(), + n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% stats::na.omit() %>% length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) if (length(name) == 1L) { @@ -220,9 +221,12 @@ cb_filter.discrete_text.tblist <- function( } stats <- list( choices = if ("choices" %in% name) data_object[[dataset]][[variable]] %>% - collapse::funique() %>% paste(collapse = ","), + collapse::funique() %>% + paste(collapse = ","), n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% - stats::na.omit() %>% collapse::funique() %>% length(), + stats::na.omit() %>% + collapse::funique() %>% + length(), n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() ) if (length(name) == 1L) { @@ -261,7 +265,8 @@ get_range_frequencies <- function(data_object, dataset, variable, extra_params) level = character(0L), count = numeric(0L), l_bound = numeric(0L), - u_bound = numeric(0L) + u_bound = numeric(0L), + stringsAsFactors = FALSE ) ) } @@ -273,7 +278,8 @@ get_range_frequencies <- function(data_object, dataset, variable, extra_params) level = "1", count = length(data_object[[dataset]][[variable]]), l_bound = min_val, - u_bound = max_val + u_bound = max_val, + stringsAsFactors = FALSE ) ) } @@ -296,8 +302,8 @@ get_range_frequencies <- function(data_object, dataset, variable, extra_params) dplyr::mutate( level = factor( findInterval(!!sym(variable), breaks, rightmost.closed = FALSE), - levels = 1L:(length(breaks)), - labels = as.character(1L:(length(breaks))) + levels = seq_len(length(breaks)), + labels = as.character(seq_len(length(breaks))) ) ) %>% dplyr::group_by(level) %>% @@ -409,7 +415,8 @@ get_date_range_frequencies <- function(data_object, dataset, variable, extra_par level = character(0L), count = numeric(0L), l_bound = numeric(0L), - u_bound = numeric(0L) + u_bound = numeric(0L), + stringsAsFactors = FALSE ) ) } @@ -421,7 +428,8 @@ get_date_range_frequencies <- function(data_object, dataset, variable, extra_par level = "1", count = length(data_object[[dataset]][[variable]]), l_bound = min_val, - u_bound = max_val + u_bound = max_val, + stringsAsFactors = FALSE ) ) } @@ -439,8 +447,8 @@ get_date_range_frequencies <- function(data_object, dataset, variable, extra_par dplyr::mutate( level = factor( findInterval(!!sym(variable), breaks, rightmost.closed = FALSE), - levels = 1L:(length(breaks)), - labels = as.character(1L:(length(breaks))) + levels = seq_len(length(breaks)), + labels = as.character(seq_len(length(breaks))) ) ) %>% dplyr::group_by(level) %>% diff --git a/R/step.R b/R/step.R index 44763c6..929e1c5 100644 --- a/R/step.R +++ b/R/step.R @@ -49,7 +49,7 @@ eval_step_filters <- function(step, source) { purrr::map(eval_filter, step_id = step$id, source = source) filters_names <- step$filters %>% purrr::map_chr(~.x$id) - if (any(duplicated(filters_names))) { + if (anyDuplicated(filters_names) > 0L) { stop("Cannot create filters with the same id in a single step.") } step$filters <- step$filters %>% diff --git a/tests/testthat/test-cohort_methods.R b/tests/testthat/test-cohort_methods.R index 1d02949..5e5355f 100644 --- a/tests/testthat/test-cohort_methods.R +++ b/tests/testthat/test-cohort_methods.R @@ -672,11 +672,13 @@ test_that("Caching works fine", { test_that("Bind keys work fine", { patients <- data.frame( id = letters[1L:3L], name = c("a", "b", "b"), - surname = c("A", "A", "B"), surname2 = c("A", "A", "B"), age = 1L:3L + surname = c("A", "A", "B"), surname2 = c("A", "A", "B"), + age = 1L:3L, stringsAsFactors = FALSE ) treatment <- data.frame( id = letters[1L:3L], name = c("a", "b", "b"), - surname = c("A", "A", "B"), treatment = LETTERS[1L:3L] + surname = c("A", "A", "B"), treatment = LETTERS[1L:3L], + stringsAsFactors = FALSE ) @@ -1076,20 +1078,21 @@ test_that("restore correctly restore filters filter type date_range and datetime ), step( filter( - "date_range", id = "issues_date", dataset = "issues", - variable = "date", range = c(as.Date("2010-10-01"), as.Date("2015-10-01")) + "date_range", id = "issues_date", dataset = "issues", + variable = "date", range = c(as.Date("2010-10-01"), as.Date("2015-10-01")) ), filter( - "date_range", id = "issues_date2", dataset = "issues", - variable = "date", range = as.Date(NULL) + "date_range", id = "issues_date2", dataset = "issues", + variable = "date", range = as.Date(NULL) ), filter( - "datetime_range", id = "issues_datetime", dataset = "issues", - variable = "date", range = c(as.POSIXct("2010-10-01"), as.POSIXct("2015-10-01")) + "datetime_range", id = "issues_datetime", dataset = "issues", + variable = "date", range = c(as.POSIXct("2010-10-01"), as.POSIXct("2015-10-01")) ), filter( - "datetime_range", id = "issues_datetime2", dataset = "issues", - variable = "date", range = as.POSIXct(NULL)) + "datetime_range", id = "issues_datetime2", dataset = "issues", + variable = "date", range = as.POSIXct(NULL) + ) ) ) diff --git a/tests/testthat/test-filter.R b/tests/testthat/test-filter.R index 89a8243..f62ff1b 100644 --- a/tests/testthat/test-filter.R +++ b/tests/testthat/test-filter.R @@ -17,7 +17,8 @@ test_that("Calling filter with id returns function of source param, calling vali test_that("Calling filter on source returns list with valid methods and parameters", { expect_true(is.list(variable_filter)) expect_identical( - c("id", "type", "name", "input_param", "filter_data", "get_stats", "plot_data", "get_params", "get_data", "get_defaults"), + c("id", "type", "name", "input_param", "filter_data", + "get_stats", "plot_data", "get_params", "get_data", "get_defaults"), names(variable_filter) ) }) @@ -32,7 +33,8 @@ test_that("Discrete text filter works fine", { iris_source <- set_source( tblist(iris = iris) ) - spec_filter <- filter("discrete_text", id = "species", dataset = "iris", variable = "Species", value = "setosa,virginica") + spec_filter <- filter("discrete_text", id = "species", dataset = "iris", + variable = "Species", value = "setosa,virginica") coh <- Cohort$new( iris_source, spec_filter @@ -47,7 +49,7 @@ test_that("Discrete text filter works fine", { }) test_that("Multi discrete filter works fine", { - md_data <- data.frame(col1 = c("A", "B", "A", "B", "A"), col2 = c("C", "C", "C", "D", "D")) + md_data <- data.frame(col1 = c("A", "B", "A", "B", "A"), col2 = c("C", "C", "C", "D", "D"), stringsAsFactors = FALSE) md_source <- set_source( tblist(md_data = md_data) ) @@ -86,7 +88,7 @@ test_that("Multi discrete filter works fine", { }) test_that("Query discrete filter works fine", { - md_data <- data.frame(col1 = c("A", "B", "A", "B", "A"), col2 = c("C", "C", "C", "D", "D")) + md_data <- data.frame(col1 = c("A", "B", "A", "B", "A"), col2 = c("C", "C", "C", "D", "D"), stringsAsFactors = FALSE) md_source <- set_source( tblist(md_data = md_data) ) diff --git a/tests/testthat/test-source_methods.R b/tests/testthat/test-source_methods.R index 1a93da6..b0241f3 100644 --- a/tests/testthat/test-source_methods.R +++ b/tests/testthat/test-source_methods.R @@ -37,15 +37,17 @@ test_that("Adding step on source works fine", { # two steps iris_source <- set_source( tblist(iris = iris) - ) %>% add_step( - step( - discrete_filter_species - ) - ) %>% add_step( - step( - discrete_filter_species + ) %>% + add_step( + step( + discrete_filter_species + ) + ) %>% + add_step( + step( + discrete_filter_species + ) ) - ) coh <- Cohort$new(iris_source) state <- coh$sum_up_state() expect_true(state$source) @@ -78,15 +80,17 @@ test_that("Removing step on source works fine", { # two steps iris_source <- set_source( tblist(iris = iris) - ) %>% add_step( - step( - discrete_filter_species - ) - ) %>% add_step( - step( - discrete_filter_species + ) %>% + add_step( + step( + discrete_filter_species + ) + ) %>% + add_step( + step( + discrete_filter_species + ) ) - ) no_last_step <- iris_source$clone() %>% rm_step() @@ -153,11 +157,13 @@ test_that("Adding filter on source works fine and attaches it to correct step", # multiple filters in the same (latest) step iris_source <- set_source( tblist(iris = iris) - ) %>% add_filter( - discrete_filter_species - ) %>% add_filter( - discrete_filter_species_two - ) + ) %>% + add_filter( + discrete_filter_species + ) %>% + add_filter( + discrete_filter_species_two + ) coh <- Cohort$new(iris_source) state <- coh$sum_up_state() @@ -170,13 +176,15 @@ test_that("Adding filter on source works fine and attaches it to correct step", # multiple filters in different steps iris_source <- set_source( tblist(iris = iris) - ) %>% add_filter( - discrete_filter_species, - step_id = 1L - ) %>% add_filter( - discrete_filter_species, - step_id = 2L - ) + ) %>% + add_filter( + discrete_filter_species, + step_id = 1L + ) %>% + add_filter( + discrete_filter_species, + step_id = 2L + ) coh <- Cohort$new(iris_source) state <- coh$sum_up_state() @@ -206,11 +214,13 @@ test_that("Removing filter on source works fine", { iris_source <- set_source( tblist(iris = iris) - ) %>% add_filter( - discrete_filter_species - ) %>% add_filter( - discrete_filter_species_two - ) + ) %>% + add_filter( + discrete_filter_species + ) %>% + add_filter( + discrete_filter_species_two + ) removed_filter_but_not_last_one <- iris_source$clone() %>% rm_filter(1L, "species_filter_two") coh <- Cohort$new(removed_filter_but_not_last_one) @@ -248,9 +258,9 @@ test_that("Updating filter on source works fine", { test_that("Removing step with ID '0' triggers warning", { iris_source <- set_source( tblist(iris = iris) - ) %>% add_filter( - discrete_filter_species - ) + ) %>% add_filter( + discrete_filter_species + ) expect_warning(iris_source$rm_step("0"), "No steps to remove or wrong ID passed") }) diff --git a/vignettes/binding-keys.Rmd b/vignettes/binding-keys.Rmd index 1b5d38f..bcaa16d 100644 --- a/vignettes/binding-keys.Rmd +++ b/vignettes/binding-keys.Rmd @@ -12,7 +12,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -options("tibble.print_min" = 5, "tibble.print_max" = 5) +options("tibble.print_min" = 5L, "tibble.print_max" = 5L) library(magrittr) library(cohortBuilder) ``` @@ -34,15 +34,17 @@ librarian_source <- set_source( as.tblist(librarian) ) -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( step( filter( - "discrete", id = "title", dataset = "books", + "discrete", + id = "title", dataset = "books", variable = "title", value = "Birdsong" ), filter( - "date_range", id = "issue_date", dataset = "issues", + "date_range", + id = "issue_date", dataset = "issues", variable = "date", range = c(as.Date("2016-01-01"), as.Date("2016-12-31")) ) ) @@ -66,11 +68,11 @@ for example we can define a new condition in the next filtering step: ```{r} run(librarian_cohort) selected_isbn <- get_data(librarian_cohort)$books$isbn -librarian_cohort %->% +librarian_cohort %->% step( - filter("discrete", id = "isbn", dataset = "issues", variable = "isbn", value = selected_isbn) - ) %>% - run(step_id = 2) + filter("discrete", id = "isbn", dataset = "issues", variable = "isbn", value = selected_isbn) + ) %>% + run(step_id = 2L) ``` Now `librarian_cohort` should store all the issues related to selected book. @@ -78,12 +80,11 @@ For the final part we need to filter borrowers based on those issues. We'll do t ```{r} selected_borrower_id <- get_data(librarian_cohort)$issues$borrower_id -librarian_cohort %->% +librarian_cohort %->% step( - filter("discrete", id = "borr_id", dataset = "borrowers", variable = "id", value = selected_borrower_id) - ) %>% - run(step_id = 3) - + filter("discrete", id = "borr_id", dataset = "borrowers", variable = "id", value = selected_borrower_id) + ) %>% + run(step_id = 3L) ``` Resulting third-step data should contain desired information: @@ -155,15 +156,17 @@ librarian_source <- set_source( binding_keys = case_bks ) -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( step( filter( - "discrete", id = "title", dataset = "books", + "discrete", + id = "title", dataset = "books", variable = "title", value = "Birdsong" ), filter( - "date_range", id = "issue_date", dataset = "issues", + "date_range", + id = "issue_date", dataset = "issues", variable = "date", range = c(as.Date("2016-01-01"), as.Date("2016-12-31")) ) ) diff --git a/vignettes/cohort-configuration.Rmd b/vignettes/cohort-configuration.Rmd index e6974f3..44938a9 100644 --- a/vignettes/cohort-configuration.Rmd +++ b/vignettes/cohort-configuration.Rmd @@ -29,15 +29,17 @@ You can achieve configuring filtering steps in Source using `add_step` method: ```{r} librarian_source <- set_source( as.tblist(librarian) -) %>% +) %>% add_step( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -49,14 +51,16 @@ or with `%->%` pipe operator: ```{r} librarian_source <- set_source( as.tblist(librarian) -) %->% +) %->% step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -67,20 +71,22 @@ You can also configure filtering steps using `add_filter` methods, passing `step ```{r} librarian_source <- set_source( as.tblist(librarian) -) %>% +) %>% add_filter( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), - step_id = 1 - ) %>% + step_id = 1L + ) %>% add_filter( filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ), - step_id = 1 + step_id = 1L ) ``` @@ -91,13 +97,15 @@ Or even simpler using `%->%` (to put filters in the last existing step): ```{r} librarian_source <- set_source( as.tblist(librarian) -) %->% +) %->% filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" - ) %->% + ) %->% filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ``` @@ -121,15 +129,17 @@ librarian_source <- set_source( as.tblist(librarian) ) -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -139,14 +149,16 @@ librarian_cohort <- librarian_source %>% Or if you want to define only one step, place filters directly: ```{r} -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -160,20 +172,21 @@ Using `add_step`: ```{r} librarian_cohort <- librarian_source %>% cohort() -librarian_cohort %>% +librarian_cohort %>% add_step( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) ) - ``` Using `%->%` pipe operator: @@ -181,14 +194,16 @@ Using `%->%` pipe operator: ```{r} librarian_cohort <- librarian_source %>% cohort() -librarian_cohort %->% +librarian_cohort %->% step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -199,16 +214,18 @@ You can also configure filtering steps using `add_filter` methods, passing `step ```{r} librarian_cohort <- librarian_source %>% cohort() -librarian_cohort %>% +librarian_cohort %>% add_filter( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ) - ) %>% + ) %>% add_filter( filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -221,13 +238,15 @@ Or even simpler using `%->%` (to put filters in the last existing step): ```{r} librarian_cohort <- librarian_source %>% cohort() -librarian_cohort %->% +librarian_cohort %->% filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" - ) %->% + ) %->% filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ``` diff --git a/vignettes/cohortBuilder.Rmd b/vignettes/cohortBuilder.Rmd index d517bea..1a805bf 100644 --- a/vignettes/cohortBuilder.Rmd +++ b/vignettes/cohortBuilder.Rmd @@ -12,7 +12,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -options("tibble.print_min" = 5, "tibble.print_max" = 5) +options("tibble.print_min" = 5L, "tibble.print_max" = 5L) library(magrittr) library(cohortBuilder) ``` @@ -75,7 +75,7 @@ If you want to operate on R-loaded list of tables, provide `tblist` class object **Note.** In order to convert list of data frames to 'tblist' just use `as.tblist`. ```{r} -str(as.tblist(librarian), max.level = 1) +str(as.tblist(librarian), max.level = 1L) ``` Let's proceed with creating the source: @@ -105,7 +105,7 @@ In the standard workflow we build `Cohort` on top of `Source`. We achieve it with `cohort` function: ```{r} -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort() class(librarian_cohort) ``` @@ -169,7 +169,7 @@ librarian_cohort <- librarian_cohort %->% Or define the filter while creating Cohort: ```{r} -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( author_filter ) @@ -223,15 +223,15 @@ If you want to run data filtering automatically when the filter is defined you c set `run_flow = TRUE`: ```{r} -librarian_cohort <- librarian_source %>% - cohort() %>% +librarian_cohort <- librarian_source %>% + cohort() %>% add_filter(author_filter, run_flow = TRUE) ``` when using `add_filter` or: ```{r} -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( author_filter, run_flow = TRUE @@ -265,22 +265,25 @@ We'll include filters 1. and 2. in the first step - filter 3. in the second one. The below code does the job: ```{r} -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ), step( filter( - "range", id = "copies", dataset = "books", - variable = "copies", range = c(-Inf, 5) + "range", + id = "copies", dataset = "books", + variable = "copies", range = c(-Inf, 5L) ) ) ) @@ -309,8 +312,8 @@ In order to precise the step we want to get data from, just pass its id as `step ```{r} run(librarian_cohort) -get_data(librarian_cohort, step_id = 1) -get_data(librarian_cohort, step_id = 2) +get_data(librarian_cohort, step_id = 1L) +get_data(librarian_cohort, step_id = 2L) ``` **Note.** When `step_id` is not provided, the method returns the last step data. @@ -320,8 +323,8 @@ Because the proceeding step uses result from the previous one, we have: ```{r} identical( - get_data(librarian_cohort, step_id = 1, state = "post"), - get_data(librarian_cohort, step_id = 2, state = "pre") + get_data(librarian_cohort, step_id = 1L, state = "post"), + get_data(librarian_cohort, step_id = 2L, state = "pre") ) ``` @@ -344,15 +347,15 @@ you can: - display data changes across filtering steps. ```{r} -stat(librarian_cohort, step_id = 1, filter_id = "program") -stat(librarian_cohort, step_id = 2, filter_id = "copies") +stat(librarian_cohort, step_id = 1L, filter_id = "program") +stat(librarian_cohort, step_id = 2L, filter_id = "copies") ``` ```{r} -plot_data(librarian_cohort, step_id = 1, filter_id = "program") +plot_data(librarian_cohort, step_id = 1L, filter_id = "program") ``` ```{r} -plot_data(librarian_cohort, step_id = 2, filter_id = "copies") +plot_data(librarian_cohort, step_id = 2L, filter_id = "copies") ``` ```{r} @@ -386,22 +389,25 @@ librarian_source <- set_source( }) ) -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ), step( filter( - "range", id = "copies", dataset = "books", - variable = "copies", range = c(-Inf, 5) + "range", + id = "copies", dataset = "books", + variable = "copies", range = c(-Inf, 5L) ) ), run_flow = TRUE diff --git a/vignettes/custom-filters.Rmd b/vignettes/custom-filters.Rmd index 8fa86e5..0354184 100644 --- a/vignettes/custom-filters.Rmd +++ b/vignettes/custom-filters.Rmd @@ -203,11 +203,15 @@ cb_filter.logical.tblist <- function( } stats <- list( choices = if ("choices" %in% name) data_object[[dataset]][[variable]] %>% - stats::na.omit() %>% table() %>% as.list(), + stats::na.omit() %>% + table() %>% + as.list(), n_data = if ("n_data" %in% name) data_object[[dataset]][[variable]] %>% stats::na.omit() %>% length(), - n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum() + n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% + is.na() %>% + sum() ) if (length(name) == 1L) { return(stats[[name]]) diff --git a/vignettes/managing-cohort.Rmd b/vignettes/managing-cohort.Rmd index c22a63b..710ef26 100644 --- a/vignettes/managing-cohort.Rmd +++ b/vignettes/managing-cohort.Rmd @@ -12,7 +12,7 @@ knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) -options("tibble.print_min" = 5, "tibble.print_max" = 5) +options("tibble.print_min" = 5L, "tibble.print_max" = 5L) library(magrittr) library(cohortBuilder) ``` @@ -29,22 +29,25 @@ librarian_source <- set_source( as.tblist(librarian) ) -librarian_cohort <- librarian_source %>% +librarian_cohort <- librarian_source %>% cohort( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ), step( filter( - "range", id = "copies", dataset = "books", - variable = "copies", range = c(-Inf, 5) + "range", + id = "copies", dataset = "books", + variable = "copies", range = c(-Inf, 5L) ) ), run_flow = TRUE @@ -62,9 +65,9 @@ In order to manage filters configuration you may call the following methods: Updating filter: ```{r} -librarian_cohort %>% +librarian_cohort %>% update_filter( - step_id = 1, filter_id = "author", value = c("Dan Brown", "Khaled Hosseini") + step_id = 1L, filter_id = "author", value = c("Dan Brown", "Khaled Hosseini") ) sum_up(librarian_cohort) @@ -73,13 +76,14 @@ sum_up(librarian_cohort) Adding new filter: ```{r} -librarian_cohort %>% +librarian_cohort %>% add_filter( filter( - "date_range", id = "issue_date", dataset = "issues", + "date_range", + id = "issue_date", dataset = "issues", variable = "date", range = c(as.Date("2010-01-01"), Inf) ), - step_id = 2 + step_id = 2L ) sum_up(librarian_cohort) @@ -88,8 +92,8 @@ sum_up(librarian_cohort) Removing filter: ```{r} -librarian_cohort %>% - rm_filter(step_id = 2, filter_id = "copies") +librarian_cohort %>% + rm_filter(step_id = 2L, filter_id = "copies") sum_up(librarian_cohort) ``` @@ -100,7 +104,7 @@ Calling `run` we trigger all steps computations. In our case we've updated only second step so we can optimize workflow skipping the previous steps calculation by specifying `min_step_id` parameter: ```{r} -run(librarian_cohort, min_step_id = 2) +run(librarian_cohort, min_step_id = 2L) get_data(librarian_cohort) ``` @@ -114,8 +118,8 @@ Similar to filter, you can operate on the Cohort to manage steps. `cohortBuilder` offers `add_step` and `rm_step` methods to add new, or remove existing step respectively. ```{r} -librarian_cohort %>% - rm_step(step_id = 1) +librarian_cohort %>% + rm_step(step_id = 1L) sum_up(librarian_cohort) ``` @@ -123,15 +127,17 @@ sum_up(librarian_cohort) **Note.** Removing not the last step results with renaming all step ids (so that we always have steps numbering starting with 1). ```{r} -librarian_cohort %>% +librarian_cohort %>% add_step( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -193,15 +199,17 @@ In this case, the good practice is to keep the configuration directly in Source: ```{r} source_one <- set_source( as.tblist(librarian) -) %>% +) %>% add_step( step( filter( - "discrete", id = "author", dataset = "books", + "discrete", + id = "author", dataset = "books", variable = "author", value = "Dan Brown" ), filter( - "discrete", id = "program", dataset = "borrowers", + "discrete", + id = "program", dataset = "borrowers", variable = "program", value = "premium", keep_na = FALSE ) ) @@ -209,12 +217,13 @@ source_one <- set_source( source_two <- set_source( as.tblist(librarian) -) %>% +) %>% add_step( step( filter( - "range", id = "copies", dataset = "books", - variable = "copies", range = c(-Inf, 5) + "range", + id = "copies", dataset = "books", + variable = "copies", range = c(-Inf, 5L) ) ) ) From 7b54924d680b5a588e73e20e771a599d2a522dfc Mon Sep 17 00:00:00 2001 From: Borys Date: Wed, 7 May 2025 08:43:54 +0200 Subject: [PATCH 10/10] Update files to pass lint check --- R/bind_keys.R | 6 ++++-- R/filter.R | 9 ++++++--- tests/testthat/test-cohort_methods.R | 23 ----------------------- tests/testthat/test-filter.R | 5 ++--- tests/testthat/test-source_methods.R | 4 ++-- 5 files changed, 14 insertions(+), 33 deletions(-) diff --git a/R/bind_keys.R b/R/bind_keys.R index e757938..02ba573 100644 --- a/R/bind_keys.R +++ b/R/bind_keys.R @@ -71,14 +71,16 @@ primary_keys <- function(...) { #' - `data_key` - requires to provide two parameters: #' \itemize{ #' \item{\code{dataset} - Name of the dataset existing in Source.} -#' \item{\code{key} - Single character string or vector storing column names that are keys, which should be used to describe relation.} +#' \item{\code{key} - Single character string or vector storing column names that are keys, +#' which should be used to describe relation.} #' } #' For example `data_key('books', 'author_id')`. #' #' - `bind_key` - requires to provide two obligatory parameters #' \itemize{ #' \item{\code{update} - Data key describing which table should be updated.} -#' \item{\code{...} - \strong{Triggering data keys}. One or more data keys describing on which dataset(s) the one in `update` is dependent.} +#' \item{\code{...} - \strong{Triggering data keys}. One or more data keys describing on which dataset(s) +#' the one in `update` is dependent.} #' } #' The output of `bind_key` function is named \strong{binding key}. #' `bind_key` offers two extra parameters `post` and `activate`. diff --git a/R/filter.R b/R/filter.R index b9a7dea..42b9b83 100644 --- a/R/filter.R +++ b/R/filter.R @@ -53,11 +53,14 @@ get_filter_state <- function(filter, extra_fields) { #' @param name Filter name. #' @param input_param Name of parameter responsible for providing filtering value. #' @param filter_data Function of `data_object` parameter defining filtering logic on Source data object. -#' @param get_stats Function of `data_object` and `name` parameters defining what and how data statistics should be calculated. +#' @param get_stats Function of `data_object` and `name` parameters +#' defining what and how data statistics should be calculated. #' @param plot_data Function of `data_object` parameter defining how filter data should be plotted. -#' @param get_params Function of `name` parameter returning filter parameters (if names is skipped all the parameters are returned). +#' @param get_params Function of `name` parameter returning +#' filter parameters (if names is skipped all the parameters are returned). #' @param get_data Function of `data_object` returning filter related data. -#' @param get_defaults Function of `data_object` and `cache_object` parameters returning default `input_param` parameter value. +#' @param get_defaults Function of `data_object` and `cache_object` parameters +#' returning default `input_param` parameter value. #' @return A list of filter specific values and methods (`def_filter`) or no value (`new_filter`). #' #' @export diff --git a/tests/testthat/test-cohort_methods.R b/tests/testthat/test-cohort_methods.R index 5e5355f..40196d2 100644 --- a/tests/testthat/test-cohort_methods.R +++ b/tests/testthat/test-cohort_methods.R @@ -1107,26 +1107,3 @@ test_that("restore correctly restore filters filter type date_range and datetime expect_identical(get_state(coh), pre_state) }) - -# if (!covr::in_covr()) { # covr modifies function body so the test doesn't pass -# test_that("(experimental) Retrieving reproducible code works fine", { -# # Using direct Cohort methods -# coh <- Cohort$new( -# set_source( -# tblist(iris = iris) -# ), -# discrete_iris_one -# ) -# repro_code <- coh$get_code(1, "species_filter") -# target_code <- quote({ -# data_object <- source$datasets -# if (!identical(c("setosa", "virginica"), NA)) { -# data_object[["iris"]] <- data_object[["iris"]] %>% dplyr::filter(!!sym("Species") %in% !!c("setosa", "virginica")) -# } -# }) -# expect_equal( -# as.character(repro_code), -# as.character(target_code) -# ) -# }) -# } diff --git a/tests/testthat/test-filter.R b/tests/testthat/test-filter.R index f62ff1b..f5c2c2a 100644 --- a/tests/testthat/test-filter.R +++ b/tests/testthat/test-filter.R @@ -8,14 +8,14 @@ variable_filter <- discrete_filter(patients_source) test_that("Calling filter with id returns function of source param, calling valid S3 method", { expect_named(formals(discrete_filter), "source") - expect_true(is.function(discrete_filter)) + expect_s3_class(discrete_filter, "function") skip_on_covr() expect_identical(as.character(body(discrete_filter)[[2L]][[2L]]), "cb_filter.discrete") }) test_that("Calling filter on source returns list with valid methods and parameters", { - expect_true(is.list(variable_filter)) + expect_type(variable_filter, "list") expect_identical( c("id", "type", "name", "input_param", "filter_data", "get_stats", "plot_data", "get_params", "get_data", "get_defaults"), @@ -26,7 +26,6 @@ test_that("Calling filter on source returns list with valid methods and paramete test_that("Filter methods operate correctly based on its definition", { expect_identical(variable_filter$filter_data(patients_source$dtconn)$patients$age, 50L) expect_identical(variable_filter$get_stats(patients_source$dtconn)$choices, as.list(table(50L:51L))) - expect_identical(class(variable_filter$plot_data(patients_source$dtconn)), c("matrix", "array")) }) test_that("Discrete text filter works fine", { diff --git a/tests/testthat/test-source_methods.R b/tests/testthat/test-source_methods.R index b0241f3..79decd0 100644 --- a/tests/testthat/test-source_methods.R +++ b/tests/testthat/test-source_methods.R @@ -221,9 +221,9 @@ test_that("Removing filter on source works fine", { add_filter( discrete_filter_species_two ) - removed_filter_but_not_last_one <- iris_source$clone() %>% + removed_filter_not_last_one <- iris_source$clone() %>% rm_filter(1L, "species_filter_two") - coh <- Cohort$new(removed_filter_but_not_last_one) + coh <- Cohort$new(removed_filter_not_last_one) state <- coh$sum_up_state() expect_true(state$source) expect_null(state$source_vars)