Add qs file type

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: dpdeploy
 Title: A package to manage deployment of data products
-Version: 0.3.0
+Version: 0.4.0
 Authors@R: c(
     person(given = "Afshin", family = "Mashadi-Hossein", email ="amashadihossein@gmail.com", role = c("aut", "cre")),
     person(given = "Yue", family = "Jiang", email = "rivehill@gmail.com", role = "aut")
@@ -9,7 +9,6 @@ Description: An R package to manage deployment of data product to remote.
 License: GPL-3
 BugReports: https://github.com/amashadihossein/dpdeploy/issues
 Imports: 
-    aws.s3,
     aws.signature,
     cli,
     dpbuild (>= 0.2.0),
@@ -29,10 +28,13 @@ Imports:
     yaml
 Suggests: 
     covr,
-    roxygen2
+    qs,
+    roxygen2,
+    testthat (>= 3.0.0)
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Remotes: 
     github::camorosi/pinsLabkey
+Config/testthat/edition: 3

NEWS.md

@@ -1,3 +1,7 @@
+# dpdeploy 0.4.0
+
+* Enable saving data objects in qs format via the "type" param in `dpinput_sync()`. Note that `dp_deploy()` now detects type automatically. 
+
 # dpdeploy 0.3.0
 
 * Removed references to `board_alias` (#34) as this argument is now deprecated with `pinsLabkey` v0.2.0

R/dp_deploy.R

@@ -22,30 +22,60 @@ dp_deploy <- function(project_path = ".", ...) {
   # get daap content and info
   conf <- dpconf_get(project_path = project_path)
   dlog <- get_dlog(project_path = project_path)
-  d <- readRDS(file = glue::glue(
-    "{project_path}/output_files/RDS_format/",
-    "data_object.RDS"
-  ))
+  # get the data object file type
+  type <- detect_type(project_path)
+  d <- object_read(project_path, type)
 
   dp_deployCore(
     conf = conf, project_path = project_path, d = d, dlog = dlog,
-    git_info = git_info, ...
+    git_info = git_info, type = type, ...
   )
 }
 
+#' @title Detect output object type
+#' @description Determines the saved data output object type (rds vs qs etc.)
+#' @noRd 
+detect_type = function(project_path){
+  fs::dir_ls(file.path(project_path,'output_files/'), recurse = T, regexp = 'data_object') %>% 
+      tools::file_ext() %>%
+      tolower()
+}
+
+#' @title Read data output object
+#' @description read the output data object, for now only rds and qs are supported
+#' @noRd 
+object_read <- function(project_path, type){
+  type = rlang::arg_match0(type, c('rds', 'qs'))
+  switch(type, 
+  rds = readRDS(file = glue::glue("{project_path}/output_files/RDS_format/data_object.RDS")),
+  qs = read_qs(project_path)
+  )
+}
+
+#' @title Reas qs object
+#' @description Read in qs object
+#' @noRd  
+read_qs <- function(path){
+  rlang::check_installed("qs")
+  dataobj_path <- glue::glue(
+    "{path}/",
+    "output_files/qs_format/data_object.qs"
+  )
+  qs::qread(dataobj_path)
+}
+
+
 #' The dp_deploy is a wrapper around this.
 #' Reason: With S3 generic methods, function calls as defaults parameters are
 #' not recognized as the class of the object they return
 #' @keywords internal
-dp_deployCore <- function(conf, project_path, d, dlog, git_info, ...) {
+dp_deployCore <- function(conf, project_path, d, dlog, git_info, type, ...) {
   ellipsis::check_dots_used()
   UseMethod("dp_deployCore", object = conf)
 }
 
-
-
 #' @keywords internal
-dp_deployCore.s3_board <- function(conf, project_path, d, dlog, git_info,
+dp_deployCore.s3_board <- function(conf, project_path, d, dlog, git_info, type, 
                                    verbose = F, ...) {
   if (verbose) {
     print(glue::glue("Deploying to S3 remote"))
@@ -79,6 +109,7 @@ dp_deployCore.s3_board <- function(conf, project_path, d, dlog, git_info,
 
   pins::pin_write(
     x = d,
+    type = type,
     name = as.character(attr(d, "dp_name")),
     board = board,
     description = as.character(attr(d, "branch_description"))
@@ -91,7 +122,7 @@ dp_deployCore.s3_board <- function(conf, project_path, d, dlog, git_info,
 }
 
 #' @keywords internal
-dp_deployCore.labkey_board <- function(conf, project_path, d, dlog, git_info,
+dp_deployCore.labkey_board <- function(conf, project_path, d, dlog, git_info, type,
                                        verbose = F, ...) {
   if (verbose) {
     print(glue::glue("Deploying to LabKey remote"))
@@ -114,6 +145,7 @@ dp_deployCore.labkey_board <- function(conf, project_path, d, dlog, git_info,
 
   pinsLabkey::pin_write(
     x = d,
+    type = type,
     name = as.character(attr(d, "dp_name")),
     board = board,
     description = as.character(attr(d, "branch_description"))
@@ -127,7 +159,7 @@ dp_deployCore.labkey_board <- function(conf, project_path, d, dlog, git_info,
 
 
 #' @keywords internal
-dp_deployCore.local_board <- function(conf, project_path, d, dlog, git_info,
+dp_deployCore.local_board <- function(conf, project_path, d, dlog, git_info, type, 
                                       verbose = F, ...) {
   if (verbose) {
     print(glue::glue("Deploying to local or mounted drive"))
@@ -142,6 +174,7 @@ dp_deployCore.local_board <- function(conf, project_path, d, dlog, git_info,
 
   pins::pin_write(
     x = d,
+    type = type,
     name = attr(d, "dp_name"),
     board = board_object,
     description = attr(d, "branch_description")

R/dpinput_sync.R

@@ -3,11 +3,12 @@
 #' @param conf environment containing all config.R variables. See `dpconf_get()`
 #' @param input_map object containing all input data to be synced. See `map_input()`
 #' @param verbose T/F
+#' @param type data format to pin input data to remote, default: rds
 #' @param ... other parameters e.g. verbose = T
 #' @return synced_map this is input_map with sync status added to metadata
 #' @importFrom dplyr .data
 #' @export
-dpinput_sync <- function(conf, input_map, verbose = F, ...) {
+dpinput_sync <- function(conf, input_map, verbose = F, type = "rds", ...) {
   # grab rewrite_ok if passed in ...
   args <- list(...)
   rewrite_ok <- args$rewrite_ok
@@ -43,7 +44,8 @@ dpinput_sync <- function(conf, input_map, verbose = F, ...) {
         get_pin_version(
           d = input_i$data,
           pin_name = input_i$metadata$name,
-          pin_description = input_i$metadata$description
+          pin_description = input_i$metadata$description, 
+          type = type
         )
     }
     input_i
@@ -56,6 +58,7 @@ dpinput_sync <- function(conf, input_map, verbose = F, ...) {
     board_object = board,
     skip_sync = skip_sync,
     rewrite_ok = rewrite_ok,
+    type = type, 
     verbose = verbose
   )
 
@@ -193,7 +196,7 @@ pathnames_reroot <- function(pathnames, new_root = "input_files") {
 }
 
 #' @keywords internal
-sync_iterate <- function(input_map, board_object, skip_sync, rewrite_ok = F,
+sync_iterate <- function(input_map, board_object, skip_sync, rewrite_ok = F, type = "rds",
                          verbose) {
   synced_map <- purrr::map(.x = input_map, .f = function(input_i) {
     if (board_object$board == "pins_board_labkey") {
@@ -241,13 +244,15 @@ sync_iterate <- function(input_map, board_object, skip_sync, rewrite_ok = F,
       if (board_object$board == "pins_board_labkey") {
         tmp_pind <- try(pinsLabkey::pin_write(
           x = input_i$data,
+          type = type,
           name = input_i$metadata$name,
           board = board_object,
           description = input_i$metadata$description
         ))
       } else {
         tmp_pind <- try(pins::pin_write(
           x = input_i$data,
+          type = type,
           name = input_i$metadata$name,
           board = board_object,
           description = input_i$metadata$description

R/utils.R

@@ -1,14 +1,32 @@
 #' @importFrom dpbuild dpconf_get
+#' @title Get data product config information
+#' @description Reads in data product config file `.daap/daap_config.yaml`and
+#' returns config details
+#' @details This function reads in the yaml config as a list. In the process, it
+#' hydrates any expression for `board_params` and `creds`. Make sure environment
+#' variables declared in dried functions are set prior to calling `dpconf_get`.
+#' @param project_path path to project folder
+#' @return a list dpconf
 #' @export
 #' @name dpconf_get
 dpbuild::dpconf_get
 
 #' @importFrom dpbuild is_valid_dp_repository
+#' @title Determine if valid dp repository
+#' @description Looks at the path, runs `dp_repository_check` and returns TRUE
+#' if all TRUE
+#' @details All diagnostic tests to check validity of dp repository are run
+#' regardless of choice of checks. Checks determines what subset is considered
+#' in return T/F.
+#' @param path Path to be evaluated
+#' @param checks any combination of c("all","git","dp","renv","branch"). default
+#' is all.
+#' @param verbose If TRUE, it will print which tests passed/failed
+#' @return TRUE or FALSE
 #' @export
 #' @name is_valid_dp_repository
 dpbuild::is_valid_dp_repository
 
-
 #' @title Validate git info for deploy
 #' @description Validates and extracts gitinfo per deploy requirements
 #' @param project_path path to project
@@ -166,13 +184,15 @@ dpboardlog_update <- function(conf, git_info, dlog = NULL,
     if (board_object$board == "pins_board_labkey") {
       pinsLabkey::pin_write(
         x = dpboard_log,
+        type = 'rds',
         name = "dpboard-log",
         board = board_object,
         description = "Data Product Log"
       )
     } else {
       pins::pin_write(
         x = dpboard_log,
+        type = 'rds',
         name = "dpboard-log",
         board = board_object,
         description = "Data Product Log"
@@ -218,13 +238,15 @@ dpboardlog_update <- function(conf, git_info, dlog = NULL,
   if (board_object$board == "pins_board_labkey") {
     pinsLabkey::pin_write(
       x = dpboard_log,
+      type = 'rds',
       name = "dpboard-log",
       board = board_object,
       description = "Data Product Log"
     )
   } else {
     pins::pin_write(
       x = dpboard_log,
+      type = 'rds',
       name = "dpboard-log",
       board = board_object,
       description = "Data Product Log"
@@ -254,10 +276,11 @@ get_dlog <- function(project_path) {
 #' @param d data object
 #' @param pin_name what the pin will be named. For data products, it is encoded in dp_param
 #' @param pin_description what the pin description will be. For data products, it is encoded in dp_params
+#' @param type File type used to save the data product, default RDS
 #' @return a character version
 #' @importFrom dplyr .data
 #' @keywords internal
-get_pin_version <- function(d, pin_name, pin_description) {
+get_pin_version <- function(d, pin_name, pin_description, type = 'rds') {
   withr::local_options(list(pins.quiet = TRUE))
   pin_name <- as.character(pin_name)
   pin_description <- as.character(pin_description)
@@ -272,6 +295,7 @@ get_pin_version <- function(d, pin_name, pin_description) {
 
   pins::pin_write(
     x = d,
+    type = type,
     name = pin_name,
     board = temp_board_folder,
     description = pin_description

README.Rmd

@@ -13,7 +13,7 @@ knitr::opts_chunk$set(
 )
 ```
 
-# dpdeploy
+# dpdeploy <a href="https://amashadihossein.github.io/dpdeploy/"><img src="man/figures/logo.png" align="right" height="139" alt="dpdeploy website" /></a>
 
 <!-- badges: start -->
 [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental)

README.md

@@ -1,7 +1,7 @@
 
 <!-- README.md is generated from README.Rmd. Please edit that file -->
 
-# dpdeploy
+# dpdeploy <a href="https://amashadihossein.github.io/dpdeploy/"><img src="man/figures/logo.png" align="right" height="139" alt="dpdeploy website" /></a>
 
 <!-- badges: start -->
 

dpdeploy.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 3012d3b7-e935-40a0-bd55-af57288d05fe
 
 RestoreWorkspace: No
 SaveWorkspace: No