Using image files on disk with R animation package - r

I used R to create a series of images that took a long time to run. I'd like to use the animation package to make a video from them without re-running the analysis.
I can't find an example using existing images from file. The closest is Yihui Xie's demo('flowers') to create an HTML animation. I changed his code and can successfully make an mp4 of the flower images but I'm not sure how to access images already on file.
Based on his code, it should be something like this:
library(animation)
oopts = if (.Platform$OS.type == "windows") {
ani.options(ffmpeg = "C:/Software/ffmpeg/ffmpeg-20151015-git-0418541-win64-static/bin/ffmpeg.exe")}
#My list of images from disk
extList = list.files(myDir, pattern='.jpg', full.names=T)
saveVideo({
for (i in 1:length(extList)) {
#Yihui Xie's example downloads jpegs from web
#This code works to make an mp4 but I want to use images from disk
#extList = c('http://i.imgur.com/rJ7xF.jpg',
# 'http://i.imgur.com/Lyr9o.jpg',
# 'http://i.imgur.com/18Qrb.jpg')
#download.file(url = extList[i], destfile = sprintf(ani.options('img.fmt'), i), mode = 'wb')
someFunctionToAccessImage(extList[i])
}
}, video.name='notFlowers.mp4',
use.dev = FALSE,
ani.type = 'jpg',
interval = 2,
single.opts = "'dwellMultiplier': 1")
Bonus question - Can I do this with PNGs or other image types?

I found there to be a couple of problems with this. saveVideo uses a temporary directory to process the files and make the movie. Also, the postfix it was adding to the image name wasn't working correctly. So, here is a way to do it where you copy the images from the folder you have them stored in into the temporary directory used by saveVideo. The tricky part is finding the path to that directory, which is done using sys.frame from a function defined in the expression.
Note: another possible option could be to manually copy the images to the temporary folder that you know saveVideo will use (it will call tempdir()), or redefine tempdir() to return the path to your current images, but I haven't tested that.
library(animation)
oopts = if (.Platform$OS.type == "windows")
ani.options(ffmpeg = "C:\\home\\src\\ffmpeg-20151017-git-e9299df-win64-static\\bin\\ffmpeg.exe")
## Some variables
dirPath <- normalizePath("images/") # path to folder containing images
postfix <- "%03d" # I created my files with "Rplot%03d"
## Make the animation
saveVideo({
## Need to retrieve some variables from environments up the call stack
env.info <- (function() { list(wd = sys.frame(-1)$owd, fmt=sys.frame(-2)$img.fmt,
e=sys.frame(-2)) })()
postfix <- postfix
img.fmt <- gsub("%d", postfix, env.info$fmt, fixed=TRUE)
assign('img.fmt', img.fmt, envir=env.info$e)
file.copy(list.files(dirPath, full.names = TRUE), to=env.info$wd, overwrite = TRUE)
}, video.name='heatBalls.mp4', img.name='Rplot', interval = .05, use.dev=FALSE)
Full example
## Random function to save some images to disk
circ <- function(x,y,r) { s <- seq(-pi,pi,len=30); data.frame(x=x+r*cos(s), y=y+r*sin(s)) }
imgFun <- function(n, ncircs, dirPath) {
if (!require(scales)) stop("install scales package")
rads <- runif(ncircs, 0.5, 3)
xs <- runif(ncircs, 0.1+rads, 19.9-rads)
ys <- runif(ncircs, 0.1+rads, 19.9-rads)
vs <- matrix(runif(ncircs*2), 2)
cols <- colorRampPalette(c('lightblue','darkblue'), alpha=0.3)(ncircs)
png(file.path(dirPath, 'Rplot%03d.png'))
for (i in seq_len(n)) {
image(x=seq(0, 20, length=20), y=seq(0, 20, length=20),
z=matrix(rnorm(400),20), col=heat.colors(20, alpha=0.6), xlab='', ylab='')
for(j in 1:ncircs) polygon(x=circ(xs[j], ys[j], rads[j]), col=alpha(cols[j],0.7))
condx <- (xs + rads) > 20 | (xs - rads) < 0
condy <- (ys + rads) > 20 | (ys - rads) < 0
vs[1,condx] <- -vs[1,condx]
vs[2,condy] <- -vs[2,condy]
xs <- xs + vs[1,]
ys <- ys + vs[2,]
}
dev.off()
}
## Create some images on disk in a folder called "images"
dirPath <- normalizePath("images/")
dir.create(dirPath)
imgFun(50, 18, dirPath)
Then run the above code and a movie like the following should be made.

