[Fix #545] Propagate locale to format trainer

R/guess.r

@@ -224,7 +224,7 @@ guess_formats <- function(x, orders, locale = Sys.getlocale("LC_TIME"),
   ## the number of matched elements in X
   ## can return NULL if formats is NULL
 
-  trials <- lapply(formats, function(fmt) .strptime(x, fmt))
+  trials <- lapply(formats, function(fmt) .strptime(x, fmt, locale = locale))
   successes <- unlist(lapply(trials, function(x) sum(!is.na(x))), use.names = FALSE)
   names(successes) <- formats
   sort(successes, decreasing = TRUE)
@@ -251,6 +251,7 @@ guess_formats <- function(x, orders, locale = Sys.getlocale("LC_TIME"),
     nchar(gsub("[^%]", "", nms)) + ## longer formats have priority
     grepl("%Y", nms, fixed = T)*1.5 + ## Y has priority over 0
     grepl("%y[^%]", nms)*1.6 + ## y has priority over Y, but only when followed by non %
+    grepl("%B", nms)*.31 + ## B format should get more weight than %Om
     ## C parser formats
     grepl("%Om", nms)*.1 + grepl("%Op", nms)*.1 +
     grepl("%O", nms)*.2

R/parse.r

@@ -591,7 +591,7 @@ parse_date_time <- function(x, orders, tz = "UTC", truncated = 0, quiet = FALSE,
         .best_formats(train, orders, locale = locale, select_formats, drop = drop)
       }
     if( length(formats) > 0 ){
-      out <- .parse_date_time(x, formats, tz = tz, quiet = quiet)
+      out <- .parse_date_time(x, formats, tz = tz, quiet = quiet, locale = locale)
       new_na <- is.na(out)
       if( any(new_na) ){
         x <- x[new_na]
@@ -686,11 +686,11 @@ fast_strptime <- function(x, format, tz = "UTC", lt = TRUE){
   .POSIXlt(dtlist, tz = tz)
 }
 
-.parse_date_time <- function(x, formats, tz, quiet){
+.parse_date_time <- function(x, formats, tz, quiet, locale){
 
   ## print(formats) # for debugging
 
-  out <- .strptime(x, formats[[1]], tz = tz, quiet = quiet)
+  out <- .strptime(x, formats[[1]], tz = tz, quiet = quiet, locale = locale)
   na <- is.na(out)
   newx <- x[na]
 
@@ -700,13 +700,13 @@ fast_strptime <- function(x, format, tz = "UTC", lt = TRUE){
 
   ## recursive parsing
   if( length(formats) > 1 && length(newx) > 0 )
-    out[na] <- .parse_date_time(newx, formats[-1], tz = tz, quiet = quiet)
+    out[na] <- .parse_date_time(newx, formats[-1], tz = tz, quiet = quiet, locale = locale)
 
   ## return POSIXlt
   out
 }
 
-.strptime <- function(x, fmt, tz = "UTC", quiet = FALSE){
+.strptime <- function(x, fmt, tz = "UTC", quiet = FALSE, locale = NULL){
 
   ## Depending on fmt we might need to preprocess x.
   ## ISO8601 and internal parser are the only cases so far.
@@ -742,6 +742,15 @@ fast_strptime <- function(x, format, tz = "UTC", lt = TRUE){
   } else {
     ## STRPTIME PARSER:
 
+    ## strptime doesn't accept 'locale' argument; need a hard reset
+    if (!is.null(locale)) {
+      old_lc_time <- Sys.getlocale("LC_TIME")
+      if (old_lc_time != locale){
+        Sys.setlocale("LC_TIME", locale)
+        on.exit(Sys.setlocale("LC_TIME", old_lc_time))
+      }
+    }
+
     if( zpos > 0 ){
       ## If ISO8601 -> pre-process x and fmt
       capt <- attr(zpos, "capture.names")[attr(zpos, "capture.start") > 0][[2]] ## <- second subexp

R/stamp.r

@@ -57,7 +57,7 @@ stamp <- function(x, orders = lubridate_formats,
   if( length(fmts) == 1L ){
     FMT <- fmts[[1]]
   }else{
-    trained <- .train_formats(x, fmts)
+    trained <- .train_formats(x, fmts, locale = locale)
     formats <- .select_formats(trained)
     FMT <- formats[[1]]
     if( !quiet && length(trained) > 1 ) {

tests/testthat/test-stamp.R

@@ -131,6 +131,13 @@ test_that("stamp works with ISO-8601 formats", {
   ##              "2012-12-31T18:30:00+0000 KK")
 })
 
+test_that("stamp recognizes correctly B orders", {
+  formater <- stamp("Sunday, November 30, 23:15", "ABdHM")
+  x <- ymd_hm(c("2017-01-20 15:15", "2017-02-11 10:10"))
+  expect_equal(formater(x), c("Friday, January 20, 15:15", "Saturday, February 11, 10:10"))
+})
+
+
 
 ## ## Don't delete this. We need it for interactive testing
 ## y <- c('February 20th 1973',