From e2ba14e3db6dc76f556b15e9c443ef3d87d23b63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Adrian=20Du=C8=99a?= Date: Wed, 29 Nov 2023 15:14:16 +0100 Subject: [PATCH] more likely types --- R/haven.R | 3 +- R/internals.R | 149 +++++++++++++++++++++++++++----------------------- R/print.R | 1 + 3 files changed, 84 insertions(+), 69 deletions(-) diff --git a/R/haven.R b/R/haven.R index d4e1b33..4e036c6 100644 --- a/R/haven.R +++ b/R/haven.R @@ -67,6 +67,7 @@ `as.haven.declared` <- function (x, ...) { attrx <- attributes (x) declared_is_integer <- is.integer(x) + type <- likely_type(x) # this is necessary to replace those values # (because of the "[<-.declared" method) @@ -189,7 +190,7 @@ ) if (spss) { - if (declared_is_integer && grepl("integer", likely_type (x))) { + if (declared_is_integer && grepl("integer", type)) { x <- as.integer (x) attrx$class <- c ("integer", attrx$class) diff --git a/R/internals.R b/R/internals.R index 21d712b..568557b 100644 --- a/R/internals.R +++ b/R/internals.R @@ -8,17 +8,28 @@ NULL #' @keywords internal #' @export `format_declared` <- function (x, digits = getOption ("digits")) { - if (is.null (x) || !is.atomic (x)) { - stopError_ ("`x` has to be a vector.") - } + if (is.null (x) || !is.atomic (x)) { + stopError_ ("`x` has to be a vector.") + } - out <- format (unclass (x), digits = digits) + if ( + length(intersect( + c ("Date", "POSIXct", "POSIXt", "POSIXlt"), + class (x) + )) == 0 + ) { + out <- format (unclass (x), digits = digits) + } + else { + class(x) <- setdiff(class(x), "declared") + out <- as.character(x) + } - na_index <- attr (x, "na_index") - out[na_index] <- paste0 ("NA(", names (na_index), ")") + na_index <- attr (x, "na_index") + out[na_index] <- paste0 ("NA(", names (na_index), ")") - # format again to make sure all elements have same width - return (format (out, justify = "right")) + # format again to make sure all elements have same width + return (format (out, justify = "right")) } #' @rdname declared_internal @@ -28,101 +39,103 @@ NULL x, na.last = NA, decreasing = FALSE, method = c ("auto", "shell", "radix"), empty.last = na.last, ...) { - if (!is.declared (x)) { - stopError_ ("`x` has to be a vector of class `declared`.") - } + if (!is.declared (x)) { + stopError_ ("`x` has to be a vector of class `declared`.") + } - if (!identical (empty.last, NA)) { - if (!(isTRUE (empty.last) | isFALSE (empty.last))) { - stopError_ ("Argument `empty.last` should be either TRUE or FALSE.") + if (!identical (empty.last, NA)) { + if (!(isTRUE (empty.last) | isFALSE (empty.last))) { + stopError_ ("Argument `empty.last` should be either TRUE or FALSE.") + } } - } - method <- match.arg (method) + method <- match.arg (method) - x_indexes <- seq_along(x) + x_indexes <- seq_along(x) - na_index <- attr (x, "na_index") - na_declared <- logical (length (x)) - na_declared[na_index] <- TRUE - na_empty <- is.empty (x) + na_index <- attr (x, "na_index") + na_declared <- logical (length (x)) + na_declared[na_index] <- TRUE + na_empty <- is.empty (x) - declared_indexes <- c () + declared_indexes <- c () - if (any (na_declared)) { - x <- undeclare (x) - nms <- names (na_index) - if (possibleNumeric_ (nms)) { - nms <- asNumeric_ (nms) + if (any (na_declared)) { + x <- undeclare (x) + nms <- names (na_index) + if (possibleNumeric_ (nms)) { + nms <- asNumeric_ (nms) + } + declared_indexes <- unname ( + na_index[order (nms, decreasing = decreasing, method = method)] + ) } - declared_indexes <- unname ( - na_index[order (nms, decreasing = decreasing, method = method)] - ) - } - attributes (x) <- NULL - x_indexes <- x_indexes[!(is.na (x) | na_declared)] - x <- x[!(is.na (x) | na_declared)] + attributes (x) <- NULL + x_indexes <- x_indexes[!(is.na (x) | na_declared)] + x <- x[!(is.na (x) | na_declared)] - res <- c () + res <- c () - if (isFALSE (na.last)) { - if (isFALSE (empty.last)) { - res <- c (which (na_empty), declared_indexes) - } + if (isFALSE (na.last)) { + if (isFALSE (empty.last)) { + res <- c (which (na_empty), declared_indexes) + } - if (isTRUE (empty.last)) { - res <- c (declared_indexes, which (na_empty)) + if (isTRUE (empty.last)) { + res <- c (declared_indexes, which (na_empty)) + } } - } - res <- c ( - res, - x_indexes[order (unclass (x), decreasing = decreasing, method = method)] - ) + res <- c ( + res, + x_indexes[order (unclass (x), decreasing = decreasing, method = method)] + ) - if (isTRUE (na.last)) { - if (isTRUE (empty.last)) { - res <- c (res, declared_indexes, which (na_empty)) - } + if (isTRUE (na.last)) { + if (isTRUE (empty.last)) { + res <- c (res, declared_indexes, which (na_empty)) + } - if (isFALSE (empty.last)) { - res <- c (res, which (na_empty), declared_indexes) + if (isFALSE (empty.last)) { + res <- c (res, which (na_empty), declared_indexes) + } } - } - return (res) + return (res) } #' @rdname declared_internal #' @keywords internal #' @export `value_labels` <- function (...) { - .Deprecated(msg = "Function value_labels() is deprecated, use labels()\n") - labels (...) + .Deprecated(msg = "Function value_labels() is deprecated, use labels()\n") + labels (...) } #' @rdname declared_internal #' @keywords internal #' @export `variable_label` <- function (...) { - .Deprecated(msg = "Function variable_label() is deprecated, use label()\n") - label(...) + .Deprecated(msg = "Function variable_label() is deprecated, use label()\n") + label(...) } `likely_type` <- function (x) { type <- NULL - if (is.numeric (x)) { - type <- "numeric" - if (!anyTagged_(x) && (is.integer (x) || wholeNumeric_ (x))) { + others <- setdiff (class (x), "declared") + + if (length (others) > 0) { + type <- others[1] + } + + if (identical(type, "numeric")) { + if (!anyTagged_ (x) && (is.integer (x) || wholeNumeric_ (x))) { type <- "integer" } } - else if (is.character (x)) { - type <- "character" - } if (!is.null (type)) { return (paste0 ("<", type, ">")) @@ -785,9 +798,9 @@ NULL # A floating point number like 234.1 might have been represented as # 0.0999999999999943 (after subtracting the floor) x[w9] <- sub ( - # last 0 becomes 1 + # last 0 becomes 1 "0+", "1", - # retains everthing the sequence + # retains everthing the sequence sub ("(*)999999.*", "\\1", x[w9]) ) } @@ -901,7 +914,7 @@ NULL ) # ptn = possibly the name - # ,c("A","B") or c(A, B) + # ,c("A","B") or c(A, B) ptn <- gsub ("]", "", substr (x, stindex + 1, startpos)) if (substring (ptn, 1, 1) == ",") { @@ -909,7 +922,7 @@ NULL } if (substring (ptn, 1, 2) == "c(") { - # "A","B" or A,B + # "A","B" or A,B ptn <- substring (ptn, 3, nchar(ptn) - 1) } diff --git a/R/print.R b/R/print.R index 5165dab..f739e43 100644 --- a/R/print.R +++ b/R/print.R @@ -19,6 +19,7 @@ "\n" ) ) + if (length (x) > 0) { print (noquote (format_declared (x)), ...)