Related

How to click on element with Chrome DevTools Protocol?

I'm using chromote R package and I'm testing it with shiny application. I'm trying to click on the icon that should duplicate few select elements. But all I have is tooltip when I take a screenshot and if I open the browser it freezes the R process.
Here is my code:
#' Run shiny in background - based on shinytest source code
#' #export
shiny.bg <- function(path, loadTimeout = 10000, shinyOptions = list()) {
tempfile_format <- tempfile("%s-", fileext = ".log")
p <- callr::r_bg(function(path, shinyOptions) {
do.call(shiny::runApp, c(path, shinyOptions))
},
args = list(
path = normalizePath(path),
shinyOptions = shinyOptions
),
stdout = sprintf(tempfile_format, "shiny-stdout"),
stderr = sprintf(tempfile_format, "shiny-stderr"),
supervise = TRUE
)
if (! p$is_alive()) {
abort(paste0(
"Failed to start shiny. Error: ",
strwrap(readLines(p$get_error_file()))
))
}
## Try to read out the port. Try 5 times/sec, until timeout.
max_i <- loadTimeout / 1000 * 5
for (i in seq_len(max_i)) {
err_lines <- readLines(p$get_error_file())
if (!p$is_alive()) {
abort(paste0(
"Error starting application:\n", paste(err_lines, collapse = "\n")
))
}
if (any(grepl("Listening on http", err_lines))) break
Sys.sleep(0.2)
}
if (i == max_i) {
abort(paste0(
"Cannot find shiny port number. Error:\n", paste(err_lines, collapse = "\n")
))
}
line <- err_lines[grepl("Listening on http", err_lines)]
m <- rematch::re_match(text = line, "https?://(?<host>[^:]+):(?<port>[0-9]+)")
url <- sub(".*(https?://.*)", "\\1", line)
list(
process = p,
url = url
)
}
#' Run shiny application and Chromeote instance
chromote.shiny <- function() {
chr <- chromote::ChromoteSession$new()
app <- shiny.bg('.')
chr$Page$navigate(app$url)
chr$Page$loadEventFired()
chr$screenshot()
list(
chr = chr,
app = app
)
}
#' kill browser and R shiny process
cleanUp <- function(obj) {
obj$chr$Browser$close()
obj$app$process$kill()
}
#' click on the element
chromote.click <- function(chromote, selector) {
doc = chromote$DOM$getDocument()
node = chromote$DOM$querySelector(doc$root$nodeId, selector)
box <- chromote$DOM$getBoxModel(node$nodeId)
left <- box$model$content[[1]]
top <- box$model$content[[2]]
x <- left + (box$model$width / 2)
y <- top + (box$model$height / 2)
chromote$Input$dispatchMouseEvent(type = "mousePressed", x = x, y = y, button="left")
chromote$Input$dispatchMouseEvent(type = "mouseReleased", x = x, y = y, button="left")
}
tmp <- chromote.shiny()
chromote.click(tmp$chr, ".clone-pair")
tmp$chr$screenshot()
I have no idea how I can debug this and there are not much information how to make a click, I've found dispatchMouseEvent in issue in GitHub repo for chromote.
Links to repo https://github.com/rstudio/chromote
The reason why I want to use chromote is I want to create unit/integration test for my application and shinytest is way outdated it use phantomJS that was abandoned years ago (so you need to use very old JavaScript because otherwise pantomJS will throw error and test will fail) and RSelenium is also not maintained anymore.
Had the same issue..
I found this library that uses chromote but has a number of functions (GetElement, Click) from RSelenium.
install.packages("remotes")
remotes::install_github("rundel/hayalbaz")

how to write out multiple files in R?

