diff --git a/.Rbuildignore b/.Rbuildignore index 09d1bf4d..485addcb 100644 --- a/.Rbuildignore +++ b/.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$ diff --git a/DESCRIPTION b/DESCRIPTION index 89071331..eaf71666 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NAMESPACE b/NAMESPACE index 9fad4a4d..187e2316 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/mthd_exhibit.R b/R/mthd_exhibit.R index 2a8c3859..61a7dfa5 100644 --- a/R/mthd_exhibit.R +++ b/R/mthd_exhibit.R @@ -3,6 +3,17 @@ #' @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 @@ -10,10 +21,44 @@ #' @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, + ... = ...) + } + } }) diff --git a/R/mthd_manufacture.R b/R/mthd_manufacture.R new file mode 100644 index 00000000..63cc1fe6 --- /dev/null +++ b/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) +}) diff --git a/R/mthd_procure.R b/R/mthd_procure.R new file mode 100644 index 00000000..700588f5 --- /dev/null +++ b/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) +}) diff --git a/R/mthd_renew.R b/R/mthd_renew.R index 7da21fc7..5dfe9c50 100644 --- a/R/mthd_renew.R +++ b/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") { diff --git a/_pkgdown.yml b/_pkgdown.yml index bb970943..36a18147 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -31,5 +31,7 @@ reference: - author-TTUReports - exhibit-TTUProject - investigate-TTUProject + - manufacture-TTUProject + - procure-TTUProject - renew-TTUProject - share-TTUProject diff --git a/data-raw/s4_fns/exhibit.R b/data-raw/s4_fns/exhibit.R index 77273409..ac2fcff8 100644 --- a/data-raw/s4_fns/exhibit.R +++ b/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, + ... = ...) + } + } } diff --git a/data-raw/s4_fns/manufacture.R b/data-raw/s4_fns/manufacture.R new file mode 100644 index 00000000..704aa986 --- /dev/null +++ b/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) +} diff --git a/data-raw/s4_fns/procure.R b/data-raw/s4_fns/procure.R new file mode 100644 index 00000000..87fd5858 --- /dev/null +++ b/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) +} diff --git a/data-raw/s4_fns/renew.R b/data-raw/s4_fns/renew.R index f6e29889..b8e8857a 100644 --- a/data-raw/s4_fns/renew.R +++ b/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"){ diff --git a/man/exhibit-methods.Rd b/man/exhibit-methods.Rd index 0eba57ac..6d8eefe8 100644 --- a/man/exhibit-methods.Rd +++ b/man/exhibit-methods.Rd @@ -5,11 +5,48 @@ \alias{exhibit,TTUProject-method} \title{Exhibit features of a dataset by printing them to the R console} \usage{ -\S4method{exhibit}{TTUProject}(x, what_1L_chr = "predictors", ...) +\S4method{exhibit}{TTUProject}( + 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", + ... +) } \arguments{ \item{x}{An object of class TTUProject} +\item{captions_chr}{Captions (a character vector), Default: NULL} + +\item{display_1L_chr}{Display (a character vector of length one), Default: 'all'} + +\item{header_1L_chr}{Header (a character vector of length one), Default: ''} + +\item{header_col_nms_chr}{Header column names (a character vector), Default: ' '} + +\item{mkdn_tbl_refs_chr}{Markdown table references (a character vector), Default: NULL} + +\item{profile_idx_int}{Profile index (an integer vector), Default: NA} + +\item{output_type_1L_chr}{Output type (a character vector of length one), Default: 'HTML'} + +\item{type_1L_chr}{Type (a character vector of length one), Default: 'default'} + +\item{use_lbls_as_col_nms_1L_lgl}{Use labels as column names (a logical vector of length one), Default: T} + +\item{use_rdocx_1L_lgl}{Use rdocx (a logical vector of length one), Default: F} + +\item{variables_chr}{Variables (a character vector), Default: character(0)} + \item{what_1L_chr}{What (a character vector of length one), Default: 'predictors'} \item{...}{Additional arguments} diff --git a/man/manufacture-methods.Rd b/man/manufacture-methods.Rd new file mode 100644 index 00000000..3ff83311 --- /dev/null +++ b/man/manufacture-methods.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mthd_manufacture.R +\name{manufacture-TTUProject} +\alias{manufacture-TTUProject} +\alias{manufacture,TTUProject-method} +\title{Manufacture a new object} +\usage{ +\S4method{manufacture}{TTUProject}(x, type_1L_chr = "dummys", what_1L_chr = "factors", ...) +} +\arguments{ +\item{x}{An object of class TTUProject} + +\item{type_1L_chr}{Type (a character vector of length one), Default: 'dummys'} + +\item{what_1L_chr}{What (a character vector of length one), Default: 'factors'} + +\item{...}{Additional arguments} +} +\value{ +Object (an output object of multiple potential types) +} +\description{ +manufacture method applied to TTUProject +} diff --git a/man/procure-methods.Rd b/man/procure-methods.Rd new file mode 100644 index 00000000..099ab14d --- /dev/null +++ b/man/procure-methods.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mthd_procure.R +\name{procure-TTUProject} +\alias{procure-TTUProject} +\alias{procure,TTUProject-method} +\title{Procure items from a dataset} +\usage{ +\S4method{procure}{TTUProject}( + x, + type_1L_chr = "default", + variables_chr = character(0), + what_1L_chr = "records", + ... +) +} +\arguments{ +\item{x}{An object of class TTUProject} + +\item{type_1L_chr}{Type (a character vector of length one), Default: 'default'} + +\item{variables_chr}{Variables (a character vector), Default: character(0)} + +\item{what_1L_chr}{What (a character vector of length one), Default: 'records'} + +\item{...}{Additional arguments} +} +\value{ +Object (an output object of multiple potential types) +} +\description{ +procure method applied to TTUProject +}