Pillar support

.Rbuildignore

@@ -7,3 +7,4 @@
 ^cran-comments\.md$
 ^appveyor\.yml$
 ^revdep$
+^tic\.R$

.travis.yml

@@ -1,19 +1,47 @@
 # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r
+# Default configuration for use with tic package
+# Usually you shouldn't need to change the first part of the file
 
-language: R
+# DO NOT CHANGE THE CODE BELOW
+before_install: R -q -e 'install.packages("remotes"); remotes::install_github("ropenscilabs/tic"); tic::prepare_all_stages(); tic::before_install()'
+install: R -q -e 'tic::install()'
+after_install: R -q -e 'tic::after_install()'
+before_script: R -q -e 'tic::before_script()'
+script: R -q -e 'tic::script()'
+after_success: R -q -e 'tic::after_success()'
+after_failure: R -q -e 'tic::after_failure()'
+before_deploy: R -q -e 'tic::before_deploy()'
+deploy:
+  provider: script
+  script: R -q -e 'tic::deploy()'
+  on:
+    all_branches: true
+after_deploy: R -q -e 'tic::after_deploy()'
+after_script: R -q -e 'tic::after_script()'
+# DO NOT CHANGE THE CODE ABOVE
+
+# Custom parts:
+
+# Header
+language: r
 sudo: false
+dist: trusty
 cache: packages
+latex: false
 r:
-  - oldrel
-  - release
-  - devel
+- oldrel
+- release
+- devel
 
-r_packages: covr
+#env
+env:
+  global:
+  - _R_CHECK_FORCE_SUGGESTS_=false
+  - MAKEFLAGS="-j 2"
 
