Debug CI failures

.Rbuildignore

@@ -10,3 +10,4 @@
 ^vignettes/articles$
 ^LICENSE\.md$
 ^blog$
+^_pkgdown\.yml$

R/board_datatxt.R

@@ -108,7 +108,7 @@ datatxt_refresh_index <- function(board) {
   }
 
   fs::dir_create(fs::path_dir(local_index))
-  yaml::write_yaml(current_index, local_index)
+  write_yaml(current_index, local_index)
 }
 
 
@@ -527,7 +527,7 @@ board_manifest_load <- function(manifest) {
 }
 
 board_manifest_create <- function(index, file) {
-  yaml::write_yaml(index, file)
+  write_yaml(index, file)
 }
 
 pin_entries_to_dataframe <- function(entries) {

R/board_github.R

@@ -461,7 +461,7 @@ board_pin_create.pins_board_github <- function(board, path, name, metadata, ...)
 
     names(datatxt$filenames) <- datatxt$path
 
-    yaml::write_yaml(datatxt, file_path)
+    write_yaml(datatxt, file_path)
   }
 
   # create upload definition of remote-path/local-path

R/board_local.R

@@ -58,7 +58,10 @@ board_browse.pins_board_local <- function(board, ...) {
 
 #' @export
 pin_list.pins_board_local <- function(board, ...) {
-  fs::path_file(fs::dir_ls(board$path, type = "directory"))
+  dir <- fs::dir_ls(board$path, type = "directory")
+  metadata <- fs::path(dir, "data.txt")
+
+  fs::path_file(dir[fs::file_exists(metadata)])
 }
 
 #' @export

R/board_rsconnect.R

@@ -539,7 +539,7 @@ read_cache <- function(path) {
 update_cache <- function(path, key, value) {
   cache <- read_cache(path)
   cache[[key]] <- value
-  yaml::write_yaml(cache, path)
+  write_yaml(cache, path)
 
   value
 }

R/board_rsconnect_bundle.R

@@ -6,7 +6,7 @@ rsc_bundle <- function(board, name, path, metadata, x = NULL, bundle_path = temp
   fs::file_copy(path, fs::path(bundle_path, fs::path_file(path)))
 
   # * data.txt (used to retrieve pins)
-  yaml::write_yaml(metadata, fs::path(bundle_path, "data.txt"))
+  write_yaml(metadata, fs::path(bundle_path, "data.txt"))
 
   # * index.html
   rsc_bundle_preview_create(board, name, metadata, path = bundle_path, x = x)

R/meta.R

@@ -22,7 +22,7 @@ read_meta <- function(path) {
 
 write_meta <- function(x, path) {
   path <- fs::path(path, "data.txt")
-  yaml::write_yaml(x, path)
+  write_yaml(x, path)
 }
 
 # pin metadata ------------------------------------------------------------

R/pin_manifest.R

@@ -16,7 +16,7 @@ pin_manifest_get <- function(path) {
 pin_manifest_update <- function(path, manifest) {
   data_txt <- file.path(path, "data.txt")
 
-  manifest <- yaml::write_yaml(manifest, data_txt)
+  manifest <- write_yaml(manifest, data_txt)
 
   manifest
 }
@@ -33,7 +33,7 @@ pin_manifest_create <- function(path, metadata, files) {
   entries[sapply(entries, is.null)] <- NULL
 
   fs::dir_create(path)
-  yaml::write_yaml(entries, file.path(path, "data.txt"))
+  write_yaml(entries, file.path(path, "data.txt"))
 }
 
 # retrieve a list of files to download

R/pin_registry.R

@@ -18,7 +18,7 @@ pin_registry_read <- function(board) {
 pin_registry_write <- function(board, entries) {
   stopifnot(is.board(board))
 
-  yaml::write_yaml(unname(entries), pin_registry_path(board, "data.txt"))
+  write_yaml(unname(entries), pin_registry_path(board, "data.txt"))
 }
 
 # Lock registry file to prevent multi-process race conditions

R/utils.R

@@ -66,3 +66,23 @@ ui_loud <- function() {
 }
 
 github_raw <- function(x) paste0("https://raw.githubusercontent.com/", x)
+
+write_yaml <- function(x, path) {
+  x <- to_utf8(x)
+  yaml::write_yaml(x, path)
+}
+
+# On Windows, yaml::write_yaml() crashes with Latin1 data
+# https://github.com/viking/r-yaml/issues/90
+to_utf8 <- function(x) {
+  if (is.list(x)) {
+    if (!is.null(names(x))) {
+      names(x) <- enc2utf8(names(x))
+    }
+    lapply(x, to_utf8)
+  } else if (is.character(x)) {
+    enc2utf8(x)
+  } else {
+    x
+  }
+}

tests/testthat/test-utils.R

@@ -0,0 +1,13 @@
+test_that("write_yaml can write non-UTF8 data", {
+  str <- "fa\xE7ile"
+  Encoding(str) <- "latin1"
+
+  x <- list(str)
+  names(x) <- str
+
+  path <- tempfile()
+  write_yaml(x, path)
+
+  y <- yaml::read_yaml(path)
+  expect_equal(y, list("fa\u00e7ile" = "fa\u00e7ile"))
+})