Merge pull request #37 from priism-center/dev

updates to variable selection page

README.md

@@ -29,3 +29,4 @@ You can run the latest development version locally by executing the below R code
 remotes::install_github('priism-center/thinkCausal_dev', subdir = 'thinkCausal')
 thinkCausal::run_app()
 ```
+

scratch/potential_outcomes_two.Rmd

@@ -69,7 +69,7 @@ lm(Y ~ Z + first.race, dat)
 With all potential outcomes we could know about the causal effect of HyperShoes for a specific runner. For example, we can see that wearing HyperShoes caused runner 2 to run 13 minutes faster than they would have ran with standard shoes. On the other hand,  HyperShoes caused runner X to run Y minutes slower than they would have run with standard shoes. The causal effect of HyperShoes is different for each runner!
 
 ```{r}
-p1 <- dat[1:10, ] %>% 
+p1 <- dat[c(2, 7, 6, 99), ] %>% 
   pivot_longer(cols = c(Y0, Y1)) %>% 
   ggplot(aes(name, value, col = name, label = runner)) + 
   geom_line(aes(group = runner), col = 'black', linetype = 2) + 
@@ -89,7 +89,6 @@ p2 <- dat %>%
 
 p1 
  
-
 ```
 
 With all potential outcomes we could easily determine the causal effect of HyperShoes for across our sample of runners. If we take the average difference between each runners Y1 and each runners Y0 the average causal effect of HyperShoes in this sample is -4.07. On average, HyperShoes do cause faster running in this sample!
@@ -214,12 +213,18 @@ reactable(dat3, columns = list(
 
 
 ```{r}
+dat3$ITE_true <- with(dat, Y1 - Y0)
+
 dat3 %>% 
-  arrange(ITE) %>% 
-  mutate(rank = 1:nrow(dat3)) %>% 
-ggplot(aes(runner, ITE)) + 
+  pivot_longer(contains('ITE')) %>% 
+ggplot(aes(runner, value, col = name, shape = name)) + 
   geom_point() + 
