create-shiny-alias.R

alias_input_from_shiny <- function(
  input = "actionLink",
  update = NULL,
  new_input = NULL,
  new_update = NULL
) {
  if (is.null(update)) {
    update <- paste0("update", toupper(substr(input, 1, 1)), substring(input, 2))
  }

  stopifnot(
    exists(input, envir = asNamespace("shiny")),
    exists(update, envir = asNamespace("shiny"))
  )

  if (is.null(new_input)) {
    new_input <- snakecase::to_snake_case(input)
    new_input <- sub("_input", "", new_input)
    new_input <- paste0("input_", new_input)
  }

  if (is.null(new_update)) {
    new_update <- snakecase::to_snake_case(update)
    new_update <- sub("_input", "", new_update)
    if (!grepl("^update_", new_update)) {
      new_update <- paste0("update_", new_update)
    }
  }

  # Input call ----
  input_call <- rlang::call2(input, .ns = "shiny")
  new_input_fmls <- input_fmls <- rlang::fn_fmls(eval(input_call[[1]]))

  # Replace inputId in new fn definition with id
  names(new_input_fmls)[names(input_fmls) == "inputId"] <- "id"

  # Pass new input fmls to shiny function
  input_fmls[names(input_fmls) != "..."] <- rlang::syms(setdiff(names(new_input_fmls), "..."))
  if ("..." %in% names(input_fmls)) {
    input_fmls["..."] <- rlang::pairlist2("..." = )
  }

  inner_input_call <- rlang::call2(input, !!!input_fmls, .ns = "shiny")

  # Update call ----
  update_call <- rlang::call2(update, .ns = "shiny")
  new_update_fmls <- update_fmls <- rlang::fn_fmls(eval(update_call[[1]]))

  # Replace inputId in new fn definition with id
  names(new_update_fmls)[names(update_fmls) == "inputId"] <- "id"

  update_fmls[names(update_fmls) != "..."] <- rlang::syms(setdiff(names(new_update_fmls), "..."))
  inner_update_call <- rlang::call2(update, !!!update_fmls, .ns = "shiny")

  # Move session argument to the end of `update` function
  new_update_fmls <- c(
    new_update_fmls["id"],
    rlang::pairlist2("..." = ),
    new_update_fmls[setdiff(names(new_update_fmls), c("id", "...", "session"))],
    new_update_fmls["session"]
  )

  # Replace `session` with a call to `get_current_session()`
  new_update_fmls[names(new_update_fmls) == "session"] <- rlang::expr(get_current_session())

  # create a new function with rlang
  new_input_fn <- rlang::new_function(new_input_fmls, inner_input_call)
  new_update_fn <- rlang::new_function(new_update_fmls, inner_update_call)

  fn_text <- function(fn) {
    fn <- rlang::expr_text(fn)
    fn <- sub("... = ", "...", fn, fixed = TRUE)
    fn <- sub("session = get_current_session", "session = get_current_session()", fn, fixed = TRUE)
    fn
  }

  code <- glue::glue(r"(
#' @inherit shiny::{input} params return title description details sections references
#'
#' @inheritParams input_action_button
#'
#' @family Shiny input aliases
#' @export
{new_input} <- {fn_text(new_input_fn)}

#' @inherit shiny::{update} params return title description details sections references
#'
#' @param ... Ignored, included for future expansion.
#'
#' @family Shiny update aliases
#' @export
{new_update} <- {fn_text(new_update_fn)}
)")

  code <- grkstyle::grk_style_text(code)
  clipr::write_clip(code)

  usethis::use_r(glue::glue("shiny-{new_input}.R"))

  code
}



alias_output_from_shiny <- function(
  output = "verbatimTextOutput",
  render = NULL,
  new_output = NULL,
  new_render = NULL
) {
  if (is.null(render)) {
    render <- sub("Output$", "", output)
    render <- paste0("render", toupper(substr(render, 1, 1)), substring(render, 2))
    cli::cli_inform("Guessing render function: {.fn shiny::{render}}")
  }

  stopifnot(
    exists(output, envir = asNamespace("shiny")),
    exists(render, envir = asNamespace("shiny"))
  )

  new_output <- new_output
  new_render <- new_render

  if (is.null(new_output)) {
    new_output <- snakecase::to_snake_case(output)
    new_output <- sub("_output", "", new_output)
    new_output <- paste0("output_", new_output)
  }

  if (is.null(new_render)) {
    new_render <- snakecase::to_snake_case(render)
    # new_render <- sub("_input", "", new_render)
    # if (!grepl("^update_", new_render)) {
    #   new_render <- paste0("update_", new_render)
    # }
  }

  # Output call ----
  output_call <- rlang::call2(output, .ns = "shiny")
  new_output_fmls <- output_fmls <- rlang::fn_fmls(eval(output_call[[1]]))

  # Replace outputId in new fn definition with id
  names(new_output_fmls)[names(output_fmls) == "outputId"] <- "id"

  # Pass new input fmls to shiny function
  output_fmls[names(output_fmls) != "..."] <- rlang::syms(setdiff(names(new_output_fmls), "..."))
  if ("..." %in% names(output_fmls)) {
    output_fmls["..."] <- rlang::pairlist2("..." = )
  }

  inner_output_call <- rlang::call2(output, !!!output_fmls, .ns = "shiny")

  # render call ----
  render_call <- rlang::call2(render, .ns = "shiny")
  new_render_fmls <- render_fmls <- rlang::fn_fmls(eval(render_call[[1]]))

  # Replace inputId in new fn definition with id
  names(new_render_fmls)[names(render_fmls) == "inputId"] <- "id"

  render_fmls[names(render_fmls) != "..."] <- rlang::syms(setdiff(names(new_render_fmls), "..."))
  inner_render_call <- rlang::call2(render, !!!render_fmls, .ns = "shiny")

  # Move session argument to the end of `update` function
  # new_render_fmls <- c(
  #   new_render_fmls["id"],
  #   rlang::pairlist2("..." = ),
  #   new_render_fmls[setdiff(names(new_render_fmls), c("id", "...", "session"))],
  #   new_render_fmls["session"]
  # )

  if ("session" %in% names(new_render_fmls)) {
    # Replace `session` with a call to `get_current_session()`
    new_render_fmls[names(new_render_fmls) == "session"] <- rlang::expr(get_current_session())
  }

  # create a new function with rlang
  new_output_fn <- rlang::new_function(new_output_fmls, inner_output_call)
  new_render_fn <- rlang::new_function(new_render_fmls, inner_render_call)

  fn_text <- function(fn) {
    fn <- rlang::expr_text(fn)
    fn <- sub("... = ", "...", fn, fixed = TRUE)
    fn <- sub("session = get_current_session", "session = get_current_session()", fn, fixed = TRUE)
    fn
  }

  code <- glue::glue(r"(
#' @inherit shiny::{output} params return title description details sections references
#'
#' @inheritParams output_text
#'
#' @seealso [{new_render}()] to reactively update the `new_output()`.
#'
#' @family Shiny output aliases
#' @export
{new_output} <- {fn_text(new_output_fn)}

#' @inherit shiny::{render} params return title description details sections references
#'
#' @section Aliased from Shiny: `r docs_callout_shiny_alias("{new_render}", "{render}")`
#'
#' @seealso [{new_output}()] to create an output in the UI.
#'
#' @family Shiny render aliases
#' @export
{new_render} <- {fn_text(new_render_fn)}
)")

  code <- grkstyle::grk_style_text(code)
  clipr::write_clip(code)

  usethis::use_r(glue::glue("shiny-{new_output}.R"))

  code
}