I am a newbie R user. Now, I have a question related to write out multiple files with different names. Lets says that my data has the following structure:
IV_HAR_m1<-matrix(rnorm(1:100), ncol=30, nrow = 2000)
DV_HAR_m1<-matrix(rnorm(1:100), ncol=10, nrow = 2000)
I am trying to estimate multiple LASSO regressions. At the beginning, I was storing the iterations in one object called Dinamic_beta. This object was stored in only one file, and it saves the required information each time that my code iterate.
For doing this I was using stew which belongs to pomp package, but the total process takes 5 or 6 days and I am worried about a power outage or a fail in my computer.
Now, I want to save each environment (iterations) in a .Rnd file. I do not know how can I do that? but the code that I am using is the following:
library(glmnet)
library(Matrix)
library(pomp)
space <- 7 #THE NUMBER OF FILES THAT I would WANT TO CREATE
Dinamic_betas<-array(NA, c(10, 31, (nrow(IV_HAR_m1)-space)))
dimnames(Dinamic_betas) <- list(NULL, NULL)
set.seed(12345)
stew( #stew save the enviroment in a .Rnd file
file = "Dinamic_LASSO_RD",{ # The name required by stew for creating one file with all information
for (i in 1:dim(Dinamic_betas)[3]) {
tryCatch( #print messsages
expr = {
cv_dinamic <- cv.glmnet(IV_HAR_m1[i:(space+i-1),],
DV_HAR_m1[i:(space+i-1),], alpha = 1, family = "mgaussian", thresh=1e-08, maxit=10^9)
LASSO_estimation_dinamic<- glmnet(IV_HAR_m1[i:(space+i-1),], DV_HAR_m1[i:(space+i-1),],
alpha = 1, lambda = cv_dinamic$lambda.min, family = "mgaussian")
coefs <- as.matrix(do.call(cbind, coef(LASSO_estimation_dinamic)))
Dinamic_betas[,,i] <- t(coefs)
},
error = function(e){
message("Caught an error!")
print(e)
},
warning = function(w){
message("Caught an warning!")
print(w)
},
finally = {
message("All done, quitting.")
}
)
if (i%%400==0) {print(i)}
}
}
)
If someone can suggest another package that stores the outputs in different files I will grateful.
Try adding this just before the close of your loop
save.image(paste0("Results_iteration_",i,".RData"))
This should save your entire workspace to disk for every iteration. You can then use load() to load the workspace of every environment. Let me know if this works.

How to skip writing dependencies in htmlwidgets::saveWidget()?

When visualizing data with plotly, i want to write widgets as html-documents without htmlwidgets::saveWidget writing dependencies every time, assuming that these already are in place, to save processing time. The widgets need to be self-contained to save disk space.
library(plotly)
t <- Sys.time()
p <- plot_ly(ggplot2::diamonds, y = ~price, color = ~cut, type = "box")
htmlwidgets::saveWidget(as_widget(p), "test.html", selfcontained = F, libdir = NULL)
print(Sys.time() - t)
Time difference of 4.303076 secs on my machine.
This produces ~6 mb of data only in depedencies (crosstalk-1.0.0, htmlwidgets-1.2, jquery-1.11.3, plotly-binding-4.7.1.9000, plotly-htmlwidgets-css-1.38.3, plotly-main-1.38.3, typedarray-0.1)
htmlwidgets::saveWidget writes dependencies although these files already exist. Can this be prevented?
Good question. I tried to answer inline in comments within the code. htmlwidgets dependencies come from two sources: htmlwidgets::getDependency() and the dependencies element in the widget list. Changing the src element within dependencies to href instead of file means these dependencies will not get copied. However, the dependencies from htmlwidgets::getDependency() are harder to overwrite, but in the case will only copy htmlwidgets.js and plotly-binding.js, which are fairly small in comparison with the other four.
library(plotly)
p <- plot_ly(ggplot2::diamonds, y = ~price, color = ~cut, type = "box")
# let's inspect our p htmlwidget list for clues
p$dependencies
# if the src argument for htmltools::htmlDependency
# is file then the file will be copied
# but if it is href then the file will not be copied
# start by making a copy of your htmlwidget
# this is not necessary but we'll do to demonstrate the difference
p2 <- p
p2$dependencies <- lapply(
p$dependencies,
function(dep) {
# I use "" below but guessing that is not really the location
dep$src$href = "" # directory of your already saved dependency
dep$src$file = NULL
return(dep)
}
)
# note this will still copy htmlwidgets and plotly-binding
# requires a much bigger hack to htmlwidgets::getDependency() to change
t <- Sys.time()
htmlwidgets::saveWidget(as_widget(p), "test.html", selfcontained = F, libdir = NULL)
print(Sys.time() - t)
t <- Sys.time()
htmlwidgets::saveWidget(as_widget(p2), "test.html", selfcontained = F, libdir = NULL)
print(Sys.time() - t)

