Solve a couple of bugs

Stan125 · Dec 19, 2018 · 2fd115d · 2fd115d
1 parent 6109133
commit 2fd115d
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 9 deletions.
diff --git a/R/plot_moments.R b/R/plot_moments.R
@@ -150,9 +150,8 @@ plot_moments <- function(model, int_var, pred_data, palette = "default",
     if (samples && uncertainty)
       plot <- plot + geom_ribbon(data = preds_reshaped_mean,
                                  aes_string(ymin = "lowerlim",
-                                            ymax = "upperlim",
-                                            color = NULL),
-                                 alpha = 0.2)
+                                            ymax = "upperlim"),
+                                 alpha = 0.6)
 
   } else if (coltype == "cat") {
     plot <- ground +
@@ -170,17 +169,25 @@ plot_moments <- function(model, int_var, pred_data, palette = "default",
                       col = "black")
   }
 
-  # Add rug if necessary
-  if (rug) {
+  # Add rug if wanted
+  if (rug && coltype == "num") {
     var <- model_data(model, varname = int_var)
     plot <- plot +
       geom_rug(data =
                  data.frame(var,
-                            prediction = unique(preds$prediction)[1],
+                            prediction =
+                              unique(preds_reshaped_mean$prediction)[1],
                             value = 0),
                aes_string(x = "var"),
                sides = "b", alpha = 0.5, color = "black")
   }
+
+  # Don't display rug in discrete cases
+  if (rug && coltype == "cat") {
+    stop("Cannot display a rug plot in discrete cases")
+  }
+
+  # Return plot here
   return(plot)
 }
 

diff --git a/R/vis.R b/R/vis.R
@@ -110,7 +110,7 @@ vis <- function() {
     # Reactive model family
     fam <- reactive({
       if (!is.null(m()))
-        family(m())
+        fam_obtainer(m())
     })
 
     # Got Model and data?
@@ -420,7 +420,20 @@ vis <- function() {
 
         # Rug Plot
         infl_sidebar[[length(infl_sidebar) + 1]] <-
-          checkboxInput("infl_rug", label = "Rug Plot?", value = TRUE)
+          checkboxInput("infl_rug", label = "Rug Plot?", value = FALSE)
+
+        # If we analyze a bamlss model there is the ability to compute estimate based on samples
+        if (is.bamlss(fam())) {
+          # Samples
+          infl_sidebar[[length(infl_sidebar) + 1]] <-
+            checkboxInput("infl_samples",
+                          label = "Compute estimate based on samples?",
+                          value = FALSE)
+
+          # Uncertainty Measures
+          infl_sidebar[[length(infl_sidebar) + 1]] <-
+            checkboxInput("infl_uncertainty", label = "Uncertainty measures", value = FALSE)
+        }
 
         # Get the code
         infl_sidebar[[length(infl_sidebar) + 1]] <-
@@ -503,7 +516,9 @@ vis <- function() {
                      pred$data,
                      palette = input$infl_pal_choices,
                      ex_fun = input$infl_exfun,
-                     rug = input$infl_rug)
+                     rug = input$infl_rug,
+                     samples = input$infl_samples,
+                     uncertainty = input$infl_uncertainty)
     })
 
   }