added checker to gist_create for binary files and directories, added …

…local tests for those checks
ropensci · Apr 10, 2015 · ad40063 · ad40063
1 parent 5fd67c8
commit ad40063
Show file tree

Hide file tree

Showing 5 changed files with 59 additions and 14 deletions.
diff --git a/R/gist_create.R b/R/gist_create.R
@@ -91,8 +91,8 @@
 #' }
 
 gist_create <- function(files=NULL, description = "", public = TRUE, browse = TRUE, code=NULL,
-  filename="code.R", knit=FALSE, knitopts=list(), renderopts=list(), include_source = FALSE, 
-  artifacts = FALSE, imgur_inject = FALSE, ...) {
+                        filename="code.R", knit=FALSE, knitopts=list(), renderopts=list(), include_source = FALSE, 
+                        artifacts = FALSE, imgur_inject = FALSE, ...) {
 
   if (!is.null(code)) files <- code_handler(code, filename)
   if (knit) {
@@ -117,6 +117,8 @@ gist_create <- function(files=NULL, description = "", public = TRUE, browse = TR
   } else {
     allfiles <- files
   }
+  is_binary(allfiles)
+  is_dir(allfiles)
   body <- creategist(unlist(allfiles), description, public)
   res <- gist_POST(paste0(ghbase(), '/gists'), gist_auth(), ghead(), body, ...)
   gist <- as.gist(res)
@@ -160,18 +162,18 @@ inject_imgur <- function(x, imgur_inject = TRUE) {
       str <- "```{r echo=FALSE}\nknitr::opts_knit$set(upload.fun = imgur_upload, base.url = NULL)\n```\n"
       cat(str, orig, file = x, sep = "\n")
     } 
-#     else if(grepl("\\.[rR]nw$", x)) {
-#       str <- "```{r echo=FALSE}\nknitr::opts_knit$set(upload.fun = imgur_upload, base.url = NULL)\n```\n"
-#       cat(str, orig, file = x, sep = "\n")
-#     }
+    #     else if(grepl("\\.[rR]nw$", x)) {
+    #       str <- "```{r echo=FALSE}\nknitr::opts_knit$set(upload.fun = imgur_upload, base.url = NULL)\n```\n"
+    #       cat(str, orig, file = x, sep = "\n")
+    #     }
   }
 }
 
 inject_root_dir <- function(x, path) {
   orig <- readLines(x)
   cat(sprintf("```{r echo=FALSE}
-knitr::opts_knit$set(root.dir = \"%s\")
-```\n", path), orig, file = x, sep = "\n")
+              knitr::opts_knit$set(root.dir = \"%s\")
+              ```\n", path), orig, file = x, sep = "\n")
 }
 
 # swapfilename <- function(x, filename){
@@ -191,3 +193,33 @@ code_handler <- function(x, filename){
   writeLines(text, tmp)
   return(tmp)
 }
+
+is.binary <- function(x, max = 1000) {
+  if (!is.dir(x)) {
+    f <- file(x, "rb", raw = TRUE)
+    b <- readBin(f, "int", max, size = 1, signed = FALSE)
+    tmp <- max(b) > 128
+    close.connection(f)
+    tmp
+  } else {
+    FALSE
+  }
+}
+
+is_binary <- function(x) {
+  bin <- vapply(x, is.binary, logical(1))
+  if (any(bin)) {
+    stop("Binary files not supported\n", x[bin], call. = FALSE)
+  }
+}
+
+is.dir <- function(x) {
+  file.info(x)$isdir
+}
+
+is_dir <- function(x) {
+  bin <- vapply(x, is.dir, logical(1))
+  if (any(bin)) {
+    stop("Directories not supported\n", x[bin], call. = FALSE)
+  }
+}
diff --git a/inst/examples/file.png b/inst/examples/file.png
diff --git a/inst/examples/plots.md b/inst/examples/plots.md
@@ -7,7 +7,7 @@
 plot(mpg ~ cyl, data=mtcars)
 ```
 
-![plot of chunk unnamed-chunk-2](http://i.imgur.com/07jtYvL.png) 
+![plot of chunk unnamed-chunk-2](http://i.imgur.com/mSbJ1PF.png) 
 
 ## Bar plot
 
@@ -16,7 +16,7 @@ plot(mpg ~ cyl, data=mtcars)
 barplot(VADeaths)
 ```
 
-![plot of chunk unnamed-chunk-3](http://i.imgur.com/tpuEz9k.png) 
+![plot of chunk unnamed-chunk-3](http://i.imgur.com/cCZ5YH9.png) 
 
 ## Histogram
 
@@ -25,4 +25,4 @@ barplot(VADeaths)
 hist(iris$Petal.Length)
 ```
 
-![plot of chunk unnamed-chunk-4](http://i.imgur.com/IghDLyE.png) 
+![plot of chunk unnamed-chunk-4](http://i.imgur.com/fKdOi34.png) 
diff --git a/inst/examples/plots_imgur.md b/inst/examples/plots_imgur.md
@@ -7,7 +7,7 @@
 plot(mpg ~ cyl, data=mtcars)
 ```
 
-![plot of chunk unnamed-chunk-2](http://i.imgur.com/c7Tq4mH.png) 
+![plot of chunk unnamed-chunk-2](http://i.imgur.com/bDPhAPd.png) 
 
 ## Bar plot
 
@@ -16,7 +16,7 @@ plot(mpg ~ cyl, data=mtcars)
 barplot(VADeaths)
 ```
 
-![plot of chunk unnamed-chunk-3](http://i.imgur.com/zULHBZ4.png) 
+![plot of chunk unnamed-chunk-3](http://i.imgur.com/DXeQ2yw.png) 
 
 ## Histogram
 
@@ -25,4 +25,4 @@ barplot(VADeaths)
 hist(iris$Petal.Length)
 ```
 
-![plot of chunk unnamed-chunk-4](http://i.imgur.com/4iU5qKL.png) 
+![plot of chunk unnamed-chunk-4](http://i.imgur.com/RYXt7Lj.png) 
diff --git a/tests/localtests/test-gist_create.R b/tests/localtests/test-gist_create.R
@@ -44,3 +44,16 @@ test_that("gist_create works to upload images", {
   suppressMessages(res1 %>% delete())
   suppressMessages(res2 %>% delete())
 })
+
+test_that("gist_create fails correctly when binary files passed", {
+  file <- system.file("examples", "file.png", package = "gistr")
+  expect_error(gist_create(file, browse = FALSE), "Binary files not supported")
+})
+
+test_that("gist_create fails correctly when directory passed", {
+  file <- system.file("examples", "file.png", package = "gistr")
+  direct <- tempdir()
+  expect_error(gist_create(direct, browse = FALSE), "Directories not supported")
+  # binary check is first in the function
+  expect_error(gist_create(c(direct, file), browse = FALSE), "Binary files not supported")
+})