Shinystan animated

.Rbuildignore

@@ -1,9 +1,2 @@
 ^.*\.Rproj$
 ^\.Rproj\.user$
-LICENSE
-^\.travis\.yml$
-^README\.md$
-.gitignore
-^cran-comments\.md$
-^revdep$
-man-roxygen/*

.gitignore

@@ -1,14 +1,9 @@
-.Rhistory
-.Rapp.history
-*-Ex.R
-.Rdata
 .Rproj.user
-shinystan.Rproj
-
-*.DS_Store
-inst/doc
-^cran-comments\.md$
-cran-comments.md
-
-revdep/
-*.swf
+.Rhistory
+.RData
+test_shinystan_gganimate.R
+save_gif.gif
+dropping_balls.gif
+"dropping balls.gif"
+inst/ShinyStan/www/gg_animate_shinystan.webm
+8 schools

DESCRIPTION

@@ -26,12 +26,14 @@ URL: https://github.com/stan-dev/shinystan/, http://mc-stan.org/
 BugReports: https://github.com/stan-dev/shinystan/issues/
 Depends:
     R (>= 3.1.0),
-    shiny (>= 0.12.1)
+    shiny (>= 0.12.1),
+    tweenr,
+    knitr (>= 1.9),
+    stringr
 License: GPL (>=3)
 LazyData: true
 Suggests:
     coda,
-    knitr (>= 1.9),
     rmarkdown (>= 0.8.1),
     rstanarm (>= 2.9.0-3),
     testthat

inst/ShinyStan/.gitignore

@@ -0,0 +1 @@
+server_utils_changeres.R

inst/ShinyStan/global_utils.R

@@ -155,3 +155,14 @@ strongBig <- function(...)
   strong(style = "font-size: 18px; margin-bottom: 5px;", ...)
 strong_bl <- function(...) 
   strong(style = "color: #006DCC;", ...)
+
+# list needed for animation aspect ratio selections
+# taken from https://support.google.com/youtube/answer/6375112
+
+youtube_aspect <- list(`2160p`=list(width=3840,height=2160),
+                       `1440p`=list(width=2560,height=1440),
+                       `1080p`=list(width=1920,height=1080),
+                       `720p`=list(width=1280,height=720),
+                       `480p`=list(width=854,height=480),
+                       `360p`=list(width=640,height=360),
+                       `240p`=list(width=426,height=240))

inst/ShinyStan/helper_functions/shinystan_helpers.R

@@ -610,9 +610,7 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential",
   samps_use <- array(samps[,,params], c(nIter, nParams))
   colnames(samps_use) <- params
 
-  t_x <- get(transform_x)
-  # t_x <- function(x) eval(parse(text = transform_x))
-  t_y <- get(transform_y)
+
   x_lab <- if (transform_x != "identity") 
     paste0(transform_x, "(", param, ")") else param
   y_lab <- if (transform_y != "identity") 
@@ -667,3 +665,245 @@ priors <- data.frame(family = c("Normal", "t", "Cauchy", "Beta", "Exponential",
     theme_classic() %+replace% (no_lgnd + axis_labs + fat_axis + axis_color + transparent)
 }
 
+
+# Animation plot ----------------------------------------------------------
+
+.animate_plot <- function(samps, sp = NULL, max_td = NULL,
+                          param, param2,
+                          pt_alpha = 0.10,
+                          pt_size = 2,
+                          pt_shape = 10,
+                          ellipse_lev = "None",
+                          ellipse_lty = 1,
+                          ellipse_lwd = 1,
+                          ellipse_alpha = 1,
+                          lines = "back",
+                          lines_alpha,
+                          points = TRUE,
+                          transform_x = "identity",
+                          transform_y = "identity",
+                          this_chain="All",
+                          frame_speed=16,
+                          row_min = NULL,
+                          row_max = NULL,
+                          standardize = FALSE,
+                          colour_palette = "Set1",
+                          tween_ratio = 10,
+                          top_title=TRUE,
+                          height=youtube_aspect[["1080p"]]$height,
+                          width=youtube_aspect[["1080p"]]$width,
+                          resolution="Automatic",
+                          graph_type='Scatterplot',
+                          num_cores=1
+) {
+
+  shape_translator <- function(x) {
+    shape <- if (x >= 6) x + 9 else x
+    shape
+  }
+
+  # Need to set a file name to save the WEBM to
+
+  outfile1 <- 'www/gg_animate_shinystan.webm'
+  outfile2 <- 'gg_animate_shinystan.webm'
+
+  # options for animation
+  if(resolution=="Automatic") {
+    resolution <- width/8
+  } else {
+    resolution <- as.numeric(resolution)
+  }
+
+  params <- c(param, param2)
+  nParams <- length(params)
+
+  # Adjust number of rows per slider Input
+
+  if(!is.null(row_min)) {
+    samps <- samps[row_min:row_max,,]
+    sp <- lapply(sp,function(x) {x <- x[row_min:row_max,]
+                                return(x)})
+  }
+
+  .nChains <- dim(samps)[2]
+
+  # if only one x parameter, allow multiple chains, but otherwise only use a single chain
+
+  if(.nChains>1 && length(param2)==1 && this_chain=='All') {
+  nIter <- dim(samps)[1] * dim(samps)[2]
+  } else {
+    nIter <- dim(samps)[1]
+  }
+  if(length(param2)>1) {
+  samps_use <- array(samps[,as.numeric(this_chain),params], c(nIter, nParams))
+  colnames(samps_use) <- c('y',param2)
+  } else if(this_chain=="All" && .nChains>1) {
+    param_chain <- paste0("Chain ",1:.nChains)
+    params <- c(param,param2)
+    nParams <- length(params)
+    samps_use <- array(samps[,,params], c(nIter, nParams))
+    colnames(samps_use) <- c('y',param2)
+  } else if(this_chain=="All" && .nChains==1){
+    samps_use <- array(samps[,,params], c(nIter, nParams))
+    colnames(samps_use) <- c('y',param2)
+  } else if(this_chain!="All") {
+    samps_use <- array(samps[,as.numeric(this_chain),params], c(nIter, nParams))
+    colnames(samps_use) <- c('y',param2)
+  }
+
+
+  param2 <- if (transform_x != "identity") 
+    paste0(transform_x, "(", param2, ")") else param2
+  param <- if (transform_y != "identity") 
+    paste0(transform_y, "(", param, ")") else param
+
+
+# After transforming, perform an optional standardization -----------------
+
+
+  if(length(param2)>1) {
+    param2_label <- paste0(param2,collapse=", ")
+  }  else if(length(param2)==1 && this_chain=="All" && .nChains>1) {
+    param2_label <- param2
+  } else {
+    param2_label <- param2
+  }
+  param_labs <- labs(x = param2_label, y = param)
+
+  t_x <- get(transform_x)
+  # t_x <- function(x) eval(parse(text = transform_x))
+  t_y <- get(transform_y)
+
+  if(transform_y!="identity") {
+    samps_use[,1] <- t_y(samps_use[,1])
+  }
+  if(transform_x!="identity") {
+    for(i in 1:(nParams-1)) {
+      samps_use[,(i+1)] <- t_x(samps_use[,(i+1)])
+    }
+  }
+
+
+  if(standardize) 
+    samps_use[,2:ncol(samps_use)] <- scale(samps_use[,2:ncol(samps_use)]) 
+
+
+  # Now need to 'tween' the data: add interpolation to the dataset so that the frames transition smoothly
+
+  if(length(param2)>1 | this_chain!='All') {
+      dat <- as.data.frame(samps_use)
+      dat$id <- 1
+      dat$time <- 1:nrow(dat)
+      dat$ease <- 'quadratic-in-out'
+      if (!is.null(sp)) {
+        dat$divergent <- sp[[as.numeric(this_chain)]][, "divergent__"]
+        dat$hit_max_td <- if (is.null(max_td)) 0 else 
+          as.numeric(sp[[as.numeric(this_chain)]][, "treedepth__"] == max_td)
+      } else {
+        dat$divergent <- 0
+        dat$hit_max_td <- 0
+      } 
+      dat <- tweenr::tween_elements(dat,'time','id','ease',nframes=(nrow(dat)*tween_ratio))
+      dat <- reshape2::melt(dat,id.vars=c('y','.group','.frame','time','divergent','hit_max_td'),value.name='x')
+  } else {
+    dat <- as.data.frame(samps_use)
+    dat$time <- rep(1:(nIter/.nChains),times=.nChains)
+    dat$ease <- 'quadratic-in-out'
+    if (!is.null(sp)) {
+      dat$divergent <- c(sapply(sp, FUN = function(y) y[, "divergent__"]))
+      dat$hit_max_td <- if (is.null(max_td)) 0 else 
+        c(sapply(sp, FUN = function(y) as.numeric(y[, "treedepth__"] == max_td))) 
+    } else {
+      dat$divergent <- 0
+      dat$hit_max_td <- 0
+    } 
+    dat$x <- dat[,2]
+    dat$id <- rep(param_chain,each=nIter/.nChains)
+    dat <- tweenr::tween_elements(dat,'time','id','ease',nframes=dim(samps)[1]*tween_ratio)
+    dat$variable <- dat$.group
+  }
+
+
+
+# Graph building for scatterplots -----------------------------------------
+
+
+  if(graph_type=='Scatterplot') {
+    graph <- ggplot(dat, aes(x = x, y = y, xend=c(tail(x, n=-1), NA), 
+                             yend=c(tail(y, n=-1), NA),colour=variable,frame=.frame)) 
+
+
+  # Add in options from bivariate plot, which should be essentially the same --------
+
+    if (lines == "hide") {
+      graph <- graph + geom_point(alpha = pt_alpha, size = pt_size, 
+                                  shape = shape_translator(pt_shape))
+    } else { # if lines = "back" or "front"
+      if (lines == "back") {
+        graph <- graph + 
+          geom_path(alpha = lines_alpha, aes(cumulative=TRUE)) + 
+          geom_point(alpha = pt_alpha, size = pt_size, 
+                     shape = shape_translator(pt_shape))
+      } else { # lines = "front"
+        graph <- graph + 
+          geom_point(alpha = pt_alpha, size = pt_size, 
+                     shape = shape_translator(pt_shape)) +
+          geom_path(alpha = lines_alpha,aes(cumulative=TRUE))
+      }
+    }
+    if (ellipse_lev != "None")
+      graph <- graph + stat_ellipse(level = as.numeric(ellipse_lev), 
+                                    linetype = ellipse_lty, size = ellipse_lwd, alpha = ellipse_alpha)
+    if (!all(dat$divergent == 0))
+      graph <- graph + geom_point(data = subset(dat, divergent == 1), aes(x,y,frame=NULL), 
+                                  size = pt_size + 0.5, shape = 21, 
+                                  color = "#570000", fill = "#ae0001")
+    if (!all(dat$hit_max_td == 0))
+      graph <- graph + geom_point(data = subset(dat, hit_max_td == 1), aes(x,y,frame=NULL), 
+                                  size = pt_size + 0.5, shape = 21,
+                                  color = "#5f4a13", fill = "#eeba30")
+
+    # Set colour and label values for graphs with more than one variable --------
+
+    if(length(param2)>1 | (.nChains>0 && this_chain=='All')) {
+      graph <- graph + geom_text(aes(label=variable),vjust=-0.4) + scale_colour_brewer(palette=colour_palette)
+    }
+
+    # Adjust text because otherwise it looks too small
+
+    graph <- graph + param_labs + 
+      theme_classic() %+replace% (no_lgnd + axis_labs + fat_axis + axis_color + transparent)
+  }
+
+
+# Code building for animated histograms -----------------------------------
+  else if(graph_type=='Density') {
+    fill_color <-  "gray20"
+    line_color <-  "gray35"
+
+    graph <- ggplot(dat, aes(x = x, frame=.frame))
+
+    graph <- graph +
+      geom_density(aes(group=.frame),fill=fill_color,colour=line_color) +
+      scale_colour_brewer(palette=colour_palette) + 
+      scale_fill_discrete("") +
+      labs(x = param2_label, y = "") +
+      theme_classic() %+replace% (no_lgnd + title_txt + axis_color + fat_axis + no_yaxs + transparent) 
+
+  }
+
+
+  # Movie file is saved in WEBM format, a lightweight and opensource video codec. It is saved to 'www' directory
+  # Because that is where the shiny hmtlOutput function will look for it. 
+  # the -b option is the bitrate, in megabits, which adjusts the quality (and size) of the video.
+
+  animated  <- gganimate::gg_animate(graph,title_frame=top_title)
+
+  # use separate function for better options control than the base gganimate function
+
+  shiny_animate_save(animated,filename=outfile1,height=height,width=width,resolution=resolution,frame_speed=frame_speed,num_cores=num_cores)
+
+
+  return(list(src=outfile2,
+              alt="Animated scatterplot"))
+}

inst/ShinyStan/markdown/about_video.Rmd

@@ -0,0 +1,34 @@
+---
+title: "About Shinystan Video"
+output: html_document
+---
+
+This page will create videos of MCMC parameter exploration relative to another variable or to the log-posterior on the y axis. It will either show multiple parameters of a single chain or multiple chains of a single parameter along the x axis. 
+
+```{r,echo=FALSE}
+check_requirements <- function() {
+  x <- list()
+  x$image_magick <- ifelse(class(try(system("ffmpeg --help",intern=TRUE)))=='try-error'," not present"," present")
+  x$gg_animate <- ifelse(require(gganimate,quietly=TRUE)," present"," not present")
+  return(x)
+}
+check <- check_requirements()
+paste0("Your system shows that the ffmpeg library is ",check$image_magick," and the gg_animate package is ", check$gg_animate)
+```
+
+If either of these are listed as "not present", please read the installation instructions below.
+
+As this function relies on additional software (non-R) for support, please read through the following installation guidelines:
+
+1. Install the ffmpeg package. It is included with the ImageMagick software for Windows or Mac OS at  <http://www.imagemagick.org/script/binary-releases.php>. After installing the software, you must restart R or Rstudio.
+
+2. Install the gg_animate package in R or Rstudio from github using the following code:
+
+```
+devtools::install_github("dgrtwo/gganimate")
+```
+
+You are now ready to create movie files. Please be aware that the greater number of iterations you include in a movie, and the greater number of frames used to smooth the movie (see the options panel), the more time will be required to produce the result. For example, if you select 20 iterations and a frame smoothing factor of 10, this will require the production of 20 * 10 = 200 charts before the video can compile. Reducing the frame smoothing factor will produce a jumpy video.
+
+The videos are produced in the .WEBM format. This format may not display in Safari or Internet Explorer without additional plugins; however, it will play correctly on Chrome and Firefox. The movie can also be uploaded directly to Youtube to share and/or watch. To share on Youtube, first download the movie to your computer using the download button at the bottom of the screen.
+

inst/ShinyStan/markdown/about_video.md

@@ -0,0 +1,28 @@
+---
+title: "About Shinystan Video"
+output: html_document
+---
+
+This page will create videos of MCMC parameter exploration relative to another variable or to the log-posterior on the y axis. It will either show multiple parameters of a single chain or multiple chains of a single parameter along the x axis. 
+
+
+```
+## [1] "Your system shows that the ffmpeg library is  present and the gg_animate package is  present"
+```
+
+If either of these are listed as "not present", please read the installation instructions below.
+
+As this function relies on additional software (non-R) for support, please read through the following installation guidelines:
+
+1. Install the ffmpeg package. It is included with the ImageMagick software for Windows or Mac OS at  <http://www.imagemagick.org/script/binary-releases.php>. After installing the software, you must restart R or Rstudio.
+
+2. Install the gg_animate package in R or Rstudio from github using the following code:
+
+```
+devtools::install_github("dgrtwo/gganimate")
+```
+
+You are now ready to create movie files. Please be aware that the greater number of iterations you include in a movie, and the greater number of frames used to smooth the movie (see the options panel), the more time will be required to produce the result. For example, if you select 20 iterations and a frame smoothing factor of 10, this will require the production of 20 * 10 = 200 charts before the video can compile. Reducing the frame smoothing factor will produce a jumpy video.
+
+The videos are produced in the .WEBM format. This format may not display in Safari or Internet Explorer without additional plugins; however, it will play correctly on Chrome and Firefox. The movie can also be uploaded directly to Youtube to share and/or watch. To share on Youtube, first download the movie to your computer using the download button at the bottom of the screen.
+