new methods

.Rbuildignore

@@ -171,3 +171,5 @@
 ^data-raw/s4_fns/investigate\.R$
 ^data-raw/s4_fns/renew\.R$
 ^data-raw/s4_fns/share\.R$
+^data-raw/s4_fns/manufacture\.R$
+^data-raw/s4_fns/procure\.R$

DESCRIPTION

@@ -42,7 +42,8 @@ Imports:
 VignetteBuilder: knitr
 Depends: 
     R (>= 2.10),
-    specific
+    scorz (>= 0.0.0.9059),
+    specific (>= 0.0.0.9103)
 LazyData: true
 Collate: 
     'C4_TTUSynopsis.R'
@@ -68,9 +69,12 @@ Suggests:
     betareg,
     caret,
     knitrBootstrap,
-    rmarkdown
+    rmarkdown,
+    youthvars (>= 0.0.0.9121)
 Remotes: 
     ready4-dev/ready4,
     ready4-dev/ready4show,
     ready4-dev/ready4use,
-    ready4-dev/specific
+    ready4-dev/specific,
+    ready4-dev/youthvars,
+    ready4-dev/scorz

NAMESPACE

@@ -13,6 +13,8 @@ exportClasses(TTUSynopsis)
 exportMethods(author)
 exportMethods(exhibit)
 exportMethods(investigate)
+exportMethods(manufacture)
+exportMethods(procure)
 exportMethods(renew)
 exportMethods(share)
 import(methods)
@@ -22,6 +24,7 @@ importFrom(Hmisc,capitalize)
 importFrom(R.utils,copyDirectory)
 importFrom(dplyr,filter)
 importFrom(dplyr,mutate)
+importFrom(dplyr,select)
 importFrom(ggplot2,ggsave)
 importFrom(lifecycle,deprecated)
 importFrom(magrittr,"%>%")
@@ -38,6 +41,8 @@ importFrom(ready4,author)
 importFrom(ready4,exhibit)
 importFrom(ready4,investigate)
 importFrom(ready4,make_list_phrase)
+importFrom(ready4,manufacture)
+importFrom(ready4,procure)
 importFrom(ready4,renew)
 importFrom(ready4,share)
 importFrom(ready4,write_fls_to_dv)

R/mthd_exhibit.R

@@ -3,17 +3,62 @@
 #' @name exhibit-TTUProject
 #' @description exhibit method applied to TTUProject
 #' @param x An object of class TTUProject
+#' @param captions_chr Captions (a character vector), Default: NULL
+#' @param display_1L_chr Display (a character vector of length one), Default: 'all'
+#' @param header_1L_chr Header (a character vector of length one), Default: ''
+#' @param header_col_nms_chr Header column names (a character vector), Default: ' '
+#' @param mkdn_tbl_refs_chr Markdown table references (a character vector), Default: NULL
+#' @param profile_idx_int Profile index (an integer vector), Default: NA
+#' @param output_type_1L_chr Output type (a character vector of length one), Default: 'HTML'
+#' @param type_1L_chr Type (a character vector of length one), Default: 'default'
+#' @param use_lbls_as_col_nms_1L_lgl Use labels as column names (a logical vector of length one), Default: T
+#' @param use_rdocx_1L_lgl Use rdocx (a logical vector of length one), Default: F
+#' @param variables_chr Variables (a character vector), Default: character(0)
 #' @param what_1L_chr What (a character vector of length one), Default: 'predictors'
 #' @param ... Additional arguments
 #' @return NULL
 #' @rdname exhibit-methods
 #' @aliases exhibit,TTUProject-method
 #' @export 
 #' @importFrom ready4 exhibit
