pre-init shinyproxy

Author: alexvpickering

Dockerfile

@@ -88,9 +88,6 @@ RUN R -e "install.packages(repos=NULL, '.')" && \
 #-----------
 from common AS production
 
-# add runner
-COPY inst/run.R .
-
 # ----------
 # TESTING
 #-----------

NAMESPACE

@@ -5,20 +5,25 @@ export(bulkPage)
 export(bulkPageUI)
 export(check_has_scseq)
 export(clean_kb_scseq)
+export(dir_exists)
 export(download_kb_index)
 export(drugsPage)
 export(drugsPageUI)
+export(file_exists)
 export(from_crossmeta)
 export(getDeleteRowButtons)
 export(get_expression_colors)
 export(get_palette)
 export(get_presto_markers)
 export(get_species)
 export(init_dseqr)
+export(isTruthy)
 export(load_scseq_qs)
+export(make_unique)
 export(navbar2UI)
 export(navbarUI)
 export(qread.safe)
+export(req)
 export(run_dseqr)
 export(run_kb_scseq)
 export(scPage)

R/modules-sc-utils.R

@@ -2538,17 +2538,38 @@ get_expression_colors <- function(ft.scaled) {
   return(colors)
 }
 
+#' Safe file.exists
+#'
+#' @param x file path
+#'
+#' @return a logical vector of TRUE or FALSE values
+#' @export
+#'
 file_exists <- function(x) {
   if (!length(x)) return(FALSE)
   file.exists(x)
 }
 
+#' Safe dir.exists
+#'
+#' @param x directory path
+#'
+#' @return a logical vector of TRUE or FALSE values
+#' @export
+#'
 dir_exists <- function(x) {
   if (!length(x)) return(FALSE)
   dir.exists(x)
 }
 
 