-after_success:
-  - Rscript -e 'covr::codecov()'
+#before_script
+before_script:
+- head -n 100 tests/testthat/out/*
 
-notifications:
-  email:
-    on_success: change
-    on_failure: change
+#services
+services:

DESCRIPTION

@@ -11,12 +11,18 @@ Description: Implements an S3 class for storing and formatting time-of-day
 Imports:
     methods,
     pkgconfig
-Suggests: testthat,
-    lubridate
+Suggests:
+    crayon,
+    pillar,
+    lubridate,
+    testthat
 License: GPL-3
 Encoding: UTF-8
 LazyData: true
 URL: https://github.com/tidyverse/hms
 BugReports: https://github.com/tidyverse/hms/issues
 RoxygenNote: 6.0.1
 Roxygen: list(markdown = TRUE)
+Remotes: 
+    r-lib/crayon,
+    hadley/pillar@3c43a5f

R/arith.R

@@ -40,3 +40,13 @@ split_seconds <- function(x) {
 split_second_of_second <- function(x) {
   abs(split_seconds(x) - seconds(x))
 }
+
+decompose <- function(x) {
+  list(
+    sign = x < 0 & !is.na(x),
+    hours = abs(hours(x)),
+    minute_of_hour = minute_of_hour(x),
+    second_of_minute = second_of_minute(x),
+    split_seconds = split_second_of_second(x)
+  )
+}

R/colformat.R

@@ -0,0 +1,52 @@
+# Dynamically exported, see zzz.R
+pillar_shaft.hms <- function(x, ...) {
+  data <- rep(NA_character_, length(x))
+
+  xx <- decompose(x)
+  highlight_hours <- xx$hours > 0
+  highlighted <- highlight_hours
+  highlight_minutes <- !highlighted & xx$minute_of_hour > 0
+  highlighted <- highlighted | highlight_minutes
+  highlight_seconds <- !highlighted & xx$second_of_minute > 0
+  highlighted <- highlighted | highlight_seconds
+  highlight_split_seconds <- !highlighted & xx$split_seconds > 0
+
+  need_split_seconds <- any(highlight_split_seconds, na.rm = TRUE)
+  need_seconds <- need_split_seconds || any(highlight_seconds, na.rm = TRUE)
+  need_hours <- any(highlight_hours, na.rm = TRUE)
+  need_sign <- any(xx$sign)
+
+  if (need_hours) {
+    data_seconds <- paste0(
+      if (need_sign) ifelse(xx$sign, "-", " ") else "",
+      pillar::style_num(format_hours(xx$hours), xx$sign, highlight_hours),
+      pillar::style_subtle(":"),
+      pillar::style_num(format_two_digits(xx$minute_of_hour), xx$sign, highlight_minutes),
+      if (need_seconds) paste0(
+        pillar::style_subtle(":"),
+        pillar::style_num(format_two_digits(xx$second_of_minute), xx$sign, highlight_seconds)
+      )
+    )
+    data <- paste0(
+      data_seconds,
+      pillar::style_num(format_split_seconds(xx$split_seconds), xx$sign, highlight_split_seconds)
+    )
+  } else {
+    data_seconds <- paste0(
+      if (need_sign) ifelse(xx$sign, "-", " ") else "",
+      pillar::style_num(format_two_digits(xx$minute_of_hour), xx$sign, highlight_minutes),
+      pillar::style_subtle("'"),
+      pillar::style_num(format_two_digits(xx$second_of_minute), xx$sign, highlight_seconds)
+    )
+    data <- paste0(
+      data_seconds,
+      pillar::style_num(format_split_seconds(xx$split_seconds), xx$sign, highlight_split_seconds),
+      pillar::style_subtle('"')
+    )
+  }
+
+  na_indent <- crayon::col_nchar(data_seconds[1], type = "width") - 2L
+  data[is.na(x)] <- NA
+
+  pillar::new_pillar_shaft(data, na_indent = na_indent)
+}

R/format.R

@@ -1,11 +1,14 @@
+format_hours <- function(x) {
+  format(format_two_digits(x), justify = "right")
+}
+
 format_two_digits <- function(x) {
   formatC(x, width = 2, flag = "0")
 }
 
 format_split_seconds <- function(x) {
-  split_second <- split_second_of_second(x)
-  out <- format(split_second, scientific = FALSE)
+  out <- format(x, scientific = FALSE)
   digits <- max(min(max(nchar(out) - 2), 6), 0)
-  out <- formatC(split_second, format = "f", digits = digits)
+  out <- formatC(x, format = "f", digits = digits)
   gsub("^0", "", out)
 }

R/hms.R

@@ -115,12 +115,14 @@ as.POSIXlt.hms <- function(x, ...) {
 #' @rdname hms
 #' @export
 as.character.hms <- function(x, ...) {
+  xx <- decompose(x)
+
   ifelse(is.na(x), "NA", paste0(
-    ifelse(x < 0, "-", ""),
-    format_two_digits(abs(hours(x))), ":",
-    format_two_digits(minute_of_hour(x)), ":",
-    format_two_digits(second_of_minute(x)),
-    format_split_seconds(x)))
+    ifelse(xx$sign, "-", ""),
+    format_hours(xx$hours), ":",
+    format_two_digits(xx$minute_of_hour), ":",
+    format_two_digits(xx$second_of_minute),
+    format_split_seconds(xx$split_seconds)))
 }
 
 #' @rdname hms

R/zzz.R

@@ -0,0 +1,31 @@
+# nocov start
+.onLoad <- function(...) {
+  register_s3_method("pillar", "pillar_shaft", "hms")
+
+  invisible()
+}
+
+register_s3_method <- function(pkg, generic, class, fun = NULL) {
+  stopifnot(is.character(pkg), length(pkg) == 1)
+  stopifnot(is.character(generic), length(generic) == 1)
+  stopifnot(is.character(class), length(class) == 1)
+
+  if (is.null(fun)) {
+    fun <- get(paste0(generic, ".", class), envir = parent.frame())
+  } else {
+    stopifnot(is.function(fun))
+  }
+
+  if (pkg %in% loadedNamespaces()) {
+    registerS3method(generic, class, fun, envir = asNamespace(pkg))
+  }
+
+  # Always register hook in case package is later unloaded & reloaded
+  setHook(
+    packageEvent(pkg, "onLoad"),
+    function(...) {
+      registerS3method(generic, class, fun, envir = asNamespace(pkg))
+    }
+  )
+}
+# nocov end

appveyor.yml

@@ -8,35 +8,42 @@ init:
         Import-Module '..\appveyor-tool.ps1'
 
 install:
-  ps: Bootstrap
+  - ps: Bootstrap
+  - cmd: R -q -e "writeLines('options(repos = \'https://cloud.r-project.org\')', '~/.Rprofile')"
+  - cmd: R -q -e "getOption('repos')"
+  - cmd: R -q -e "install.packages('remotes'); remotes::install_github('ropenscilabs/tic'); tic::prepare_all_stages()"
+
+cache:
+- C:\RLibrary
+
+before_build: R -q -e "tic::before_install()"
+build_script: R -q -e "tic::install()"
+after_build: R -q -e "tic::after_install()"
+before_test: R -q -e "tic::before_script()"
+test_script: R -q -e "tic::script()"
+on_success: R -q -e "try(tic::after_success(), silent = TRUE)"
+on_failure: R -q -e "tic::after_failure()"
+before_deploy: R -q -e "tic::before_deploy()"
+deploy_script: R -q -e "tic::deploy()"
+after_deploy: R -q -e "tic::after_deploy()"
+on_finish: R -q -e "tic::after_script()"
 
 # Adapt as necessary starting from here
 
-branches:
-  only:
-    - master
-    - production
+#on_failure:
+#  - 7z a failure.zip *.Rcheck\*
+#  - appveyor PushArtifact failure.zip
 
 environment:
-  global:
-    WARNINGS_ARE_ERRORS: 1
+  GITHUB_PAT:
+    secure: ydE+Zo04e/ffDUNpRKEqjTJFbiL/aozpxl886+6s8YSPtUDOcUbhNmwmhYlY10sc
 
   matrix:
   - R_VERSION: release
     R_ARCH: x64
 
   - R_VERSION: patched
 
-build_script:
-  - travis-tool.sh install_deps
-
-test_script:
-  - travis-tool.sh run_tests
-
-on_failure:
-  - 7z a failure.zip *.Rcheck\*
-  - appveyor PushArtifact failure.zip
-
 artifacts:
   - path: '*.Rcheck\**\*.log'
     name: Logs

tests/testthat/out/hm.txt

@@ -0,0 +1,7 @@
+<time>
+-01:00
+-00:01
+ 00:00
+ 00:01
+ 01:00
+    NA

tests/testthat/out/hms.txt

@@ -0,0 +1,11 @@
+<time>     
+-1000:00:00
+-  01:00:00
+-  00:01:00
+-  00:00:01
+   00:00:00
+   00:00:01
+   00:01:00
+   01:00:00
+ 1000:00:00
+         NA

tests/testthat/out/hmss.txt

@@ -0,0 +1,11 @@
+<time>       
+-01:00:00.000
+-00:01:00.000
+-00:00:01.000
+-00:00:00.001
+ 00:00:00.000
+ 00:00:00.001
+ 00:00:01.000
+ 00:01:00.000
+ 01:00:00.000
+       NA    

tests/testthat/out/ms.txt

@@ -0,0 +1,7 @@
+<time> 
+-01'00"
+-00'01"
+ 00'00"
+ 00'01"
+ 01'00"
+    NA 

tests/testthat/out/mss.txt

@@ -0,0 +1,9 @@
+<time>     
+-01'00.000"
+-00'01.000"
+-00'00.001"
+ 00'00.000"
+ 00'00.001"
+ 00'01.000"
+ 01'00.000"
+    NA     

tests/testthat/test-colformat.R

@@ -0,0 +1,24 @@
+context("pillar")
+
+test_that("pillar", {
+  pillar:::expect_pillar_output(
+    xp = hms(c(-3600, -60, -1, -0.001, 0, 0.001, 1, 60, 3600, NA)),
+    filename = "hmss.txt"
+  )
+  pillar:::expect_pillar_output(
+    xp = hms(c(-3600000, -3600, -60, -1, 0, 1, 60, 3600, 3600000, NA)),
+    filename = "hms.txt"
+  )
+  pillar:::expect_pillar_output(
+    xp = hms(c(-3600, -60, 0, 60, 3600, NA)),
+    filename = "hm.txt"
+  )
+  pillar:::expect_pillar_output(
+    xp = hms(c(-60, -1, 0, 1, 60, NA)),
+    filename = "ms.txt"
+  )
+  pillar:::expect_pillar_output(
+    xp = hms(c(-60, -1, -0.001, 0, 0.001, 1, 60, NA)),
+    filename = "mss.txt"
+  )
+})

tests/testthat/test-output.R

@@ -17,7 +17,7 @@ test_that("beyond 24 hours (#12)", {
   expect_identical(format(hms(hours = 99:101)),
                    c(" 99:00:00", "100:00:00", "101:00:00"))
   expect_identical(format(hms(hours = c(-99, 100))),
-                   c("-99:00:00", "100:00:00"))
+                   c("- 99:00:00", " 100:00:00"))
   expect_identical(format(hms(hours = c(-100, 99))),
                    c("-100:00:00", "  99:00:00"))
 })

tic.R

@@ -0,0 +1 @@
+add_package_checks()