Skip to content

Commit

Permalink
Remove dynamic domain determination
Browse files Browse the repository at this point in the history
  • Loading branch information
elimillera committed Nov 27, 2023
1 parent dc751f3 commit 251ac9a
Show file tree
Hide file tree
Showing 22 changed files with 123 additions and 175 deletions.
1 change: 1 addition & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@ export(type_log)
export(var_names_log)
export(var_ord_msg)
export(xportr_df_label)
export(xportr_domain_name)
export(xportr_format)
export(xportr_label)
export(xportr_length)
Expand Down
7 changes: 3 additions & 4 deletions R/df_label.R
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@
#' label = c("Subject-Level Analysis", "Adverse Events Analysis")
#' )
#'
#' adsl <- xportr_df_label(adsl, metadata)
#' adsl <- xportr_df_label(adsl, metadata, domain = "adsl")
xportr_df_label <- function(.df,
metadata = NULL,
domain = NULL,
Expand All @@ -54,10 +54,9 @@ xportr_df_label <- function(.df,
domain_name <- getOption("xportr.df_domain_name")
label_name <- getOption("xportr.df_label")

## Common section to detect domain from argument or pipes
## Common section to detect domain from argument or attribute

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section
Expand Down
5 changes: 2 additions & 3 deletions R/format.R
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,7 @@
#' format = c(NA, "DATE9.")
#' )
#'
#' adsl <- xportr_format(adsl, metadata)
#' adsl <- xportr_format(adsl, metadata, domain = "adsl")
xportr_format <- function(.df,
metadata = NULL,
domain = NULL,
Expand All @@ -59,8 +59,7 @@ xportr_format <- function(.df,

## Common section to detect domain from argument or pipes

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section
Expand Down
5 changes: 2 additions & 3 deletions R/label.R
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@
#' label = c("Unique Subject Identifier", "Study Site Identifier", "Age", "Sex")
#' )
#'
#' adsl <- xportr_label(adsl, metadata)
#' adsl <- xportr_label(adsl, metadata, domain = "adsl")
xportr_label <- function(.df,
metadata = NULL,
domain = NULL,
Expand All @@ -75,8 +75,7 @@ xportr_label <- function(.df,

## Common section to detect domain from argument or pipes

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section
Expand Down
5 changes: 2 additions & 3 deletions R/length.R
Original file line number Diff line number Diff line change
Expand Up @@ -62,7 +62,7 @@
#' length = c(10, 8)
#' )
#'
#' adsl <- xportr_length(adsl, metadata)
#' adsl <- xportr_length(adsl, metadata, domain = "adsl")
xportr_length <- function(.df,
metadata = NULL,
domain = NULL,
Expand All @@ -82,8 +82,7 @@ xportr_length <- function(.df,

## Common section to detect domain from argument or pipes

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section
Expand Down
22 changes: 20 additions & 2 deletions R/metadata.R
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,8 @@
#' @return `.df` dataset with metadata and domain attributes set
#' @export
#'
#' @rdname metadata
#'
#' @examples
#'
#' metadata <- data.frame(
Expand All @@ -33,18 +35,34 @@
#' library(magrittr)
#'
#' adlb %>%
#' xportr_domain_name("adlb") %>%
#' xportr_metadata(metadata, "test") %>%
#' xportr_type() %>%
#' xportr_order()
#' }
xportr_metadata <- function(.df, metadata, domain = NULL) {
## Common section to detect domain from argument or pipes

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section

structure(.df, `_xportr.df_metadata_` = metadata)
}


#' Update Metadata Domain Name
#'
#' @inheritParams xportr_length
#'
#' @return `.df` dataset with domain argument set
#' @export
#'
#' @rdname metadata
xportr_domain_name <- function(.df, domain) {

attr(.df, "_xportr.df_arg_") <- domain

.df
}
5 changes: 2 additions & 3 deletions R/order.R
Original file line number Diff line number Diff line change
Expand Up @@ -58,7 +58,7 @@
#' order = 1:4
#' )
#'
#' adsl <- xportr_order(adsl, metadata)
#' adsl <- xportr_order(adsl, metadata, domain = "adsl")
xportr_order <- function(.df,
metadata = NULL,
domain = NULL,
Expand All @@ -78,8 +78,7 @@ xportr_order <- function(.df,

## Common section to detect domain from argument or pipes

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section
Expand Down
1 change: 1 addition & 0 deletions R/support-test.R
Original file line number Diff line number Diff line change
Expand Up @@ -180,6 +180,7 @@ multiple_vars_in_spec_helper2 <- function(FUN) {
local_cli_theme()

adsl %>%
xportr_domain_name("adsl") %>%
FUN(metadata) %>%
testthat::expect_no_message(message = "There are multiple specs for the same variable name")
}
3 changes: 1 addition & 2 deletions R/type.R
Original file line number Diff line number Diff line change
Expand Up @@ -99,8 +99,7 @@ xportr_type <- function(.df,

## Common section to detect domain from argument or pipes

df_arg <- tryCatch(as_name(enexpr(.df)), error = function(err) NULL)
domain <- get_domain(.df, df_arg, domain)
domain <- get_domain(.df, domain)
if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain

## End of common section
Expand Down
7 changes: 2 additions & 5 deletions R/utils-xportr.R
Original file line number Diff line number Diff line change
Expand Up @@ -309,17 +309,14 @@ xpt_validate <- function(data) {
#'
#' @return A string representing the domain
#' @noRd
get_domain <- function(.df, df_arg, domain) {
get_domain <- function(.df, domain) {
if (!is.null(domain) && !is.character(domain)) {
abort(c("`domain` must be a vector with type <character>.",
x = glue("Instead, it has type <{typeof(domain)}>.")
))
}

if (identical(df_arg, ".")) {
df_arg <- get_pipe_call()
}
result <- domain %||% attr(.df, "_xportr.df_arg_") %||% df_arg
result <- domain %||% attr(.df, "_xportr.df_arg_")
result
}

Expand Down
6 changes: 6 additions & 0 deletions man/xportr_metadata.Rd → man/metadata.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/xportr_df_label.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/xportr_format.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/xportr_label.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/xportr_length.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/xportr_order.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

22 changes: 11 additions & 11 deletions tests/testthat/test-depreciation.R
Original file line number Diff line number Diff line change
Expand Up @@ -3,10 +3,10 @@ test_that("xportr_df_label: deprecated metacore argument still works and gives w
df <- data.frame(x = "a", y = "b")
df_meta <- data.frame(dataset = "df", label = "Label")

df_spec_labeled_df <- xportr_df_label(df, metacore = df_meta)
df_spec_labeled_df <- xportr_df_label(df, metacore = df_meta, domain = "df")

expect_equal(attr(df_spec_labeled_df, "label"), "Label")
xportr_df_label(df, metacore = df_meta) %>%
xportr_df_label(df, metacore = df_meta, domain = "df") %>%
lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
})

Expand All @@ -19,10 +19,10 @@ test_that("xportr_format: deprecated metacore argument still works and gives war
format = "date9."
)

formatted_df <- xportr_format(df, metacore = df_meta)
formatted_df <- xportr_format(df, metacore = df_meta, domain = "df")

expect_equal(attr(formatted_df$x, "format.sas"), "DATE9.")
xportr_format(df, metacore = df_meta) %>%
xportr_format(df, metacore = df_meta, domain = "df") %>%
lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
})

Expand All @@ -33,14 +33,14 @@ test_that("xportr_label: deprecated metacore argument still works and gives warn
df_meta <- data.frame(dataset = "df", variable = "x", label = "foo")

df_labeled_df <- suppressMessages(
xportr_label(df, metacore = df_meta)
xportr_label(df, metacore = df_meta, domain = "df")
)

expect_equal(attr(df_labeled_df$x, "label"), "foo")

# Note that only the deprecated message should be caught (others are ignored)
suppressMessages(
xportr_label(df, metacore = df_meta) %>%
xportr_label(df, metacore = df_meta, domain = "df") %>%
lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
)
})
Expand All @@ -55,11 +55,11 @@ test_that("xportr_length: deprecated metacore argument still works and gives war
length = c(1, 2)
)

df_with_width <- xportr_length(df, metacore = df_meta)
df_with_width <- xportr_length(df, metacore = df_meta, domain = "df")

expect_equal(c(x = 1, y = 2), map_dbl(df_with_width, attr, "width"))

xportr_length(df, metacore = df_meta) %>%
xportr_length(df, metacore = df_meta, domain = "df") %>%
lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
})

Expand All @@ -81,7 +81,7 @@ test_that("xportr_order: deprecated metacore argument still works and gives warn

# Note that only the deprecated message should be caught (others are ignored)
suppressMessages(
xportr_order(df, metacore = df_meta) %>%
xportr_order(df, metacore = df_meta, domain = "df") %>%
lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
)
})
Expand All @@ -102,12 +102,12 @@ test_that("xportr_type: deprecated metacore argument still works and gives warni
)

df2 <- suppressMessages(
xportr_type(df, metacore = df_meta)
xportr_type(df, metacore = df_meta, domain = "df")
)

# Note that only the deprecated message should be caught (others are ignored)
suppressMessages(
xportr_type(df, metacore = df_meta) %>%
xportr_type(df, metacore = df_meta, domain = "df") %>%
lifecycle::expect_deprecated("Please use the `metadata` argument instead.")
)
})
Loading

0 comments on commit 251ac9a

Please sign in to comment.