-methods::setMethod("exhibit", "TTUProject", function (x, what_1L_chr = "predictors", ...) 
+methods::setMethod("exhibit", "TTUProject", function (x, captions_chr = NULL, display_1L_chr = "all", header_1L_chr = "", 
+    header_col_nms_chr = " ", mkdn_tbl_refs_chr = NULL, profile_idx_int = NA_integer_, 
+    output_type_1L_chr = "HTML", type_1L_chr = "default", use_lbls_as_col_nms_1L_lgl = T, 
+    use_rdocx_1L_lgl = F, variables_chr = character(0), what_1L_chr = "predictors", 
+    ...) 
 {
     if (what_1L_chr == "predictors") {
         exhibitSlot(x, "b_SpecificParameters@predictors_lup", 
             ... = ...)
     }
+    if (what_1L_chr == "profile") {
+        exhibit(procure(x, variables_chr = variables_chr, type_1L_chr == 
+            "default", what_1L_chr = what_1L_chr, ... = ...), 
+            captions_chr = captions_chr, header_1L_chr = header_1L_chr, 
+            header_col_nms_chr = header_col_nms_chr, mkdn_tbl_refs_chr = mkdn_tbl_refs_chr, 
+            profile_idx_int = profile_idx_int, output_type_1L_chr = output_type_1L_chr, 
+            what_1L_chr = type_1L_chr)
+    }
+    if (what_1L_chr == "records") {
+        if (type_1L_chr %in% c("ds", "dict")) {
+            exhibit(x@a_ScorzProfile@a_YouthvarsProfile@a_Ready4useDyad, 
+                caption_1L_chr = {
+                  if (is.null(captions_chr)) {
+                    NA_character_
+                  }
+                  else {
+                    captions_chr[1]
+                  }
+                }, display_1L_chr = display_1L_chr, mkdn_tbl_ref_1L_chr = {
+                  if (is.null(mkdn_tbl_refs_chr)) {
+                    ""
+                  }
+                  else {
+                    mkdn_tbl_refs_chr[1]
+                  }
+                }, output_type_1L_chr = "HTML", type_1L_chr = type_1L_chr, 
+                use_lbls_as_col_nms_1L_lgl = T, use_rdocx_1L_lgl = F, 
+                ... = ...)
+        }
+    }
 })

R/mthd_manufacture.R

@@ -0,0 +1,21 @@
+#' 
+#' Manufacture a new object
+#' @name manufacture-TTUProject
+#' @description manufacture method applied to TTUProject
+#' @param x An object of class TTUProject
+#' @param type_1L_chr Type (a character vector of length one), Default: 'dummys'
+#' @param what_1L_chr What (a character vector of length one), Default: 'factors'
+#' @param ... Additional arguments
+#' @return Object (an output object of multiple potential types)
+#' @rdname manufacture-methods
+#' @aliases manufacture,TTUProject-method
+#' @export 
+#' @importFrom ready4 manufacture
+methods::setMethod("manufacture", "TTUProject", function (x, type_1L_chr = "dummys", what_1L_chr = "factors", 
+    ...) 
+{
+    object_xx <- manufacture(x@c_SpecificProject@a_YouthvarsProfile@a_Ready4useDyad, 
+        type_1L_chr = type_1L_chr, what_1L_chr = what_1L_chr, 
+        restrict_to_chr = x@c_SpecificProject@b_SpecificParameters@candidate_covars_chr)
+    return(object_xx)
+})

R/mthd_procure.R

@@ -0,0 +1,43 @@
+#' 
+#' Procure items from a dataset
+#' @name procure-TTUProject
+#' @description procure method applied to TTUProject
+#' @param x An object of class TTUProject
+#' @param type_1L_chr Type (a character vector of length one), Default: 'default'
+#' @param variables_chr Variables (a character vector), Default: character(0)
+#' @param what_1L_chr What (a character vector of length one), Default: 'records'
+#' @param ... Additional arguments
+#' @return Object (an output object of multiple potential types)
+#' @rdname procure-methods
+#' @aliases procure,TTUProject-method
+#' @export 
+#' @importFrom dplyr select
+#' @importFrom ready4 procure
+methods::setMethod("procure", "TTUProject", function (x, type_1L_chr = "default", variables_chr = character(0), 
+    what_1L_chr = "records", ...) 
+{
+    if (what_1L_chr == "parameters") {
+        if (type_1L_chr == "models_lup") {
+            object_xx <- x@b_SpecificParameters@candidate_mdls_lup
+        }
+    }
+    if (what_1L_chr %in% c("project")) {
+        if (type_1L_chr == "models") {
+            object_xx <- procureSlot(x, "c_SpecificProject", 
+                use_procure_mthd_1L_lgl = T, what_1L_chr = "prefd_mdls")
+        }
+    }
+    if (what_1L_chr %in% c("profile", "records")) {
+        object_xx <- x@a_ScorzProfile@a_YouthvarsProfile
+        if (!identical(variables_chr, character(0))) {
+            object_xx@a_Ready4useDyad@ds_tb <- object_xx@a_Ready4useDyad@ds_tb %>% 
+                dplyr::select(variables_chr)
+        }
+        if (what_1L_chr == "records") {
+            if (type_1L_chr %in% c("default")) {
+                object_xx <- object_xx@a_Ready4useDyad@ds_tb
+            }
+        }
+    }
+    return(object_xx)
+})

R/mthd_renew.R

@@ -65,12 +65,29 @@ methods::setMethod("renew", "TTUProject", function (x, new_val_xx = NULL, consen
         }
     }
     if (what_1L_chr == "project") {
-        x <- renewSlot(x, "c_SpecificProject", SpecificModels(a_YouthvarsProfile = x@a_ScorzProfile@a_YouthvarsProfile, 
-            b_SpecificParameters = x@b_SpecificParameters, paths_chr = paths_chr))
-        x <- ratifySlot(x, "c_SpecificProject")
-        x <- renewSlot(x, "c_SpecificProject", authorSlot(x, 
-            "c_SpecificProject", consent_1L_chr = consent_1L_chr, 
-            what_1L_chr = "workspace"))
+        if (type_1L_chr == "default") {
+            x <- renewSlot(x, "c_SpecificProject", SpecificModels(a_YouthvarsProfile = x@a_ScorzProfile@a_YouthvarsProfile, 
+                b_SpecificParameters = x@b_SpecificParameters, 
+                paths_chr = paths_chr))
+            x <- ratifySlot(x, "c_SpecificProject")
+            x <- renewSlot(x, "c_SpecificProject", authorSlot(x, 
+                "c_SpecificProject", consent_1L_chr = consent_1L_chr, 
+                what_1L_chr = "workspace"))
+        }
+        if (type_1L_chr == "dummys") {
+            x <- renewSlot(x, "c_SpecificProject", renew(x@c_SpecificProject, 
+                new_val_xx, what_1L_chr = type_1L_chr))
+        }
+    }
+    if (what_1L_chr == "records") {
+        if (type_1L_chr == "ds") {
+            x <- renewSlot(x, "a_ScorzProfile@a_YouthvarsProfile@a_Ready4useDyad@ds_tb", 
+                new_val_xx)
+        }
+        if (type_1L_chr == "dict") {
+            x <- renewSlot(x, "a_ScorzProfile@a_YouthvarsProfile@a_Ready4useDyad@dictionary_r3", 
+                new_val_xx)
+        }
     }
     if (what_1L_chr == "reporting") {
         if (type_1L_chr == "default") {

_pkgdown.yml

@@ -31,5 +31,7 @@ reference:
   - author-TTUReports
   - exhibit-TTUProject
   - investigate-TTUProject
+  - manufacture-TTUProject
+  - procure-TTUProject
   - renew-TTUProject
   - share-TTUProject

data-raw/s4_fns/exhibit.R

@@ -1,9 +1,42 @@
 exhibit_TTUProject <- function(x,
+                               captions_chr = NULL,
+                               display_1L_chr = "all",
+                               header_1L_chr = "",
+                               header_col_nms_chr = " ",
+                               mkdn_tbl_refs_chr = NULL,
+                               profile_idx_int = NA_integer_,
+                               output_type_1L_chr = "HTML",
+                               type_1L_chr = "default",
+                               use_lbls_as_col_nms_1L_lgl = T,
+                               use_rdocx_1L_lgl = F,
+                               variables_chr = character(0),
                                what_1L_chr = "predictors",
                                ...){
   if(what_1L_chr == "predictors"){
     exhibitSlot(x, "b_SpecificParameters@predictors_lup",
                 ... = ...)
   }
-
+  if(what_1L_chr == "profile"){
+    exhibit(procure(x, variables_chr = variables_chr, type_1L_chr == "default", what_1L_chr = what_1L_chr, ...=...),
+            captions_chr = captions_chr,
+            header_1L_chr = header_1L_chr,
+            header_col_nms_chr = header_col_nms_chr,
+            mkdn_tbl_refs_chr = mkdn_tbl_refs_chr,
+            profile_idx_int = profile_idx_int,
+            output_type_1L_chr = output_type_1L_chr,
+            what_1L_chr = type_1L_chr) #descriptives
+  }
+  if(what_1L_chr == "records"){
+    if(type_1L_chr %in% c("ds","dict")){
+      exhibit(x@a_ScorzProfile@a_YouthvarsProfile@a_Ready4useDyad,
+              caption_1L_chr = {if(is.null(captions_chr)){NA_character_}else{captions_chr[1]}},
+              display_1L_chr = display_1L_chr,
+              mkdn_tbl_ref_1L_chr = {if(is.null(mkdn_tbl_refs_chr)){""}else{mkdn_tbl_refs_chr[1]}},
+              output_type_1L_chr = "HTML",
+              type_1L_chr = type_1L_chr,
+              use_lbls_as_col_nms_1L_lgl = T,
+              use_rdocx_1L_lgl = F,
+              ... = ...)
+    }
+  }
 }

data-raw/s4_fns/manufacture.R

@@ -0,0 +1,8 @@
+manufacture_TTUProject <- function(x,
+                                   type_1L_chr = "dummys",
+                                   what_1L_chr = "factors",
+                                   ...){
+  object_xx <- manufacture(x@c_SpecificProject@a_YouthvarsProfile@a_Ready4useDyad, type_1L_chr = type_1L_chr, what_1L_chr = what_1L_chr,
+                           restrict_to_chr = x@c_SpecificProject@b_SpecificParameters@candidate_covars_chr)
+  return(object_xx)
+}

data-raw/s4_fns/procure.R

@@ -0,0 +1,28 @@
+procure_TTUProject <- function(x,
+                               type_1L_chr = "default",
+                               variables_chr = character(0),
+                               what_1L_chr = "records",
+                               ...){
+  if(what_1L_chr == "parameters"){
+    if(type_1L_chr == "models_lup"){
+      object_xx <- x@b_SpecificParameters@candidate_mdls_lup
+    }
+  }
+  if(what_1L_chr %in% c("project")){
+    if(type_1L_chr == "models"){
+      object_xx <- procureSlot(x,"c_SpecificProject", use_procure_mthd_1L_lgl = T, what_1L_chr = "prefd_mdls")
+    }
+  }
+  if(what_1L_chr %in% c("profile", "records")){
+    object_xx <- x@a_ScorzProfile@a_YouthvarsProfile
+    if(!identical(variables_chr, character(0))){
+      object_xx@a_Ready4useDyad@ds_tb <- object_xx@a_Ready4useDyad@ds_tb %>% dplyr::select(variables_chr)
+    }
+    if(what_1L_chr == "records"){
+      if(type_1L_chr %in% c("default")){
+        object_xx <- object_xx@a_Ready4useDyad@ds_tb
+      }
+    }
+  }
+  return(object_xx)
+}

data-raw/s4_fns/renew.R

@@ -41,17 +41,31 @@ renew_TTUProject <- function(x,
     }
   }
   if(what_1L_chr == "project"){
-    x <- renewSlot(x, "c_SpecificProject", SpecificModels(a_YouthvarsProfile = x@a_ScorzProfile@a_YouthvarsProfile,
-                                                          b_SpecificParameters = x@b_SpecificParameters, paths_chr = paths_chr))
-    x <- ratifySlot(x, "c_SpecificProject")
-    x <- renewSlot(x, "c_SpecificProject", authorSlot(x, "c_SpecificProject", consent_1L_chr = consent_1L_chr, what_1L_chr = "workspace"))
+    if(type_1L_chr == "default"){
+      x <- renewSlot(x, "c_SpecificProject", SpecificModels(a_YouthvarsProfile = x@a_ScorzProfile@a_YouthvarsProfile,
+                                                            b_SpecificParameters = x@b_SpecificParameters, paths_chr = paths_chr))
+      x <- ratifySlot(x, "c_SpecificProject")
+      x <- renewSlot(x, "c_SpecificProject", authorSlot(x, "c_SpecificProject", consent_1L_chr = consent_1L_chr, what_1L_chr = "workspace"))
+    }
+    if(type_1L_chr == "dummys"){
+      x <- renewSlot(x, "c_SpecificProject", renew(x@c_SpecificProject, new_val_xx, what_1L_chr = type_1L_chr))
+    }
+  }
+  if(what_1L_chr == "records"){
+    if(type_1L_chr == "ds"){
+      x <- renewSlot(x, "a_ScorzProfile@a_YouthvarsProfile@a_Ready4useDyad@ds_tb", new_val_xx)
+    }
+    if(type_1L_chr == "dict"){
+      x <- renewSlot(x, "a_ScorzProfile@a_YouthvarsProfile@a_Ready4useDyad@dictionary_r3", new_val_xx)
+    }
+
   }
   if(what_1L_chr == "reporting"){
     if(type_1L_chr == "default"){
-        Y <- metamorphoseSlot(x, "c_SpecificProject")
-        Y <- TTUSynopsis(a_Ready4showPaths = Y@a_Ready4showPaths, b_SpecificResults = Y@b_SpecificResults, c_SpecificParameters = Y@c_SpecificParameters,
-                         d_YouthvarsProfile = Y@d_YouthvarsProfile, rmd_fl_nms_ls = Y@rmd_fl_nms_ls)
-        Y <- TTUReports(a_TTUSynopsis = Y)
+      Y <- metamorphoseSlot(x, "c_SpecificProject")
+      Y <- TTUSynopsis(a_Ready4showPaths = Y@a_Ready4showPaths, b_SpecificResults = Y@b_SpecificResults, c_SpecificParameters = Y@c_SpecificParameters,
+                       d_YouthvarsProfile = Y@d_YouthvarsProfile, rmd_fl_nms_ls = Y@rmd_fl_nms_ls)
+      Y <- TTUReports(a_TTUSynopsis = Y)
       x <- renewSlot(x, "d_TTUReports", Y)
     }
     if(type_1L_chr == "abstract"){