more likely types

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)
 

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 <up to> the sequence
+            # retains everthing <up to> the sequence
             sub ("(*)999999.*", "\\1", x[w9])
         )
     }
@@ -901,15 +914,15 @@ 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) == ",") {
             ptn <- substring (ptn, 2)
         }
 
         if (substring (ptn, 1, 2) == "c(") {
-             # "A","B" or A,B
+            # "A","B" or A,B
             ptn <- substring (ptn, 3, nchar(ptn) - 1)
         }
 

R/print.R

@@ -19,6 +19,7 @@
             "\n"
         )
     )
+
     if (length (x) > 0) {
         print (noquote (format_declared (x)), ...)