chore: #84 merge in devel

Merge remote-tracking branch 'origin/devel' into 84_xportr_deep_dive_vignette
# Please enter a commit message to explain why this merge is necessary,
# especially if it merges an updated upstream into a topic branch.
#
# Lines starting with '#' will be ignored, and an empty message aborts
# the commit.

.github/workflows/check-standard.yaml

@@ -1,13 +1,13 @@
 # Workflow derived from https://github.com/r-lib/actions/tree/master/examples
 # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+name: R-CMD-check 📦
+
 on:
  push:
  branches: [main, devel]
  pull_request:
  branches: [main, devel]
 
-name: R-CMD-check
-
 jobs:
  R-CMD-check:
  runs-on: ${{ matrix.config.os }}

.github/workflows/lint.yaml

@@ -1,13 +1,13 @@
 # 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
+name: Check Lint 🧹
+
 on:
  push:
  branches: [main]
  pull_request:
  branches: [main, devel]
 
-name: lint
-
 jobs:
  lint:
  runs-on: ubuntu-latest
@@ -29,4 +29,4 @@ jobs:
  run: lintr::lint_package()
  shell: Rscript {0}
  env:
- LINTR_ERROR_ON_LINT: true
+ LINTR_ERROR_ON_LINT: true

.github/workflows/pkgdown.yaml

@@ -1,11 +1,11 @@
+name: Deploy pkgdown site 📜
+
 on:
  push:
  branches:
  - main
  - master
 
-name: pkgdown
-
 jobs:
  pkgdown:
  runs-on: macOS-latest

.github/workflows/spellcheck.yml

@@ -1,5 +1,4 @@
----
-name: Spelling 🆎
+name: Check Spelling 🆎
 
 on:
  workflow_dispatch:

.github/workflows/style.yml

@@ -0,0 +1,45 @@
+name: Check Style 🎨
+
+on:
+ push:
+ branches: [main]
+ pull_request:
+ branches: [main, devel]
+
+concurrency:
+ group: style-${{ github.event.pull_request.number || github.ref }}
+ cancel-in-progress: true
+
+jobs:
+ style:
+ name: Check code style 🧑‍🎨
+ runs-on: ubuntu-latest
+ if: >
+ !contains(github.event.commits[0].message, '[skip stylecheck]')
+ && github.event.pull_request.draft == false
+
+ steps:
+ - uses: actions/checkout@v3
+ with:
+ path: ${{ github.event.repository.name }}
+ fetch-depth: 0
+
+ - uses: r-lib/actions/setup-r@v2
+ with:
+ use-public-rspm: true
+
+ - name: Install styler 🖌️
+ run: install.packages(c("styler", "knitr", "roxygen2"), repos = "https://cloud.r-project.org")
+ shell: Rscript {0}
+
+ - name: Run styler 🖼️
+ run: |
+ detect <- styler::style_pkg(dry = "on")
+ if (TRUE %in% detect$changed) {
+ problems <- subset(detect$file, detect$changed == T)
+ cat(paste("Styling errors found in", length(problems), "files\n"))
+ cat("Please run `styler::style_pkg()` to fix the style\n")
+ quit(status = 1)
+ }
+ shell: Rscript {0}
+ working-directory: ${{ github.event.repository.name }}

.github/workflows/test-coverage.yaml

@@ -1,3 +1,5 @@
+name: Check Test Coverage 🧪
+
 on:
  push:
  branches:
@@ -8,8 +10,6 @@ on:
  - main
  - master
 
-name: test-coverage
-
 jobs:
  test-coverage:
  runs-on: macOS-latest

R/df_label.R

@@ -27,46 +27,34 @@
 #'
 #' adsl <- xportr_df_label(adsl, metacore)
 xportr_df_label <- function(.df, metacore, domain = NULL) {
-
  domain_name <- getOption("xportr.df_domain_name")
  label_name <- getOption("xportr.df_label")
-
-
- df_arg <- as_name(enexpr(.df))
-
- if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_")
- else if (identical(df_arg, ".")) {
- attr(.df, "_xportr.df_arg_") <- get_pipe_call()
- df_arg <- attr(.df, "_xportr.df_arg_")
- }
-
- 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)}>."))
- )
- }
-
- df_arg <- domain %||% df_arg
-
+
+ ## 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)
  if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain
-
- if (inherits(metacore, "Metacore"))
+
+ ## End of common section
+
+ if (inherits(metacore, "Metacore")) {
  metacore <- metacore$ds_spec
-
+ }
+
  label <- metacore %>%
- filter(!!sym(domain_name) == df_arg) %>%
+ filter(!!sym(domain_name) == domain) %>%
  select(!!sym(label_name)) %>%
  # If a dataframe is used this will also be a dataframe, change to character.
  as.character()
- 
+
  label_len <- nchar(label)