+#' Truthy and falsy values
+#'
+#' @param x An expression whose truthiness value we want to determine
+#'
+#' @return a logical vector of TRUE or FALSE values
+#' @export
+#'
 isTruthy <- function(x) {
   if (inherits(x, 'try-error'))
     return(FALSE)
@@ -2571,6 +2592,14 @@ isTruthy <- function(x) {
   return(TRUE)
 }
 
+#' Check for required values
+#'
+#' @param ... Values to check for truthiness.
+#' @param cancelOutput
+#'
+#' @return The first value that was passed in.
+#' @export
+#'
 req <- function(..., cancelOutput = FALSE) {
   shiny:::dotloop(function(item) {
     if (!isTruthy(item)) {
@@ -2588,8 +2617,16 @@ req <- function(..., cancelOutput = FALSE) {
     invisible()
 }
 
-make_unique <- function(x, sep = ".") {
-  x <- as.character(x)
-  make.unique(x, sep = sep)
+#' Make Character Strings Unique
+#'
+#' @param names a character vector.
+#' @param sep a character string used to separate a duplicate name from its sequence number.
+#'
+#' @return A character vector of same length as names with duplicates changed, in the current locale's encoding.
+#' @export
+#'
+make_unique <- function(names, sep = ".") {
+  names <- as.character(names)
+  make.unique(names, sep = sep)
 }
 

R/run_dseqr.R

@@ -36,11 +36,11 @@
 #' if (interactive()) {
 #'
 #'   data_dir <- tempdir()
-#'   user_name <- 'example'
-#'   run_dseqr(user_name, data_dir)
+#'   app_name <- 'example'
+#'   run_dseqr(app_name, data_dir)
 #' }
 #'
-run_dseqr <- function(user_name,
+run_dseqr <- function(app_name,
                       data_dir,
                       tabs = c('Single Cell', 'Bulk Data', 'Drugs'),
                       pert_query_dir = file.path(data_dir, '.pert_query_dir'),
@@ -66,7 +66,7 @@ run_dseqr <- function(user_name,
   opts <- list()
 
   # on remote: send errors to slack
-  if (!is_local) opts$shiny.error <- function() send_slack_error(user_name)
+  if (!is_local) opts$shiny.error <- function() send_slack_error(app_name)
 
   # allow up to 30GB uploads
   opts$shiny.maxRequestSize <- 30*1024*1024^2
@@ -91,8 +91,8 @@ run_dseqr <- function(user_name,
 
   if (missing(data_dir)) stop('data_dir not specified.')
 
-  user_dir <- file.path(data_dir, user_name)
-  if (!dir_exists(user_dir)) init_dseqr(user_name, data_dir)
+  # user_dir <- file.path(data_dir, app_name)
+  # if (!dir_exists(user_dir)) init_dseqr(app_name, data_dir)
 
   # ensure various directories exist
   # duplicated in server.R for tests
@@ -101,7 +101,8 @@ run_dseqr <- function(user_name,
 
   # pass arguments to app through options then run
   shiny::shinyOptions(
-    user_dir = normalizePath(user_dir),
+    data_dir = normalizePath(data_dir),
+    app_name = app_name,
     pert_query_dir = normalizePath(pert_query_dir),
     pert_signature_dir = normalizePath(pert_signature_dir),
     gs_dir = normalizePath(gs_dir),
@@ -153,3 +154,22 @@ init_dseqr <- function(user_name, data_dir = '/srv/dseqr') {
   dir.create(file.path(default_dir, 'custom_queries'))
 
 }
+
+run_dseqr_shinyproxy <- function(project_name, host_url) {
+
+  is_example <- project_name == 'example'
+
+  logout_url <- sprintf('https://%s/logout', host_url)
+
+  message('project_name: ', project_name)
+  message('is_example: ', is_example)
+  message('logout_url: ', logout_url)
+
+  # where to download/load drug and reference data from dseqr.data
+  Sys.setenv('DSEQR_DATA_PATH' = '/srv/dseqr/.data')
+
+  run_dseqr(project_name,
+            logout_url = logout_url,
+            is_example = is_example)
+
+}

inst/app/server.R

@@ -71,8 +71,8 @@ server <- function(input, output, session) {
   # shiny::shinyOptions don't make it through
 
   # base directory contains data_dir folder
-  user_dir <- getShinyOption('user_dir', 'tests/testthat/test_data_dir/test_user')
-  data_dir <- dirname(user_dir)
+  app_name <- getShinyOption('app_name', 'test_app')
+  data_dir <- getShinyOption('data_dir', 'tests/testthat/test_data_dir/')
 
   # path where pert queries will be stored
   pert_query_dir <- getShinyOption('pert_query_dir', file.path(data_dir, '.pert_query_dir'))
@@ -92,13 +92,6 @@ server <- function(input, output, session) {
   is_example <- getShinyOption('is_example', FALSE)
   is_local <- getShinyOption('is_local', TRUE)
 
-  # reset testing data
-  if (isTRUE(getOption('shiny.testmode'))) {
-    unlink(data_dir, recursive = TRUE)
-    user_name <- basename(user_dir)
-    dseqr::init_dseqr(user_name, data_dir)
-  }
-
   # ensure various directories exist
   # duplicated here and in run_dseqr for tests
   app_dirs <- c(pert_query_dir, pert_signature_dir, indices_dir, tx2gene_dir, gs_dir)
@@ -108,6 +101,29 @@ server <- function(input, output, session) {
   # hide tour button for docs page
   observe(shinyjs::toggleClass('start_tour', 'invisible', condition = input$tab == 'Docs'))
 
+  user_name <- reactive({
+    if (app_name == 'example' || is_local) return(app_name)
+
+    # app_name is 'private'
+    user_name <- session$request$HTTP_X_SP_USERID
+    print('user_name!!!!')
+    print(user_name)
+    return(user_name)
+  })
+
+  user_dir <- reactive({
+    user_name <- user_name()
+    user_dir <- file.path(data_dir, user_name)
+
+    # reset testing data
+    if (isTRUE(getOption('shiny.testmode')))
+      unlink(data_dir, recursive = TRUE)
+
+    if (!dir_exists(user_dir))
+      init_dseqr(user_name, data_dir)
+
+    return(user_dir)
+  })
 
   # rintrojs
   observeEvent(input$start_tour, {
@@ -164,9 +180,12 @@ server <- function(input, output, session) {
   }
 
   # selecting the project
-  project_choices <- reactiveVal(
-    list.dirs(user_dir, recursive = FALSE, full.names = FALSE)
-  )
+  project_choices <- reactiveVal()
+
+  observe({
+    choices <- list.dirs(user_dir(), recursive = FALSE, full.names = FALSE)
+    project_choices(choices)
+  })
 
   observeEvent(input$select_project, {
     req(!is_example)
@@ -176,16 +195,18 @@ server <- function(input, output, session) {
 
   projects_table <- reactive({
     projects <- project_choices()
+    project <- project()
+    req(project)
 
-    nsc <- sapply(projects, get_num_sc_datasets, user_dir)
-    nbulk <- sapply(projects, get_num_bulk_datasets, user_dir)
+    nsc <- sapply(projects, get_num_sc_datasets, user_dir())
+    nbulk <- sapply(projects, get_num_bulk_datasets, user_dir())
 
     df <- data.frame(
       ` ` = getDeleteRowButtons(session, length(projects), title = 'Delete project'),
       'Project' = projects,
       'Single Cell Datasets' = nsc,
       'Bulk Datasets' = nbulk,
-      selected = ifelse(projects == project(), 'hl', 'other'),
+      selected = ifelse(projects == project, 'hl', 'other'),
       check.names = FALSE,
       row.names = NULL
     )
@@ -322,7 +343,7 @@ server <- function(input, output, session) {
     }
 
     # remove data
-    unlink(file.path(user_dir, del), recursive = TRUE)
+    unlink(file.path(user_dir(), del), recursive = TRUE)
     removeModal()
   })
 
@@ -344,14 +365,14 @@ server <- function(input, output, session) {
     choices[info$row] <- new
     project_choices(choices)
 
-    new_dir <- file.path(user_dir, new)
+    new_dir <- file.path(user_dir(), new)
 
     if (prev == "") {
       dir.create(new_dir, showWarnings = FALSE)
       return(NULL)
     }
 
-    prev_dir <- file.path(user_dir, prev)
+    prev_dir <- file.path(user_dir(), prev)
 
     if (dir_exists(prev_dir))
       file.rename(prev_dir, new_dir)
@@ -360,21 +381,36 @@ server <- function(input, output, session) {
 
   })
 
-  observe(qs::qsave(project(), prev_path))
+  observe({
+    project <- project()
+    req(project)
+    qs::qsave(project, prev_path())
+  })
+
 
+  project_dir <- reactive(file.path(user_dir(), project()))
+  prev_path <- reactive(file.path(user_dir(), 'prev_project.qs'))
 
-  prev_path <- file.path(user_dir, 'prev_project.qs')
-  project <- reactiveVal(qread.safe(prev_path, .nofile = 'default'))
-  project_dir <- reactive(file.path(user_dir, project()))
+  project <- reactiveVal()
+
+  observe({
+    project(qread.safe(prev_path(), .nofile = 'default'))
+  })
 
   sc_dir <- reactive({
-    sc_dir <- file.path(user_dir, project(), 'single-cell')
+    project <- project()
+    req(project)
+
+    sc_dir <- file.path(user_dir(), project, 'single-cell')
     dir.create(sc_dir, showWarnings = FALSE)
     return(sc_dir)
   })
 
   bulk_dir <- reactive({
-    bulk_dir <- file.path(user_dir, project(), 'bulk')
+    project <- project()
+    req(project)
+
+    bulk_dir <- file.path(user_dir(), project, 'bulk')
     dir.create(bulk_dir, showWarnings = FALSE)
     return(bulk_dir)
   })
@@ -411,7 +447,7 @@ server <- function(input, output, session) {
     project <- project()
     slack <- readRDS(system.file('extdata/slack.rds', package = 'dseqr'))
 
-    workspace <- basename(user_dir)
+    workspace <- basename(user_dir())
     workspace <- ifelse(workspace == user, 'private', workspace)
 
     httr::POST(