Dev

.github/workflows/check-standard.yaml

@@ -26,7 +26,6 @@ jobs:
         config:
           - {os: windows-latest, r: 'release'}
           - {os: macOS-latest, r: 'release'}
-          - {os: ubuntu-20.04, r: '3.6', repos: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
           - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
           - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
 

.github/workflows/rhub.yaml

@@ -0,0 +1,95 @@
+# R-hub's generic GitHub Actions workflow file. It's canonical location is at
+# https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml
+# You can update this file to a newer version using the rhub2 package:
+#
+# rhub::rhub_setup()
+#
+# It is unlikely that you need to modify this file manually.
+
+name: R-hub
+run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}"
+
+on:
+  workflow_dispatch:
+    inputs:
+      config:
+        description: 'A comma separated list of R-hub platforms to use.'
+        type: string
+        default: 'linux,windows,macos'
+      name:
+        description: 'Run name. You can leave this empty now.'
+        type: string
+      id:
+        description: 'Unique ID. You can leave this empty now.'
+        type: string
+
+jobs:
+
+  setup:
+    runs-on: ubuntu-latest
+    outputs:
+      containers: ${{ steps.rhub-setup.outputs.containers }}
+      platforms: ${{ steps.rhub-setup.outputs.platforms }}
+
+    steps:
+    # NO NEED TO CHECKOUT HERE
+    - uses: r-hub/actions/setup@v1
+      with:
+        config: ${{ github.event.inputs.config }}
+      id: rhub-setup
+
+  linux-containers:
+    needs: setup
+    if: ${{ needs.setup.outputs.containers != '[]' }}
+    runs-on: ubuntu-latest
+    name: ${{ matrix.config.label }}
+    strategy:
+      fail-fast: false
+      matrix:
+        config: ${{ fromJson(needs.setup.outputs.containers) }}
+    container:
+      image: ${{ matrix.config.container }}
+
+    steps:
+      - uses: r-hub/actions/checkout@v1
+      - uses: r-hub/actions/platform-info@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+      - uses: r-hub/actions/setup-deps@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+      - uses: r-hub/actions/run-check@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+
+  other-platforms:
+    needs: setup
+    if: ${{ needs.setup.outputs.platforms != '[]' }}
+    runs-on: ${{ matrix.config.os }}
+    name: ${{ matrix.config.label }}
+    strategy:
+      fail-fast: false
+      matrix:
+        config: ${{ fromJson(needs.setup.outputs.platforms) }}
+
+    steps:
+      - uses: r-hub/actions/checkout@v1
+      - uses: r-hub/actions/setup-r@v1
+        with:
+          job-config: ${{ matrix.config.job-config }}
+          token: ${{ secrets.RHUB_TOKEN }}
+      - uses: r-hub/actions/platform-info@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+      - uses: r-hub/actions/setup-deps@v1
+        with:
+          job-config: ${{ matrix.config.job-config }}
+          token: ${{ secrets.RHUB_TOKEN }}
+      - uses: r-hub/actions/run-check@v1
+        with:
+          job-config: ${{ matrix.config.job-config }}
+          token: ${{ secrets.RHUB_TOKEN }}

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: metacore
 Title: A Centralized Metadata Object Focus on Clinical Trial Data Programming Workflows
-Version: 0.1.2
+Version: 0.1.3
 Authors@R: 
     c(person(given = "Christina",
              family = "Fillmore",
@@ -21,13 +21,19 @@ Authors@R:
              role = "aut",
              email = "[email protected]",
              comment = c(ORCID = "0000-0001-6030-723X")),
+      person(given = "Tamara",
+             family = "Senior",
+             role = "aut",
+             email = "[email protected]"),
       person(given = "GSK/Atorus JPT",
              role = c("cph", "fnd")))
 Description: Create an immutable container holding metadata for the purpose of better enabling programming activities and functionality of other packages within the clinical programming workflow.
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE, r6 = FALSE)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.3.1
+Depends: 
+    R (>= 3.6)
 Suggests: 
     testthat,
     knitr,

NAMESPACE

@@ -7,6 +7,7 @@ export(check_inconsistent_types)
 export(create_tbl)
 export(define_to_metacore)
 export(get_control_term)
+export(get_keys)
 export(is_metacore)
 export(load_metacore)
 export(metacore)

NEWS.md