- 
+
  if (label_len > 40) {
  abort("Length of dataset label must be 40 characters or less.")
  }
-
-
+
  attr(.df, "label") <- label
- 
+
  .df
 }

R/format.R

@@ -28,57 +28,47 @@
 #'
 #' adsl <- xportr_format(adsl, metacore)
 xportr_format <- function(.df, metacore, domain = NULL, verbose = getOption("xportr.format_verbose", "none")) {
-
  domain_name <- getOption("xportr.domain_name")
  format_name <- getOption("xportr.format_name")
  variable_name <- getOption("xportr.variable_name")
-
-
- df_arg <- as_name(enexpr(.df))
-
- if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_")
- else if (identical(df_arg, ".")) {
- attr(.df, "_xportr.df_arg_") <- get_pipe_call()
- df_arg <- attr(.df, "_xportr.df_arg_")
- }
-
- 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)}>."))
- )
- }
-
- df_arg <- domain %||% df_arg
-
+
+ ## 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)
  if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain
-
- if (inherits(metacore, "Metacore"))
+
+ ## End of common section
+
+ if (inherits(metacore, "Metacore")) {
  metacore <- metacore$var_spec
-
+ }
+
  if (domain_name %in% names(metacore)) {
  metadata <- metacore %>%
- dplyr::filter(!!sym(domain_name) == df_arg & !is.na(!!sym(format_name)))
+ dplyr::filter(!!sym(domain_name) == domain & !is.na(!!sym(format_name)))
  } else {
  metadata <- metacore
  }
- 
+
  filtered_metadata <- metadata %>%
  filter(!!sym(variable_name) %in% names(.df))
 
- 
+
  format <- filtered_metadata %>%
- select(!!sym(format_name))  %>%
+ select(!!sym(format_name)) %>%
  unlist() %>%
  toupper()
 
  names(format) <- filtered_metadata[[variable_name]]
- 
+
  for (i in seq_len(ncol(.df))) {
  format_sas <- purrr::pluck(format, colnames(.df)[i])
- if (is.na(format_sas) || is.null(format_sas))
+ if (is.na(format_sas) || is.null(format_sas)) {
  format_sas <- ""
+ }
  attr(.df[[i]], "format.sas") <- format_sas
  }
- 
+
  .df
 }

R/label.R

@@ -31,63 +31,57 @@
 #' adsl <- xportr_label(adsl, metacore)
 xportr_label <- function(.df, metacore, domain = NULL,
  verbose = getOption("xportr.label_verbose", "none")) {
-
  domain_name <- getOption("xportr.domain_name")
  variable_name <- getOption("xportr.variable_name")
  variable_label <- getOption("xportr.label")
-
- df_arg <- as_name(enexpr(.df))
-
- if (!is.null(attr(.df, "_xportr.df_arg_"))) df_arg <- attr(.df, "_xportr.df_arg_")
- else if (identical(df_arg, ".")) {
- attr(.df, "_xportr.df_arg_") <- get_pipe_call()
- df_arg <- attr(.df, "_xportr.df_arg_")
- }
-
- 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)}>."))
- )
- }
-
- df_arg <- domain %||% df_arg
-
+
+ ## 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)
  if (!is.null(domain)) attr(.df, "_xportr.df_arg_") <- domain
-
- if (inherits(metacore, "Metacore"))
+
+ ## End of common section
+
+ if (inherits(metacore, "Metacore")) {
  metacore <- metacore$var_spec
-
+ }
+
  if (domain_name %in% names(metacore)) {
  metadata <- metacore %>%
- dplyr::filter(!!sym(domain_name) == df_arg)
+ dplyr::filter(!!sym(domain_name) == domain)
  } else {
  metadata <- metacore
  }
 
- 
+
  # Check any variables missed in metadata but present in input data ---
  miss_vars <- setdiff(names(.df), metadata[[variable_name]])
 
  label_log(miss_vars, verbose)
- 
+
  label <- metadata[[variable_label]]
  names(label) <- metadata[[variable_name]]
- 
+
  # Check any variable label have more than 40 characters ---
  label_len <- lapply(label, nchar)
- err_len <- which(label_len > 40) %>% names
- 
+ err_len <- which(label_len > 40) %>% names()
+
  if (length(err_len) > 0) {
  warn(
  c("Length of variable label must be 40 characters or less.",
- x = glue("Problem with {encode_vars(err_len)}."))
+ x = glue("Problem with {encode_vars(err_len)}.")
+ )
  )
  }
- 
+
  for (i in names(.df)) {
- if (i %in% miss_vars) attr(.df[[i]], "label") <- ""
- else attr(.df[[i]], "label") <- label[[i]]
+ if (i %in% miss_vars) {
+ attr(.df[[i]], "label") <- ""
+ } else {
+ attr(.df[[i]], "label") <- label[[i]]
+ }
  }
- 
+
  .df
 }