Handle search/hash URL components and custom app locations

.Rbuildignore

@@ -1,3 +1,4 @@
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^LICENSE\.md$
+^inst/tmp$

DESCRIPTION

@@ -1,9 +1,10 @@
 Package: blaze
 Type: Package
 Title: Observe URL Paths with 'shiny'
-Version: 0.0.1
+Version: 0.0.1.9000
 Author: c(
-    person("Nathan", "Teetor", email = "[email protected]", role = c("aut", "cre")))
+    person("Nathan", "Teetor", email = "[email protected]", role = c("aut", "cre")),
+    person("Garrick", "Aden-Buie", email = "[email protected]", role = c("ctb"),  comment = c(ORCID = "0000-0002-7111-0077")))
 Maintainer: Nathan Teetor <[email protected]>
 Description: Simulate routing within a 'shiny' application by observering
     and reacting to URL changes. 'shiny' applications are considered single page
@@ -12,12 +13,13 @@ Description: Simulate routing within a 'shiny' application by observering
 License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.0.2
+RoxygenNote: 7.1.1
 Imports: 
     fs,
     htmltools,
     rematch2,
     rlang,
-    shiny
+    shiny,
+    utils
 Suggests: 
     testthat

NAMESPACE

@@ -1,9 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as_paths,character)
+S3method(as_paths,list)
+S3method(as_paths,yml)
+export(blaze)
 export(getPath)
 export(observePath)
-export(param)
 export(pathLink)
+export(paths)
 export(pushPath)
 importFrom(fs,dir_create)
 importFrom(fs,dir_delete)

R/blaze.R

@@ -19,26 +19,27 @@ NULL
 #'
 #' Using path link elements (a variation of standard hyperlinks) users can
 #' browse to different URL paths. A shiny application can detect these changes
-#' with `observePath()` allowing you to update tab sets or other dynamic
-#' elements within the application. `pushPath()` lets you redirect the user from
+#' with [observePath()] allowing you to update tab sets or other dynamic
+#' elements within the application. [pushPath()] lets you redirect the user from
 #' the server.
 #'
 #' Because of how shiny handles URL paths be sure to run the
-#' `paths()` function before launching an application.
+#' [paths()] function before launching an application.
 #'
 #' @name blaze
 "_PACKAGE"
 
 #' @section Including in a shiny app:
 #'
-#' To use blaze with a shiny application the `blaze()` function must be called
+#' To use blaze with a shiny application the [blaze()] function must be called
 #' inside the application's UI.
 #'
 #' @rdname blaze
