diff --git a/.Rbuildignore b/.Rbuildignore index 7066ea24..91114bf2 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,9 +1,2 @@ ^.*\.Rproj$ ^\.Rproj\.user$ -LICENSE -^\.travis\.yml$ -^README\.md$ -.gitignore -^cran-comments\.md$ -^revdep$ -man-roxygen/* diff --git a/.gitignore b/.gitignore index d9f5f208..ce31f665 100644 --- a/.gitignore +++ b/.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 diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index dccf4d45..00000000 --- a/.travis.yml +++ /dev/null @@ -1,9 +0,0 @@ -language: r -r: devel -cache: packages - -r_github_packages: - - jimhester/covr - -after_success: - - Rscript -e 'covr::codecov(function_exclusions = c("launch$", "launch_shinystan_demo"), line_exclusions = list("R/zzz.R"))' \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 6940dc7a..36f9c711 100644 --- a/DESCRIPTION +++ b/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 diff --git a/inst/ShinyStan/.gitignore b/inst/ShinyStan/.gitignore new file mode 100644 index 00000000..87bf2851 --- /dev/null +++ b/inst/ShinyStan/.gitignore @@ -0,0 +1 @@ +server_utils_changeres.R diff --git a/inst/ShinyStan/global_utils.R b/inst/ShinyStan/global_utils.R index 22344315..a9e6e01f 100644 --- a/inst/ShinyStan/global_utils.R +++ b/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)) diff --git a/inst/ShinyStan/helper_functions/shinystan_helpers.R b/inst/ShinyStan/helper_functions/shinystan_helpers.R index 3de549e5..eeb38a51 100644 --- a/inst/ShinyStan/helper_functions/shinystan_helpers.R +++ b/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")) +} diff --git a/inst/ShinyStan/markdown/about_video.Rmd b/inst/ShinyStan/markdown/about_video.Rmd new file mode 100644 index 00000000..21e01202 --- /dev/null +++ b/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 . 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. + diff --git a/inst/ShinyStan/markdown/about_video.md b/inst/ShinyStan/markdown/about_video.md new file mode 100644 index 00000000..8db6f82b --- /dev/null +++ b/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 . 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. + diff --git a/inst/ShinyStan/server.R b/inst/ShinyStan/server.R index d2374d47..c9ce22eb 100644 --- a/inst/ShinyStan/server.R +++ b/inst/ShinyStan/server.R @@ -10,6 +10,8 @@ SERVER_FILES <- server_files[!server_files %in% path_to_extract_sso] source("global_utils.R", local = TRUE) source("server_utils.R", local = TRUE) source(path_to_extract_sso, local = TRUE) +# source functions for video creation +source(server_files[grepl("new_saveVideo.R",server_files)],local=TRUE) # BEGIN server ------------------------------------------------------ # ___________________________________________________________________ @@ -38,7 +40,7 @@ function(input, output, session) { # Toggle options dropdowns options_trigger_ids <- c("table", "multiparam", "autocorr", "rhat_warnings", - "bivariate", "trivariate", "density", "hist") + "bivariate", "trivariate", "density", "hist","animate") observe({ lapply(seq_along(options_trigger_ids), function(j) { shinyjs::onclick( diff --git a/inst/ShinyStan/server_files/pages/explore/server/animate.R b/inst/ShinyStan/server_files/pages/explore/server/animate.R new file mode 100644 index 00000000..539ec473 --- /dev/null +++ b/inst/ShinyStan/server_files/pages/explore/server/animate.R @@ -0,0 +1,87 @@ +# animate scatterplot options + +animate_plot <- reactive({ + validate( + need(input$param, message = FALSE), + need(input$animate_ellipse_lev, message = FALSE), + need(input$animate_param_x, message = FALSE) + ) + + if(length(input$animate_param_x)>1) + validate(need(input$animate_chain!='All', + message='Please select a specific chain if examining more than one x variable.')) + + + if (!is.null(input$animate_ellipse_lev)) { + validate( + need(is.numeric(input$animate_pt_size), message = "Point size must be numeric"), + need(is.numeric(input$animate_pt_shape), message = "Point shape must be numeric") + ) + + if (input$animate_ellipse_lev != "None") { + validate( + need( + input$param != input$animate_param_x, + "For this option the x and y can't be the same parameter." + ), + need( + is.numeric(input$animate_ellipse_lwd), + message = "Ellipse size must be numeric" + ), + need( + is.numeric(input$animate_ellipse_lty), + message = "Ellipse shape must be numeric" + ) + ) + } + } + + .animate_plot( + samps = SAMPS_all, + sp = SAMPLER_PARAMS, + max_td = if ("max_td" %in% names(MISC)) MISC$max_td else NULL, + param = input$animate_param_y, + param2 = input$animate_param_x, + pt_alpha = input$animate_pt_alpha, + pt_size = input$animate_pt_size, + pt_shape = input$animate_pt_shape, + ellipse_lev = input$animate_ellipse_lev, + ellipse_lty = input$animate_ellipse_lty, + ellipse_lwd = input$animate_ellipse_lwd, + ellipse_alpha = input$animate_ellipse_alpha, + lines = input$animate_lines, + lines_alpha = input$animate_lines_alpha, + transform_x = input$animate_transform_x, + transform_y = input$animate_transform_y, + this_chain = input$animate_chain, + frame_speed = input$frame_speed, + row_min = input$animate_iters[1], + row_max = input$animate_iters[2], + standardize = input$animate_standardize, + colour_palette = input$animate_color, + tween_ratio = input$frame_tween, + top_title = input$animate_title, + height = youtube_aspect[[input$animation_quality]]$height, + width = youtube_aspect[[input$animation_quality]]$width, + resolution = input$animate_resolution, + graph_type=input$animate_plot, + num_cores=input$animate_cores + ) +}) + +output$animate_plot_out <- renderUI({ + if(input$animate_now==0) return(includeMarkdown('markdown/about_video.md')) + # Return a list with a src attribute that equals the location of the WEBM file + output_info <- isolate(animate_plot()) + tags$video(src=output_info$src,height='500',width='100%',type='video/webm; codecs="vp8.0,vorbis"',controls="controls") +}) + +# download +output$download_animate <- downloadHandler( + filename = 'gg_animate_shinystan_download.webm', + content = function(file) { + + file.copy('www/gg_animate_shinystan.webm',file) + }, + contentType = 'video/webm' +) diff --git a/inst/ShinyStan/server_files/pages/explore/ui/ui_animate_select_y.R b/inst/ShinyStan/server_files/pages/explore/ui/ui_animate_select_y.R new file mode 100644 index 00000000..529626ac --- /dev/null +++ b/inst/ShinyStan/server_files/pages/explore/ui/ui_animate_select_y.R @@ -0,0 +1,9 @@ +output$ui_animate_select_y <- renderUI({ + selectizeInput( + "animate_param_y", + label = strong_bl("y-axis"), + choices = .make_param_list(object), + selected = input$param, + multiple = FALSE + ) +}) \ No newline at end of file diff --git a/inst/ShinyStan/server_files/utilities/new_saveVideo.R b/inst/ShinyStan/server_files/utilities/new_saveVideo.R new file mode 100644 index 00000000..46254f78 --- /dev/null +++ b/inst/ShinyStan/server_files/utilities/new_saveVideo.R @@ -0,0 +1,138 @@ +# Make custom saving function that works better with gg_animate() +# Based on saveVideo function from package animate +# Modified to use resolution and only involve png output for simplicity, also allow for parallel processing + +# helper function for parallel + +over_plots <- function(x,counter_data,directory,width=NULL,height=NULL,resolution=NULL,plots) { + use_data <- counter_data[counter_data$parallel_counter==x,] + files_dir <- file.path(directory,paste0("Rplots_core_",x,"_%d",".png")) + png(files_dir,width = width, + height = height,res=resolution) + for(i in use_data$id) { + plot_ggplot_build(plots[[i]]) + } + dev.off() +} + +make_parallel_counter <- function(x,y) { + remainder <- x%%y + if(remainder==0) { + parallel_counter <- rep(1:y,each=floor(x/y)) + } else { + parallel_counter <- rep(1:y,each=floor(x/y)) + parallel_counter <- c(parallel_counter,rep(y[length(y)],remainder)) + } + return(parallel_counter) +} + + +outputVideo <- function(in_plots, video.name = 'animation.mp4', img.name = 'Rplot', ffmpeg = animation::ani.options('ffmpeg'), + other.opts=NULL, width=NULL,height=NULL,resolution=NULL,frame_speed=NULL,num_cores=1) { + if(num_cores>1) { + num_chain <- num_cores + } else { + num_chain <- 1 + } + + + if(!dir.exists(dirname(video.name))){ + dir.create(dirname(video.name)) + } + + owd <- setwd(tempdir()) + on.exit(setwd(owd), add = TRUE) + + if(is.null(other.opts)) { + + other.opts <- paste0("-c:v libvpx -pix_fmt yuv420p"," -crf 7 -b:v 2M -c:a libvorbis") + } +file.ext <- 'png' +num <- ifelse(file.ext == 'pdf', '', '%d') +unlink(paste(img.name, '*.', file.ext, sep = '')) +save_dir <- tempdir() +img.fmt_template <- paste(img.name, num, '.', file.ext, sep = '') +img.fmt_template <- file.path(save_dir, img.fmt_template) + +counter_data <- data.frame(id=1:length(in_plots$plots), + parallel_counter=make_parallel_counter(length(in_plots$plots),num_chain)) + +parallel::mclapply(1:num_chain,over_plots,width=width,height=height,resolution=resolution,plots=in_plots$plots, + counter_data=counter_data,directory=save_dir, + mc.cores=num_chain) +#Rename to allow sequential video processing +get_files <- list.files(path=save_dir,pattern="Rplots_core_") +cores <- as.numeric(gsub(pattern="_",replacement = "",stringr::str_extract(get_files,"_[0-9]_"))) +filenums <- as.numeric(gsub(pattern="_|.png",replacement = "",stringr::str_extract(get_files,"_[0-9]+.png"))) + +truenums <- filenums + (cores - 1) * length(in_plots$plots) + +truenames <- file.path(save_dir,paste0("Rplot",truenums,'.png')) +file.rename(from = get_files,to=truenames) +## call FFmpeg +ffmpeg <- paste('ffmpeg', '-y', '-framerate',frame_speed, '-i', + basename(img.fmt_template), other.opts, basename(video.name)) +message('Executing: ', ffmpeg) +cmd <- system(ffmpeg,intern=TRUE) + +if (class(cmd)!= 'try-error') { + setwd(owd) + if(!grepl(save_dir,video.name,fixed = T)) + file.copy(file.path(save_dir, basename(video.name)), video.name, overwrite = TRUE) + message('\n\nVideo has been created at: ', + output.path <- normalizePath(video.name)) +} else { + + message('\n\n Video file creation via ffmpeg failed.') +} + + +} + +# This function is from the gg_animate package, but it is not exported, so it is used here + +plot_ggplot_build <- function (b, newpage = is.null(vp), vp = NULL) +{ + if (newpage) { + grid::grid.newpage() + } + grDevices::recordGraphics(requireNamespace("ggplot2", quietly = TRUE), + list(), getNamespace("ggplot2")) + gtable <- ggplot_gtable(b) + if (is.null(vp)) { + grid::grid.draw(gtable) + } + else { + if (is.character(vp)) + grid::seekViewport(vp) + else grid::pushViewport(vp) + grid::grid.draw(gtable) + grid::upViewport() + } +} + +# This function is a modified version of the gg_animate_save function + +shiny_animate_save <- function(g, filename = NULL,frame_speed, + width,height,resolution,parallel=TRUE,num_cores=1) { + + g$filename <- filename + + # temporarily move to directory (may be current one, that's OK) + # this helps with animation functions like saveGIF that work only in + # current directory + + if(parallel==TRUE && num_cores>1) { + num_cores <- num_cores + } else { + num_cores <- 1 + } + withr::with_dir(dirname(filename), { + outputVideo(g, basename(filename),frame_speed=frame_speed,width=width,height=height,resolution=resolution,num_cores=num_cores) + }) + + g$src <- base64enc::dataURI(file = filename, mime = 'video/webm') + g$mime_type <- 'video/webm' + g$saved <- TRUE + g +} \ No newline at end of file diff --git a/inst/ShinyStan/server_utils.R b/inst/ShinyStan/server_utils.R index a909a53c..cb9bb1be 100644 --- a/inst/ShinyStan/server_utils.R +++ b/inst/ShinyStan/server_utils.R @@ -2,3 +2,8 @@ suppress_and_print <- function(x) { suppressMessages(suppressWarnings(print(x))) } + +# Create help text for video tab in Explore + +knitr::knit('markdown/about_video.Rmd',output='markdown/about_video.md',quiet=TRUE) + diff --git a/inst/ShinyStan/ui_files/PAGE_explore.R b/inst/ShinyStan/ui_files/PAGE_explore.R index f9795285..f33f818d 100644 --- a/inst/ShinyStan/ui_files/PAGE_explore.R +++ b/inst/ShinyStan/ui_files/PAGE_explore.R @@ -98,6 +98,16 @@ tagList( hr(), downloadButton("download_histogram", "ggplot2", class = "plot-download"), downloadButton('save_pdf_histogram', "pdf", class = "plot-download pdf-download") - ) - ) -) \ No newline at end of file + ), + + tabPanel( + title="Animation", + source_ui("animate_select.R"), + source_ui("animate_select2.R"), + a_options("animate"), + source_ui("animate_customize.R"), + htmlOutput("animate_plot_out"), + hr(), + downloadButton("download_animate", "Movie", class = "plot-download") + ) +)) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/animate_customize.R b/inst/ShinyStan/ui_files/animate_customize.R new file mode 100644 index 00000000..b4ea7bd2 --- /dev/null +++ b/inst/ShinyStan/ui_files/animate_customize.R @@ -0,0 +1,156 @@ +shinyjs::hidden( + div(id = "animate_options", + wellPanel( + class = "optionswell", + hr(class='hroptions'), + strongBig('Animation'), + fluidRow( + column(width=2,numericInput("frame_speed",strongMed("Frames per second"),value = 16,min = 1,step = 1), + numericInput("frame_tween",strongMed("Smoothing frames"),value=10,min=1,step=1)), + column(width = 2,selectInput("animate_color",label = strongMed("Color Palette"),choices = row.names(RColorBrewer::brewer.pal.info),selected = "Set1", + multiple = FALSE), + selectInput("animation_quality",strongMed("Select video quality"),choices = names(youtube_aspect),selected = "1080p",multiple = FALSE)), + column(width=2, + selectInput("animate_resolution",strongMed("Resolution (pixels)"),choices=c("Automatic",seq(from=10,to=500,by=10)),multiple = FALSE,selected = "Automatic"), + checkboxInput("animate_title",strongMed("Frame counter?"),value=FALSE)), + column(width=2, + selectInput("animate_plot",strongMed("Plot Type"),choices=c("Scatterplot","Density"),multiple=FALSE,selected="Scatterplot"), + numericInput('animate_cores',strongMed('Number of Cores (Parallel)'),1,min=1,step=1)) + ), + hr(class = "hroptions"), + strongBig("Transformation"), + transform_helpText("x,y"), + fluidRow( + column(width = 3, transformation_selectInput("animate_transform_y")), + column(width = 3, transformation_selectInput("animate_transform_x")) + ), + hr(class = "hroptions"), + selectInput( + "animate_options_display", + label = strongBig("Control"), + choices = c("Points", "Ellipse", "Lines"), + selected = "Points", + width = "50%" + ), + conditionalPanel( + condition = "input.animate_options_display == 'Points'", + fluidRow( + column( + width = 2, + numericInput( + "animate_pt_size", + strongMed("Size"), + value = 3.5, + min = 0, + max = 10, + step = 0.5 + ) + ), + column( + width = 2, + numericInput( + "animate_pt_shape", + strongMed("Shape"), + value = 10, + min = 1, + max = 10, + step = 1 + ) + ), + column( + width = 2, + sliderInput( + "animate_pt_alpha", + strongMed("Opacity"), + value = alpha_calc_pt(.nIter), + min = 0, + max = 1, + step = 0.01, + ticks = FALSE + ) + ) + )), + conditionalPanel( + condition = "input.animate_options_display == 'Ellipse'", + fluidRow( + column( + width = 2, + selectizeInput( + inputId = "animate_ellipse_lev", + label = strongMed("Type"), + selected = "None", + choices = list( + "None" = "None", + "50%" = 0.5, + "80%" = 0.8, + "95%" = 0.95, + "99%" = 0.99 + ) + ) + ), + column( + width = 2, + numericInput( + "animate_ellipse_lwd", + strongMed("Size"), + value = 1, + min = 0, + max = 5, + step = 0.5 + ) + ), + column( + width = 2, + numericInput( + "animate_ellipse_lty", + strongMed("Shape"), + value = 1, + min = 1, + max = 6, + step = 1 + ) + ), + column( + width = 2, + sliderInput( + "animate_ellipse_alpha", + strongMed("Opacity"), + value = 1, + min = 0, + max = 1, + step = 0.01, + ticks = FALSE + ) + ) + ) + ), + conditionalPanel( + condition = "input.animate_options_display == 'Lines'", + fluidRow( + column( + width = 2, + selectizeInput( + inputId = "animate_lines", + label = strongMed("Position"), + choices = c(Hide = "hide", Back = "back", Front = "front"), + selected = "back" + ) + ), + column( + width = 2, + sliderInput( + "animate_lines_alpha", + label = strongMed("Opacity"), + value = alpha_calc_lines(.nIter), + min = 0, + max = 1, + step = 0.01, + ticks = FALSE + ) + ) + ) + ) + ) + ) +) + diff --git a/inst/ShinyStan/ui_files/animate_select.R b/inst/ShinyStan/ui_files/animate_select.R new file mode 100644 index 00000000..ffe458a1 --- /dev/null +++ b/inst/ShinyStan/ui_files/animate_select.R @@ -0,0 +1,26 @@ +fluidRow( + column( + width = 2, + uiOutput("ui_animate_select_y") + ), + column( + width = 3, + selectizeInput( + "animate_param_x", + label = strong_bl("x-axis"), + choices = .param_list, + selected = if (length(unlist(.param_list)) > 1) + unlist(.param_list)[2] else unlist(.param_list)[1], + multiple = TRUE + ) + ), + column( + width=2, + selectInput("animate_chain",label = strong_bl("chain"),choices=c("All",1:.nChains),selected = "All") + ), + column( + width=2, + strong_bl("click to start"), + actionButton("animate_now","Create Animation") + ) +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_files/animate_select2.R b/inst/ShinyStan/ui_files/animate_select2.R new file mode 100644 index 00000000..06e689a8 --- /dev/null +++ b/inst/ShinyStan/ui_files/animate_select2.R @@ -0,0 +1,11 @@ +fluidRow( + column( + width = 6, + sliderInput("animate_iters",strong_bl("Select iterations: "), + min=1,max=.nIter, + value=c(pmax(.nIter - 50, (.nIter - round(.nIter*.5))),.nIter),step=1,round=TRUE,width='100%')), + column( + width=2, + checkboxInput("animate_standardize","Standardize X variables?",value=FALSE) + ) +) \ No newline at end of file diff --git a/inst/ShinyStan/ui_utils.R b/inst/ShinyStan/ui_utils.R index 676ddd8b..559baf9f 100644 --- a/inst/ShinyStan/ui_utils.R +++ b/inst/ShinyStan/ui_utils.R @@ -214,3 +214,6 @@ if (exists("object")) if (exists(".SHINYSTAN_OBJECT")) rm(.SHINYSTAN_OBJECT) gc() + + + diff --git a/inst/ShinyStan/www/.gitignore b/inst/ShinyStan/www/.gitignore new file mode 100644 index 00000000..b6977fa4 --- /dev/null +++ b/inst/ShinyStan/www/.gitignore @@ -0,0 +1 @@ +gg_animate_shinystan.webm diff --git a/inst/ShinyStan/www/gg_animate_shinystan.webm b/inst/ShinyStan/www/gg_animate_shinystan.webm new file mode 100644 index 00000000..e8dc6720 Binary files /dev/null and b/inst/ShinyStan/www/gg_animate_shinystan.webm differ diff --git a/shinystan_develop.Rproj b/shinystan_develop.Rproj new file mode 100644 index 00000000..21a4da08 --- /dev/null +++ b/shinystan_develop.Rproj @@ -0,0 +1,17 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source diff --git a/tests/gg_animate_test.R b/tests/gg_animate_test.R new file mode 100644 index 00000000..45ef765b --- /dev/null +++ b/tests/gg_animate_test.R @@ -0,0 +1,45 @@ +# Use case for shinystan with animation tab + +require(rstan) +devtools::load_all(".") +excode <- ' + transformed data { +int N; +real y[20]; +y[1] <- 0.5796; y[2] <- 0.2276; y[3] <- -0.2959; +y[4] <- -0.3742; y[5] <- 0.3885; y[6] <- -2.1585; +y[7] <- 0.7111; y[8] <- 1.4424; y[9] <- 2.5430; +y[10] <- 0.3746; y[11] <- 0.4773; y[12] <- 0.1803; +y[13] <- 0.5215; y[14] <- -1.6044; y[15] <- -0.6703; +y[16] <- 0.9459; y[17] <- -0.382; y[18] <- 0.7619; +y[19] <- 0.1006; y[20] <- -1.7461; +N <- 20; +} +parameters { +real mu; +real sigma; +vector[2] z[3]; +real alpha; +} +model { +y ~ normal(mu, sigma); +for (i in 1:3) +z[i] ~ normal(0, 1); +alpha ~ exponential(2); +} +generated quantities { + vector[N] log_lik; + for (n in 1:N) + log_lik[n] <- normal_log(y[n],mu,sigma); +} +' + +exfit <- stan(model_code = excode, save_dso = FALSE, iter = 200,chains = 4) +print(exfit) +plot(exfit) + +exfit2 <- as.shinystan(exfit) + +#load shiny_animate and test + +launch_shinystan(exfit)