Merge pull request #45 from priism-center/dev

Dev

thinkCausal/R/fct_popup.R

@@ -111,6 +111,33 @@ show_popup_learn_common_support <- function(session){
   show_popup(session = session, content)
 }
 
+show_popup_variable_selection_warning <- function(x, session, ns){
+  content <- tags$div(
+    style = 'margin: auto; text-align: left',
+    h5(glue::glue('Currently, there are {x} avalable covaraites not included in the analysis.')),
+    h5('For observational studies in thinkCausal, include all pre-treatment variables in the analysis.'),
+    h5('The only reasons you should exclude a variable from the analysis are:'),
+    h5('  1. The variable is a post-treatment variable (the variable could be effected by the treatment)'),
+    h5('  2. The variable is an ID variable.'),
+    br(),
+    div(
+      class = 'backNextContainer',
+      style = "width:60%;display:inline-block;horizontal-align:center;",
+      actionButton(inputId = ns('analysis_model_variable_selection_popup_stop'),
+                   class = 'nav-path',
+                   label = 'Stay on page and update variable selection'),
+      actionButton(inputId = ns('analysis_model_variable_selection_popup_continue'),
+                   class = 'nav-btn-focus',
+                   label = glue::glue('Continue: All {x} variables are either post-treatment variables or ID variables')),
+      actionButton(inputId = ns('analysis_model_variable_selection_popup_posttreatment'),
+                   class = 'nav-btn-focus',
+                   label = 'Learn more about post-treatment variables')
+    )
+  )
+  show_popup(session = session, content, size = 'l')
+
+}
+
 show_popup_model_no_estimand_warning <- function(session, ns){
   content <- tags$div(
     style = 'margin: auto; text-align: center',

thinkCausal/R/mod_analysis_variable_selection.R

@@ -402,11 +402,7 @@ mod_analysis_variable_selection_server <- function(id, store){
       return(drag_drop_html)
     })
 
-    # create new dataframe when user saves column assignments and move to next page
-    observeEvent(input$analysis_select_button_columnAssignSave, {
-
-      req(store$analysis_data_uploaded_df)
-
+    check_variable_assignment <- reactive({
       # remove any previous dataframes from the store
       store <- remove_downstream_data(store, page = 'select')
 
@@ -549,11 +545,51 @@ mod_analysis_variable_selection_server <- function(id, store){
                           '\n\tblocking variable(s): ', paste0(cols_block, collapse = '; '))
       store$log <- append(store$log, log_event)
 
+    })
+
+
+
+    # create new dataframe when user saves column assignments and move to next page
+    observeEvent(input$analysis_select_button_columnAssignSave, {
+      req(store$analysis_data_uploaded_df)
+      pass_variable <- reactiveVal(length(input$analysis_select_dragdrop_avalable) == 0)
+      # check that all predictors are included, if not launch popup
+      if (isFALSE(pass_variable()) & isTRUE(input$analysis_design == "Observational Study (Treatment not Randomized)")) {
+        show_popup_variable_selection_warning(x = length(input$analysis_select_dragdrop_avalable),
+                                              session, ns = ns)
+
+      }
+
+      validate(need(pass_variable(), ''))
+      check_variable_assignment()
+      # move to next page
+      bs4Dash::updateTabItems(store$session_global, inputId = 'sidebar', selected = 'analysis_verify')
+
+    })
+
+    ## pop up buttons if variable selection warning is activated.
+    ## This means a user has tried to proceed without including all variables in the analysis.
+    # first button adjust variables
+    observeEvent(input$analysis_model_variable_selection_popup_stop, {
+      close_popup(session = session)
+    })
+
+    # second button continue and override warning
+    observeEvent(input$analysis_model_variable_selection_popup_continue, {
+      close_popup(session = session)
+      check_variable_assignment()
       # move to next page
       bs4Dash::updateTabItems(store$session_global, inputId = 'sidebar', selected = 'analysis_verify')
 
     })
 
+    # third button move to learn post-treatment page
+    observeEvent(input$analysis_model_variable_selection_popup_posttreatment, {
+      close_popup(session = session)
+      store$analysis_origin <- 'analysis_select'
+      bs4Dash::updateTabItems(store$session_global, inputId = 'sidebar', selected = 'learn_post_treatment')
+    })
+
   })
   return(store)
 }

thinkCausal/R/mod_learn_post_treatment.R

@@ -72,6 +72,7 @@ mod_learn_post_treatment_ui <- function(id){
         br(),
         br(),
         br(),
+        uiOutput(ns('analysis_return')),
         includeMarkdown(app_sys("app", "www", "learn", "post-treatment", "markdowns", 'post_treatment_citations.md')),
         includeMarkdown(app_sys("app", "www", "learn", "post-treatment", "markdowns", 'post_treatment_learn_more.md'))
       )
@@ -87,6 +88,21 @@ mod_learn_post_treatment_server <- function(id, store){
   moduleServer( id, function(input, output, session){
     ns <- session$ns
 
+    output$analysis_return <- renderUI({
+      req(store$analysis_origin)
+      if(store$analysis_origin == 'analysis_select'){
+        actionButton(ns('analysis_return'), label = 'Return to Analysis', class = 'nav-path')
+
+      }else{
+        NULL
+      }
+    })
+
+    observeEvent(input$analysis_return, {
+      bs4Dash::updateTabItems(store$session_global, inputId = 'sidebar', selected = 'analysis_variable_selection')
+      store$analysis_origin <- NULL
+    })
+
     # run the quiz
     mod_quiz_server(
       id = "quiz", # this should always be quiz