@@ -1,4 +1,8 @@
-# Metacroe 0.1.2
+# Metacore 0.1.3
+- Add `get_keys` function which returns the dataset keys for a given dataset [#102](https://github.com/atorus-research/metacore/issues/102) 
+- Fix issues with `select_dataset(simplify = TRUE)` [#97](https://github.com/atorus-research/metacore/issues/97) 
+
+# Metacore 0.1.2
 - Update to resolve issues from the dplyr updates
 
 # Metacore 0.1.1

R/metacore.R

@@ -189,14 +189,17 @@ MetaCore_filter <- function(value) {
                  multiple = "all") %>%
       distinct(variable, .keep_all = TRUE) # for when duplicates gett through and have different lables but the same name
 
+   # Get values/variables that need derivations
+   val_deriv <- private$.value_spec %>%
+      distinct(.data$derivation_id) %>%
+      na.omit()
+
    private$.derivations <- private$.derivations %>%
-      right_join(private$.value_spec %>%
-                    select(derivation_id) %>%
-                    na.omit(), by = "derivation_id", multiple = "all")
+      right_join(val_deriv, by = "derivation_id", multiple = "all")
 
    private$.codelist <- private$.codelist %>%
       right_join(private$.value_spec %>%
-                    select(code_id) %>%
+                    distinct(.data$code_id) %>%
                     na.omit(), by = "code_id", multiple = "all")
 
    private$.supp <- private$.supp %>% filter(dataset == value)
@@ -330,13 +333,13 @@ select_dataset <- function(.data, dataset, simplify = FALSE) {
 
    if (simplify) {
 
-      suppressMessages(
+     test <-  suppressMessages(
          list(
             cl$ds_vars,
             cl$var_spec,
             cl$value_spec,
             cl$derivations,
-            cl$codelist,
+            select(cl$codelist, code_id, codes),
             cl$supp
          ) %>%
             reduce(left_join)
@@ -410,6 +413,43 @@ get_control_term <- function(metacode, variable, dataset = NULL){
 }
 
 
+#' Get Dataset Keys
+#'
+#' Returns the dataset keys for a given dataset
+#'
+#' @param metacode metacore object
+#' @param dataset A dataset name
+#'
+#' @return a 2-column tibble with dataset key variables and key sequence
+#' @export
+#'
+#' @importFrom rlang as_label enexpr as_name
+#'
+#' @examples
+#' \dontrun{
+#' meta_ex <- spec_to_metacore(metacore_example("p21_mock.xlsx"))
+#' get_keys(meta_ex, "AE")
+#' get_keys(meta_ex, AE)
+#' }
+get_keys <- function(metacode, dataset){
+   dataset_val <- ifelse(str_detect(as_label(enexpr(dataset)), "\""),
+                         as_name(dataset), as_label(enexpr(dataset))) # to make the filter more explicit
+
+   subset_data <- metacode$ds_vars %>%
+      filter(dataset == dataset_val)
+   if(nrow(subset_data) == 0){
+      stop(paste0(dataset_val, " not found in the ds_vars table. Please check the dataset name"))
+   }
+
+   keys <- subset_data %>%
+      filter(!is.na(key_seq)) %>%
+      select(variable, key_seq)
+
+   keys <- keys[order(keys$key_seq),]
+
+   return(keys)
+}
+
 
 #' save metacore object
 #'

R/spec_builder.R

@@ -2,8 +2,8 @@
 #'
 #' This function takes the location of an excel specification document and reads
 #' it in as a meta core object. At the moment it only supports specification in
-#' the format of pinnacle 21 specifications. But, the @family spec builder can
-#' be used as building blocks for bespoke specification documents
+#' the format of pinnacle 21 specifications. But, the section level spec builder can
+#' be used as building blocks for bespoke specification documents.
 #'
 #' @param path string of file location
 #' @param quiet Option to quietly load in, this will suppress warnings, but not
@@ -96,7 +96,7 @@ read_all_sheets <- function(path){
 #' @return a dataset formatted for the metacore object
 #' @export
 #'
-#' @family spec builder
+#' @family {spec builder}
 spec_type_to_ds_spec <- function(doc, cols = c("dataset" = "[N|n]ame|[D|d]ataset|[D|d]omain",
                                                "structure" = "[S|s]tructure",
                                                "label" = "[L|l]abel|[D|d]escription"), sheet = NULL){
@@ -140,7 +140,7 @@ spec_type_to_ds_spec <- function(doc, cols = c("dataset" = "[N|n]ame|[D|d]ataset
 #' @return a dataset formatted for the metacore object
 #' @export
 #'
-#' @family spec builder
+#' @family {spec builder}
 spec_type_to_ds_vars <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]omain",
                                                "variable" = "[V|v]ariable [[N|n]ame]?|[V|v]ariables?",
                                                "order" = "[V|v]ariable [O|o]rder|[O|o]rder",
@@ -214,7 +214,7 @@ spec_type_to_ds_vars <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]oma
 #' @return a dataset formatted for the metacore object
 #' @export
 #'
-#' @family spec builder
+#' @family {spec builder}
 spec_type_to_var_spec <- function(doc, cols = c("variable" = "[N|n]ame|[V|v]ariables?",
                                                 "length" = "[L|l]ength",
                                                 "label" = "[L|l]abel",
@@ -314,7 +314,7 @@ spec_type_to_var_spec <- function(doc, cols = c("variable" = "[N|n]ame|[V|v]aria
 #' @return a dataset formatted for the metacore object
 #' @export
 #'
-#' @family spec builder
+#' @family {spec builder}
 spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]omain",
                                                   "variable" = "[N|n]ame|[V|v]ariables?",
                                                   "origin" = "[O|o]rigin",
@@ -408,7 +408,10 @@ spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]
 
    if(!"derivation_id" %in% names(cols)){
       out <- out %>%
-         mutate(derivation_id = paste0(dataset, ".", variable))
+         mutate(derivation_id =
+                   if_else(str_to_lower(.data$origin) == "assigned",
+                      paste0(dataset, ".", variable),
+                      paste0("pred.", dataset, ".", variable)))
    }
 
    # Get missing columns
@@ -421,7 +424,7 @@ spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]
       mutate(sig_dig = as.integer(.data$sig_dig),
              derivation_id = case_when(
                 !is.na(.data$derivation_id) ~ .data$derivation_id,
-                str_to_lower(.data$origin) == "predecessor" ~ as.character(.data$predecessor),
+                str_to_lower(.data$origin) == "predecessor" ~ paste0("pred.", as.character(.data$predecessor)),
                 str_to_lower(.data$origin) == "assigned" ~ paste0(.data$dataset, ".", .data$variable))
       ) %>%
       select(-.data$predecessor)
@@ -453,7 +456,7 @@ spec_type_to_value_spec <- function(doc, cols = c("dataset" = "[D|d]ataset|[D|d]
 #' @return a dataset formatted for the metacore object
 #' @export
 #'
-#' @family spec builder
+#' @family {spec builder}
 spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID",
                                                          "name" = "[N|n]ame",
                                                          "code" = "^[C|c]ode|^[T|t]erm",
@@ -558,7 +561,7 @@ spec_type_to_codelist <- function(doc, codelist_cols = c("code_id" = "ID",
 #' @return a dataset formatted for the metacore object
 #' @export
 #'
-#' @family spec builder
+#' @family {spec builder}
 #' @importFrom purrr quietly
 spec_type_to_derivations <- function(doc, cols = c("derivation_id" = "ID",
                                                    "derivation" = "[D|d]efinition|[D|d]escription"),
@@ -587,11 +590,25 @@ spec_type_to_derivations <- function(doc, cols = c("derivation_id" = "ID",
    if(class(ls_derivations)[1] == "list"){
       ls_derivations <- ls_derivations %>%
          reduce(bind_rows)
+      # Get the comments
+      if(any(str_detect(names(doc), "[C|c]omment"))){
+         comments <- doc[str_detect(names(doc), "[C|c]omment")][[1]] |>
+            select(matches("ID|Description"))
+         with_comments <- ls_derivations |>
+            filter(str_to_lower(.data$origin) == "assigned") |>
+            left_join(comments, by = c("comment" = "ID" )) |>
+            mutate(comment = .data$Description) |>
+            select(-.data$Description)
+         ls_derivations <- ls_derivations |>
+            filter(str_to_lower(.data$origin) != "assigned") |>
+            bind_rows(with_comments)
+      }
    }
+
    other_derivations <- ls_derivations %>%
       mutate(
          derivation_id = case_when(
-            str_to_lower(.data$origin) == "predecessor" ~ as.character(.data$predecessor),
+            str_to_lower(.data$origin) == "predecessor" ~ paste0("pred.", as.character(.data$predecessor)),
             str_to_lower(.data$origin) == "assigned" ~ paste0(.data$dataset, ".", .data$variable),
             TRUE ~ NA_character_
             ),

R/xml_builders.R

@@ -357,8 +357,12 @@ xml_to_codelist <- function(doc) {
             version = xml_attr(node, "Version"),
             type = "external_library"
          )
-      }) %>%
-      nest(codes = c(.data$dictionary, .data$version))
+      })
+   if(nrow(external_libs) > 0){
+      external_libs <- external_libs |>
+         nest(codes = c(.data$dictionary, .data$version))
+   }
+
 
    # Combinging the code decode with the permitted values
    bind_rows(code_decode, permitted_val, external_libs) %>%