-  geom_hline(yintercept = mean(dat3$ITE)) + 
+  scale_color_manual(values = c(1, 6)) + 
+  scale_shape_manual(values = c(19, 21)) + 
+  #geom_hline(aes(yintercept = mean(value), col = name)) + 
+  geom_hline(yintercept = mean(dat3$ITE)) +   
+  geom_hline(yintercept = mean(dat3$ITE_true), col = 6) + 
+  geom_area(aes(runner)) + 
   theme_bw()
  
 ```
@@ -328,4 +333,4 @@ geom_histogram(col = 'black')
 
 ## A visit from the oracle 
 
-How do we know whether or not we should beleive these estimates?
+How do we know whether or not we should beleive these estimates?

thinkCausal/R/app_server.R

@@ -72,7 +72,7 @@ app_server <- function(input, output, session) {
 
   # mobile popup warning
   # TODO: this can be removed for native installation
-  observe(if (shinybrowser::get_device() == 'Mobile') show_popup_mobile(session))
+  observe(if (isTRUE(shinybrowser::is_device_mobile())) show_popup_mobile(session))
 
   # toggle side bar help menu
   # bs4Dash::updateControlbar(id = "help-slideover", session = session)

thinkCausal/R/app_ui.R

@@ -174,7 +174,6 @@ app_ui <- function(request) {
             mod_settings_reference_ui(module_ids$settings$reference)
           )
 
-
         )
       ),
 
@@ -314,7 +313,7 @@ app_ui <- function(request) {
       controlbar = bs4Dash::dashboardControlbar(
         mod_help_ui('help'),
         id = 'help-slideover',
-        width = 450
+        width = 500
       ),
 
       footer = bs4Dash::dashboardFooter(

thinkCausal/R/fct_clean.R

@@ -113,10 +113,19 @@ clean_auto_convert_logicals <- function(input_data){
   return(input_data)
 }
 
+clean_detect_continuous_or_logical <- function(x){
+  # used to test if response variable can be modeled by BART
+
+  # continuous and logicals will work
+  classes_good <- c('numeric', 'integer', 'complex', 'logical')
+  if (inherits(x, classes_good)) return(TRUE)
+
+  return(FALSE)
+}
+
 clean_detect_logical <- function(x){
 
   if(inherits(x, 'data.frame')) stop('x cannot be a dataframe')
-
   # is x exclusively in list of pre-determined
   inclusion_list <- c(0, 1, 't', 'f', 'true', 'false')
   x_as_char <- as.character(x)
@@ -125,6 +134,48 @@ clean_detect_logical <- function(x){
   return(is_in_list)
 }
 
+clean_detect_binary <- function(x){
+  if(inherits(x, 'data.frame')) stop('x cannot be a dataframe')
+  is_binary <- ifelse(length(unique(x)) == 2, TRUE, FALSE)
+  return(is_binary)
+}
+
+clean_eval_outcome <- function(x){
+  # is outcome logical or continuous
+  status <- ifelse(clean_detect_continuous_or_logical(x), 'pass', 'fail')
+
+  # if first check fails is outcome a binary
+  if(status == 'fail'){
+    status <- ifelse(clean_detect_binary(x), 'conditional pass', 'fail')
+  }
+
+  result <- switch (status,
+    'pass' = 'pass',
+    'conditional pass' = 'need information',
+    'fail' = 'fail'
+  )
+
+  return(result)
+}
+
+clean_eval_treatment <- function(x){
+  # is treatment a logical
+  status <- ifelse(clean_detect_logical(x), 'pass', 'fail')
+
+  # if first check fails is treatment a binary
+  if(status == 'fail'){
+    status <- ifelse(clean_detect_binary(x), 'conditional pass', 'fail')
+  }
+
+  result <- switch (status,
+                    'pass' = 'pass',
+                    'conditional pass' = 'need information',
+                    'fail' = 'fail'
+  )
+
+  return(result)
+}
+
 #' @title Convert integer-like columns with few levels to a factor
 #'
 #' @description Useful for plotting
@@ -165,6 +216,7 @@ clean_detect_integers <- function(x, n_levels_threshold = 15){
 
   # does x match its self coerced to an integer
   is_integer <- tryCatch(all.equal(x, as.integer(x)),
+                         warning = function(w) FALSE,
                          error = function(e) FALSE)
 
   if (isTRUE(is_integer)){

thinkCausal/R/fct_detect.R

@@ -30,19 +30,6 @@ clean_detect_column_types <- function(.data){
   return(column_types)
 }
 
-clean_detect_continuous_or_logical <- function(x){
-  # used to test if response variable can be modeled by BART
-
-  # continuous and logicals will work
-  classes_good <- c('numeric', 'integer', 'complex', 'logical')
-  if (inherits(x, classes_good)) return(TRUE)
-
-  # if its a categorical and only two levels then it will work
-  classes_maybe <- c('character', 'factor')
-  if (inherits(x, classes_maybe) & length(unique(x)) == 2) return(TRUE)
-
-  return(FALSE)
-}
 
 
 # TODO: should adjust this to accept yes, no

thinkCausal/R/fct_ui.R

@@ -19,8 +19,11 @@ open_help_sidebar <- function(store, section){
   shinyjs::runjs(
     paste0(
       "
-      let y = $('#", selector, "')[0].offsetTop
-      setTimeout(function(){$('#help-slideover .os-viewport')[0].scrollTo({top: y, behavior: 'smooth'}); }, 600);
+      setTimeout(function() {
+        let section = $('#", selector, "')[0];
+        let y = section.offsetTop;
+        $('#help-slideover .os-viewport')[0].scrollTo({top: y, behavior: 'smooth'});
+      }, 600);
       "
     )
   )

thinkCausal/R/mod_analysis_diagnostics.R

@@ -93,7 +93,7 @@ mod_analysis_diagnostics_ui <- function(id){
                                 ),
                                 selectInput(
                                   inputId = ns('convergence'),
-                                  label = 'Paramater:',
+                                  label = 'Parameter:',
                                   choices = c('Average Treatment Effect', 'Sigma')
                                 )
                ),
@@ -421,6 +421,8 @@ mod_analysis_diagnostics_server <- function(id, store){
         p <- plotBart::plot_predicted_common_support(.model = bart_model,
                                                      max_depth = input$overlap_tree_depth,
                                                      rule = input$overlap_rule)
+        p[[1]] <- p[[1]] + store$options$theme_custom
+        p[[2]] <- p[[2]] + store$options$theme_custom
         validate(need(!is.null(p), 'BART overlap rules did not detect any observations to remove!'))
       }else{
         p <- plotBart::plot_common_support(.model = bart_model,

thinkCausal/R/mod_analysis_upload.R

@@ -18,7 +18,7 @@ mod_analysis_upload_ui <- function(id) {
         title = "Upload your data",
         HTML(
           "<p>Data should be rectangular and in wide format where each column represents one variable.</p>
-                        <p> Files can be uploaded from .csv, .txt, Excel (.xlsx), SPSS (.sav) or STATA (.dta) formats.</p>"
+                        <p> Files can be uploaded from .csv, .txt, Excel (.xlsx), SPSS (.sav), R (.Rdata/.rds) or STATA (.dta) formats.</p>"
         ),
         div(
           id = "upload_file_div",
@@ -27,8 +27,8 @@ mod_analysis_upload_ui <- function(id) {
             label = "Choose file:",
             buttonLabel = 'Browse',
             multiple = FALSE,
-            accept = c('.csv', '.txt', '.xlsx', '.sav', '.dta'),
-            placeholder = 'csv, txt, xlsx, sav, or dta'
+            accept = c('.csv', '.txt', '.xlsx', '.sav','.Rdata','.rds', '.dta'),
+            placeholder = 'csv, txt, xlsx, sav, Rdata or dta'
           ),
         ),
         conditionalPanel(
@@ -114,7 +114,7 @@ mod_analysis_upload_server <- function(id, store){
 
         # stop if not one of the accepted file types
         # this should be caught by fileInput() on the UI side
-        accepted_filetypes <- c('csv', 'txt', 'xlsx', 'dta', 'sav')
+        accepted_filetypes <- c('csv', 'txt', 'xlsx', 'dta', 'sav', 'Rdata', 'rds')
         validate(need(
           filetype %in% accepted_filetypes,
           paste(
@@ -124,7 +124,6 @@ mod_analysis_upload_server <- function(id, store){
         ))
 
         tryCatch({
-
           # if it's a txt file then ask the user what the delimiter is
           if (filetype == 'txt'){
             output$show_delim <- reactive(TRUE)
@@ -152,7 +151,14 @@ mod_analysis_upload_server <- function(id, store){
             )
           } else if (filetype == 'sav'){
             uploaded_file <- Hmisc::spss.get(file = filepath)
-          } else stop("File type is invalid")
+          } else if(filetype == 'Rdata'){
+            e <- new.env()
+            name <- load(file = filepath, envir = e)
+            uploaded_file <- e[[name]]
+            rm(e)
+          } else if(filetype == 'rds'){
+            uploaded_file <- readr::read_rds(filepath)
+          }else stop("File type is invalid")
         },
         error = function(e) {
           # return a safeError if a parsing error occurs or if dataset isn't yet uploaded
@@ -191,7 +197,6 @@ mod_analysis_upload_server <- function(id, store){
 
       # retrieve the raw uploaded data frame
       uploaded_df <- uploaded_df()
-
       # auto convert all of the logical columns
       auto_cleaned_df <- clean_auto_convert_logicals(uploaded_df)