+#' @export
 blaze <- function() {
   htmltools::htmlDependency(
     name = "blaze",
-    version = packageVersion("blaze"),
+    version = utils::packageVersion("blaze"),
     src = c(
       file = path_package("blaze", "www", "js"),
       href = "blaze/js"

R/link.R

@@ -4,13 +4,13 @@
 #' let the user browse to different parts of your application without refreshing
 #' the current page.
 #'
-#' @param ... Arguments passed to `htmltools::a()`.
+#' @param ... Arguments passed to [htmltools::a()].
 #'
 #' @param href A character string specifying the URL path to navigate to.
 #'
 #' @export
 pathLink <- function(href, ...) {
   stopifnot(is.character(href))
 
-  htmltools::a(..., href = href, `data-blaze` = NA)
+  htmltools::a(..., href = path_app(href), `data-blaze` = NA)
 }

R/paths.R

@@ -23,7 +23,73 @@ paths_remove <- function(p) {
   .globals$paths[[p]] <- NULL
 }
 
-paths <- function(...) {
+#' Declare Paths for Use with Shiny
+#'
+#' Declare path endpoints that will be available inside your Shiny app. This
+#' function should be called before the call to [shiny::shinyApp()] in your
+#' `app.R` file or inside your `server.R` script before the server function.
+#' This function makes it possible for users to enter your app URL with a path,
+#' e.g. `<myapp.com>/about`, and be directed to the `"about"` page within your
+#' Shiny app.
+#'
+#' @examples
+#' \dontrun{
+#' library(shiny)
+#' library(blaze)
+#'
+#' options(shiny.launch.browser = TRUE)
+#'
+#' blaze::paths(
+#'   "home",
+#'   "about",
+#'   "explore"
+#' )
+#'
+#' shinyApp(
+#'   ui = fluidPage(
+#'     blaze(),
+#'     tags$nav(
+#'       pathLink("/home", "Home"),
+#'       pathLink("/about", "About"),
+#'       pathLink("/explore", "Explore")
+#'     ),
+#'     uiOutput("page")
+#'   ),
+#'   server = function(input, output, session) {
+#'     state <- reactiveValues(page = NULL)
+#'
+#'     observePath("/home", {
+#'       state$page <- "Home is where the heart is."
+#'     })
+#'
+#'     observePath("/about", {
+#'       state$page <- "About this, about that."
+#'     })
+#'
+#'     observePath("/explore", {
+#'       state$page <- div(
+#'         p("Curabitur blandit tempus porttitor."),
+#'         p("Vivamus sagittis lacus augue rutrum dolor auctor.")
+#'       )
+#'     })
+#'
+#'     output$page <- renderUI(state$page)
+#'   }
+#' )
+#' }
+#'
+#' @param ... Path names as character strings that will be valid entry points
+#'   into your Shiny app.
+#'
+#' @param app_path The name of the sub-directory where your Shiny app is hosted,
+#'  e.g. `host.com/<app_path>/`.
+#'
+#' @return Invisibly writes temporary HTML files to be hosted by Shiny to
+#'   redirect users to the requested path within your Shiny app. The [paths()]
+#'   function returns the temporary folder used by \pkg{blaze}.
+#'
+#' @export
+paths <- function(..., app_path = NULL) {
   args <- lapply(list(...), as_paths)
   routes <- unique(unlist(args))
   tmp <- path(tempdir(check = TRUE), "blaze")
@@ -34,28 +100,43 @@ paths <- function(...) {
   old <- setwd(tmp)
   on.exit(setwd(old))
 
+  .globals$app_path <- if (!is.null(app_path)) {
+    app_path <- gsub("^/|/$", "", app_path)
+    dir_create(app_path, recurse = TRUE)
+    app_path
+  }
+
   lapply(routes, function(route) {
+    if (!is.null(app_path)) route <- path(app_path, route)
     dir_create(route)
   })
 
-  dirs <- dir_ls(tmp, recurse = FALSE, type = "directory")
+  app_dir <- if (is.null(app_path)) tmp else path(tmp, app_path)
+  dirs <- dir_ls(app_dir, recurse = FALSE, type = "directory")
   prefixes <- path_file(dirs)
 
   Map(p = prefixes, dir = dirs, paths_add)
 
-  dir_walk(recurse = TRUE, type = "directory", fun = function(d) {
+  dir_walk(app_dir, recurse = TRUE, type = "directory", fun = function(d) {
     index <- file_create(path(d, "index.html"))
 
     if (!grepl("^/", d)) {
       d <- paste0("/", d)
     }
 
+    app_redirect <- if (is.null(app_path)) "" else paste0("/", app_path)
+
     cat(file = index, sprintf("
       <!DOCTYPE html>
       <html>
-      <head><script>window.location.replace(\"/?redirect=%s\")</script></head>
+      <head><script>
+      // blaze: redirect /<pathname> to Shiny app using URL search query
+      let {origin, pathname, search, hash} = window.location
+      search = (search ? search + '&' : '?') + `redirect=${pathname}`
+      window.location.replace(origin + '%s' + search + hash)
+      </script></head>
       <body>Redirecting</body>
-      </html>", d
+      </html>", app_redirect
     ))
   })
 
@@ -66,6 +147,7 @@ as_paths <- function(x, ...) {
   UseMethod("as_paths", x)
 }
 
+#' @export
 as_paths.character <- function(x, ...) {
   n <- names(x)
 
@@ -81,6 +163,7 @@ as_paths.character <- function(x, ...) {
   }, character(1))
 }
 
+#' @export
 as_paths.list <- function(x, ...) {
   x <- unlist(x)
 
@@ -91,6 +174,20 @@ as_paths.list <- function(x, ...) {
   as_paths.character(x)
 }
 
+#' @export
 as_paths.yml <- function(x, ...) {
   as_paths.list(unclass(x))
 }
+
+
+path_app <- function(path) {
+  if (!grepl("^/", path)) {
+    path <- paste0("/", path)
+  }
+
+  if (!is.null(.globals$app_path)) {
+    path <- paste0("/", .globals$app_path, path)
+  }
+
+  path
+}

R/url.R

@@ -19,7 +19,7 @@
 #' @param ... Additional arguments passed to `grepl()`.
 #'
 #' @param domain A reactive context, defaults to
-#'   `shiny::getDefaultReactiveDomain()`.
+#'   [shiny::getDefaultReactiveDomain()].
 #'
 #' @export
 observePath <- function(path, handler, env = parent.frame(), quoted = FALSE,
@@ -58,6 +58,14 @@ as_route <- function(x) {
     x <- gsub("/:([^/]*)", "/(?<\\1>[^/]+)", x)
   }
 
+  if (!grepl("^/", x)) {
+    x <- paste0("/", x)
+  }
+
+  if (!is.null(.globals$app_path)) {
+    x <- paste0("/", .globals$app_path, x)
+  }
+
   if (!grepl("^[\\^]", x)) {
     x <- paste0("^", x)
   }
@@ -86,8 +94,6 @@ mask_params <- function(path, url) {
   })
 }
 
-#' @rdname observePath
-#' @export
 param <- function(x, params = peek_params()) {
   sym_x <- rlang::ensym(x)
   name_x <- rlang::as_name(sym_x)
@@ -103,25 +109,36 @@ peek_params <- function() {
 #' Push a new URL path or get the current path.
 #'
 #' @param path A character string specifying a new URL path
+#' @param mode Either `"push"` or `"replace"`. If `"push"`, the default, the
+#'   path is pushed onto the history stack and pressing the back button in the
+#'   browser will redirect to the current path (before pushing the path). If
+#'   `"replace"`, then the pushed path will replace the current path without
+#'   changing the next page in the browser's back button stack.
 #'
 #' @param session A reactive context, defaults to
 #'   `shiny::getDefaultReactiveDomain()`.
 #'
 #' @export
-pushPath <- function(path, session = getDefaultReactiveDomain()) {
-  if (!grepl("^/", path)) {
-    path <- paste0("/", path)
-  }
+pushPath <- function(path, mode = c("push", "replace"), session = getDefaultReactiveDomain()) {
+  path <- path_app(path)
+  mode <- match.arg(mode)
 
   path <- utils::URLencode(path)
 
   session$sendCustomMessage("blaze:pushstate", list(
-    path = path
+    path = path,
+    mode = mode
   ))
 }
 
 #' @rdname pushPath
 #' @export
 getPath <- function(session = getDefaultReactiveDomain()) {
-  session$clientData$url_state
+  url <- session$clientData$url_state
+  if (is.null(.globals$app_path)) {
+    return(url)
+  }
+  url <- sub(paste0("/", .globals$app_path), "", url, fixed = TRUE)
+  if (!length(url) || !grepl("^/", url)) url <- paste0("/", url)
+  url
 }

R/zzz.R

@@ -1,3 +1,3 @@
-.onLoad <- function(pkg, lib) {
+.onLoad <- function(lib, pkg) {
   shiny::addResourcePath("blaze", path_package("blaze", "www"))
 }