R gif with function

I am trying to make a gif out of an R-Script using a function to generate the images.
I have a function that given some information creates a Map with dots on it.
I use this function on a Vector obtaining a series of different images, and I would like to put them together in a gif. It looks more or less like that:
createMap <- function(my_variable){
my_map <- a_map() + geom_point() # some variable missing
png(filename = paste(aDate, ".png", sep = ""), width = 3149, height = 2183, units = "px")
plot(mw_map)
dev.off()
}
ImageMagick is installed on my pc and the conversion file "converter.exe" also. Later I try to generate the gif using
saveGIF({
lapply(my_vector, createMap)
}, movie.name = "MY_GIF.gif")
but I get an error message:
> convert: improper image header `Rplot1.png' #
> error/png.c/ReadPNGImage/4362. convert: no images defined `MY_GIF.gif'
> # error/convert.c/ConvertImageCommand/3254.
an error occurred in the conversion...
does anybody know what I did wrong?
After creating the map png files. Use the below code. You don't need ImageMagick is installed on PC.
library(magick)
png.files <- sprintf("Rplot%02d.png", 1:10) #Mention the number of files to be read
GIF.convert <- function(x, output = "animation.gif")#Create a function to read, animate and convert the files to gif
{
image_read(x) %>%
image_animate(fps = 1) %>%
image_write(output)
}
GIF.convert(png.files)
For more details check this link: Link

Importing data into R (rdata) from Github

I want to put some R code plus the associated data file (RData) on Github.
So far, everything works okay. But when people clone the repository, I want them to be able to run the code immediately. At the moment, this isn't possible because they will have to change their work directory (setwd) to directory that the RData file was cloned (i.e. downloaded) to.
Therefore, I thought it might be easier, if I changed the R code such that it linked to the RData file on github. But I cannot get this to work using the following snippet. I think perhaps there is some issue text / binary issue.
x <- RCurl::getURL("https://github.com/thefactmachine/hex-binning-gis-data/raw/master/popDensity.RData")
y <- load(x)
Any help would be appreciated.
Thanks
This works for me:
githubURL <- "https://github.com/thefactmachine/hex-binning-gis-data/raw/master/popDensity.RData"
load(url(githubURL))
head(df)
# X Y Z
# 1 16602794 -4183983 94.92019
# 2 16602814 -4183983 91.15794
# 3 16602834 -4183983 87.44995
# 4 16602854 -4183983 83.79617
# 5 16602874 -4183983 80.19643
# 6 16602894 -4183983 76.65052
EDIT Response to OP comment.
From the documentation:
Note that the https:// URL scheme is not supported except on Windows.
So you could try this:
download.file(githubURL,"myfile")
load("myfile")
which works for me as well, but this will clutter your working directory. If that doesn't work, try setting method="curl" in the call to download.file(...).
I've had trouble with this before as well, and the solution I've found to be the most reliable is to use a tiny modification of source_url from the fantastic [devtools][1] package. This works for me (on a Mac).
load_url <- function (url, ..., sha1 = NULL) {
# based very closely on code for devtools::source_url
stopifnot(is.character(url), length(url) == 1)
temp_file <- tempfile()
on.exit(unlink(temp_file))
request <- httr::GET(url)
httr::stop_for_status(request)
writeBin(httr::content(request, type = "raw"), temp_file)
file_sha1 <- digest::digest(file = temp_file, algo = "sha1")
if (is.null(sha1)) {
message("SHA-1 hash of file is ", file_sha1)
}
else {
if (nchar(sha1) < 6) {
stop("Supplied SHA-1 hash is too short (must be at least 6 characters)")
}
file_sha1 <- substr(file_sha1, 1, nchar(sha1))
if (!identical(file_sha1, sha1)) {
stop("SHA-1 hash of downloaded file (", file_sha1,
")\n does not match expected value (", sha1,
")", call. = FALSE)
}
}
load(temp_file, envir = .GlobalEnv)
}
I use a very similar modification to get text files from github using read.table, etc. Note that you need to use the "raw" version of the github URL (which you included in your question).
[1] https://github.com/hadley/devtoolspackage
load takes a filename.
x <- RCurl::getURL("https://github.com/thefactmachine/hex-binning-gis-data/raw/master/popDensity.RData")
writeLines(x, tmp <- tempfile())
y <- load(tmp)

Resources