new_Gnm <- function(x = character(), categories = NULL,
skip_stats = FALSE){
vctrs::vec_assert(x, character())
categories <- categories %||% unique(x[!is.na(x)])
nms <- names(x)
stats <- NULL
if(!skip_stats){
stats <- table(x,useNA = "always") %>%
tibble::as_tibble() %>%
dplyr::mutate(dist = n/sum(n), names = c(nms, NA)) %>%
dplyr::rename(category = x)
}
vctrs::new_vctr(x, categories = categories,
n_categories = length(categories),
stats = stats, class = "hd_Gnm")
}
#' @export
Gnm <- function(x = character(), categories = NULL, skip_stats = FALSE) {
# x <- vctrs::vec_cast(x, character())
x <- as.character(x)
new_Gnm(x, categories = categories, skip_stats = skip_stats)
}
#' @export
is_Gnm <- function(x) {
inherits(x, "hd_Gnm")
}
# Methods
## Format method
#' @export
format.hd_Gnm <- function(x, ...) {
sprintf(fmt = "%s", x)
}
#' @export
vec_ptype_abbr.hd_Gnm <- function(x, ...) {
"Gnm"
}
# Coercion
#' @rdname vctrs-compat
#' @method vec_ptype2 hd_Gnm
#' @export
#' @export vec_ptype2.hd_Gnm
vec_ptype2.hd_Gnm <- function(x, y, ...) UseMethod("vec_ptype2.hd_Gnm", y)
#' @method vec_ptype2.hd_Gnm default
#' @export
vec_ptype2.hd_Gnm.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}
# A Gnm combined with a Gnm returns a Gnm
#' @method vec_ptype2.hd_Gnm hd_Gnm
#' @export
vec_ptype2.hd_Gnm.hd_Gnm <- function(x, y, ...) new_Gnm()
# Gnm and character return double
#' @method vec_ptype2.hd_Gnm character
#' @export
vec_ptype2.hd_Gnm.character <- function(x, y, ...) character()
#' @method vec_ptype2.character hd_Gnm
#' @export
vec_ptype2.character.hd_Gnm <- function(x, y, ...) character()
# Casting
#' @rdname vctrs-compat
#' @method vec_cast hd_Gnm
#' @export
#' @export vec_cast.hd_Gnm
vec_cast.hd_Gnm <- function(x, to, ...) UseMethod("vec_cast.hd_Gnm")
#' @method vec_cast.hd_Gnm default
#' @export
vec_cast.hd_Gnm.default <- function(x, to, ...) vec_default_cast(x, to)
# Coerce Gnm to Gnm
#' @method vec_cast.hd_Gnm hd_Gnm
#' @export
vec_cast.hd_Gnm.hd_Gnm <- function(x, to, ...) x
#' @method vec_cast.hd_Gnm character
#' @export
vec_cast.hd_Gnm.character <- function(x, to, ...) Gnm(x)
#' @method vec_cast.character hd_Gnm
#' @export
vec_cast.character.hd_Gnm <- function(x, to, ...) vctrs::vec_data(x)
#' @export
as_Gnm <- function(x) {
x <- as.character(x)
vctrs::vec_cast(x, new_Gnm())
}
#' @export
Gnm_get_categories <- function(x){
if(!is_Gnm(x)) stop("x must be a Gnm")
attr(x, "categories")
}
#' @export
Gnm_get_n_categories <- function(x){
if(!is_Gnm(x)) stop("x must be a Gnm")
attr(x, "n_categories")
}
#' @export
Gnm_get_stats <- function(x){
if(!is_Gnm(x)) stop("x must be a Gnm")
attr(x, "stats")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.