new_hdType <- function(x = character()){
vctrs::vec_assert(x, character())
av <- available_hdTypes(as_character = TRUE)
if(!all(vctrs::vec_data(x) %in% av)){
stop(x, "hdType must be one of: ", paste(av, collapse = ", "))
}
vctrs::new_vctr(x, class = "hdType")
}
hdType <- function(x = character()) {
x <- vctrs::vec_cast(x, character())
new_hdType(x)
}
# hdType ------------------------------------------------------------------
#' @title hdType Vectors
#'
#' @description test for objects of type "hdType"
#'
#' @param x object to be coerced or tested
#'
#' @return returns TRUE or FALSE depending on whether its argument is of type hdType or not.
#'
#' @examples
#'
#' some_value <- hdType("Cat")
#' is_hdType(some_value)
#'
#' @export
is_hdType <- function(x) {
inherits(x, "hdType")
}
#' @title hdType Vectors
#'
#' @description test for objects of type "hdType"
#'
#' @param x hdType object to be coerced or tested
#'
#' @return returns TRUE or FALSE depending on whether its argument is one of the [available_hdTypes()] or not.
#'
#' @examples
#'
#' some_cat_value <- Cat("value1")
#' is_any_hdType(some_cat_value)
#'
#' @export
is_any_hdType <- function(x){
sum(grepl("hd_", class(x))) > 0
}
#' @title hdType Vectors
#'
#' @description Detect which hdType is the value.
#'
#' @param x hdType object to be coerced or tested
#'
#' @return returns the name of the hdType value. You can see the valid hdTypes with [available_hdTypes()]
#'
#' @examples
#'
#' some_cat_value <- Cat("value1")
#' which_hdType(some_cat_value)
#'
#' @export
which_hdType <- function(x){
if(is_any_hdType(x)){
gsub("hd_","",class(x)[grep("hd_", class(x))])
} else {
cat("The value is not a valid hdType.")
}
}
# hdType ------------------------------------------------------------------
#' @title hdType Vectors
#'
#' @description coerces its argument to a hdType. It is an abbreviated form of hdType.
#'
#' @param x object to be coerced
#'
#' @return attempts to coerce its argument to hdType type
#'
#' @examples
#'
#' some_chr_value <- "Cat"
#' class(some_chr_value)
#'
#' some_hdt_value <- as_hdType(some_chr_value)
#' class(some_hdt_value)
#'
#' @export
as_hdType <- function(x) {
if(any(class(x) == "factor")){
x <- as.character(x)
}
vctrs::vec_cast(x, new_hdType())
}
# Methods
## Format method
#' @export
format.hdType <- function(x, ...) {
sprintf(fmt = "%s", x)
}
#' @export
vec_ptype_abbr.hdType <- function(x, ...) {
"hdType"
}
# Coercion
#' @method vec_ptype2 hdType
#' @export
vec_ptype2.hdType <- function(x, y, ...) UseMethod("vec_ptype2.hdType", y)
#' @method vec_ptype2.hdType default
#' @export
vec_ptype2.hdType.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}
# A hdType combined with a hdType returns a hdType
#' @method vec_ptype2.hdType hdType
#' @export
vec_ptype2.hdType.hdType <- function(x, y, ...) new_hdType()
# # hdType and character return hdType
#' @method vec_ptype2.hdType character
#' @export
vec_ptype2.hdType.character <- function(x, y, ...) character()
#' @method vec_ptype2.character hdType
#' @export
vec_ptype2.character.hdType <- function(x, y, ...) character()
# Casting
#' @method vec_cast hdType
#' @export
vec_cast.hdType <- function(x, to, ...) UseMethod("vec_cast.hdType")
#' @method vec_cast.hdType default
#' @export
vec_cast.hdType.default <- function(x, to, ...) vec_default_cast(x, to)
# Coerce hdType to hdType
#' @method vec_cast.hdType hdType
#' @export
vec_cast.hdType.hdType <- function(x, to, ...) x
#' @method vec_cast.hdType character
#' @export
vec_cast.hdType.character <- function(x, to, ...) hdType(x)
#' @method vec_cast.character hdType
#' @export
vec_cast.character.hdType <- function(x, to, ...) vctrs::vec_data(x)
#' @method as.character hdType
#' @export
as.character.hdType <- function(x) as.character(vctrs::vec_data(x))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.