Merge pull request #115 from stan-dev/feature-issue-109-yrep-globalenv

allow selecting y_rep from global environment for ppcs
stan-dev · Apr 28, 2016 · 664cab5 · 664cab5
2 parents f6c6b32 + 1e950ae
commit 664cab5
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 24 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -6,6 +6,7 @@ object (useful for very large objects when you only want to look at a subset of
 parameters).
 * Add **rstanarm** to Suggests (in the DESCRIPTION file) so `rstanarm::pp_check`
 can be called.
+* Allow selecting yrep from global environment for PPcheck
 
 ### Version 2.1.0
 * Compatibility with recent ggplot2 update

diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/server/pp_utils.R
@@ -5,20 +5,7 @@ pp_tests <- reactive({
            need(get_yrep(), message = "Waiting for y_rep \n"))
 })
 
-# y_rep -------------------------------------------------------------------
-get_yrep <- reactive({
-  if (!is.null(pp_yrep)) 
-    return(pp_yrep)
-  else {
-    validate(need(input$yrep_name, message = "Waiting for y_rep"))
-    yreps <- grep(paste0("^",input$yrep_name,"\\["), param_names)
-    out <- samps_post_warmup[,,yreps]
-    dd <- dim(out)
-    out <- array(out, dim = c(prod(dd[1:2]), dd[3]))
-    return(out)
-  }
-})
-
+# y -------------------------------------------------------------------
 get_y <- reactive({
   if (!is.null(pp_y)) return(pp_y)
   else {
@@ -30,6 +17,35 @@ get_y <- reactive({
   }
 })
 
+# y_rep -------------------------------------------------------------------
+has_yrep_name <- reactive({
+  a <- input$yrep_name  # name selected from model parameters / generated quantities
+  b <- input$yrep_name2  # name of object in global environment
+  validate(need(a != "" || b != "", message = "Waiting for y_rep"))
+  if (a != "" && b != "") {
+    validate(need(FALSE, "y_rep can only be specified once"))
+  }
+  TRUE
+})
+get_yrep <- reactive({
+  if (!is.null(pp_yrep)) 
+    return(pp_yrep)
+  else {
+    validate(need(has_yrep_name(), message = "Waiting for y_rep"))
+    if (input$yrep_name2 != "") {
+      return(get(input$yrep_name2))
+    } else {
+      yreps <- grep(paste0("^", input$yrep_name, "\\["), param_names)
+      out <- samps_post_warmup[,, yreps]
+      dd <- dim(out)
+      validate(need(dd[3] == length(as.vector(get_y())), 
+                    message = "ncol(y_rep) should equal length(y)"))
+      out <- array(out, dim = c(prod(dd[1:2]), dd[3]))
+      return(out)
+    }
+  }
+})
+
 # sample_ids_for_hist ------------------------------------------------------
 nrow_yrep <- reactive({
   nrow(get_yrep())

diff --git a/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R b/inst/ShinyStan/server_files/pages/diagnose/ppcheck/ui/pp_get_y_and_yrep.R
@@ -15,11 +15,12 @@
 output$ui_pp_get_y <- renderUI({
   if (is.null(pp_y)) {
     div(
-      h4("Select the appropriate object from your global environment"),
-      selectizeInput("y_name", 
-                     label = span(style = "color: #337ab7;", withMathJax("\\(\\mathbf{y}\\), a vector of observations")), 
+      h4(withMathJax("Select \\(\\mathbf{y}\\) (vector of observations)")),
+      selectizeInput("y_name",
+                     label = "Object from global environment",
                      choices = c("", objects(envir = .GlobalEnv)), 
-                     options = list(placeholder = "Select an object"))
+                     options = list(placeholder = "Select an object"),
+                     width = "50%")
     )
   } 
   else {
@@ -35,12 +36,17 @@ output$ui_pp_get_yrep <- renderUI({
     choices <- lapply(choices, function(i) return(i[1]))
     choices <- unique(unlist(choices))
     div(
-      h4("Select the appropriate parameter name from your model"),
-      selectizeInput("yrep_name", 
-                     label = span(style = "color: #337ab7;", 
-                                  withMathJax("\\(\\mathbf{y^{rep}}\\), posterior predictive replications")), 
-                     choices = c("", choices), 
-                     options = list(placeholder = "Select a parameter name"))
+      h4(withMathJax("Select \\(\\mathbf{y^{rep}}\\) (posterior predictive replications)")),
+      flowLayout(
+        selectizeInput("yrep_name", 
+                       label = "Parameter/generated quantity from model", 
+                       choices = c("", choices), 
+                       options = list(placeholder = "Select a parameter name")),
+        selectizeInput("yrep_name2", 
+                       label = "Or object from global environment", 
+                       choices = c("", objects(envir = .GlobalEnv)), 
+                       options = list(placeholder = "Select an object")) 
+      )
     )
   }
   else {