kinesis coverage - 17.74%

Files
Source

# UI ===========================================================================
#' Prepare Data UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [prepare_server()]
#' @family generic modules
#' @keywords internal
#' @export
prepare_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Data"),
    value = "data",
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Data"),
        import_ui(ns("import"))
      ), # sidebar
      ## Output: value box
      box_ui(ns("box")),
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Data"),
          checkboxInput(
            inputId = ns("head"),
            label = tr_("Table overview"),
            value = TRUE),
          gt::gt_output(outputId = ns("table"))
        ),
        nav_panel(
          title = tr_("Clean values"),
          clean_ui(ns("clean"))
        ),
        nav_panel(
          title = tr_("Missing values"),
          missing_ui(ns("missing"))
        )
      ),
      border_radius = FALSE,
      fillable = TRUE,
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Prepare Data Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param demo A [`character`] string specifying the name of a dataset (see
#'  [import_server()]).
#' @return A reactive [`data.frame`].
#' @seealso [prepare_ui()]
#' @family generic modules
#' @keywords internal
#' @export
prepare_server <- function(id, demo = NULL) {
  moduleServer(id, function(input, output, session) {
    ## Prepare data -----
    data_raw <- import_server("import", demo = demo)
    data_clean <- clean_server("clean", x = data_raw)
    data_miss <- missing_server("missing", x = data_clean)

    ## Render description -----
    box_server("box", x = data_miss)

    ## Render table -----
    output$table <- gt::render_gt({
      tbl <- if (isTRUE(input$head)) utils::head(data_miss()) else data_miss()
      gt::gt(tbl, rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%")
    })

    data_miss
  })
}

# Modules ======================================================================
## Value box -------------------------------------------------------------------
box_ui <- function(id) {
  ns <- NS(id)

  layout_columns(
    col_widths = breakpoints(
      xs = c(12, 12, 12, 12),
      md = c(6, 6, 6, 6),
      lg = c(3, 3, 3, 3)
    ),
    fill = FALSE,
    value_box(
      title = tr_("Dimensions"),
      uiOutput(outputId = ns("value_dimensions"))
    ),
    value_box(
      title = tr_("Sparsity"),
      uiOutput(outputId = ns("value_sparsity"))
    ),
    value_box(
      title = tr_("Missing values"),
      uiOutput(outputId = ns("value_missing"))
    ),
    card(
      helpText(tr_("Export your data for futur use.")),
      render_export_button(ns("export"))
    )
  )
}
box_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    output$value_dimensions <- renderUI({
      req(x())
      paste0(dim(x()), collapse = " x ")
    })
    output$value_sparsity <- renderUI({
      req(x())
      paste0(round(arkhe::sparsity(x()) * 100, 2), "%")
    })
    output$value_missing <- renderUI({
      req(x())
      sum(is.na(x()))
    })

    ## Download -----
    export_table("export", x, name = "data", label = tr_("Download"))
  })
}

## Clean -----------------------------------------------------------------------
clean_ui <- function(id) {
  ns <- NS(id)

  list(
    ## Input: remove whitespace
    checkboxInput(
      inputId = ns("remove_whitespace"),
      label = tr_("Remove leading/trailing whitespace"),
      value = FALSE,
      width = "100%"
    ),
    ## Input: remove zero
    checkboxInput(
      inputId = ns("remove_zero_row"),
      label = tr_("Remove rows with zero"),
      value = FALSE,
      width = "100%"
    ),
    checkboxInput(
      inputId = ns("remove_zero_column"),
      label = tr_("Remove columns with zero"),
      value = FALSE,
      width = "100%"
    ),
    ## Input: remove constant
    checkboxInput(
      inputId = ns("remove_constant_column"),
      label = tr_("Remove constant columns"),
      value = FALSE,
      width = "100%"
    ),
    ## Input: remove all?
    checkboxInput(
      inputId = ns("all"),
      label = tr_("Remove only if all values meet the condition"),
      value = TRUE,
      width = "100%"
    )
  )
}

#' @param id A [`character`] string specifying the namespace.
#' @param x A reactive `matrix`-like object.
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return A reactive [`data.frame`].
#' @noRd
clean_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Clean whitespace
    no_ws <- reactive({
      req(x())
      if (!isTRUE(input$remove_whitespace)) return(x())
      arkhe::clean_whitespace(x(), squish = TRUE)
    })

    ## Remove (all) rows with zeros
    no_zero_row <- reactive({
      req(no_ws())
      if (!isTRUE(input$remove_zero_row)) return(no_ws())
      arkhe::remove_zero(no_ws(), margin = 1, all = isTRUE(input$all),
                         verbose = verbose)
    })

    ## Remove (all) columns with zeros
    no_zero_col <- reactive({
      req(no_zero_row())
      if (!isTRUE(input$remove_zero_column)) return(no_zero_row())
      arkhe::remove_zero(no_zero_row(), margin = 2, all = isTRUE(input$all),
                         verbose = verbose)
    })

    ## Remove constant columns
    no_cte <- reactive({
      req(no_zero_col())
      if (!isTRUE(input$remove_constant_column)) return(no_zero_col())
      arkhe::remove_constant(no_zero_col(), verbose = verbose)
    })

    no_cte
  })
}

## Missing ---------------------------------------------------------------------
missing_ui <- function(id) {
  ns <- NS(id)

  layout_column_wrap(
    width = 1/2,
    list(
      ## Input: empty as missing
      checkboxInput(
        inputId = ns("empty_as_NA"),
        label = tr_("Empty string as missing value"),
        value = FALSE
      ),
      ## Input: zero as missing
      checkboxInput(
        inputId = ns("zero_as_NA"),
        label = tr_("Zero as missing value"),
        value = FALSE
      ),
      ## Input: remove missing
      radioButtons(
        inputId = ns("remove"),
        label = tr_("Remove missing values:"),
        choiceNames = c(
          tr_("Keep as is"),
          tr_("Replace missing values with zeros"),
          tr_("Remove rows with missing values"),
          tr_("Remove columns with missing values")
        ),
        choiceValues = c("none", "zero", "row", "col")
      )
    ),
    output_plot(ns("heatmap"))
  )
}

#' @param id A [`character`] string specifying the namespace.
#' @param x A reactive `matrix`-like object.
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return A reactive [`data.frame`].
#' @noRd
missing_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Replace empty strings
    empty_as_na <- reactive({
      req(x())
      if (!isTRUE(input$empty_as_NA)) return(x())
      arkhe::replace_empty(x(), value = NA)
    })

    ## Replace zeros
    zero_as_na <- reactive({
      req(empty_as_na())
      if (!isTRUE(input$zero_as_NA)) return(empty_as_na())
      arkhe::replace_zero(empty_as_na(), value = NA)
    })

    ## Remove missing values
    no_missing <- reactive({
      req(zero_as_na())

      choice <- input$remove %|||% ""
      fun <- switch(
        choice,
        zero = function(x) {
          arkhe::replace_NA(x, value = 0)
        },
        row = function(x) {
          arkhe::remove_NA(x, margin = 1, all = FALSE, verbose = verbose)
        },
        col = function(x) {
          arkhe::remove_NA(x, margin = 2, all = FALSE, verbose = verbose)
        },
        function(x) { x }
      )

      fun(zero_as_na())
    })

    ## Render plot
    plot_missing <- reactive({
      req(all(dim(no_missing()) > 0))
      function() {
        col <- if (anyNA(no_missing())) c("#DDDDDD", "#BB5566") else "#DDDDDD"
        tabula::plot_heatmap(object = is.na(no_missing()), color = col,
                             fixed_ratio = FALSE)
      }
    })
    render_plot("heatmap", x = plot_missing)

    no_missing
  })
}

# Utilities ====================================================================
select_data <- function(x, names, drop = FALSE) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(names))

  reactive({
    if (!all(dim(x()) > 0)) return(NULL)

    cols <- arkhe::get_columns(x = x(), names = names())
    if (!isTRUE(drop)) return(cols)
    unlist(cols, use.names = FALSE)
  }) |>
    bindEvent(names())
}
subset_data <- function(x, f = NULL) {
  stopifnot(is.reactive(x))

  reactive({
    req(x())
    if (!is.function(f)) return(x())
    arkhe::keep_columns(x = x(), f = f, verbose = get_option("verbose", FALSE))
  })
}
subset_quantitative <- function(x, positive = FALSE) {
  if (isTRUE(positive)) {
    f <- \(x) is.numeric(x) && all(x >= 0, na.rm = TRUE)
  } else {
    f <- is.numeric
  }
  subset_data(x, f)
}
subset_qualitative <- function(x) {
  f <- \(x) Negate(is.numeric)(x)
  subset_data(x, f)
}

# UI ===========================================================================
#' Updatable Select List
#'
#' @param id A [`character`] string specifying the namespace.
#' @return
#'  A select list control that can be added to a UI definition
#'  (see [shiny::selectizeInput()]).
#' @seealso [update_selectize_colnames()], [update_selectize_rownames()]
#' @keywords internal
selectize_ui <- function(id, label = "Choose", multiple = FALSE, help = NULL) {
  ns <- NS(id)
  plugins <- ifelse(isTRUE(multiple), "remove_button", "clear_button")
  options <- list(plugins = plugins)

  if (!is.null(help)) {
    label <- bslib::tooltip(trigger = list(label, icon("info-circle")), help)
  }

  selectizeInput(
    inputId = ns("names"),
    label = label,
    choices = NULL,
    selected = NULL,
    multiple = multiple,
    options = options
  )
}

#' Updatable Checkbox Group
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A checkbox group control that can be added to a UI definition
#'  (see [shiny::checkboxGroupInput()]).
#' @seealso [update_checkbox_colnames()]
#' @keywords internal
checkbox_ui <- function(id, label = "Choose", inline = TRUE) {
  ns <- NS(id)

  checkboxGroupInput(
    inputId = ns("names"),
    label = label,
    choices = NULL,
    selected = NULL,
    inline = inline
  )
}

# Server =======================================================================
#' Update a Checkbox Group with Column Names
#'
#' @inheritParams update_input
#' @return
#'  A reactive [`character`] vector of column names.
#'
#'  Side effect: change the value of a checkbox group on the client.
#' @seealso [checkbox_ui()]
#' @keywords internal
update_checkbox_colnames <- function(id, x, exclude = reactive(NULL), select = TRUE) {
  update_input(id = id, x = x, exclude = exclude, select = select,
               control = updateCheckboxGroupInput)
}

#' Update a Select List with Column Names
#'
#' @inheritParams update_input
#' @return
#'  A reactive [`character`] vector of column names.
#'
#'  Side effect: change the value of a select list on the client.
#' @seealso [selectize_ui()]
#' @keywords internal
update_selectize_colnames <- function(id, x, exclude = reactive(NULL),
                                      select = FALSE, placeholder = TRUE) {
  update_input(id = id, x = x, exclude = exclude, select = select,
               placeholder = placeholder,
               control = updateSelectizeInput)
}

#' Update a Select List with Row Names
#'
#' @inheritParams update_input
#' @return
#'  A reactive [`character`] vector of row names.
#'
#'  Side effect: change the value of a select list on the client.
#' @seealso [selectize_ui()]
#' @keywords internal
update_selectize_rownames <- function(id, x, exclude = reactive(NULL),
                                      select = FALSE, placeholder = TRUE) {
  update_input(id = id, x = x, choices = rownames, exclude = exclude,
               select = select, placeholder = placeholder,
               control = updateSelectizeInput)
}

#' Update an Input Control with Column Names
#'
#' @param id A [`character`] string specifying the namespace.
#' @param x A reactive `matrix`-like object.
#' @param control An UI input updater.
#' @param choices A [`function`] that takes `x` as a single argument and returns
#'  a `character` vector.
#' @param exclude A reactive [`character`] vector of values to be excluded from
#'  choices.
#' @param select A [`logical`] scalar: should all choices be selected?
#' @param placeholder A [`logical`] scalar: should a placeholder be added?
#' @return
#'  A reactive [`character`] vector of column names.
#'
#'  Side effect: change the value of an input control on the client.
#' @seealso [update_checkbox_colnames()], [update_selectize_colnames()],
#'  [update_selectize_rownames()]
#' @keywords internal
update_input <- function(id, x, control,
                         choices = colnames, exclude = reactive(NULL),
                         select = TRUE, placeholder = FALSE) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(exclude))

  moduleServer(id, function(input, output, session) {
    trigger <- reactive({ exclude() %|||% x() })

    ## Update UI
    observe({
      opt <- choices(x())
      opt <- setdiff(opt, exclude())
      selected <- if (isTRUE(select)) opt else NULL

      if (length(opt) > 0) {
        ## Try to keep previous selection, if any
        keep <- intersect(opt, input$names)
        if (length(keep) > 0) selected <- keep
      } else {
        opt <- character(0)
      }

      names(opt) <- opt

      ## Add placeholder
      if (isTRUE(placeholder)) {
        opt <- c("", opt)
        names(opt) <- c(tr_("Choose"), rep("", length(opt) - 1))
      }

      freezeReactiveValue(input, "names")
      control(
        session,
        inputId = "names",
        choices = opt,
        selected = selected
      )
    }) |>
      bindEvent(trigger())

    ## Return variable names
    reactive({ input$names })
  })
}

# UI ===========================================================================
#' Aoristic Analysis UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [aoristic_server()]
#' @family chronology modules
#' @keywords internal
#' @export
aoristic_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Analysis"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Aoristic Analysis"),
        numericInput(
          inputId = ns("step"),
          label = tr_("Temporal step size"),
          value = 10,
          min = 1,
          max = 500
        ),
        numericInput(
          inputId = ns("start"),
          label = tr_("Beginning of the time window"),
          value = NULL
        ),
        numericInput(
          inputId = ns("end"),
          label = tr_("End of the time window"),
          value = NULL
        ),
        select_calendar(ns("calendar")),
        checkboxInput(
          inputId = ns("weight"),
          label = tr_("Weigth"),
          value = FALSE
        ),
        info_article("Ratcliffe", "2002", "10.1023/A:1013240828824"),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        render_export_button(ns("export"))
      ), # sidebar
      output_plot(id = ns("plot_ao"))
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Aoristic Analysis Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `list` (returned by [time_interval_server()])
#' @return A reactive [`kairos::AoristicSum-class`] object.
#' @seealso [aoristic_ui()]
#' @family chronology modules
#' @keywords internal
#' @export
aoristic_server <- function(id, x, y) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(y))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    calendar <- get_calendar("calendar")
    lower <- reactive({
      req(x()$results)
      aion::start(x()$results, calendar = calendar())
    })
    upper <- reactive({
      req(x()$results)
      aion::end(x()$results, calendar = calendar())
    })

    observe({
      updateNumericInput(inputId = "start", value = min(lower(), na.rm = TRUE))
    }) |>
      bindEvent(lower())
    observe({
      updateNumericInput(inputId = "end", value = max(upper(), na.rm = TRUE))
    }) |>
      bindEvent(upper())

    ## Compute analysis -----
    compute_ao <- ExtendedTask$new(
      function(x, y, step, start, end, calendar, weight, groups) {
        mirai::mirai({
          kairos::aoristic(x, y, step, start, end, calendar, weight, groups)
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_ao$invoke(x = lower(), y = upper(), step = input$step,
                        start = input$start, end = input$end,
                        calendar = calendar(), weight = input$weight,
                        groups = x()$groups)
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_ao$result(), title = tr_("Aoristic Analysis"))
    })

    ## Plot -----
    plot_ao <- reactive({
      req(results())
      function() {
        kairos::plot(results(), calendar = calendar(), col = "grey")
      }
    })

    ## Render plots -----
    render_plot("plot_ao", x = plot_ao)

    ## Export -----
    export_table("export", results, name = "aoristic")

    results
  })
}

# UI ===========================================================================
#' Co-Occurrence UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [occurrence_server()]
#' @family count data modules
#' @keywords internal
#' @export
occurrence_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Co-Occurrence"),
    layout_sidebar(
      sidebar = sidebar(
        title = tr_("Co-Occurrence"),
        radioButtons(
          inputId = ns("method"),
          label = tr_("Method"),
          choiceNames = c(tr_("Absolute frequency"),
                          tr_("Relative frequency"),
                          tr_("Z-score")),
          choiceValues = c("absolute", "relative", "binomial")
        ),
        info_article(author = "Kintigh", year = "2006", doi = "10.6067/XCV8J38QSS"),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        render_export_button(ns("export_results"))
      ), # sidebar
      layout_columns(
        col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
        output_plot(
          id = ns("plot"),
          tools = graphics_ui(ns("par"), col_quali = FALSE,
                              pch = FALSE, lty = FALSE, cex = FALSE),
        ),
        card(
          gt::gt_output(outputId = ns("table"))
        )
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Co-Occurrence Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` returned by [diversity_server()].
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return
#'  No return value, called for side effects.
#' @seealso [occurrence_ui()]
#' @family count data modules
#' @keywords internal
#' @export
occurrence_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Compute index -----
    compute_occur <- ExtendedTask$new(
      function(x, method) {
        mirai::mirai({ tabula::occurrence(x, method = tolower(method)) }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_occur$invoke(x = x(), method = input$method)
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_occur$result(), title = tr_("Co-Occurrence"))
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Plot -----
    map <- reactive({
      req(results())
      function() tabula::plot_heatmap(results(), color = param$pal_quant)
    })

    ## Render table -----
    output$table <- gt::render_gt({
      req(results())
      tbl <- as.data.frame(as.matrix(results()))
      gt::gt(tbl, rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%")
    })

    ## Render plot -----
    render_plot("plot", x = map)

    ## Download -----
    export_table("export_results", results, name = "occurrence")

    results
  })
}

# HELPERS

## https://michaelchirico.github.io/potools/articles/developers.html
tr_ <- function(...) {
  enc2utf8(gettext(paste0(...), domain = "R-kinesis"))
}

#' Bootstrap Theme
#'
#' @param version A [`character`] string specifying the major version of
#'  Bootstrap to use.
#' @param ... Extra parameters to be passed to [bslib::bs_theme()].
#' @return
#'  Returns a [sass::sass_bundle()] object (see [bslib::bs_theme()]).
#' @keywords internal
#' @export
theme_ui <- function(version = "5", ...) {
  path_style <- system.file("static", "custom.scss", package = "kinesis")
  scss <- sass::sass_file(path_style)

  bs <- bslib::bs_theme(
    version = version,
    base_font = c("sans-serif"),
    heading_font = c("sans-serif"),
    code_font = NULL,
    ...
  )
  bslib::bs_add_rules(bs, scss)
}

# Helpers ======================================================================
validate_csv <- function(x) {
  validate(need(x, message = tr_("Import a CSV file first.")))
}
validate_rows <- function(x, n = 1) {
  rows <- ngettext(n, "Select at least %d row.", "Select at least %d rows.")
  validate(need(NROW(x) >= n, sprintf(rows, n)), errorClass = "kinesis")
}
validate_columns <- function(x, n = 1) {
  cols <- ngettext(n, "Select at least %d column.", "Select at least %d columns.")
  validate(need(NCOL(x) >= n, sprintf(cols, n)), errorClass = "kinesis")
}
validate_dim <- function(x, i = 1, j = 1) {
  validate_rows(x, n = i)
  validate_columns(x, n = j)
}
validate_na <- function(x) {
  validate(need(!anyNA(x), tr_("Your data should not contain missing values.")),
           errorClass = "kinesis")
}
validate_zero <- function(x) {
  validate(need(all(x != 0), tr_("Your data should not contain zeros.")),
           errorClass = "kinesis")
}

#' Default Value for Falsy
#'
#' Replaces a [falsy][shiny::isTruthy] value with a default value.
#' @param x,y An object.
#' @return If `x` is not [truthy][shiny::isTruthy()], returns `y`;
#'  otherwise returns `x`.
#' @keywords internal
#' @name falsy
#' @rdname falsy
`%|||%` <- function(x, y) {
  if (isTruthy(x)) x else y
}

# Widgets ======================================================================
select_calendar <- function(id, default = "CE") {
  ns <- NS(id)

  selectizeInput(
    inputId = ns("calendar"),
    label = tr_("Calendar"),
    choices = c("CE", "BCE", "BP", "AD", "BC"),
    selected = default,
    multiple = FALSE,
    options = list(plugins = "remove_button")
  )
}
get_calendar <- function(id) {
  moduleServer(id, function(input, output, session) {

    cal <- reactive({
      aion::calendar(input$calendar)
    })

    cal
  })
}

#' Build Numeric Input
#'
#' @param id A [`character`] string specifying the namespace.
#' @param x A reactive `data.frame` (typically returned by [import_server()]).
#' @return
#'  * `build_numeric_input()` returns a reactive [`numeric`] vector
#'    (side effect: render numeric input controls).
#'  * `render_numeric_input()` is called for its side effects
#'    (creates UI elements).
#' @keywords internal
build_numeric_input <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Get variable names
    vars <- reactive({ names(x()) })

    ## Build UI
    output$controls <- renderUI({
      lapply(
        X = vars(),
        FUN = function(var) {
          numericInput(
            inputId = session$ns(paste0("num_", var)),
            label = var,
            value = 0
          )
        }
      )
    })

    ## Get values
    values <- reactive({
      vapply(
        X = paste0("num_", vars()),
        FUN = function(var, input) input[[var]],
        FUN.VALUE = numeric(1),
        input = input
      )
    })

    values
  })
}

#' @rdname build_numeric_input
render_numeric_input <- function(id) {
  uiOutput(NS(id, "controls"))
}

# Notification =================================================================
#' Toast Notification
#'
#' Shows a lightweight, temporary message.
#' @param text A [`character`] string giving the body content of the
#'  notification.
#' @param title A [`character`] string giving the title of the notification.
#' @inheritParams bslib::toast
#' @return Invisibly returns the toast ID (string).
#' @keywords internal
#' @noRd
show_notification <- function(text, title = NULL, id = NULL, duration = 5,
                              closable = TRUE, type = "default") {
  # text <- paste0(text, collapse = "\n")
  id <- show_toast(
    toast(
      markdown(text, hardbreaks = TRUE),
      header = title,
      icon = NULL,
      id = id,
      type = type,
      duration_s = duration,
      position = c("top", "center"),
      closable = closable
    )
  )
  invisible(id)
}

#' Notification
#'
#' Shows a notification if an expression raises an error or a warning.
#' @param expr An expression to be evaluated.
#' @param title A [`character`] string giving the title of the notification.
#' @return The result of `expr` or `NULL`.
#' @keywords internal
#' @noRd
notify <- function(expr, title = NULL) {
  warn <- err <- NULL

  res <- withCallingHandlers(
    tryCatch(
      expr,
      error = function(e) {
        if (!inherits(e, "shiny.silent.error")) { # Ignore silent error
          err <<- conditionMessage(e)
        }
        return(NULL)
      }
    ),
    warning = function(w) {
      warn <<- append(warn, conditionMessage(w))
      invokeRestart("muffleWarning")
    }
  )

  if (!is.null(err)) {
    show_notification(text = err, title = title, type = "error")
  }
  if (!is.null(warn)) {
    warn <- unique(warn)
    show_notification(text = warn, title = title, type = "warning")
  }

  res
}

# UI ===========================================================================
#' Scatter Plot UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [scatter_server()]
#' @family plot modules
#' @keywords internal
#' @export
scatter_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Scatter Plot"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Variables"),
        ## Input: select axes
        selectize_ui(ns("axis1"), label = tr_("Component X")),
        selectize_ui(ns("axis2"), label = tr_("Component Y")),
        ## Input: aesthetics mapping
        selectize_ui(ns("extra_quali"), label = tr_("Extra qualitative variable")),
        selectize_ui(ns("extra_quanti"), label = tr_("Extra quantitative variable")),
        ## Input: add ellipses
        radioButtons(
          inputId = ns("wrap"),
          label = tr_("Wrap:"),
          choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
                          tr_("Confidence ellipse"), tr_("Convex hull")),
          choiceValues = c("none", "tol", "conf", "hull"),
        ),
        checkboxGroupInput(
          inputId = ns("level"),
          label = tr_("Ellipse level:"),
          selected = "0.95",
          choiceNames = c("68%", "95%", "99%"),
          choiceValues = c("0.68", "0.95", "0.99")
        )
      ), # sidebar
      helpText(
        tr_("Click and drag to select an area, then double-click to zoom in."),
        tr_("Double-click again to reset the zoom.")
      ),
      layout_columns(
        col_widths = c(8, 4),
        output_plot(
          id = ns("plot"),
          tools = list(
            graphics_ui(ns("par"), lty = FALSE, asp = TRUE),
            checkboxInput(inputId = ns("grid"), label = tr_("Grid"), value = TRUE)
          ),
          title = tr_("Scatter Plot"),
          click = ns("plot_click"),
          dblclick = ns("plot_dblclick"),
          brush = brushOpts(
            id = ns("plot_brush"),
            resetOnNew = TRUE
          ),
          height = "100%"
        ),
        card(
          helpText(tr_("Click the plot to select rows of data.")),
          gt::gt_output(outputId = ns("info"))
        )
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Scatter Plot Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`data.frame`].
#' @return
#'  No return value, called for side effects.
#' @seealso [scatter_ui()]
#' @family plot modules
#' @keywords internal
#' @export
scatter_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

    axis1 <- update_selectize_colnames("axis1", x = quanti)
    axis2 <- update_selectize_colnames("axis2", x = quanti, exclude = axis1)
    col_quali <- update_selectize_colnames("extra_quali", x = quali)
    col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)

    ## Extra variables -----
    extra_quali <- select_data(quali, col_quali, drop = TRUE)
    extra_quanti <- select_data(quanti, col_quanti, drop = TRUE)

    ## Interactive zoom -----
    ## When a double-click happens, check if there's a brush on the plot.
    ## If so, zoom to the brush bounds; if not, reset the zoom.
    range_plot <- reactiveValues(x = NULL, y = NULL)
    observe({
      range_plot$x <- brush_xlim(input$plot_brush)
      range_plot$y <- brush_ylim(input$plot_brush)
    }) |>
      bindEvent(input$plot_dblclick)
    info <- reactive({
      ## With base graphics, need to tell it what the x and y variables are.
      nearPoints(x(), input$plot_click, xvar = axis1(), yvar = axis2(),
                 threshold = 5)
    })

    ## Ellipses -----
    wrap <- reactive({
      level <- as.numeric(input$level)
      switch(
        input$wrap,
        tol = function(x, y, z, ...) dimensio::viz_tolerance(x, y, group = z, level = level, ...),
        conf = function(x, y, z, ...) dimensio::viz_confidence(x, y, group = z, level = level, ...),
        hull = function(x, y, z, ...) dimensio::viz_hull(x, y, group = z, ...),
        function(...) invisible()
      )
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Build plot -----
    plot_scatter <- reactive({
      ## Select data
      req(x(), axis1(), axis2())

      coord_x <- x()[[axis1()]]
      coord_y <- x()[[axis2()]]


      if (isTruthy(extra_quali())) {
        col <- param$col_quali(extra_quali())
      } else {
        col <- param$col_quant(extra_quanti())
      }
      pch <- param$pch(extra_quali())
      cex <- param$cex(extra_quanti())

      ## Keep NAs
      if (isTruthy(extra_quali())) {
        pch[which(is.na(extra_quali()))] <- 16
      }

      ## Build plot
      function() {
        graphics::plot(
          x = coord_x,
          y = coord_y,
          type = "p",
          xlim = range_plot$x,
          ylim = range_plot$y,
          xlab = axis1(),
          ylab = axis2(),
          panel.first = if (isTRUE(input$grid)) graphics::grid() else NULL,
          col = col,
          pch = pch,
          cex = cex,
          asp = param$asp,
          las = 1
        )

        ## Add ellipses
        wrap()(
          x = coord_x,
          y = coord_y,
          z = extra_quali() %|||% rep("All", length(coord_x)),
          color = param$pal_quali
        )

        if (isTruthy(extra_quali())) {
          ## Add legend
          labels <- unique(extra_quali())
          keep <- !is.na(labels)
          cols <- unique(col)
          symb <- unique(pch)
          graphics::legend(
            x = "topleft",
            legend = labels[keep],
            col = if (length(cols) == 1) cols else cols[keep],
            pch = if (length(symb) == 1) symb else symb[keep]
          )
        }
      }
    })

    ## Render table -----
    output$info <- gt::render_gt({
      gt::gt(info(), rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%")
    })

    ## Render plot -----
    render_plot("plot", x = plot_scatter)
  })
}

# UI ===========================================================================
#' Linear Model UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [lm_server()]
#' @family modeling modules
#' @keywords internal
#' @export
lm_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Linear Model"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Linear Model"),
        ## Input: select axes
        selectize_ui(
          id = ns("response"),
          label = tr_("Dependent variable"),
          multiple = FALSE
        ),
        selectize_ui(
          id = ns("explanatory"),
          label = tr_("Independent variable"),
          multiple = FALSE
        ),
        selectize_ui(
          id = ns("quali"),
          label = tr_("Extra qualitative variable")
        ),
        selectize_ui(
          id = ns("group"),
          label = tr_("Group")
        )
      ), # sidebar
      navset_card_pill(
        nav_panel(
          title = tr_("Prediction"),
          layout_sidebar(
            sidebar = sidebar(
              ## Input: prediction
              radioButtons(
                inputId = ns("interval"),
                label = tr_("Interval"),
                choiceNames = c(tr_("Confidence interval"), tr_("Prediction interval")),
                choiceValues = c("confidence", "prediction")
              ),
              radioButtons(
                inputId = ns("level"),
                label = tr_("Level:"),
                selected = "0.95",
                choiceNames = c("68%", "95%", "99%"),
                choiceValues = c("0.68", "0.95", "0.99")
              )
            ),
            layout_columns(
              col_widths = c(8, 4),
              output_plot(
                id = ns("plot_lm"),
                title = tr_("Plot"),
                tools = list(
                  graphics_ui(
                    id = ns("par"), col_quali = FALSE, col_quant = FALSE,
                    pch = FALSE, lty = FALSE, cex = FALSE, asp = TRUE
                  ),
                  checkboxInput(inputId = ns("grid"), label = tr_("Grid"), value = TRUE)
                )
              ),
              gt::gt_output(outputId = ns("prediction"))
            )
          )
        ),
        nav_panel(
          title = tr_("Summary"),
          verbatimTextOutput(outputId = ns("summary"))
        ),
        nav_panel(
          title = tr_("Diagnostic"),
          layout_columns(
            col_widths = breakpoints(xs = 12, sm = c(6, 6), md = c(4, 4, 4)),
            output_plot(id = ns("plot_hist"), title = tr_("Residuals histogram")),
            output_plot(id = ns("plot_qq"), title = tr_("Residual Q-Q plot")),
            output_plot(id = ns("plot_fitted"), title = tr_("Residuals-Fitted")),
            output_plot(id = ns("plot_scale"), title = tr_("Scale-Location")),
            output_plot(id = ns("plot_cook"), title = tr_("Cook's distance")),
            output_plot(id = ns("plot_lev"), title = tr_("Residuals-Leverage"))
          )
        )
      ) # navset_card_pill
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Linear Model Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`data.frame`].
#' @return A reactive [`lm`] object.
#' @seealso [lm_ui()]
#' @family modeling modules
#' @keywords internal
#' @export
lm_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

    col_quali <- update_selectize_colnames("quali", x = quali)
    resp <- update_selectize_colnames("response", x = quanti)
    expl <- update_selectize_colnames("explanatory", x = quanti, exclude = resp)

    ## Subset -----
    groups <- select_data(quali, col_quali, drop = TRUE)
    group <- update_input("group", x = groups, control = updateSelectizeInput,
                          choices = unique, select = FALSE, placeholder = TRUE)
    data <- reactive({
      if (!isTruthy(group())) return(x())
      x()[which(groups() == group()), , drop = FALSE]
    })

    ## Linear regression -----
    vars <- reactive({
      req(resp(), expl())
      stats::as.formula(paste0(resp(), " ~ ", paste0(expl(), collapse = " + ")))
    }) |>
      bindEvent(expl()) |>
      debounce(500)

    model <- reactive({
      notify(
        stats::lm(vars(), data = data(), na.action = stats::na.omit, y = TRUE)
      )
    }) |>
      bindEvent(vars(), data())

    prediction <- reactive({
      pred <- notify(
        stats::predict(
          object = model(),
          se.fit = FALSE,
          interval = input$interval,
          level = as.numeric(input$level)
        )
      )
      data.frame(y = model()$y, pred)
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Build plot -----
    plot_lm <- reactive({
      ## Select data
      req(data(), prediction())

      coord_x <- data()[[expl()]]
      coord_y <- data()[[resp()]]

      ## Build plot
      function() {
        graphics::plot(
          x = coord_x,
          y = coord_y,
          type = "p",
          xlab = expl(),
          ylab = resp(),
          panel.first = if (isTRUE(input$grid)) graphics::grid() else NULL,
          col = "black",
          pch = 16,
          cex = 1,
          asp = param$asp,
          las = 1
        )

        i <- order(coord_x)
        graphics::polygon(
          x = c(coord_x[i], rev(x = coord_x[i])),
          y = c(prediction()$upr[i], rev(prediction()$lwr[i])),
          col = grDevices::adjustcolor("grey", alpha.f = 0.5), border = NA
        )
        graphics::lines(x = coord_x[i], y = prediction()$upr[i],
                        lty = 2, lwd = 1, col = "#004488")
        graphics::lines(x = coord_x[i], y = prediction()$lwr[i],
                        lty = 2, lwd = 1, col = "#004488")
        graphics::lines(x = coord_x[i], y = prediction()$fit[i],
                        lty = 1, lwd = 1, col = "#BB5566")
      }
    })

    ## Diagnostic tests -----
    # TODO?

    ## Diagnostic plots -----
    plot_hist <- reactive({
      function() {
        graphics::hist(stats::residuals(model()), main = NULL,
                       xlab = tr_("Residuals"), ylab = tr_("Frequency"))
      }
    })
    plot_fitted <- reactive({
      function() {
        plot(model(), which = 1, caption = "", sub.caption = "")
      }
    })
    plot_qq <- reactive({
      function() {
        plot(model(), which = 2, caption = "", sub.caption = "")
      }
    })
    plot_scale <- reactive({
      function() {
        plot(model(), which = 3, caption = "", sub.caption = "")
      }
    })
    plot_cook <- reactive({
      function() {
        plot(model(), which = 4, caption = "", sub.caption = "")
      }
    })
    plot_lev <- reactive({
      function() {
        plot(model(), which = 5, caption = "", sub.caption = "")
      }
    })

    ## Render plot -----
    render_plot("plot_lm", plot_lm)
    render_plot("plot_hist", plot_hist)
    render_plot("plot_fitted", plot_fitted)
    render_plot("plot_qq", plot_qq)
    render_plot("plot_scale", plot_scale)
    render_plot("plot_cook", plot_cook)
    render_plot("plot_lev", plot_lev)

    ## Render table -----
    output$prediction <- gt::render_gt({
      lvl <- as.numeric(input$level)
      int <- switch(
        input$interval,
        confidence = tr_("Confidence interval"),
        prediction = tr_("Prediction interval")
      )
      gt::gt(prediction(), rownames_to_stub = TRUE) |>
        gt::tab_spanner(
          label = sprintf("%s (%1.0f%%)", int, lvl * 100),
          columns = c("lwr", "upr")
        ) |>
        gt::cols_label(
          y = tr_("Response"),
          fit = tr_("Fitted"),
          lwr = tr_("Lower bound"),
          upr = tr_("Upper bound")
        )
    })

    ## Render prints -----
    output$summary <- renderPrint({ summary(model()) })

    model
  })
}

# UI ===========================================================================
#' Compositional Data Summary UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [coda_summary_server()]
#' @family coda modules
#' @keywords internal
#' @export
coda_summary_ui <- function(id) {
  ## Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Statistics"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Descriptive Statistics"),
        helpText(tr_("Data summary and descriptive statistics.")),
        render_export_button(ns("export"))
      ),
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Location"),
          gt::gt_output(outputId = ns("mean")),
          gt::gt_output(outputId = ns("quantile"))
        ),
        nav_panel(
          title = tr_("Covariance"),
          gt::gt_output(outputId = ns("covariance"))
        ),
        nav_panel(
          title = tr_("PIP"),
          gt::gt_output(outputId = ns("pip"))
        ),
        nav_panel(
          title = tr_("Variation Matrix"),
          navset_pill(
            nav_panel(
              title = tr_("Table"),
              class = "pt-3",
              gt::gt_output(outputId = ns("variation"))
            ),
            nav_panel(
              title = tr_("Heatmap"),
              class = "pt-3",
              output_plot(id = ns("heatmap"))
            ),
            nav_panel(
              title = tr_("Dendrogram"),
              class = "pt-3",
              output_plot(id = ns("dendrogram"))
            )
          )
        )
      ) # navset_card_underline
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Compositional Data Summary Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
#' @return
#'  No return value, called for side effects.
#' @seealso [coda_summary_ui()]
#' @family coda modules
#' @keywords internal
#' @export
coda_summary_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Location -----
    data_loc <- reactive({
      req(x())
      if (nexus::is_grouped(x())) {
        nexus::aggregate(x(), FUN = nexus::mean, na.rm = FALSE)
      } else {
        m <- nexus::mean(x(), na.rm = FALSE)
        matrix(m, nrow = 1, dimnames = list("center", names(m)))
      }
    })

    ## Spread -----
    # TODO

    ## Percentiles -----
    data_quant <- reactive({
      req(x())
      nexus::quantile(x(), probs = seq(0, 1, 0.25))
    })

    ## CLR covariance -----
    data_cov <- reactive({
      req(x())
      nexus::covariance(x(), center = TRUE)
    })

    ## PIP -----
    data_pip <- reactive({
      req(x())
      nexus::pip(x())
    })

    ## Variation matrix -----
    data_var <- reactive({
      req(x())
      nexus::variation(x())
    })

    ## Clustering -----
    plot_clust <- reactive({
      d <- stats::as.dist(data_var())
      h <- stats::hclust(d, method = "ward.D2")

      function() {
        plot(h, hang = -1, main = "", sub = "",
             xlab = "", ylab = tr_("Total variation"), las = 1)
      }
    })

    ## Heatmap -----
    plot_heatmap <- reactive({
      req(data_var())
      function() tabula::plot_heatmap(data_var(), fixed_ratio = TRUE)
    })

    Aitchison1986 <- info_article(
      author = "Aitchison", year = "1986", html = FALSE
    )
    Egozcue2023 <- info_article(
      author = "Egozcue & Pawlowsky-Glahn", year = "2023",
      doi = "10.57645/20.8080.02.7", html = FALSE
    )

    ## Render table -----
    output$mean <- gt::render_gt({
      req(x(), data_loc())
      data_loc() |>
        as.data.frame() |>
        gt::gt(rownames_to_stub = nexus::is_grouped(x())) |>
        gt::fmt_percent(decimals = 3) |>
        gt::sub_missing() |>
        gt::tab_header(title = tr_("Compositional Mean"))
    })
    output$quantile <-  gt::render_gt({
      req(data_quant())
      data_quant() |>
        as.data.frame() |>
        gt::gt(rownames_to_stub = TRUE) |>
        gt::fmt_percent(decimals = 3) |>
        gt::sub_missing() |>
        gt::tab_header(title = tr_("Percentile Table"))
    })
    output$covariance <- gt::render_gt({
      req(data_cov())
      covar <- data_cov()
      covar[lower.tri(covar, diag = FALSE)] <- NA

      covar |>
        as.data.frame() |>
        gt::gt(rownames_to_stub = TRUE) |>
        gt::fmt_number(decimals = 3) |>
        gt::sub_missing(missing_text = "") |>
        gt::tab_header(title = tr_("Centered Log-Ratio Covariance")) |>
        gt::tab_source_note(source_note = gt::html(Aitchison1986))
    })
    output$pip <- gt::render_gt({
      req(data_pip())
      prop <- data_pip()
      prop[lower.tri(prop, diag = TRUE)] <- NA

      prop |>
        as.data.frame() |>
        gt::gt(rownames_to_stub = TRUE) |>
        gt::fmt_number(decimals = 3) |>
        gt::sub_missing(missing_text = "") |>
        gt::tab_style_body(
          fn = function(x) x >= 0.75,
          style = gt::cell_fill(color = "#FFAABB")
        ) |>
        gt::tab_header(title = tr_("Proportionality Index of Parts")) |>
        gt::tab_source_note(source_note = gt::html(Egozcue2023))
    })
    output$variation <- gt::render_gt({
      req(data_var())
      varia <- data_var()
      varia[lower.tri(varia, diag = TRUE)] <- NA

      varia |>
        as.data.frame() |>
        gt::gt(rownames_to_stub = TRUE) |>
        gt::fmt_number(decimals = 3) |>
        gt::sub_missing(missing_text = "") |>
        gt::tab_header(title = tr_("Variation Matrix")) |>
        gt::tab_source_note(source_note = gt::html(Aitchison1986))
    })

    ## Render plot -----
    render_plot("heatmap", x = plot_heatmap)
    render_plot("dendrogram", x = plot_clust)

    ## Download -----
    export_multiple(
      "export",
      mean = data_loc,
      quantiles = data_quant,
      covariance = data_cov,
      variation = data_var,
      pip = data_pip,
      name = "coda_summary",
      label = tr_("Download tables")
    )
  })
}

# UI ===========================================================================
#' Alpha Diversity UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [diversity_alpha_server()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_alpha_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = HTML(tr_("&#945; Diversity")),
    layout_sidebar(
      sidebar = sidebar(
        title = tr_("Diversity Measures"),
        render_export_button(ns("export_results"))
      ), # sidebar
      card(
        gt::gt_output(outputId = ns("measures"))
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Alpha Diversity Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` returned by [diversity_server()].
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return A reactive [`data.frame`] (see [tabula::diversity()]).
#' @seealso [diversity_alpha_ui()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_alpha_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Compute index -----
    results <- reactive({
      req(x())
      notify(tabula::diversity(x()), title = tr_("Alpha Diversity"))
    })

    ## Render table -----
    output$measures <- gt::render_gt({
      req(results())
      results() |>
        gt::gt(rownames_to_stub = TRUE) |>
        gt::tab_spanner(
          label = tr_("Heterogeneity"),
          columns = c(3, 4) + 1,
          id = "heterogeneity"
        ) |>
        gt::tab_spanner(
          label = tr_("Dominance"),
          columns = c(5, 6) + 1,
          id = "dominance"
        ) |>
        gt::tab_spanner(
          label = tr_("Richness"),
          columns = c(7, 8, 9, 10, 11) + 1,
          id = "richness"
        ) |>
        gt::cols_label(
          size = tr_("Sample size"),
          observed = tr_("Observed richness"),
          shannon = "Shannon",
          brillouin = "Brillouin",
          simpson = "Simpson",
          berger = "Berger-Parker",
          menhinick = "Menhinick",
          margalef = "Margalef",
          chao1 = "Chao1",
          ace = "ACE",
          squares = "Squares"
        ) |>
        gt::tab_header(title = tr_("Diversity Measures")) |>
        gt::fmt_number(decimals = 3) |>
        gt::sub_missing()
    })

    ## Download -----
    export_table("export_results", results, name = "alpha")

    results
  })
}

# UI ===========================================================================
#' Compositional Data Hierarchical Clustering UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [coda_hclust_server()]
#' @family coda modules
#' @keywords internal
#' @export
coda_hclust_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("HCLUST"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Hierarchical Clustering"),
        selectInput(
          inputId = ns("dist"),
          label = tr_("Distance"),
          choices = c(Aitchison = "euclidean")
        ),
        selectInput(
          inputId = ns("clust"),
          label = tr_("Clustering linkage"),
          choices = c("ward.D", "ward.D2", "single", "complete",
                      "average", "mcquitty", "median", "centroid"),
          selected = "ward.D2"
        ),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        numericInput(
          inputId = ns("cut"),
          label = tr_("Desired number of clusters"),
          value = 1, min = 1, max = NA, step = 1
        ),
        render_export_button(ns("export_dist")),
        render_export_button(ns("export_clust"))
      ), # sidebar
      output_plot(
        id = ns("plot_dendro"),
        tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, cex = FALSE),
        title = tr_("Dendrogram")
      ),
      border_radius = FALSE,
      fillable = TRUE
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Compositional Data Hierarchical Clustering Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
#' @return
#'  No return value, called for side effects.
#' @seealso [coda_hclust_ui()]
#' @family coda modules
#' @keywords internal
#' @export
coda_hclust_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Compute cluster -----
    compute_hclust <- ExtendedTask$new(
      function(x, method, clust) {
        mirai::mirai({
          clr <- nexus::transform_clr(x)
          d <- nexus::dist(clr, method = method)
          h <- stats::hclust(d, method = clust)
          h$dist <- d
          if (nexus::is_grouped(x)) h$groups <- nexus::group_names(x)
          h
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_hclust$invoke(x = x(), method = input$dist, clust = input$clust)
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_hclust$result(), title = tr_("Hierarchical Clustering"))
    })
    distances <- reactive({
      results()$dist
    })
    groups <- reactive({
      req(results(), input$cut)
      stats::cutree(results(), k = input$cut)
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Dendrogram -----
    plot_dendro <- reactive({
      req(results(), input$cut)

      function() {
        xlab <- sprintf(tr_("Aitchison distance, %s linkage"), results()$method)
        plot(results(), hang = -1, main = NULL, sub = "",
             xlab = xlab, ylab = "Height", las = 1)

        if (input$cut > 1) {
          stats::rect.hclust(results(), k = input$cut)
        }

        i <- results()$order
        g <- results()$groups
        if (!is.null(g)) {
          col <- param$col_quali(g)
          pch <- param$pch(g)
          graphics::points(
            x = seq_along(i),
            y = rep(0, length(i)),
            col = col[i],
            pch = pch[i]
          )

          arg <- list(x = "topright", pch = 16, bty = "n")
          leg <- stats::aggregate(
            data.frame(col = col, pch = pch),
            by = list(legend = g),
            FUN = unique
          )
          leg <- as.list(leg)
          leg <- utils::modifyList(leg, arg)
          do.call(graphics::legend, args = leg)
        }
      }
    })

    ## Render plot -----
    render_plot("plot_dendro", x = plot_dendro)

    ## Download -----
    export_table("export_dist", distances, name = "distances", label = tr_("Download distances"))
    export_table("export_clust", groups, name = "clusters", label = tr_("Download clusters"))
  })
}

# UI ===========================================================================
#' About UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @param package A [`character`] vector of package names to be cited.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [home_server()]
#' @family page modules
#' @keywords internal
#' @export
home_ui <- function(id, package = NULL) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Home"),
    layout_sidebar(
      sidebar = sidebar(
        width = 300,
        title = tr_("Welcome!"),
        help_tesselle(),
        help_license()
      ), # sidebar
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Overview"),
          h3(get_title()),
          markdown(get_description()),
          help_data(),
          help_warranty(),
          tags$p(
            class = "logo",
            tags$a(href = "https://www.tesselle.org/", rel = "external",
                   tags$img(src = "static/tesselle.png", alt = tr_("Logo of the tesselle project."))),
            tags$a(href = "https://www.archeosciences-bordeaux.fr/", rel = "external",
                   tags$img(src = "static/logo-archeosciences.svg", alt = "UMR 6034 Arch&eacute;osciences Bordeaux")),
            tags$a(href = "https://www.huma-num.fr/", rel = "external",
                   tags$img(src = "static/logo-humanum.svg", alt = "IR* Huma-Num"))
          )
        ),
        nav_panel(
          title = tr_("How to cite"),
          help_cite(package)
        )
      ) # navset_card_pill
    ) # layout_sidebar
  ) # nav_panel
}

#' Footer UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A [`list`] that can be converted into an HTML `<footer>` tag
#'  (see [htmltools::tags()]).
#' @seealso [footer_server()]
#' @family page modules
#' @keywords internal
#' @export
footer_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  tags$footer(
    style = "border-top: 1px; margin-top: 1em; width: 100%; text-align: center;",
    tags$p(
      actionLink(inputId = ns("session"), label = tr_("Session info")),
      HTML(" &middot; "),
      tags$a(href = "https://codeberg.org/tesselle/kinesis",
             target = "_blank", rel = "external", tr_("Source code")),
      HTML(" &middot; "),
      tags$a(href = "https://codeberg.org/tesselle/kinesis/issues",
             target = "_blank", rel = "external", tr_("Report a bug or request"))
    )
  )
}

# Server =======================================================================
#' Home Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @return
#'  No return value, called for side effects.
#' @seealso [home_ui()]
#' @family page modules
#' @keywords internal
#' @export
home_server <- function(id) {
  moduleServer(id, function(input, output, session) {
    ## Render -----
    output$session <- renderPrint({ utils::sessionInfo() })
  })
}

#' Footer Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @return
#'  No return value, called for side effects.
#' @seealso [footer_ui()]
#' @family page modules
#' @keywords internal
#' @export
footer_server  <- function(id) {
  moduleServer(id, function(input, output, session) {
    observeEvent(input$session, {
      showModal(
        modalDialog(
          title = tr_("Session info"),
          info_session(),
          size = "xl",
          easyClose = TRUE,
          footer = modalButton(tr_("Close"))
        )
      )
    })
  })
}

#' Collect Information About the Current R Session
#'
#' @param ... Currently not used.
#' @return Text marked as HTML.
#' @keywords internal
#' @noRd
info_session <- function(...) {
  info <- paste0(utils::capture.output(utils::sessionInfo()), collapse = "\n")
  markdown(sprintf("```\n%s\n```", info))
}

# SHINY

#' Run an App
#'
#' A wrapper for [shiny::shinyAppDir()].
#' @param app A [`character`] string specifying the \pkg{Shiny} application
#'  to run (see details). Any unambiguous substring can be given.
#' @param options A [`list`] of named options that should be passed to the
#'  [`shiny::shinyAppDir()`] call.
#' @details
#'  \tabular{ll}{
#'   **Application name**          \tab  **Keyword**  \cr
#'   Aoristic Analysis             \tab `aoristic`    \cr
#'   Correspondence Analysis       \tab `ca`          \cr
#'   Principal Components Analysis \tab `pca`         \cr
#'   Diversity Measures            \tab `diversity`   \cr
#'   Mean Ceramic Date             \tab `mcd`         \cr
#'   Radiocarbon Calibration       \tab `radiocarbon` \cr
#'   Scatter Plot                  \tab `scatter`     \cr
#'   Matrix Seriation              \tab `seriation`   \cr
#'   Compositional Data Analysis   \tab `source`      \cr
#'   Ternary Plot                  \tab `ternary`     \cr
#'  }
#' @examples
#' if (interactive()) {
#'  run_app("seriation")
#' }
#' @return A \pkg{shiny} application object.
#' @family shiny apps
#' @author N. Frerebeau
#' @export
run_app <- function(app = c("diversity", "seriation", "aoristic", "mcd",
                            "radiocarbon", "source",
                            "scatter", "ternary", "ca", "pca"),
                    options = list(launch.browser = interactive())) {
  ## App selection
  app <- match.arg(app, several.ok = FALSE)
  app_dir <- system.file("app", app, package = "kinesis")
  if (!nzchar(app_dir)) {
    msg <- sprintf(tr_("Could not find the %s application."), sQuote(app))
    stop(msg, call. = FALSE)
  }

  ## Create a Shiny app object
  obj <- shiny::shinyAppDir(appDir = app_dir, options = options)

  ## Bundle the options inside the shinyApp object
  opt <- get_config(app, file = NULL)
  obj$appOptions$kinesis_options <- opt

  obj
}

#' Read Configuration Values
#'
#' @param app A [`character`] string specifying the Shiny application
#'  to run (see [run_app()]).
#' @param file A [`character`] string specifying the configuration file to
#'  read from. If `NA` (the default), use the value of the
#'  `KINESIS_CONFIG_FILE` environment variable ("`config.yml`" if the variable
#'  does not exist). If `NULL`, use the build-in configuration file.
#' @param active A [`character`] string specifying the name of configuration to
#'  read from. If `NA` (the default), use the value of the
#'  `KINESIS_CONFIG_ACTIVE` environment variable ("`default`" if the variable
#'  does not exist).
#' @param use_parent A [`logical`] scalar: should parent directories be scanned
#'  for configuration files if the specified config file isn't found?
#' @return A [`list`] of configuration values.
#' @author N. Frerebeau
#' @keywords internal
#' @export
get_config <- function(app, file = NA, active = NA, use_parent = TRUE) {
  ## Get config file
  if (is.null(file)) {
    file <- system.file("app", app, "config.yml", package = "kinesis")
  }
  if (is.na(file)) {
    file <- Sys.getenv("KINESIS_CONFIG_FILE", "config.yml")
  }
  if (!file.exists(file)) {
    msg <- sprintf(tr_("Could not find the configuration file for %s."), sQuote(app))
    stop(msg, call. = FALSE)
  }

  ## Read config
  if (is.na(active)) {
    active <- Sys.getenv("KINESIS_CONFIG_ACTIVE", "default")
  }
  config::get(value = NULL, config = active, file = file,
              use_parent = use_parent)
}

#' Get App Options
#'
#' @param name A [`character`] string specifying the name of an option to get.
#'  If `NULL` (the default), all options are returned.
#' @param default A value to be returned if the option is not currently set.
#' @return
#'  The value of a \pkg{Shiny} option (see [shiny::getShinyOption()]).
#' @author N. Frerebeau
#' @keywords internal
#' @export
get_option <- function(name = NULL, default = NULL) {
  if (is.null(name)) {
    shiny::getShinyOption("kinesis_options")
  } else {
    shiny::getShinyOption("kinesis_options")[[name]] %||% default
  }
}

#' Get Current Language
#'
#' @param default A [`character`] string specifying the default language
#'  (ISO 639-2) if [`Sys.getenv("LANGUAGE")`][Sys.getenv] is not set. If `NULL`
#'  (the default), uses [`Sys.getlocale("LC_COLLATE")`][Sys.getlocale].
#' @return A [`character`] string (ISO 639-2).
#' @author N. Frerebeau
#' @keywords internal
#' @noRd
get_language <- function(default = NULL) {
  ## Get current language
  lang <- Sys.getenv("LANGUAGE", unset = NA)
  if (is.na(lang) || nchar(lang) < 2)
    lang <- default %||% Sys.getlocale("LC_COLLATE")
  substr(lang, start = 1, stop = 2)
}

#' Get App Title
#'
#' @param default A [`character`] string specifying the default language
#'  (see `get_language()`).
#' @return A [`character`] string.
#' @author N. Frerebeau
#' @keywords internal
#' @noRd
get_title <- function(default = NULL) {
  lang <- get_language(default)
  title <- get_option("title")[[lang]]
  if (is.null(title)) title <- get_option("title")[["en"]] # Fallback to English
  title
}

#' Get App Description
#'
#' @param default A [`character`] string specifying the default language
#'  (see `get_language()`).
#' @return A [`character`] string.
#' @author N. Frerebeau
#' @keywords internal
#' @noRd
get_description <- function(default = NULL) {
  lang <- get_language(default)
  desc <- get_option("description")[[lang]]
  if (is.null(desc)) desc <- get_option("description")[["en"]] # Fallback to English
  desc
}

# UI ===========================================================================
#' Radiocarbon Calibration UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [calibrate_server()]
#' @family chronology modules
#' @keywords internal
#' @export
calibrate_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Calibration"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Calibration"),
        ## Input: checkbox if F14C calibration
        checkboxInput(
          inputId = ns("f14c"),
          label = bslib::tooltip(
            trigger = list(HTML("F<sup>14</sup>C"), icon("info-circle")),
            HTML(tr_("Should the calibration be carried out in F<sup>14</sup>C space?"),
                 tr_("If so, your data must be expressed as F<sup>14</sup>C."))
          ),
          value = FALSE
        ),
        accordion(
          accordion_panel(
            title = tr_("Data"),
            ## Input: select variables
            helpText(
              tr_("Select the corresponding columns from your data set."),
              tr_("Leave blank to use the default parameters.")
            ),
            selectize_ui(id = ns("multi_names"), label = tr_("Laboratory codes")),
            selectize_ui(id = ns("multi_values"), label = tr_("Values"),
                         help = tr_("BP ages or F<sup>14</sup>C values to be calibrated.")),
            selectize_ui(id = ns("multi_errors"), label = tr_("Errors"),
                         help = tr_("Errors associated to the values to be calibrated.")),
            selectize_ui(id = ns("multi_marine_offsets"), label = tr_("Reservoir offsets"),
                         help = tr_("Offset values for any marine reservoir effect.")),
            selectize_ui(id = ns("multi_marine_errors"), label = tr_("Reservoir errors"),
                         help = tr_("Offset value errors for any marine reservoir effect.")),
            selectize_ui(id = ns("multi_curves"), label = tr_("Curves"),
                         help = tr_("Calibration curves to be used.")),
            selectize_ui(id = ns("multi_positions"), label = tr_("Positions"),
                         help = tr_("Position values (e.g. depths) for each age."))
          ),
          accordion_panel(
            title = tr_("Default parameters"),
            radioButtons(
              inputId = ns("calib_curve"),
              label = tr_("Calibration curve:"),
              choices = c("IntCal20", "Marine20", "SHCal20"),
              selected = "IntCal20"
            ),
            numericInput(
              inputId = ns("calib_marine_offset"),
              label = tr_("Reservoir offset"),
              value = 0
            ),
            numericInput(
              inputId = ns("calib_marine_error"),
              label = tr_("Reservoir error"),
              value = 0
            ),
            numericInput(
              inputId = ns("calib_from"),
              label = bslib::tooltip(
                trigger = list(tr_("From"), icon("info-circle")),
                tr_("Earliest date to calibrate for, in cal. BP years.")
              ),
              value = 55000
            ),
            numericInput(
              inputId = ns("calib_to"),
              label = bslib::tooltip(
                trigger = list(tr_("To"), icon("info-circle")),
                tr_("Latest date to calibrate for, in cal. BP years.")
              ),
              value = 0
            ),
            numericInput(
              inputId = ns("calib_resolution"),
              label = bslib::tooltip(
                trigger = list(tr_("Resolution"), icon("info-circle")),
                tr_("Temporal resolution of the calibration, in years.")
              ),
              value = 1
            )
          )
        ),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Calibrate")),
        render_export_button(ns("export_results"))
      ), # sidebar
      navset_card_pill(
        sidebar = sidebar(
          title = tr_("Options"),
          select_calendar(ns("calendar")),
          radioButtons(
            inputId = ns("level"),
            label = tr_("Level:"),
            selected = "0.95",
            choiceNames = c("68%", "95%", "99%"),
            choiceValues = c("0.68", "0.95", "0.99")
          )
        ),
        nav_panel(
          title = tr_("Results"),
          gt::gt_output(outputId = ns("table_results"))
        ),
        nav_panel(
          title = tr_("Plot"),
          output_plot(
            id = ns("plot_density"),
            tools = list(
              checkboxInput(inputId = ns("fixed"), value = TRUE, label = tr_("Fixed scale")),
              checkboxInput(inputId = ns("sort_density"), label = tr_("Decreasing order")),
              selectize_ui(
                id = ns("extra_quali"),
                label = tr_("Extra qualitative variable")
              ),
              graphics_ui(
                id = ns("par_dens"),
                col_quant = FALSE,
                pch = FALSE,
                lty = FALSE,
                cex = FALSE
              )
            )
          )
        ),
        nav_panel(
          title = tr_("Intervals"),
          layout_column_wrap(
            output_plot(
              id = ns("plot_intervals"),
              tools = list(
                checkboxInput(inputId = ns("sort_intervals"), label = tr_("Decreasing order")),
                graphics_ui(
                  id = ns("par_int"),
                  col_quali = FALSE,
                  col_quant = FALSE,
                  pch = FALSE,
                  lty = FALSE,
                  size_range = FALSE
                )
              )
            ),
            # render_export_button(ns("export_intervals")),
            tableOutput(outputId = ns("table_intervals"))
          )
        )
      ) # navset_card_pill
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Radiocarbon Calibration Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` (typically returned by [import_server()]).
#' @return A reactive [`ananke::CalibratedAges-class`] object.
#' @seealso [calibrate_ui()]
#' @family chronology modules
#' @keywords internal
#' @export
calibrate_server  <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quali <- subset_qualitative(x)
    quanti <- subset_quantitative(x)

    calendar <- get_calendar("calendar")
    values <- update_selectize_colnames("multi_values", x = quanti)
    errors <- update_selectize_colnames("multi_errors", x = quanti)
    curves <- update_selectize_colnames("multi_curves", x = quali)
    names <- update_selectize_colnames("multi_names", x = quali)
    positions <- update_selectize_colnames("multi_positions", x = quanti)
    res_off <- update_selectize_colnames("multi_marine_offsets", x = quanti)
    res_err <- update_selectize_colnames("multi_marine_errors", x = quanti)

    col_quali <- update_selectize_colnames("extra_quali", x = quali)
    extra_quali <- select_data(quali, col_quali, drop = TRUE)

    ## Calibrate -----
    compute_calib <- ExtendedTask$new(
      function(x, ...) {
        mirai::mirai({
          param <- list(...)
          do.call(ananke::c14_calibrate, param)
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      req(values(), errors())
      compute_calib$invoke(
        values = x()[[values()]],
        errors = x()[[errors()]],
        curves = if (isTruthy(curves())) x()[[curves()]] else input$calib_curve,
        names = if (isTruthy(names())) x()[[names()]] else NULL,
        positions = if (isTruthy(positions())) x()[[positions()]] else NULL,
        reservoir_offsets = if (isTruthy(res_off())) x()[[res_off()]] else input$calib_marine_offset %|||% 0,
        reservoir_errors = if (isTruthy(res_err())) x()[[res_err()]] else input$calib_marine_error %|||% 0,
        from = input$calib_from %|||% 55000,
        to = input$calib_to %|||% 0,
        resolution = input$calib_resolution %|||% 1
      )
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_calib$result(), title = tr_("Radiocarbon Calibration"))
    })

    ## Compute intervals -----
    intervals <- reactive({
      req(results())
      ananke::interval_hdr(x = results(), level = as.numeric(input$level))
    })

    ## Render table -----
    data_calib <- reactive({
      req(results())
      df <- ananke::as.data.frame(
        x = results(),
        level = as.numeric(input$level),
        calendar = calendar()
      )
      df[, -ncol(df)]
    })
    data_intervals <- reactive({
      req(intervals())
      ananke::as.data.frame(intervals(), calendar = calendar())
    })
    output$table_results <- gt::render_gt({
      gt::gt(data_calib(), rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%") |>
        gt::tab_spanner(
          label = tr_("Conventional Age"),
          columns = gt::starts_with("BP14C")
        ) |>
        gt::tab_spanner(
          label = "F14C",
          columns = gt::starts_with("F14C")
        ) |>
        gt::tab_spanner(
          label = tr_("Marine Reservoir"),
          columns = gt::starts_with("reservoir")
        ) |>
        gt::tab_spanner(
          label = tr_("Calibration"),
          columns = gt::starts_with("calibration")
        ) |>
        gt::cols_label(
          BP14C_value = tr_("Value"),
          BP14C_error = tr_("Error"),
          reservoir_offset = tr_("Offset"),
          reservoir_error = tr_("Error"),
          calibration_curve = tr_("Curve"),
          calibration_hdr = tr_("HDR")
        ) |>
        gt::opt_interactive(
          use_compact_mode = TRUE,
          use_page_size_select = TRUE
        )
    })
    output$table_intervals <- gt::render_gt({
      gt::gt(data_intervals(), rowname_col = "label") |>
        gt::tab_options(table.width = "100%") |>
        gt::cols_label(
          start = tr_("From"),
          end = tr_("To"),
          p = tr_("p")
        ) |>
        gt::opt_interactive(
          use_compact_mode = TRUE,
          use_page_size_select = TRUE
        )
    })

    ## Graphical parameters -----
    param_dens <- graphics_server("par_dens")
    param_int <- graphics_server("par_int")

    ## Render plot -----
    plot_density <- reactive({
      req(results())

      col <- "grey"
      if (isTruthy(extra_quali())) {
        col <- param_dens$col_quali(extra_quali())
      }

      function() {
        ananke::ridgelines(
          x = results(),
          calendar = calendar(),
          interval = "hdr",
          level = as.numeric(input$level),
          fixed = isTRUE(input$fixed),
          decreasing = isTRUE(input$sort_density),
          col = col
        )

        if (isTruthy(extra_quali())) {
          graphics::legend(
            x = ifelse(isTRUE(input$sort_density), "topright", "topleft"),
            legend = unique(extra_quali()),
            fill = unique(col),
            bty = "n"
          )
        }
      }
    })
    plot_intervals <- reactive({
      req(intervals())
      function() {
        aion::plot(
          x = intervals(),
          calendar = calendar(),
          decreasing = isTRUE(input$sort_intervals),
          lwd = param_int$pal_cex
        )
      }
    })
    render_plot("plot_density", x = plot_density)
    render_plot("plot_intervals", x = plot_intervals)

    ## Download -----
    export_table("export_results", data_calib, name = "calibration")
    # export_table("export_interval", data_intervals, name = "intervals")

    results
  })
}

# UI ===========================================================================
#' Graphical Parameters UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A [`list`] of UI elements.
#' @seealso [graphics_server()]
#' @family plot modules
#' @keywords internal
#' @export
graphics_ui <- function(id, col_quali = TRUE, col_quant = TRUE,
                        pch = TRUE, lty = TRUE, cex = TRUE, asp = FALSE,
                        size_range = TRUE) {
  ## Create a namespace function using the provided id
  ns <- NS(id)

  if (isTRUE(col_quali)) {
    col_quali <- select_color(
      inputId = ns("col_quali"),
      label = tr_("Qualitative scheme"),
      type = "quali"
    )
  } else {
    col_quali <- NULL
  }
  if (isTRUE(col_quant)) {
    col_quant <- select_color(
      inputId = ns("col_quant"),
      label = tr_("Quantitative scheme"),
      type = c("seq", "div")
    )
  } else {
    col_quant <- NULL
  }

  size <- if (isTRUE(size_range)) c(1L, 2L) else 1L
  pch <- if (isTRUE(pch)) select_pch(ns("pch"), default = NULL) else NULL
  lty <- if (isTRUE(lty)) select_lty(ns("lty"), default = NULL) else NULL
  cex <- if (isTRUE(cex)) select_cex(ns("cex"), default = size) else NULL
  asp <- if (isTRUE(asp)) checkboxInput(ns("asp"), label = tr_("Fixed aspect ratio"), value = FALSE) else NULL

  list(col_quali, col_quant, pch, lty, cex, asp)
}

select_cex <- function(inputId, default = c(1, 2)) {
  sliderInput(
    inputId = inputId,
    label = tr_("Symbol size"),
    min = 0.1,
    max = 9,
    value = default,
    step = 0.1
  )
}

select_pch <- function(inputId, default = c(16, 17, 15, 3, 7, 8)) {
  x <- c(
    square = 0, circle = 1, `triangle up` = 2, plus = 3, cross = 4,
    diamond = 5, `triangle down` = 6, `square cross` = 7, star = 8,
    `diamond plus` = 9, `circle plus` = 10, `triangles up and down` = 11,
    `square plus` = 12, `circle cross` = 13, `square triangle` = 14,
    `filled square` = 15, `filled circle` = 16, `filled triangle` = 17,
    `filled diamond` = 18, `solid circle` = 19, bullet = 20
  )

  selectizeInput(
    inputId = inputId,
    label = tr_("Symbol"),
    choices = x,
    selected = default,
    multiple = TRUE,
    options = list(plugins = "clear_button")
  )
}

select_lty <- function(inputId, default = 1) {
  x <- c(solid = 1, dashed = 2, dotted = 3,
         dotdash = 4, longdash = 5, twodash = 6)

  selectizeInput(
    inputId = inputId,
    label = tr_("Line type"),
    choices = x,
    selected = default,
    multiple = TRUE,
    options = list(plugins = "clear_button")
  )
}

select_color <- function(inputId, label,
                         type = c("qualitative", "sequential", "diverging")) {
  type <- match.arg(type, several.ok = TRUE)

  schemes <- list(
    qualitative = c("discreterainbow", "bright", "vibrant", "muted",
                    "highcontrast", "mediumcontrast", "light", "okabeito"),
    diverging = c("sunset", "nightfall", "BuRd", "PRGn"),
    sequential = c("YlOrBr", "iridescent", "incandescent", "smoothrainbow")
  )

  schemes <- schemes[type]
  default <- "discreterainbow"
  if (length(type) == 1) {
    if ("diverging" %in% type) default <- "BuRd"
    if ("sequential" %in% type) default <- "YlOrBr"
  }

  selectizeInput(
    inputId = inputId,
    label = label,
    choices = schemes,
    selected = default,
    multiple = FALSE,
    options = list(plugins = list("clear_button"))
  )
}

# Server =======================================================================
#' Graphical Parameters Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @return
#'  A [`reactiveValues`][shiny::reactiveValues] object with elements:
#'  \describe{
#'   \item{`col_quali`, `col_quant`}{A palette function that when called with a
#'    single argument returns a character vector of colors.}
#'   \item{`pch`}{A palette function that when called with a single argument
#'    returns a character vector of symbols.}
#'   \item{`lty`}{A palette function that when called with a single argument
#'    returns a character vector of symbols.}
#'   \item{`cex`}{A palette function that when called with a single argument
#'    returns a numeric vector giving the amount by which plotting text and
#'    symbols should be magnified relative to the default.}
#'   \item{`asp`}{A [`numeric`] giving the aspect ratio y/x.}
#'  }
#' @seealso [graphics_ui()]
#' @family plot modules
#' @keywords internal
#' @export
graphics_server <- function(id) {

  moduleServer(id, function(input, output, session) {
    param <- reactiveValues(
      col_quali = recycle("black"),
      col_quant = recycle("black"),
      pch = recycle(16L),
      lty = recycle(1L),
      cex = recycle(1L),
      asp = NA
    )

    observe({
      if (isTRUE(input$asp)) {
        param$asp <- 1
      } else {
        param$asp <- NA
      }
    }) |>
      bindEvent(input$asp)

    observe({
      param$pal_quali <- color(input$col_quali)
      param$col_quali <- protect(khroma::palette_color_discrete, "black", param$pal_quali)
    }) |>
      bindEvent(input$col_quali, ignoreNULL = FALSE)

    observe({
      param$pal_quant <- color(input$col_quant)
      param$col_quant <- protect(khroma::palette_color_continuous, "black", param$pal_quant)
    }) |>
      bindEvent(input$col_quant, ignoreNULL = TRUE)

    observe({
      pch_in <- as.integer(input$pch)
      pch <- pch_in %|||% 16L
      if (isTruthy(input$pch)) {
        param$pch <- protect(khroma::palette_shape, pch[[1L]], pch)
      } else {
        param$pch <- recycle(pch[[1L]])
      }
      if (!is.null(input$pch)) {
        param$pal_pch <- pch_in
      }
    }) |>
      bindEvent(input$pch, ignoreNULL = FALSE)

    observe({
      lty_in <- as.integer(input$lty)
      lty <- lty_in %|||% 1L
      if (isTruthy(input$lty)) {
        param$lty <- protect(khroma::palette_line, lty[[1L]], lty)
      } else {
        param$lty <- recycle(lty[[1L]])
      }
      if (!is.null(input$lty)) {
        param$pal_lty <- lty_in
      }
    }) |>
      bindEvent(input$lty, ignoreNULL = FALSE)

    observe({
      cex <- range(as.integer(input$cex)) %|||% 1L
      param$pal_cex <- input$cex
      if (isTruthy(input$cex)) {
        param$cex <- protect(khroma::palette_size_sequential, cex[[1L]], cex)
      } else {
        param$cex <- recycle(cex[[1L]])
      }
    }) |>
      bindEvent(input$cex)

    param
  })
}

color <- function(scheme, default = "black") {
  if (!isTruthy(scheme)) {
    function(n) {
      rep(default, n)
    }
  } else {
    function(n) {
      notify(khroma::color(scheme)(n))
    }
  }
}
recycle <- function(x) {
  force(x)

  function(n) {
    if (missing(n) || length(n) < 1) n <- 1
    rep(x, length(n))
  }
}
protect <- function(f, default, ...) {
  force(default)

  function(x) {
    if (!isTruthy(x)) return(default)
    notify(f(...)(x))
  }
}


# UI ===========================================================================
#' Diversity UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [diversity_server()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Indices"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        # title = tr_("Count data"),
        checkbox_ui(ns("count"), label = tr_("Count data"))
      ), # sidebar
      navset_card_pill(
        bertin_ui(ns("plot"), title = tr_("Plot")),
        diversity_alpha_ui(ns("alpha")),
        diversity_beta_ui(ns("beta")),
        occurrence_ui(ns("occurrence"))
      ) # navset_card_pill
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Alpha Diversity Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` (typically returned by [import_server()]).
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return A reactive [`data.frame`] (see [tabula::diversity()]).
#' @seealso [diversity_ui()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Get count data -----
    quanti <- subset_quantitative(x, positive = TRUE)
    quali <- subset_qualitative(x)

    ## Update UI -----
    vars <- update_checkbox_colnames("count", x = quanti)

    ## Select variables -----
    counts <- select_data(quanti, vars, drop = FALSE) |>
      debounce(500)

    ## Diversity -----
    bertin_server("plot", x = counts)
    alpha <- diversity_alpha_server("alpha", x = counts)
    diversity_beta_server("beta", x = counts, quanti = alpha, quali = quali)
    occ <- occurrence_server("occurrence", x = counts)

    counts
  })
}


# UI ===========================================================================
#' Beta Diversity UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [diversity_beta_server()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_beta_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = HTML(tr_("&#946; Diversity")),
    layout_sidebar(
      sidebar = sidebar(
        title = tr_("Principal Coordinates Analysis"),
        selectInput(
          inputId = ns("method"),
          label = tr_("Dissimilarity measure"),
          # TODO: change 'sorenson' to 'sorensen'
          choices = c(`Bray-Curtis` = "bray", `Dice-Sorensen` = "sorenson",
                      `Morisita-Horn` = "morisita"),
          multiple = FALSE
        ),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        render_export_button(ns("export_beta")),
        uiOutput(outputId = ns("download_button")),
        hr(),
        checkboxInput(
          inputId = ns("pcoa_labels"),
          label = tr_("Display labels"),
          value = FALSE
        ),
        ## Input: variable mapping
        selectize_ui(
          id = ns("extra_quanti"),
          label = tr_("Alpha diversity")
        ),
        selectize_ui(
          id = ns("extra_quali"),
          label = tr_("Groups")
        ),
        checkboxInput(
          inputId = ns("hull"),
          label = tr_("Convex hull"),
          value = FALSE
        )
      ), # sidebar
      layout_columns(
        col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
        output_plot(
          id = ns("plot_diss"),
          title = tr_("Dissimilarity"),
          tools = graphics_ui(ns("par_diss"), col_quali = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
          height = "100%"
        ),
        output_plot(
          id = ns("plot_pcoa"),
          title = tr_("PCoA"),
          tools = graphics_ui(ns("par_pcoa"), lty = FALSE),
          height = "100%"
        )
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Beta Diversity Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` returned by [diversity_server()].
#' @param quanti A reactive `data.frame` returned by [diversity_alpha_server()].
#' @param quali A reactive `data.frame` (typically returned by [import_server()]).
#' @return
#'  No return value, called for side effects.
#' @seealso [diversity_beta_ui()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_beta_server <- function(id, x, quanti, quali) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(quanti))
  stopifnot(is.reactive(quali))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    col_quali <- update_selectize_colnames("extra_quali", x = quali)
    col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)

    ## Extra variables -----
    extra_quali <- select_data(quali, col_quali, drop = TRUE)
    extra_quanti <- select_data(quanti, col_quanti, drop = TRUE)

    ## Compute similarity -----
    compute_beta <- ExtendedTask$new(
      function(x, method) {
        mirai::mirai({ 1 - tabula::similarity(x, method) }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_beta$invoke(x = x(), method = input$method)
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_beta$result(), title = tr_("Beta Diversity"))
    })

    ## Compute PCoA -----
    analysis <- reactive({
      req(results())
      validate_na(results())
      notify(dimensio::pcoa(results(), rank = 2))
    })

    ## Graphical parameters -----
    param_diss <- graphics_server("par_diss")
    param_pcoa <- graphics_server("par_pcoa")

    ## Plot -----
    plot_diss <- reactive({
      req(results())

      function() {
        tabula::plot_heatmap(
          object = results(),
          color = param_diss$pal_quant,
          diag = FALSE,
          upper = FALSE,
          fixed_ratio = TRUE
        )
      }
    })

    plot_pcoa <- reactive({
      req(analysis())

      if (!isTruthy(extra_quali()) && isTruthy(extra_quanti())) {
        col <- param_pcoa$pal_quanti
      } else {
        col <- param_pcoa$pal_quali
      }

      function() {
        dimensio::plot(
          x = analysis(),
          labels = input$pcoa_labels,
          extra_quali = extra_quali(),
          extra_quanti = extra_quanti(),
          color = col,
          symbol = param_pcoa$pal_pch,
          size = param_pcoa$pal_cex,
          panel.first = graphics::grid()
        )

        if (isTRUE(input$hull)) {
          dimensio::viz_hull(
            x = analysis(),
            group = extra_quali(),
            color = param_pcoa$pal_quali
          )
        }
      }
    })

    ## Render plot -----
    render_plot("plot_diss", x = plot_diss)
    render_plot("plot_pcoa", x = plot_pcoa)

    ## Download -----
    export_table("export_beta", results, name = "beta", label = tr_("Download dissimilarity matrix"))
    output$download_button <- renderUI({
      req(results())
      downloadButton(
        outputId = session$ns("download"),
        label = tr_("Download PCoA results")
      )
    })
    output$download <- downloadHandler(
      filename = function() { make_file_name("pcoa", "zip") },
      content = function(file) {
        dimensio::export(analysis(), file = file, flags = "-r9Xj")
      },
      contentType = "application/zip"
    )
  })
}

# UI ===========================================================================
#' CA Seriation UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [seriate_server()]
#' @family chronology modules
#' @keywords internal
#' @export
seriate_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Seriation"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Permutation"),
        ## Input: checkbox if permute rows
        checkboxInput(
          inputId = ns("margin_row"),
          label = tr_("Permute rows"),
          value = TRUE
        ),
        ## Input: checkbox if permute columns
        checkboxInput(
          inputId = ns("margin_col"),
          label = tr_("Permute columns"),
          value = TRUE
        ),
        ## Input: select CA axes
        numericInput(
          inputId = ns("axes"),
          label = tr_("CA dimension"),
          value = 1,
          min = 1,
          max = 10,
          step = 1
        ),
        ## Output: download
        render_export_button(ns("export_results"))
      ), # sidebar
      ## Output: plot reordered matrix
      navset_card_pill(
        bertin_ui(
          id = ns("plot"),
          title = tr_("Rearranged matrix")
        )
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' CA Seriation Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` (typically returned by [import_server()]).
#' @param order A reactive \R object (coercible by [kairos::as_seriation()]).
#' @return A reactive [`kairos::AveragePermutationOrder-class`] object.
#' @seealso [seriate_ui()]
#' @family chronology modules
#' @keywords internal
#' @export
seriate_server  <- function(id, x, order) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(order))

  moduleServer(id, function(input, output, session) {
    ## Seriate -----
    data_seriate <- reactive({
      validate(need(order(), tr_("Compute the seriation order first.")))

      margin <- NULL
      if (input$margin_row) margin <- c(margin, 1)
      if (input$margin_col) margin <- c(margin, 2)

      kairos::as_seriation(order(), margin = margin, axes = input$axes)
    })

    ## Permute -----
    data_permute <- reactive({
      req(x())
      req(data_seriate())
      kairos::permute(x(), data_seriate())
    })

    ## Render plot -----
    bertin_server("plot", x = data_permute)

    ## Download -----
    export_table("export_results", data_permute, name = "permuted")

    data_seriate
  })
}

# UI ===========================================================================
#' Principal Components Analysis UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @param center A [`logical`] scalar: should the variables be shifted to be
#'  zero centered?
#' @param scale A [`logical`] scalar: should the variables be scaled to unit
#'  variance?
#' @param help A [`character`] string giving a short help text.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [pca_server()]
#' @family multivariate analysis modules
#' @keywords internal
#' @export
pca_ui <- function(id, center = TRUE, scale = TRUE, help = NULL) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("PCA"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Principal Components Analysis"),
        helpText(textOutput(ns("help"))),
        checkboxInput(
          inputId = ns("center"),
          label = tr_("Center"),
          value = center
        ),
        checkboxInput(
          inputId = ns("scale"),
          label = tr_("Scale"),
          value = scale
        ),
        selectize_ui(
          id = ns("sup_row"),
          label = tr_("Supplementary individuals"),
          multiple = TRUE
        ),
        selectize_ui(
          id = ns("sup_col"),
          label = tr_("Supplementary quantitative variables"),
          multiple = TRUE
        ),
        selectize_ui(
          id = ns("sup_quali"),
          label = tr_("Supplementary qualitative variables"),
          multiple = TRUE
        ),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        uiOutput(outputId = ns("download_button"))
      ), # sidebar
      multivariate_ui(ns("pca")),
      border_radius = FALSE,
      fillable = TRUE
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Principal Components Analysis Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame`.
#' @return A reactive [`dimensio::PCA-class`] object.
#' @seealso [pca_ui()]
#' @family multivariate analysis modules
#' @keywords internal
#' @export
pca_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

    sup_row <- update_selectize_rownames("sup_row", x = x)
    sup_col <- update_selectize_colnames("sup_col", x = quanti)
    sup_quali <- update_selectize_colnames("sup_quali", x = quali, select = TRUE)

    ## Check data -----
    output$help <- renderText({
      if (inherits(x(), "LogRatio")) {
        txt <- tr_("PCA is computed on centered log-ratio (CLR), you should check the data transformation first.")
        return(txt)
      }
    })

    ## Compute PCA -----
    compute_pca <- ExtendedTask$new(
      function(x, center, scale, rank, sup_row, sup_col, sup_quali) {
        mirai::mirai({
          param <- list(object = x, center = center, scale = scale, rank = rank,
                        sup_row = arkhe::seek_rows(x, names = sup_row),
                        sup_col = sup_col)
          if (is.data.frame(x)) {
            param$sup_quali <- sup_quali
          }
          do.call(dimensio::pca, param)
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_pca$invoke(x = x(), center = input$center, scale = input$scale,
                         rank = input$rank, sup_row = sup_row(),
                         sup_col = sup_col(), sup_quali = sup_quali())
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_pca$result(), title = tr_("Principal Components Analysis"))
    })

    multivariate_server("pca", x = results, y = x)

    ## Export -----
    output$download_button <- renderUI({
      req(results())
      downloadButton(
        outputId = session$ns("download"),
        label = tr_("Download results")
      )
    })
    output$download <- downloadHandler(
      filename = function() { make_file_name("pca", "zip") },
      content = function(file) {
        req(results())
        dimensio::export(results(), file = file, flags = "-r9Xj")
      },
      contentType = "application/zip"
    )

    results
  })
}

# UI ===========================================================================
#' Compositional Data Navigation UI
#'
#' @param ... Currently not used.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @family coda modules
#' @keywords internal
#' @name coda_nav
#' @rdname coda_nav
NULL

#' @rdname coda_nav
#' @export
coda_nav_plot <- function(...) {
  nav_menu(
    title = tr_("Plot"),
    coda_hist_ui("hist"),
    coda_barplot_ui("barplot"),
    ternary_ui("ternary")
  )
}

#' @rdname coda_nav
#' @export
coda_nav_logratio <- function(...) {
  nav_menu(
    title = tr_("Transform"),
    logratio_ui("clr", title = "CLR"),
    logratio_ui("alr", title = "ALR"),
    logratio_ui("ilr", title = "ILR"),
    logratio_ui("plr", title = "PLR")
  )
}

#' @rdname coda_nav
#' @export
coda_nav_analysis <- function(...) {
  nav_menu(
    title = tr_("Analysis"),
    #coda_outliers_ui("outliers"),
    pca_ui("pca", scale = FALSE),
    coda_hclust_ui("clust")
  )
}

#' Compositional Data UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [coda_server()]
#' @family coda modules
#' @keywords internal
#' @export
coda_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Data"),
    value = "data",
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Compositional Data"),
        import_ui(ns("import"))
      ), # sidebar
      ## Output: value box
      box_ui(ns("box")),
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Data"),
          layout_sidebar(
            sidebar = sidebar(
              checkbox_ui(
                id = ns("parts"),
                label = tooltip(
                  trigger = span(
                    tr_("Compositional parts"),
                    icon("info-circle")
                  ),
                  tr_("Select the variables you want to use.")
                )
              ),
              selectize_ui(
                id = ns("group"),
                label = tooltip(
                  trigger = span(
                    tr_("Group by"),
                    icon("info-circle")
                  ),
                  tr_("You can use a qualitative variable to assign each sample to a (reference) group."),
                  tr_("Missing values will be interpreted as unassigned samples.")
                ),
                multiple = TRUE
              ),
              selectize_ui(
                id = ns("condense"),
                label = tooltip(
                  trigger = span(
                    tr_("Condense by"),
                    icon("info-circle")
                  ),
                  tr_("You can use one or more categorical variable to split the data into subsets and compute the compositional mean for each."),
                  tr_("Usefull if your data contain several observations for the same sample (e.g. repeated measurements).")
                ),
                multiple = TRUE
              ),
            ), # sidebar
            ## Output: display data
            checkboxInput(
              inputId = ns("head"),
              label = tr_("Table overview"),
              value = TRUE
            ),
            gt::gt_output(outputId = ns("table"))
          ) # layout_sidebar
        ),
        nav_panel(
          title = tr_("Clean values"),
          clean_ui(ns("clean"))
        ),
        nav_panel(
          title = tr_("Missing values"),
          missing_ui(ns("missing"))
        )
      ),
      border_radius = FALSE,
      fillable = TRUE,
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Compositional Data Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param demo A [`character`] string specifying the name of a dataset (see
#'  [import_server()]).
#' @param verbose A [`logical`] scalar: should \R report extra information
#'  on progress?
#' @return A reactive [`nexus::CompositionMatrix-class`] object.
#' @seealso [coda_ui()]
#' @family coda modules
#' @keywords internal
#' @export
coda_server <- function(id, demo = NULL, verbose = get_option("verbose", FALSE)) {
  moduleServer(id, function(input, output, session) {
    ## Prepare data -----
    data_raw <- import_server("import", demo = demo)
    quanti <- subset_quantitative(data_raw, positive = TRUE)
    quali <- subset_qualitative(data_raw)

    ## Update UI -----
    var_parts <- update_checkbox_colnames("parts", x = quanti)
    var_group <- update_selectize_colnames("group", x = quali)
    var_condense <- update_selectize_colnames("condense", x = data_raw)

    ## Compositions -----
    data_coda <- reactive({
      notify(
        nexus::as_composition(
          from = quanti(),
          parts = var_parts(),
          autodetect = FALSE,
          verbose = verbose
        ),
        title = tr_("Compositional Data")
      )
    }) |>
      bindEvent(var_parts()) |>
      debounce(500)

    ## Group -----
    data_group <- reactive({
      if (!isTruthy(var_group()) || !isTruthy(data_coda()))
        return(data_coda())

      nexus::group(data_coda(), by = quali()[var_group()],
                   verbose = verbose)
    })

    ## Condense -----
    data_condense <- reactive({
      if (!isTruthy(var_condense()) || !isTruthy(data_group()))
        return(data_group())

      nexus::condense(data_group(), by = data_raw()[var_condense()],
                      ignore_na = FALSE, verbose = verbose)
    })

    ## Missing values -----
    data_clean <- clean_server("clean", x = data_condense)
    data_missing <- missing_server("missing", x = data_clean)

    ## Zeros -----
    # TODO

    ## Check -----
    data_valid <- reactive({
      validate_csv(data_missing())
      validate_dim(data_missing(), i = 1, j = 3)
      validate_na(data_missing())
      validate_zero(data_missing())

      data_missing()
    })

    ## Render tables -----
    output$table <- gt::render_gt({
      req(data_missing())
      tbl <- as.data.frame(data_missing(), group_var = tr_("Group"))
      tbl <- if (isTRUE(input$head)) utils::head(tbl) else tbl
      gt::gt(tbl, rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%")
    })

    ## Value box -----
    box_server("box", x = data_valid)

    data_valid
  })
}

# Modules ======================================================================
## Imputation ------------------------------------------------------------------
coda_zero_ui <- function(id) {
  ns <- NS(id)

  list(
    helpText(
      tr_("If your data contains zeros, these can be considered as values below the detection limit (i.e. small unknown values)."),
      tr_("In this case, you can define the detection limit for each compositional part below."),
      tr_("If all limits are specified, zeros will be replaced by a fraction of these limits."),
      tr_("For computational details, see"),
      cite_article("Martin-Fernandez et al.", "2003", doi = "10.1023/A:1023866030544", text = TRUE)
    ),
    numericInput(
      inputId = ns("delta"),
      label = tr_("Fraction"),
      value = 2 / 3,
      min = 0,
      max = 1
    ),
    uiOutput(outputId = ns("values")),
    actionButton(inputId = ns("go"), tr_("Replace zero"))
  )
}
coda_zero_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    data <- reactiveValues(values = NULL)

    ## Build UI
    ids <- reactive({
      if (is.null(colnames(x()))) return(NULL)
      data$values <- x()
      paste0("limit_", colnames(x()))
    })

    ui <- reactive({
      req(ids())

      ui <- lapply(
        X = ids(),
        FUN = function(i) {
          numericInput(
            inputId = session$ns(i),
            label = paste(sub("limit_", "", i, fixed = TRUE), "(%)", sep = " "),
            value = 0, min = 0, max = 100
          )
        }
      )

      do.call(layout_column_wrap, args = c(ui, width = 1/4))
    })
    output$values <- renderUI({ ui() })
    outputOptions(output, "values", suspendWhenHidden = FALSE)

    ## Compute
    observe({
      req(ids())
      limits <- lapply(X = ids(), FUN = function(i, x) x[[i]], x = input)
      if (all(lengths(limits) != 0) || all(limits > 0)) {
        limits <- unlist(limits) / 100
        data$values <- nexus::replace_zero(
          x = x(),
          value = limits,
          delta = input$delta
        )
      }
    }) |>
      bindEvent(input$go)

    reactive({ data$values })
  })
}

# HELP TEXT

#' Make File Name
#'
#' @param name A [`character`] string specifying the name of the file
#'  (without extension and the leading dot).
#' @param ext A [`character`] string specifying the file extension.
#' @param project A [`character`] string specifying the name of the project.
#' @param timestamp A [`character`] string specifying the timestamp
#'  (defaults to current date and time).
#' @return A [`character`] string.
#' @family widgets
#' @keywords internal
#' @noRd
make_file_name <- function(name, ext, project = NULL, timestamp = NULL) {
  project <- if (is.null(project)) "" else paste0(project, "_")
  timestamp <- timestamp %||% format(Sys.time(), "%y%m%d_%H%M%S")

  sprintf("%s%s_%s.%s", project, name, timestamp, ext)
}

#' Build an URL
#'
#' @param package A [`character`] string giving the name of a package.
#' @return A [`character`] string (URL).
#' @keywords internal
#' @noRd
url_tesselle <- function(package = NULL) {
  if (is.null(package)) return("https://www.tesselle.org/")
  sprintf("https://packages.tesselle.org/%s/", package)
}

#' Citing \R Packages
#'
#' @param x A [`character`] vector giving the name of one or more package.
#' @return Citations properly formated in HTML.
#' @keywords internal
#' @noRd
cite_package <- function(x = NULL) {
  x <- c("kinesis", x)
  lapply(
    X = x,
    FUN = function(x) {
      bib <- format(utils::citation(x), style = "text")
      txt <- paste0(vapply(X = bib, FUN = markdown, FUN.VALUE = character(1)))
      HTML(txt)
    }
  )
}

#' Citing a Publication
#'
#' @param author A [`character`] string giving the name of the author(s).
#' @param author An [`integer`] or a [`character`] string giving the publication
#'  year.
#' @param doi A [`character`] string giving the DOI. If not `NULL`, it will be
#'  used to create a link.
#' @param text A [`logical`] scalar. If `FALSE`, the citation will be printed
#'  in parentheses.
#' @param before,after A [`character`] string to be inserted before and after
#'  the citation, resp.
#' @param html A [`logical`] scalar. If `TRUE` (the default), the text is marked
#'  as HTML.
#' @return An author-date citation in HTML.
#' @keywords internal
#' @noRd
cite_article <- function(author, year, doi = NULL, text = TRUE,
                         before = "", after = "", html = TRUE) {
  right <- paste0(")", after)
  if (is.null(doi)) {
    link <- tags$span(year, .noWS = "outside")
  } else {
    link <- url_doi(doi, label = year)
  }

  if (text) {
    cite <- tags$span(before, author, "(", link, right)
  } else {
    cite <- tags$span(paste0("(", author, ", "), link, right,
                      .noWS = c("after-begin", "before-end"))
  }
  if (!html) cite <- as.character(cite)
  cite
}

info_article <- function(...) {
  cite_article(..., before = icon("info-circle"), after = ".")
}

url_doi <- function(x, label = NULL, prefix = FALSE) {
  if (is.null(label)) label <- x
  url <- sprintf("https://doi.org/%s", x)
  no_ws <- if (prefix) c("after") else c("before", "after")
  link <- tags$a(label, href = url, target = "_blank", role="doc-biblioref", .noWS = no_ws)
  if (!prefix) return(link)
  list("DOI:", link, ".")
}

help_warranty <- function(...) {
  tags$p(
    tr_("This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY.")
  )
}

help_data <- function(...) {
  withTags(
    p(
      tr_("You can import your data in CSV format."),
      tr_("It assumes that you keep your data tidy:"),
      tr_("each variable must be saved in its own column and each sample must be saved in its own row.")
    )
  )
}

help_cite <- function(package = NULL) {
  list(
    tags$p(
      tr_("If you use this application in your research, you must report and cite it properly to ensure transparency of your results."),
      tr_("Moreover, authors and maintainers of this project are more likely to continue their work if they see that it's being used and valued by the research community.")
    ),
    tags$p(tr_("To cite in your publications, please use:")),
    cite_package(package)
  )
}

help_license <- function(...) {
  withTags(
    p(
      tr_("This app is distributed as a free and open source R package:"),
      a("packages.tesselle.org/kinesis", href = url_tesselle("kinesis"),
        target = "_blank", rel = "external", .noWS = "after"), "."
    )
  )
}

help_tesselle <- function(...) {
  withTags(
    list(
      p(HTML(
        tr_("This app is a part of the <strong>tesselle</strong> project, a collection of packages for research and teaching in archaeology."),
        tr_("The <strong>tesselle</strong> packages focus on quantitative analysis methods developed for archaeology."),
        tr_("They can be used to explore and analyze common data types in archaeology.")
      )),
      p(
        tr_("For more information and relevant links, see"),
        a("tesselle.org", href = url_tesselle(), target = "_blank",
          rel = "external", .noWS = "after"), "."
      )
    )
  )
}

# UI ===========================================================================
#' Time Intervals UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [time_interval_server()]
#' @family chronology modules
#' @keywords internal
#' @export
time_interval_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Intervals"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Time Intervals"),
        selectize_ui(
          id = ns("lower"),
          label = tr_("Lower temporal boundary")
        ),
        selectize_ui(
          id = ns("upper"),
          label = tr_("Upper temporal boundary")
        ),
        select_calendar(ns("calendar")),
        selectize_ui(
          id = ns("groups"),
          label = tr_("Groups")
        )
      ), # sidebar
      output_plot(
        id = ns("plot"),
        tools = graphics_ui(ns("par"), col_quant = FALSE, pch = FALSE,
                            lty = FALSE, cex = FALSE)
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Aoristic Analysis Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame`.
#' @return A reactive [`list`].
#' @seealso [time_interval_ui()]
#' @family chronology modules
#' @keywords internal
#' @export
time_interval_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)
    col_lower <- update_selectize_colnames("lower", x = quanti)
    col_upper <- update_selectize_colnames("upper", x = quanti, exclude = col_lower)
    col_groups <- update_selectize_colnames("groups", x = quali)

    lower <- select_data(x, col_lower, drop = TRUE)
    upper <- select_data(x, col_upper, drop = TRUE)
    groups <- select_data(x, col_groups, drop = TRUE)

    calendar <- get_calendar("calendar")

    ## Time Intervals -----
    results <- reactive({
      req(x(), lower(), upper(), calendar())
      notify(
        {
          aion::intervals(start = lower(), end = upper(),
                          calendar = calendar(), names = rownames(x()))
        },
        title = tr_("Aoristic Analysis")
      )
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Plot -----
    plot <- reactive({
      req(results())
      grp <- NULL
      col <- "black"

      if (isTruthy(groups())) {
        grp <- groups()
        col <- param$col_quali(grp)
      }

      function() {
        aion::plot(results(), calendar = aion::CE(), groups = grp, col = col)
        if (isTruthy(groups())) {
          graphics::legend(x = "topleft", legend = unique(grp), fill = unique(col))
        }
      }
    })

    ## Render plots -----
    render_plot("plot", x = plot)

    reactive({ list(results = results(), groups = groups()) })
  })
}

# UI ===========================================================================
#' MCD UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [mcd_server()]
#' @family ceramic data modules
#' @keywords internal
#' @export
mcd_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Date"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        h5(tr_("Mean Ceramic Date")),
        helpText(tr_("Set the date midpoint (in years) of each ceramic type.")),
        render_numeric_input(ns("dates")),
        select_calendar(ns("calendar_input")),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        render_export_button(ns("export_results")),
      ), # sidebar
      layout_columns(
        col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
        output_plot(
          id = ns("plot"),
          tools = list(
            select_calendar(ns("calendar_output"))
          )
        ),
        card(
          gt::gt_output(outputId = ns("table"))
        )
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' MCD Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` (typically returned by [import_server()]).
#' @return
#'  No return value, called for side effects.
#' @seealso [mcd_ui()]
#' @family ceramic data modules
#' @keywords internal
#' @export
mcd_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    dates <- build_numeric_input("dates", x)
    cal_in <- get_calendar("calendar_input")
    cal_out <- get_calendar("calendar_output")

    ## Compute MCD -----
    compute_mcd <- ExtendedTask$new(
      function(x, dates, calendar) {
        mirai::mirai({ kairos::mcd(x, dates, calendar) }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_mcd$invoke(x = x(), dates = dates(), calendar = cal_in())
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_mcd$result(), title = tr_("MCD"))
    })

    ## Plot -----
    map <- reactive({
      req(results())
      function() kairos::plot(results(), calendar = cal_out())
    })

    ## Table -----
    tbl <- reactive({
      req(results())
      as.data.frame(results(), calendar = cal_out())
    })

    ## Render table -----
    output$table <- gt::render_gt({
      req(tbl())
      tbl() |>
        gt::gt(rowname_col = "sample") |>
        gt::fmt_number(decimals = 2) |>
        gt::sub_missing()
    })

    ## Render plot -----
    render_plot("plot", x = map)

    ## Download -----
    export_table("export_results", tbl, name = "mcd")
  })
}

# UI ===========================================================================
#' Mutlivariate Analysis UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return A tab that can be passed to [shiny::tabsetPanel()].
#' @return
#'  A navigation container (see [bslib::navset_card_pill()]).
#' @seealso [multivariate_server()]
#' @family multivariate analysis modules
#' @keywords internal
#' @export
multivariate_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  navset_card_pill(
    sidebar = sidebar(
      title = tr_("Factor maps"),
      ## Input: display options
      selectizeInput(
        inputId = ns("axis1"),
        label = tr_("Horizontal axis"),
        choices = NULL,
        multiple = FALSE
      ),
      selectizeInput(
        inputId = ns("axis2"),
        label = tr_("Vertical axis"),
        choices = NULL,
        multiple = FALSE
      ),
      checkboxInput(
        inputId = ns("lab_ind"),
        label = tr_("Label individuals"),
        value = FALSE
      ),
      checkboxInput(
        inputId = ns("lab_var"),
        label = tr_("Label variables"),
        value = TRUE
      ),
      checkboxInput(
        inputId = ns("sup_ind"),
        label = tr_("Display supplementary individuals"),
        value = TRUE
      ),
      checkboxInput(
        inputId = ns("sup_var"),
        label = tr_("Display supplementary variables"),
        value = TRUE
      ),
      selectize_ui(
        id = ns("extra_quanti"),
        label = tr_("Extra quantitative variable")
      ),
      selectize_ui(
        id = ns("extra_quali"),
        label = tr_("Extra qualitative variable")
      ),
      ## Input: add ellipses
      radioButtons(
        inputId = ns("wrap"),
        label = tr_("Wrap:"),
        choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
                        tr_("Confidence ellipse"), tr_("Convex hull")),
        choiceValues = c("none", "tolerance", "confidence", "hull"),
      ),
      checkboxGroupInput(
        inputId = ns("ellipse_level"),
        label = tr_("Ellipse level:"),
        selected = "0.95",
        choiceNames = c("68%", "95%", "99%"),
        choiceValues = c("0.68", "0.95", "0.99")
      )
      # TODO: legend
    ),
    ## Results -----
    nav_panel(
      title = tr_("Results"),
      helpText(
        tr_("Click and drag to select an area, then double-click to zoom in."),
        tr_("Double-click again to reset the zoom.")
      ),
      layout_column_wrap(
        output_plot(
          id = ns("plot_ind"),
          tools = graphics_ui(ns("par_ind"), lty = FALSE),
          title = tr_("Individuals factor map"),
          dblclick = ns("plot_ind_dblclick"),
          brush = brushOpts(
            id = ns("plot_ind_brush"),
            resetOnNew = TRUE
          ),
          height = "100%"
        ),
        output_plot(
          id = ns("plot_var"),
          tools = graphics_ui(ns("par_var"), col_quant = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
          title = tr_("Variables factor map"),
          dblclick = ns("plot_var_dblclick"),
          brush = brushOpts(
            id = ns("plot_var_brush"),
            resetOnNew = TRUE
          ),
          height = "100%"
        )
      ) # layout_columns
    ),
    ## Individuals -----
    nav_panel(
      title = tr_("Individuals"),
      layout_column_wrap(
        output_plot(id = ns("plot_cos2_1")),
        output_plot(id = ns("plot_cos2_2")),
        min_height = "50%"
      ),
      gt::gt_output(outputId = ns("info_ind"))
    ),
    ## Variables -----
    nav_panel(
      title = tr_("Variables"),
      layout_column_wrap(
        output_plot(id = ns("plot_contrib_1")),
        output_plot(id = ns("plot_contrib_2")),
        min_height = "50%"
      ),
      gt::gt_output(outputId = ns("info_var"))
    ),
    ## Screeplot -----
    nav_panel(
      title = tr_("Screeplot"),
      layout_column_wrap(
        output_plot(id = ns("screeplot"), title = tr_("Screeplot")),
        tableOutput(outputId = ns("variance"))
      )
    )
  )
}

# Server =======================================================================
#' Multivariate Analysis Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`dimensio::MultivariateAnalysis-class`] object.
#' @param y A reactive `matrix`-like object use to compute the multivariate
#'  analysis.
#' @return
#'  No return value, called for side effects.
#' @seealso [multivariate_ui]
#' @family multivariate analysis modules
#' @keywords internal
#' @export
multivariate_server <- function(id, x, y) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Illustrative variables -----
    ## Set group_var for nexus::GroupedComposition objects
    extra <- reactive({ as.data.frame(y(), group_var = tr_("Group")) })
    quanti <- subset_quantitative(extra)
    quali <- subset_qualitative(extra)

    col_quali <- update_selectize_colnames("extra_quali", x = quali)
    col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)

    ## Extra variables -----
    extra_quali <- select_data(quali, col_quali, drop = TRUE)
    extra_quanti <- select_data(quanti, col_quanti, drop = TRUE)

    ## Eigenvalues -----
    eigen <- reactive({
      req(x())
      dimensio::get_eigenvalues(x())
    })

    ## Update UI -----
    axes <- reactive({
      choices <- seq_len(nrow(eigen()))
      names(choices) <- rownames(eigen())
      choices
    })
    observe({
      freezeReactiveValue(input, "axis1")
      updateSelectizeInput(inputId = "axis1", choices = axes())
    }) |>
      bindEvent(axes())
    observe({
      choices <- axes()[-axis1()]
      freezeReactiveValue(input, "axis2")
      updateSelectizeInput(inputId = "axis2", choices = choices)
    }) |>
      bindEvent(axis1())

    ## Select axes -----
    axis1 <- reactive({
      req(input$axis1)
      as.numeric(input$axis1)
    })
    axis2 <- reactive({
      req(input$axis2)
      as.numeric(input$axis2)
    })

    ## Graphical parameters -----
    param_ind <- graphics_server("par_ind")
    param_var <- graphics_server("par_var")

    ## Plot -----
    ## Interactive zoom
    ## When a double-click happens, check if there's a brush on the plot.
    ## If so, zoom to the brush bounds; if not, reset the zoom.
    range_ind <- reactiveValues(x = NULL, y = NULL)
    range_var <- reactiveValues(x = NULL, y = NULL)
    observe({
      range_ind$x <- brush_xlim(input$plot_ind_brush)
      range_ind$y <- brush_ylim(input$plot_ind_brush)
    }) |>
      bindEvent(input$plot_ind_dblclick)

    observe({
      range_var$x <- brush_xlim(input$plot_var_brush)
      range_var$y <- brush_ylim(input$plot_var_brush)
    }) |>
      bindEvent(input$plot_var_dblclick)

    ## Individuals
    plot_ind <- reactive({
      req(x())

      col <- param_ind$pal_quali
      if (isTruthy(extra_quali())) {
        quali <- extra_quali()
      } else if (isTruthy(extra_quanti())) {
        quali <- NULL
        col <- param_ind$pal_quanti
      } else {
        quali <- "observation"
      }

      add_ellipses <- any(input$wrap %in% c("confidence", "tolerance"))
      add_hull <- identical(input$wrap, "hull")

      function() {
        dimensio::viz_rows(
          x = x(),
          axes = c(axis1(), axis2()),
          active = TRUE,
          sup = isTRUE(input$sup_ind),
          labels = isTRUE(input$lab_ind),
          extra_quali = quali,
          extra_quanti = extra_quanti(),
          color = col,
          symbol = param_ind$pal_pch,
          size = param_ind$pal_cex,
          xlim = range_ind$x,
          ylim = range_ind$y,
          panel.first = graphics::grid(),
          na_show = TRUE # /!\ Undocumented feature /!\
        )

        if (add_ellipses) {
          dimensio::viz_ellipses(
            x = x(),
            group = extra_quali(),
            type = input$wrap,
            level = as.numeric(input$ellipse_level),
            color = param_ind$pal_quali
          )
        }
        if (add_hull) {
          dimensio::viz_hull(
            x = x(),
            group = extra_quali(),
            color = param_ind$pal_quali
          )
        }
      }
    })

    ## Variables
    plot_var <- reactive({
      req(x())

      function() {
        dimensio::viz_variables(
          x = x(),
          axes = c(axis1(), axis2()),
          active = TRUE,
          sup = isTRUE(input$sup_var),
          labels = isTRUE(input$lab_var),
          extra_quali = "observation",
          color = param_var$pal_quali,
          symbol = c(1, 3),
          xlim = range_var$x,
          ylim = range_var$y,
          panel.first = graphics::grid()
        )
      }
    })

    plot_cos2_1 <- reactive({
      req(x())
      function() {
        dimensio::viz_cos2(x = x(), margin = 1, axes = axis1())
      }
    })

    plot_cos2_2 <- reactive({
      req(x())
      function() {
        dimensio::viz_cos2(x = x(), margin = 1, axes = axis2())
      }
    })

    plot_contrib_1 <- reactive({
      req(x())
      function() {
        dimensio::viz_contributions(x = x(), margin = 2, axes = axis1())
      }
    })

    plot_contrib_2 <- reactive({
      req(x())
      function() {
        dimensio::viz_contributions(x = x(), margin = 2, axes = axis2())
      }
    })

    plot_eigen <- reactive({
      req(x())
      function() {
        dimensio::screeplot(
          x = x(),
          cumulative = TRUE,
          labels = FALSE,
          limit = sum(eigen()[, 3] <= 99)
        )
      }
    })

    ## Render plots -----
    render_plot("plot_ind", x = plot_ind)
    render_plot("plot_var", x = plot_var)
    render_plot("plot_cos2_1", x = plot_cos2_1)
    render_plot("plot_cos2_2", x = plot_cos2_2)
    render_plot("plot_contrib_1", x = plot_contrib_1)
    render_plot("plot_contrib_2", x = plot_contrib_2)
    render_plot("screeplot", x = plot_eigen)

    ## Render tables -----
    output$variance <- gt::render_gt({
      gt::gt(eigen(), rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%") |>
        gt::fmt_number(
          columns = c("eigenvalues"),
          decimals = 3
        ) |>
        gt::fmt_percent(
          columns = c("variance", "cumulative"),
          scale_values = FALSE
        ) |>
        gt::cols_label(
          eigenvalues = tr_("Eigenvalues"),
          variance = tr_("Explained var. (%)"),
          cumulative = tr_("Cumulative var. (%)")
        )
    })

    output$info_ind <- gt::render_gt({
      req(x())
      multivariate_summary(x(), axes = c(axis1(), axis2()), margin = 1)
    })
    output$info_var <- gt::render_gt({
      req(x())
      multivariate_summary(x(), axes = c(axis1(), axis2()), margin = 2)
    })
  })
}

multivariate_summary <- function(x, axes, margin) {
  dimensio::summary(x, axes = axes, margin = margin) |>
    as.data.frame() |>
    gt::gt(rownames_to_stub = TRUE) |>
    gt::fmt_number(decimals = 3) |>
    gt::tab_spanner(
      label = tr_("Coordinates"),
      columns = gt::ends_with("coord"),
      id = "coord"
    ) |>
    gt::tab_spanner(
      label = tr_("Contribution"),
      columns = gt::ends_with("contrib"),
      id = "contrib"
    ) |>
    gt::tab_spanner(
      label = tr_("Squared cosinus"),
      columns = gt::ends_with("cos2"),
      id = "cos2"
    ) |>
    gt::cols_label_with(
      columns = gt::matches("dist"),
      fn = function(x) tr_("Distance")
    ) |>
    gt::cols_label_with(
      columns = gt::matches("inertia"),
      fn = function(x) tr_("Inertia")
    ) |>
    gt::cols_label_with(
      columns = gt::starts_with("F"),
      fn = function(x) {
        paste(tr_("Axis"), regmatches(x, regexpr("[0-9]", x)), sep = " ")
      }
    ) |>
    gt::opt_interactive(
      use_compact_mode = TRUE,
      use_page_size_select = TRUE
    )
}

# UI ===========================================================================
#' Ternary Plot UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [ternary_server()]
#' @family plot modules
#' @keywords internal
#' @export
ternary_ui <- function(id) {
  ## Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Ternary Plot"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Ternary Plot"),
        accordion(
          accordion_panel(
            title = tr_("Variables"),
            ## Input: select axes
            selectize_ui(id = ns("axis1"), label = tr_("Component X")),
            selectize_ui(id = ns("axis2"), label = tr_("Component Y")),
            selectize_ui(id = ns("axis3"), label = tr_("Component Z")),
            ## Input: aesthetics mapping
            selectize_ui(id = ns("extra_quali"), label = tr_("Extra qualitative variable")),
            selectize_ui(id = ns("extra_quanti"), label = tr_("Extra quantitative variable")),
          ),
          accordion_panel(
            title = tr_("Layers"),
            ## Input: add points
            checkboxInput(
              inputId = ns("points"),
              label = tr_("Show points"),
              value = TRUE
            ),
            ## Input: add density
            checkboxInput(
              inputId = ns("density"),
              label = tr_("Density contour"),
              value = FALSE
            ),
            radioButtons(
              inputId = ns("tile"),
              label = tr_("Heatmap"),
              choiceNames = c(tr_("None"), tr_("Bin"), tr_("Density")),
              choiceValues = c("none", "bin", "dens"),
              selected = "none"
            ),
            sliderInput(
              inputId = ns("bin"),
              label = tr_("Number of bins"),
              min = 5, max = 20,
              value = 10, step = 1
            )
          ),
          accordion_panel(
            title = tr_("Transform"),
            checkboxInput(
              inputId = ns("center"),
              label = tr_("Center"),
              value = FALSE
            ),
            checkboxInput(
              inputId = ns("scale"),
              label = tr_("Scale"),
              value = FALSE
            )
          ),
          accordion_panel(
            title = tr_("Envelopes"),
            ## Input: add ellipses
            radioButtons(
              inputId = ns("wrap"),
              label = tr_("Wrap:"),
              choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
                              tr_("Confidence ellipse"), tr_("Convex hull")),
              choiceValues = c("none", "tol", "conf", "hull"),
            ),
            checkboxGroupInput(
              inputId = ns("level"),
              label = tr_("Ellipse level:"),
              selected = "0.95",
              choiceNames = c("68%", "95%", "99%"),
              choiceValues = c("0.68", "0.95", "0.99")
            )
          ),
          accordion_panel(
            title = tr_("Annotations"),
            ## Input: add a grid
            checkboxInput(
              inputId = ns("grid"),
              label = tr_("Grid"),
              value = TRUE
            ),
            ## Input: add labels
            checkboxInput(
              inputId = ns("labels"),
              label = tr_("Labels"),
              value = FALSE
            )
            ## Input: add a legend
            # TODO
            # checkboxInput(
            #   inputId = ns("legend"),
            #   label = tr_("Legend"),
            #   value = TRUE
            # )
          )
        )
      ), # sidebar
      helpText(
        tr_("Visualize your data in the ternary space."),
        tr_("Click and drag to select an area, then double-click to zoom in."),
        tr_("Double-click again to reset the zoom.")
      ),
      output_plot(
        id = ns("ternplot"),
        tools = graphics_ui(ns("par"), lty = FALSE),
        title = tr_("Plot"),
        dblclick = ns("ternplot_dblclick"),
        brush = brushOpts(
          id = ns("ternplot_brush"),
          resetOnNew = TRUE
        ),
        height = "100%"
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Ternary Plot Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `matrix`-like object.
#' @return
#'  No return value, called for side effects.
#' @seealso [ternary_ui()]
#' @family plot modules
#' @keywords internal
#' @export
ternary_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    data_raw <- reactive({ as.data.frame(x()) })
    quanti <- subset_quantitative(data_raw)
    quali <- subset_qualitative(data_raw)

    axis1 <- update_selectize_colnames("axis1", x = quanti)
    axis2 <- update_selectize_colnames("axis2", x = quanti, exclude = axis1)
    axis12 <- reactive({ c(axis1(), axis2()) })
    axis3 <- update_selectize_colnames("axis3", x = quanti, exclude = axis12)
    col_quali <- update_selectize_colnames("extra_quali", x = quali)
    col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)

    ## Extra variables -----
    extra_quali <- select_data(data_raw, col_quali, drop = TRUE)
    extra_quanti <- select_data(data_raw, col_quanti, drop = TRUE)

    ## Interactive zoom -----
    ## When a double-click happens, check if there's a brush on the plot.
    ## If so, zoom to the brush bounds; if not, reset the zoom.
    range_ternplot <- reactiveValues(x = NULL, y = NULL)
    observe({
      range_ternplot$x <- brush_xlim(input$ternplot_brush)
      range_ternplot$y <- brush_ylim(input$ternplot_brush)
    }) |>
      bindEvent(input$ternplot_dblclick)

    ## Get ternary data -----
    data_tern <- reactive({
      req(data_raw(), axis1(), axis2(), axis3())
      tern <- data_raw()[, c(axis1(), axis2(), axis3())]
      tern[rowSums(tern, na.rm = TRUE) != 0, , drop = FALSE]
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Heatmap
    tile <- reactive({
      switch(
        input$tile,
        bin = isopleuros::tile_bin,
        dens = isopleuros::tile_density,
        NULL
      )
    })

    ## Envelope
    wrap <- reactive({
      level <- as.numeric(input$level)
      switch(
        input$wrap,
        tol = function(x, ...) isopleuros::ternary_tolerance(x, level = level, ...),
        conf = function(x, ...) isopleuros::ternary_confidence(x, level = level, ...),
        hull = function(x, ...) isopleuros::ternary_hull(x, ...),
        NULL
      )
    })

    ## Build plot -----
    plot_ternary <- reactive({
      ## Select data
      req(data_tern())
      tern <- data_tern()
      n <- nrow(tern)

      ## Compute center and scale
      no_scale <- isFALSE(input$center) && isFALSE(input$scale)

      ## Graphical parameters
      if (isTruthy(extra_quali())) {
        col <- param$col_quali(extra_quali())
      } else {
        col <- param$col_quant(extra_quanti())
      }
      pch <- param$pch(extra_quali())
      cex <- param$cex(extra_quanti())

      ## Window
      range_coord <- list(x = NULL, y = NULL, z = NULL)
      if (isTruthy(range_ternplot$x) && isTruthy(range_ternplot$y)) {
        x_pts <- c(range_ternplot$x, mean(range_ternplot$x))
        y_pts <- c(range_ternplot$y, sqrt(3) * diff(range_ternplot$y) / 2)
        range_coord <- isopleuros::coordinates_cartesian(x = x_pts, y = y_pts)
      }

      ## Build plot
      function() {
        oldpar <- graphics::par(mar = c(1, 1, 1, 1), no.readonly = TRUE)
        on.exit(graphics::par(oldpar))

        z <- isopleuros::ternary_plot(
          x = tern,
          type = "n",
          xlim = range_coord$x,
          ylim = range_coord$y,
          zlim = range_coord$z,
          xlab = axis1(),
          ylab = axis2(),
          zlab = axis3(),
          center = input$center,
          scale = input$scale
        )

        ## Add grid
        if (isTRUE(input$grid)) {
          isopleuros::ternary_grid(center = z$center, scale = z$scale)
        }

        if (no_scale) {
          ## Heatmap
          if (isTruthy(tile())) {
            isopleuros::ternary_image(
              f = tile()(tern),
              n = as.numeric(input$bin),
              palette = param$col_quant
            )
          }

          ## Density contours
          if (isTRUE(input$density)) {
            isopleuros::ternary_density(tern)
          }

          ## Envelope
          if (isTruthy(extra_quali()) && isTruthy(wrap())) {
            for (i in split(seq_len(n), f = extra_quali())) {
              z <- tern[i, , drop = FALSE]
              if (nrow(z) < 3) next
              wrap()(z, lty = 1, border = col[i])
            }
          }
        }

        ## Add points
        if (isTRUE(input$points)) {
          isopleuros::ternary_points(tern, col = col, pch = pch, cex = cex,
                                     center = z$center, scale = z$scale)
        }

        ## Add labels
        if (isTRUE(input$labels)) {
          isopleuros::ternary_labels(tern, center = z$center, scale = z$scale,
                                     labels = rownames(tern), col = col)
        }

        ## Add legend
        if (isTruthy(extra_quali())) {
          labels <- unique(extra_quali())
          keep <- !is.na(labels)
          cols <- unique(col)
          symb <- unique(pch)
          graphics::legend(
            x = "topleft",
            legend = labels[keep],
            col = if (length(cols) == 1) cols else cols[keep],
            pch = if (length(symb) == 1) symb else symb[keep],
            bty = "n"
          )
        }
      }
    })

    ## Render plot -----
    render_plot("ternplot", x = plot_ternary)
  })
}

# UI ===========================================================================
#' Plot UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @param tools A (list of) input elements.
#' @param title A [`character`] string giving the card title.
#' @param note A [`character`] string giving a note to be placed in the footer.
#' @param ... Further parameters to be passed to [shiny::plotOutput()].
#' @return A [htmltools::div()] tag.
#' @family widgets
#' @keywords internal
output_plot <- function(id, ..., tools = NULL, title = NULL, note = NULL) {
  ## Create a namespace function using the provided id
  ns <- NS(id)

  if (!is.null(tools)) {
    tools <- popover(
      placement = "auto",
      toolbar_input_button(
        id = ns("chart_settings"),
        label = tr_("Settings"),
        icon = icon("sliders"),
        tooltip = FALSE,
        show_label = FALSE,
        title = tr_("Settings")
      ),
      tools
    )
  }
  footer <- if (!is.null(note)) card_footer(note) else NULL

  card(
    id = ns("card"),
    full_screen = TRUE,
    card_header(
      title,
      toolbar(
        tools,
        toolbar_input_button(
          id = ns("download"),
          label = tr_("Download"),
          icon = icon("download"),
          show_label = TRUE
        )
      ),
      class = "d-flex justify-content-between"
    ),
    card_body(
      plotOutput(outputId = ns("plot"), ...)
    ),
    footer
  )
}

brush_xlim <- function(e) {
  if (is.null(e)) return(NULL)
  c(e$xmin, e$xmax)
}

brush_ylim <- function(e) {
  if (is.null(e)) return(NULL)
  c(e$ymin, e$ymax)
}

# Server =======================================================================
# https://stackoverflow.com/a/46961131
#' Plot Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`function`] recording the plot.
#' @param ... Further parameters to be passed to [shiny::renderPlot()].
#' @return
#'  No return value, called for side effects.
#' @family widgets
#' @keywords internal
render_plot <- function(id, x, ...) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Show modal dialog
    observe({ showModal(download_plot(session$ns)) }) |>
      bindEvent(input$download)

    ## Plot
    output$plot <- renderPlot(x()(), ...)

    ## Preview
    output$preview <- renderImage({
      req(x())

      ## Write to a temporary PNG file
      outfile <- tempfile(fileext = ".png")

      grDevices::png(
        filename = outfile,
        width = input$width,
        height = input$height,
        units = "in",
        res = 72
      )
      x()()
      grDevices::dev.off()

      ## Return a list containing information about the image
      list(
        src = outfile,
        contentType = "image/png",
        style = "height:300px; width:auto; max-width:100%;"
      )
    }, deleteFile = TRUE)

    ## Download
    output[["pdf"]] <- export_plot(input, x, format = "pdf")
    output[["png"]] <- export_plot(input, x, format = "png")
  })
}

#' Export Plot Modal
#'
#' @param ns A [namespace][shiny::NS()] function.
#' @keywords internal
#' @noRd
download_plot <- function(ns) {
  modalDialog(
    title = tr_("Save plot - Preview"),
    size = "l",
    easyClose = FALSE,
    fade = FALSE,
    div(
      plotOutput(outputId = ns("preview")),
      style = "text-align: center;"
    ),
    layout_column_wrap(
      width = 1/3,
      textInput(
        inputId = ns("name"),
        label = tr_("File name"),
        value = "plot"
      ),
      numericInput(
        inputId = ns("width"),
        label = tr_("Width (in)"),
        min = 0.5,
        value = 7
      ),
      numericInput(
        inputId = ns("height"),
        label = tr_("Height (in)"),
        min = 0.5,
        value = 7
      )
    ),
    footer = tagList(
      modalButton(tr_("Cancel")),
      downloadButton(
        outputId = ns("pdf"),
        label = "PDF",
        icon = icon("download")
      ),
      downloadButton(
        outputId = ns("png"),
        label = "PNG",
        icon = icon("download")
      )
    )
  )
}

#' Download Plot
#'
#' Save and Download a graphic.
#' @param input Inputs selected by the user.
#' @param x A reactive [`function`] recording the plot.
#' @param format A [`character`] string specifying the file extension.
#' @return
#'  No return value, called for side effects.
#' @keywords internal
#' @noRd
export_plot <- function(input, x, format) {
  downloadHandler(
    filename = function() { make_file_name(input$name, format) },
    content = function(file) {
      device <- switch (
        format,
        pdf = function(x, ...) grDevices::pdf(x, ...),
        png = function(x, ...) grDevices::png(x, ..., units = "in", res = 300),
        stop(tr_("Unknown graphics device."), call. = FALSE)
      )

      device(file, width = input$width, height = input$height)
      x()()
      grDevices::dev.off()
    }
  )
}

# UI ===========================================================================
#' Correspondence Analysis UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [ca_server()]
#' @family multivariate analysis modules
#' @keywords internal
#' @export
ca_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("CA"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Correspondence Analysis"),
        selectize_ui(
          id = ns("sup_row"),
          label = tr_("Supplementary individuals"),
          multiple = TRUE
        ),
        selectize_ui(
          id = ns("sup_col"),
          label = tr_("Supplementary quantitative variables"),
          multiple = TRUE
        ),
        selectize_ui(
          id = ns("sup_quali"),
          label = tr_("Supplementary qualitative variables"),
          multiple = TRUE
        ),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        uiOutput(outputId = ns("download_button")),
        uiOutput(outputId = ns("chi2"))
      ), # sidebar
      multivariate_ui(ns("ca")),
      border_radius = FALSE,
      fillable = TRUE
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Correspondence Analysis Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame`.
#' @return A reactive [`dimensio::PCA-class`] object.
#' @seealso [ca_ui()]
#' @family multivariate analysis modules
#' @keywords internal
#' @export
ca_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

    sup_row <- update_selectize_rownames("sup_row", x = x)
    sup_col <- update_selectize_colnames("sup_col", x = quanti)
    sup_quali <- update_selectize_colnames("sup_quali", x = quali, select = TRUE)

    ## Compute CA -----
    compute_ca <- ExtendedTask$new(
      function(x, rank, sup_row, sup_col, sup_quali) {
        mirai::mirai({
          param <- list(object = x, rank = rank,
                        sup_row = arkhe::seek_rows(x, names = sup_row),
                        sup_col = sup_col)
          if (is.data.frame(x)) param$sup_quali <- sup_quali
          do.call(dimensio::ca, param)
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

    observe({
      compute_ca$invoke(x = x(), rank = input$rank, sup_row = sup_row(),
                        sup_col = sup_col(), sup_quali = sup_quali())
    }) |>
      bindEvent(input$go)

    old <- reactive({ x() }) |> bindEvent(input$go)
    results <- reactive({
      if (!identical(x(), old())) return(NULL) # Invalidate
      notify(compute_ca$result(), title = tr_("Correspondence Analysis"))
    })

    multivariate_server("ca", x = results, y = x)

    ## Chi-squared -----
    chi2_test <- reactive({
      req(results())
      x <- dimensio::get_data(results())
      z <- suppressWarnings(stats::chisq.test(x = x))

      # Adjusted Cramer's V [95%CI]
      k <- ncol(x)
      r <- nrow(x)
      n <- sum(x)
      phi <- max(0, (z$statistic / n) - (k - 1) * (r - 1) / (n - 1))

      k_bias <- k - (k - 1)^2 / (n - 1)
      r_bias <- r - (r - 1)^2 / (n - 1)
      V <- sqrt(phi / min(k_bias - 1, r_bias - 1))

      z$cramer <- V
      z
    })

    output$chi2 <- renderUI({
      list(
        h5(tr_("Chi-squared Test")),
        tags$ul(
          tags$li(
            sprintf(tr_("Statistic: %.0f"), chi2_test()$statistic)
          ),
          tags$li(
            sprintf(tr_("Degrees of freedom: %.0f"), chi2_test()$parameter)
          ),
          tags$li(
            sprintf(tr_("p-value: %s"), format.pval(chi2_test()$p.value, eps = 0.001))
          ),
          tags$li(
            sprintf(tr_("Cramer's V: %.2f"), chi2_test()$cramer)
          )
        )
      )
    })

    ## Export -----
    output$download_button <- renderUI({
      req(results())
      downloadButton(
        outputId = session$ns("download"),
        label = tr_("Download results")
      )
    })
    output$download <- downloadHandler(
      filename = function() { make_file_name("ca", "zip") },
      content = function(file) {
        dimensio::export(results(), file = file, flags = "-r9Xj")
      },
      contentType = "application/zip"
    )

    results
  })
}

# UI ===========================================================================
#' Import Data UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A [`list`] of UI elements.
#' @seealso [import_server()]
#' @family generic modules
#' @keywords internal
#' @export
import_ui <- function(id) {
  ## Create a namespace function using the provided id
  ns <- NS(id)

  list(
    helpText(tr_("Import your data and perform basic data cleansing and preparation steps.")),
    actionButton(
      inputId = ns("upload"),
      label = tr_("Upload"),
      icon = icon("upload")
    ),
    actionButton(
      inputId = ns("demo"),
      label = tr_("Example data"),
      icon = icon("book")
    ),
    selectize_ui(
      id = ns("rownames"),
      label = tr_("Row names"),
      multiple = FALSE
    )
  )
}

#' Import Data Modal
#'
#' @param ns A [namespace][shiny::NS()] function.
#' @return
#'  A [`list`] of UI elements.
#' @seealso [import_server()]
#' @keywords internal
#' @noRd
import_modal <- function(ns) {
  modalDialog(
    size = "xl",
    easyClose = FALSE,
    fade = FALSE,
    title = tr_("Import Data"),
    footer = tagList(
      modalButton(tr_("Cancel")),
      actionButton(inputId = ns("go"), label = "OK", class = "btn-primary")
    ),
    layout_column_wrap(
      width = 1/3,
      ## Input: select a file
      div(
        tags$p(
          helpText(tr_("Select the location of, and the file you want to upload.")),
          helpText(tr_("Please check the default settings and adjust them to your data.")),
          helpText(tr_("This application only supports data encoded in UFT-8.")),
        ),
        tags$p(
          helpText(tr_("It assumes that you keep your data tidy:")),
          helpText(tr_("each variable must be saved in its own column and each sample must be saved in its own row."))
        ),
        fileInput(
          inputId = ns("file"),
          label = tr_("Choose a CSV or a TSV file:"),
          multiple = FALSE,
          accept = c(".csv", ".tsv", "text/csv", "text/tsv",
                     "text/comma-separated-values", "text/tab-separated-values")
        )
      ),
      div(
        ## Input: checkbox if file has header
        input_switch(
          id = ns("header"),
          label = tr_("Header"),
          value = TRUE
        ),
        ## Input: select decimal
        radioButtons(
          inputId = ns("dec"),
          label = tr_("Decimal"),
          choiceNames = c(tr_("Dot"), tr_("Comma")),
          choiceValues = c(".", ","),
          selected = "."
        ),
        ## Input: select separator
        radioButtons(
          inputId = ns("sep"),
          label = tr_("Separator"),
          choiceNames = c(tr_("Comma"), tr_("Semicolon"), tr_("Tab")),
          choiceValues = c(",", ";", "\t"),
          selected = ","
        ),
        ## Input: select quotes
        radioButtons(
          inputId = ns("quote"),
          label = tr_("Quote"),
          choiceNames = c(tr_("None"), tr_("Double quote"), tr_("Single quote")),
          choiceValues = c("", '"', "'"),
          selected = '"'
        )
      ),
      div(
        ## Input: lines of the data to skip
        numericInput(
          inputId = ns("skip"),
          label = tr_("Lines of the data file to skip:"),
          value = 0,
          min = 0,
          step = 1
        ),
        ## Input: missing string
        textInput(
          inputId = ns("na.strings"),
          label = tr_("String to be interpreted as missing value:"),
          value = ""
        ),
        ## Input: comment
        textInput(
          inputId = ns("comment"),
          label = tr_("Character to be interpreted as comment:"),
          value = "#"
        )
      )
    )
  )
}

# Server =======================================================================
#' Import Data Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param demo A [`character`] string specifying the name of a dataset from
#'  \pkg{folio} or \pkg{datasets}.
#' @return A reactive [`data.frame`].
#' @seealso [import_ui()]
#' @family generic modules
#' @keywords internal
#' @export
import_server <- function(id, demo = NULL) {
  moduleServer(id, function(input, output, session) {
    ## Store data -----
    values <- reactiveVal()

    ## Show modal dialog -----
    observe({ showModal(import_modal(session$ns)) }) |>
      bindEvent(input$upload)

    ## Read from connection -----
    ## Parse query parameters
    data_url <- reactive({
      params <- parseQueryString(session$clientData$url_search)
      params[["data"]]
    })
    observe({
      msg <- tr_("Reading data...")
      # detail <- tags$a(href = data_url(), target = "_blank", data_url())
      # id <- showNotification(msg, action = detail, duration = 3, type = "message")
      # on.exit(removeNotification(id), add = TRUE)

      csv <- notify(
        withProgress(
          utils::read.csv(file = url(data_url())),
          message = msg
        ),
        title = tr_("Data Input")
      )

      values(csv)
    }) |>
      bindEvent(data_url())

    ## Load example data -----
    observe({
      req(demo)

      msg <- sprintf(tr_("Loading \"%s\" data..."), demo)
      # id <- showNotification(msg, duration = 3, type = "message")
      # on.exit(removeNotification(id), add = TRUE)

      path <- system.file("extdata", paste0(demo, ".csv"), package = "kinesis")
      csv <- notify(
        withProgress(
          utils::read.csv(file = path),
          message = msg
        ),
        title = tr_("Data Upload")
      )

      values(csv)
    }) |>
      bindEvent(input$demo)

    ## Read data file -----
    observe({
      msg <- tr_("Reading data...")
      # id <- showNotification(msg, duration = 3, type = "message")
      # on.exit(removeNotification(id), add = TRUE)

      csv <- notify(
        withProgress(
          utils::read.table(
            file = input$file$datapath,
            header = input$header,
            sep = input$sep,
            dec = input$dec,
            quote = input$quote,
            row.names = NULL,
            na.strings = input$na.strings,
            skip = if (!is.na(input$skip)) input$skip else 0,
            comment.char = input$comment
          ),
          message = msg
        ),
        title = tr_("Data Upload")
      )

      if (!is.null(csv)) removeModal()
      values(csv)
    }) |>
      bindEvent(input$go)

    ## Update UI -----
    rows <- update_selectize_colnames("rownames", values)

    ## Assign row names -----
    reactive({
      if (!isTruthy(rows())) return(values())

      notify(
        {
          column <- arkhe::seek_columns(values(), names = rows())
          arkhe::assign_rownames(values(), column = column %|||% 0, remove = TRUE)
        },
        title = tr_("Row names")
      )
    })
  })
}

# UI ===========================================================================
#' Compositional Bar Plot UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [coda_barplot_server()]
#' @family coda modules
#' @keywords internal
#' @export
coda_barplot_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Bar Plot"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Bar Plot"),
        checkboxInput(
          inputId = ns("select_major"),
          label = tr_("Major elements"),
          value = TRUE
        ),
        checkboxInput(
          inputId = ns("select_minor"),
          label = tr_("Minor elements"),
          value = TRUE
        ),
        checkboxInput(
          inputId = ns("select_trace"),
          label = tr_("Trace elements"),
          value = TRUE
        ),
        hr(),
        checkboxInput(
          inputId = ns("order_columns"),
          label = tr_("Sort columns"),
          value = FALSE
        ),
        selectize_ui(id = ns("order_rows"), label = tr_("Row order")),
        checkboxInput(
          inputId = ns("decreasing"),
          label = tr_("Decreasing row order"),
          value = FALSE
        )
      ), # sidebar
      output_plot(
        id = ns("plot"),
        tools = list(
          graphics_ui(ns("par"), col_quant = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
          numericInput(
            inputId = ns("space"),
            label = tr_("Gutter"),
            value = 0.2,
            min = 0, max = 0.5, step = 0.1
          )
        ),
        height = "100%",
        title = tr_("Plot")
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Bar Plot Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
#' @return
#'  No return value, called for side effects.
#' @seealso [coda_barplot_ui()]
#' @family coda modules
#' @keywords internal
#' @export
coda_barplot_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Subset -----
    data_bar <- reactive({
      req(x())

      elements <- logical(ncol(x()))
      is_major <- nexus::is_element_major(x())
      is_minor <- nexus::is_element_minor(x())
      is_trace <- nexus::is_element_trace(x())

      elements[which(is_major)] <- isTRUE(input$select_major)
      elements[which(is_minor)] <- isTRUE(input$select_minor)
      elements[which(is_trace)] <- isTRUE(input$select_trace)

      z <- x()[, which(elements), drop = FALSE]
      validate_dim(z, j = 3)
      z
    })

    ## Select column -----
    col_bar <- update_selectize_colnames("order_rows", x = data_bar)

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Build barplot -----
    plot_bar <- reactive({
      req(data_bar())

      col <- notify({
        pal <- khroma::palette_color_discrete(param$pal_quali, domain = colnames(x()))
        pal(colnames(data_bar()))
      })

      function() {
        nexus::barplot(
          height = data_bar(),
          order_columns = isTRUE(input$order_columns),
          order_rows = col_bar() %|||% NULL,
          decreasing = isTRUE(input$decreasing),
          color = col,
          space = input$space %|||% 0
        )
      }
    })

    ## Render barplot -----
    render_plot("plot", x = plot_bar)
  })
}

# UI ===========================================================================
#' Log-Ratio UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @param title A [`character`] string giving the sidebar title.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [logratio_server()]
#' @family coda modules
#' @keywords internal
#' @export
logratio_ui <- function(id, title) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = title,
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = textOutput(
          outputId = ns("title"),
          container = function(...) tags$header(..., class = "sidebar-title")
        ),
        helpText(tr_("Compute log-ratio transformation of compositional data.")),
        checkboxInput(
          inputId = ns("weights"),
          label = tr_("Weighted log-ratio"),
          value = FALSE
        ),
        uiOutput(outputId = ns("settings")),
        radioButtons(
          inputId = ns("type"),
          label = tr_("Plot type"),
          selected = "scatter",
          choiceNames = c(tr_("Scatter plot"), tr_("Boxplot")),
          choiceValues = c("scatter", "boxplot")
        ),
        render_export_button(ns("export_results")),
        ## Output: graph
        plotOutput(outputId = ns("graph"))
      ), # sidebar
      ## Output: plot
      output_plot(
        id = ns("plot"),
        tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, cex = FALSE),
        height = "100%",
        title = tr_("Density")
      )
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Log-Ratio Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
#' @param method A [`character`] string specifying the log-ratio to be computed.
#' @return A reactive [`nexus::LogRatio-class`] object.
#' @seealso [logratio_ui()]
#' @family coda modules
#' @keywords internal
#' @export
logratio_server <- function(id, x, method) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Render settings -----
    output$settings <- renderUI({
      if (!(method == "alr" || method == "plr")) return(NULL)
      label <- switch (
        method,
        alr = tr_("Rationing part:"),
        plr = tr_("Pivotal variable:")
      )
      selectizeInput(
        inputId = session$ns("pivot"),
        label = label,
        choices = colnames(x()),
        selected = NULL,
        multiple = FALSE,
      )
    })

    ## Compute -----
    logratio <- reactive({
      req(x())

      pivot <- input$pivot %|||% 1
      trans <- switch (
        method,
        clr = function(x) nexus::transform_clr(x, weights = input$weights),
        alr = function(x) nexus::transform_alr(x, j = pivot, weights = input$weights),
        ilr = function(x) nexus::transform_ilr(x),
        plr = function(x) nexus::transform_plr(x, pivot = pivot)
      )

      notify(trans(x()), title = toupper(method))
    })

    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Plot -----
    plot_log <- reactive({
      req(logratio())

      lvl <- ""
      if (nexus::is_grouped(logratio())) lvl <- nexus::group_levels(logratio())
      fun <- switch(
        input$type,
        scatter = function(x)
          plot(x, color = param$col_quali(lvl), symbol = param$pch(lvl)),
        boxplot = function(x)
          nexus::boxplot(x, color = param$col_quali(lvl))
      )

      function() {
        fun(logratio())
      }
    })

    ## Graph -----
    plot_graph <- reactive({
      req(logratio())
      if (inherits(logratio(), "CLR")) return(NULL)
      graph <- nexus::as_graph(logratio())

      plot(graph)
      grDevices::recordPlot()
    })

    ## Render title -----
    output$title <- renderText({
      switch(
        method,
        clr = tr_("Centered Log-Ratio"),
        alr = tr_("Additive Log-Ratio"),
        ilr = tr_("Isometric Log-Ratio"),
        plr = tr_("Pivot Log-Ratio"),
        ""
      )
    })

    ## Render table -----
    # TODO?

    ## Render plot -----
    render_plot("plot", x = plot_log)

    ## Render graph -----
    output$graph <- renderPlot({
      req(plot_graph())
      grDevices::replayPlot(plot_graph())
    })

    ## Download -----
    export_table("export_results", logratio, name = paste0("coda_", method), label = tr_("Download log-ratio"))

    logratio
  })
}

# UI ===========================================================================
#' Count Data UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [count_server()]
#' @family count data modules
#' @keywords internal
#' @export
count_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Data"),
    value = "data",
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Data"),
        import_ui(ns("import"))
      ), # sidebar
      ## Output: value box
      box_ui(ns("box")),
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Data"),
          layout_sidebar(
            sidebar = sidebar(
              checkbox_ui(
                id = ns("parts"),
                label = tooltip(
                  trigger = span(
                    tr_("Count data"),
                    icon("info-circle")
                  ),
                  tr_("Select the variables you want to use.")
                )
              )
            ),
            checkboxInput(
              inputId = ns("head"),
              label = tr_("Table overview"),
              value = TRUE
            ),
            gt::gt_output(outputId = ns("table"))
          ) # sidebar
        ), # layout_sidebar
        nav_panel(
          title = tr_("Clean values"),
          clean_ui(ns("clean"))
        ),
        nav_panel(
          title = tr_("Missing values"),
          missing_ui(ns("missing"))
        )
      ),
      border_radius = FALSE,
      fillable = TRUE,
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Count Data Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param demo A [`character`] string specifying the name of a dataset (see
#'  [import_server()]).
#' @return A reactive [`data.frame`].
#' @seealso [count_ui()]
#' @family count data modules
#' @keywords internal
#' @export
count_server <- function(id, demo = NULL) {
  moduleServer(id, function(input, output, session) {
    ## Prepare data -----
    data_raw <- import_server("import", demo = demo)
    quanti <- subset_quantitative(data_raw, positive = TRUE)

    ## Update UI -----
    parts <- update_checkbox_colnames("parts", x = quanti)

    ## Select variables -----
    data_count <- select_data(quanti, names = parts, drop = FALSE) |>
      debounce(500)

    ## Clean data -----
    data_clean <- clean_server("clean", x = data_count)
    data_missing <- missing_server("missing", x = data_clean)

    ## Check -----
    data_valid <- reactive({
      validate_csv(data_missing())
      validate_dim(data_missing(), i = 1, j = 1)
      validate_na(data_missing())

      data_missing()
    })

    ## Render description -----
    box_server("box", x = data_valid)

    ## Render table -----
    output$table <- gt::render_gt({
      req(data_missing())
      tbl <- if (isTRUE(input$head)) utils::head(data_missing()) else data_missing()
      gt::gt(tbl, rownames_to_stub = TRUE) |>
        gt::tab_options(table.width = "100%")
    })

    data_valid
  })
}

# UI ===========================================================================
#' Compositional Data Outliers UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [coda_outliers_server()]
#' @family coda modules
#' @keywords internal
#' @export
coda_outliers_ui <- function(id) {
  ## Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Outliers"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        h5(tr_("Outliers Detection")),
        helpText(
          tr_("See"),
          cite_article("Filzmoser & Hron", "2008", "10.1007/s11004-007-9141-5", after = ";"),
          cite_article("Filzmoser, Hron & Reimann", "2012", "10.1016/j.cageo.2011.06.014", after = ".")
        ),
        radioButtons(
          inputId = ns("method"),
          label = tr_("Multivariate location estimation"),
          choiceNames = c(tr_("Minimum volume ellipsoid"),
                          tr_("Minimum covariance determinant")),
          choiceValues = c("mve", "mcd")
        ),
        sliderInput(
          inputId = ns("quantile"),
          label = tr_("Quantile"),
          min = 0.025, max = 0.995,
          value = 0.975, step = 0.005
        ),
        actionButton(inputId = ns("go"), label = tr_("(Re)Detect")),
        render_export_button(ns("export_results"))
      ), # sidebar
      layout_columns(
        col_widths = "50%",
        output_plot(
          id = ns("plot"),
          title = tr_("Plot")
        ),
        div(
          radioButtons(
            inputId = ns("type"),
            label = tr_("Plot type"),
            choices = c("dotchart", "distance")
          ),
          tableOutput(outputId = ns("info"))
        )
      ) # layout_columns
    ) # layout_sidebar
  ) # nav_panel
}

# Server =======================================================================
#' Compositional Data Outliers Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
#' @return A reactive [`nexus::OutlierIndex-class`] object.
#' @seealso [coda_outliers_ui()]
#' @family coda modules
#' @keywords internal
#' @export
coda_outliers_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Detect outliers -----
    out <- reactive({
      validate(need(x(), tr_("Check your data.")))

      notify(
        {
          nexus::detect_outlier(
            x(),
            method = input$method,
            quantile = input$quantile
          )
        },
        title = tr_("Outliers Detection")
      )
    }) |>
      bindEvent(input$go)

    ## Plot -----
    plot <- reactive({
      req(out())
      function() {
        plot(out(), type = input$type)
      }
    })
    render_plot("plot", x = plot)

    ## Get data -----
    results <- reactive({
      req(out())
      as.data.frame(out())
    })

    ## Download results -----
    export_table("export_results", results, name = "coda_outliers")

    out
  })
}

# UI ===========================================================================
#' Bertin Diagrams UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @param title A [`character`] string giving the plot title.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [bertin_server()]
#' @family count data modules
#' @keywords internal
#' @export
bertin_ui <- function(id, title = NULL) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Plot"),
    layout_sidebar(
      sidebar = sidebar(
        ## Input: select plot
        radioButtons(
          inputId = ns("type"),
          label = tr_("Plot type"),
          selected = "ford",
          choiceNames = c(tr_("Ford diagram"), tr_("Bertin barplot"),
                          tr_("Bertin scalogram"), tr_("Heatmap")),
          choiceValues = c("ford", "barplot", "scalogram", "heatmap")
        ),
        conditionalPanel(
          condition = "input.type == 'ford'",
          ns = ns,
          checkboxInput(
            inputId = ns("eppm"),
            label = "EPPM",
            value = FALSE
          ),
          checkboxInput(
            inputId = ns("weights"),
            label = tr_("Weights"),
            value = FALSE
          ),
          helpText(info_article(author = "Desachy", year = "2004", doi = "10.3406/pica.2004.2396")),
        ),
        conditionalPanel(
          condition = "input.type == 'barplot'",
          ns = ns,
          radioButtons(
            inputId = ns("threshold"),
            label = tr_("Threshold"),
            selected = "none",
            choiceNames = c(tr_("None"), tr_("Mean"), tr_("Median")),
            choiceValues = c("none", "mean", "median")
          )
        )
      ),
      output_plot(
        id = ns("plot"),
        height = "100%",
        title = title,
        tools = graphics_ui(ns("par"), pch = FALSE, lty = FALSE, cex = FALSE)
      )
    )
  )
}

# Server =======================================================================
#' Bertin Diagrams Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive `data.frame` (typically returned by [import_server()]).
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return
#'  No return value, called for side effects.
#' @seealso [bertin_ui()]
#' @family count data modules
#' @keywords internal
#' @export
bertin_server  <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Graphical parameters -----
    param <- graphics_server("par")

    ## Plot -----
    plot_permute <- reactive({
      req(x())

      threshold <- switch(
        input$threshold,
        mean = mean,
        median = stats::median,
        none = NULL
      )

      switch(
        input$type,
        ford = function()
          tabula::plot_ford(x(), weights = input$weights, EPPM = input$eppm),
        barplot = function()
          tabula::plot_bertin(x(), threshold = threshold),
        scalogram = function()
          tabula::plot_spot(x(), color = "black", legend = FALSE),
        heatmap = function()
          tabula::plot_heatmap(x(), color = param$pal_quant, fixed_ratio = FALSE)
      )
    })

    ## Render plot -----
    render_plot("plot", x = plot_permute)
  })
}

# UI =====================================================================
render_export_button <- function(id) {
  uiOutput(outputId = NS(id, "download_button"))
}

# Server =======================================================================
#' Download a CSV File
#'
#' Save and Download a [`data.frame`] (CSV).
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`data.frame`] to be saved.
#' @param name A [`character`] string specifying the name of the file
#'  (without extension and the leading dot).
#' @param label A [`character`] string giving the label that should appear on
#'  the button.
#' @return
#'  No return value, called for side effects.
#' @keywords internal
export_table <- function(id, x, name, label = tr_("Download results")) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    output$download_button <- renderUI({
      req(x())
      downloadButton(
        outputId = session$ns("download"),
        label = label
      )
    })

    output$download <- downloadHandler(
      filename = function() { make_file_name(name, "csv") },
      content = function(file) {
        x <- x()
        if (!is.data.frame(x) && !is.matrix(x)) x <- as.matrix(x)
        utils::write.csv(
          x = x,
          file = file,
          fileEncoding = "utf-8"
        )
      },
      contentType = "text/csv"
    )
  })
}

#' Download Multiple CSV Files
#'
#' Save and Download several [`data.frame`] (Zip).
#' @param ... Further named arguments ([`data.frame`] to be saved).
#' @inheritParams export_table
#' @return
#'  No return value, called for side effects.
#' @keywords internal
export_multiple <- function(id, ..., name = "archive", label = tr_("Download results")) {
  tbl <- list(...)
  stopifnot(!is.null(names(tbl)))

  moduleServer(id, function(input, output, session) {
    output$download_button <- renderUI({
      req(tbl[[1L]]())
      downloadButton(
        outputId = session$ns("download"),
        label = label
      )
    })

    output$download <- downloadHandler(
      filename = function() { make_file_name(name, "zip") },
      content = function(file) {
        tmpdir <- tempdir()
        on.exit(unlink(tmpdir))

        ## Write CSV files
        fs <- vapply(
          X = names(tbl),
          FUN = function(f) {
            path <- file.path(tmpdir, paste0(f, ".csv"))
            utils::write.csv(
              x = tbl[[f]](),
              file = path,
              row.names = TRUE,
              fileEncoding = "utf-8"
            )
            return(path)
          },
          FUN.VALUE = character(1)
        )

        ## Create Zip file
        utils::zip(zipfile = file, files = fs, flags = "-r9Xjq")
      },
      contentType = "application/zip"
    )
  })
}

# UI ===========================================================================
#' Compositional Histogram UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @seealso [coda_hist_server()]
#' @family coda modules
#' @keywords internal
#' @export
coda_hist_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Histogram"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Histogram"),
        selectize_ui(id = ns("select"), label = tr_("Select a part"))
      ), # sidebar
      output_plot(
        id = ns("hist"),
        title = tr_("Histogram"),
        note = info_article(author = "Filzmoser et al.", year = "2009",
                            doi = "10.1016/j.scitotenv.2009.08.008")
      )
    ) # layout_sidebar
  ) # nav_panel
}


# Server =======================================================================
#' Compositional Histogram Server
#'
#' @param id An ID string that corresponds with the ID used to call the module's
#'  UI function.
#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
#' @return
#'  No return value, called for side effects.
#' @seealso [coda_hist_ui()]
#' @family coda modules
#' @keywords internal
#' @export
coda_hist_server <- function(id, x) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Select column -----
    col_hist <- update_selectize_colnames("select", x = x, placeholder = FALSE)

    ## Histogram -----
    plot_hist <- reactive({
      req(x(), col_hist())
      function() nexus::hist(x(), select = col_hist())
    })

    ## Render histogram -----
    render_plot("hist", x = plot_hist)
  })
}

# UI ===========================================================================
#' Diversity Definitions UI
#'
#' @param id A [`character`] vector to be used for the namespace.
#' @return
#'  A nav item that may be passed to a nav container
#'  (e.g. [bslib::navset_tab()]).
#' @family count data modules
#' @keywords internal
#' @export
diversity_docs_ui <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  nav_panel(
    title = tr_("Definitions"),
    layout_columns(
      col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
      card(
        card_title(tr_("Alpha Diversity")),
        tags$dl(
          tags$dt(tr_("Heterogeneity index")),
          tags$dd(tr_("The higher the heterogeneity value, the more diverse the individuals are in the dataset.")),
          tags$dl(
            tags$dt("Shannon"),
            tags$dd(
              "Shannon, C. E. (1948). A Mathematical Theory of Communication.",
              tags$em("The Bell System Technical Journal"), "27, 379-423.",
              url_doi("10.1002/j.1538-7305.1948.tb01338.x", prefix = TRUE)
            ),
            tags$dt("Brillouin"),
            tags$dd(
              "Brillouin, L. (1956).", tags$em("Science and information theory."), "New York: Academic Press."
            )
          ),

          tags$dt(tr_("Dominance index")),
          tags$dd(tr_("Dominance is a measure of whether a community is dominated by certain types (an increase in the value means a decrease in diversity).")),
          tags$dl(
            tags$dt("Simpson"),
            tags$dd(
              "Simpson, E. H. (1949). Measurement of Diversity.",
              tags$em("Nature"), "163(4148), 688-688.",
              url_doi("10.1038/163688a0", prefix = TRUE)
            ),
            tags$dt("Berger-Parker"),
            tags$dd(
              "Berger, W. H. & Parker, F. L. (1970). Diversity of Planktonic Foraminifera in Deep-Sea Sediments.",
              tags$em("Science"), "168(3937), 1345-1347.",
              url_doi("10.1126/science.168.3937.1345", prefix = TRUE)
            )
          ),

          tags$dt(tr_("Richness index")),
          tags$dd(tr_("Richness quantifies how many different types the dataset of interest contains, it does not take into account the abundances of the types.")),
          tags$dl(
            tags$dt("Menhinick"),
            tags$dd(
              "Menhinick, E. F. (1964). A Comparison of Some Species-Individuals Diversity Indices Applied to Samples of Field Insects.",
              tags$em("Ecology"), "45(4), 859-861.",
              url_doi("10.2307/1934933", prefix = TRUE)
            ),
            tags$dt("Margalef"),
            tags$dd(
              "Margalef, R. (1958). Information Theory in Ecology.",
              tags$em("General Systems"), "3, 36-71."
            ),
            tags$dt("Chao 1"),
            tags$dd(
              "Chao, A. (1984). Nonparametric Estimation of the Number of Classes in a Population.",
              tags$em("Scandinavian Journal of Statistics"), "11(4), 265-270."
            ),
            tags$dt("ACE"),
            tags$dd(
              "Chao, A. & Lee, S.-M. (1992). Estimating the Number of Classes via Sample Coverage.",
              tags$em("Journal of the American Statistical Association"), "87(417), 210-217.",
              url_doi("10.1080/01621459.1992.10475194", prefix = TRUE)
            ),
            tags$dt("Squares Estimator"),
            tags$dd(
              "Alroy, J. (2018). Limits to Species Richness in Terrestrial Communities.",
              tags$em("Ecology Letters"), "21(12), 1781-1789.",
              url_doi("10.1111/ele.13152", prefix = TRUE)
            )
          )
        )
      ),
      card(
        card_title(tr_("Beta Diversity")),
        tags$dl(
          tags$dt("Bray-Curtis"),
          tags$dd(
            "Bray, J. R. & Curtis, J. T. (1957). An Ordination of the Upland Forest Communities of Southern Wisconsin.",
            tags$em("Ecological Monographs"), "27(4), 325-349.",
            url_doi("10.2307/1942268", prefix = TRUE)
          ),
          tags$dt("Dice-Sorensen"),
          tags$dd(
            "Dice, L. R. (1945). Measures of the Amount of Ecologic Association Between Species.",
            tags$em("Ecology"), "26(3): 297-302.",
            url_doi("10.2307/1932409", prefix = TRUE)
          ),
          tags$dd(
            "Sorensen, T. (1948). A Method of Establishing Groups of Equal Amplitude in Plant Sociology Based on Similarity of Species Content and Its Application to Analyses of the Vegetation on Danish Commons.",
            tags$em("Kongelige Danske Videnskabernes Selskab"), "5(4): 1-34."
          ),
          tags$dt("Morisita-Horn (Horn modified version of the Morisita index)"),
          tags$dd(
            "Horn, H. S. (1966). Measurement of \"Overlap\" in Comparative Ecological Studies.",
            tags$em("The American Naturalist"), "100(914): 419-424.",
            url_doi("10.1086/282436", prefix = TRUE)
          ),
          tags$dd(
            "Mosrisita, M. (1959). Measuring of interspecific association and similarity between communities.",
            tags$em("Memoirs of the Faculty of Science, Kyushu University, Series E"), "3:65-80."
          )
        )
      )
    ) # layout_columns
  ) # nav_panel
}

1		# UI ===========================================================================
2		#' Prepare Data UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [prepare_server()]
9		#' @family generic modules
10		#' @keywords internal
11		#' @export
12		prepare_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Data"),
18	!	value = "data",
19	!	layout_sidebar(
20	!	sidebar = sidebar(
21	!	width = 400,
22	!	title = tr_("Data"),
23	!	import_ui(ns("import"))
24	!	), # sidebar
25		## Output: value box
26	!	box_ui(ns("box")),
27	!	navset_card_pill(
28	!	placement = "above",
29	!	nav_panel(
30	!	title = tr_("Data"),
31	!	checkboxInput(
32	!	inputId = ns("head"),
33	!	label = tr_("Table overview"),
34	!	value = TRUE),
35	!	gt::gt_output(outputId = ns("table"))
36		),
37	!	nav_panel(
38	!	title = tr_("Clean values"),
39	!	clean_ui(ns("clean"))
40		),
41	!	nav_panel(
42	!	title = tr_("Missing values"),
43	!	missing_ui(ns("missing"))
44		)
45		),
46	!	border_radius = FALSE,
47	!	fillable = TRUE,
48	!	) # layout_sidebar
49	!	) # nav_panel
50		}
51
52		# Server =======================================================================
53		#' Prepare Data Server
54		#'
55		#' @param id An ID string that corresponds with the ID used to call the module's
56		#' UI function.
57		#' @param demo A [`character`] string specifying the name of a dataset (see
58		#' [import_server()]).
59		#' @return A reactive [`data.frame`].
60		#' @seealso [prepare_ui()]
61		#' @family generic modules
62		#' @keywords internal
63		#' @export
64		prepare_server <- function(id, demo = NULL) {
65	!	moduleServer(id, function(input, output, session) {
66		## Prepare data -----
67	!	data_raw <- import_server("import", demo = demo)
68	!	data_clean <- clean_server("clean", x = data_raw)
69	!	data_miss <- missing_server("missing", x = data_clean)
70
71		## Render description -----
72	!	box_server("box", x = data_miss)
73
74		## Render table -----
75	!	output$table <- gt::render_gt({
76	!	tbl <- if (isTRUE(input$head)) utils::head(data_miss()) else data_miss()
77	!	gt::gt(tbl, rownames_to_stub = TRUE) \|>
78	!	gt::tab_options(table.width = "100%")
79		})
80
81	!	data_miss
82		})
83		}
84
85		# Modules ======================================================================
86		## Value box -------------------------------------------------------------------
87		box_ui <- function(id) {
88	!	ns <- NS(id)
89
90	!	layout_columns(
91	!	col_widths = breakpoints(
92	!	xs = c(12, 12, 12, 12),
93	!	md = c(6, 6, 6, 6),
94	!	lg = c(3, 3, 3, 3)
95		),
96	!	fill = FALSE,
97	!	value_box(
98	!	title = tr_("Dimensions"),
99	!	uiOutput(outputId = ns("value_dimensions"))
100		),
101	!	value_box(
102	!	title = tr_("Sparsity"),
103	!	uiOutput(outputId = ns("value_sparsity"))
104		),
105	!	value_box(
106	!	title = tr_("Missing values"),
107	!	uiOutput(outputId = ns("value_missing"))
108		),
109	!	card(
110	!	helpText(tr_("Export your data for futur use.")),
111	!	render_export_button(ns("export"))
112		)
113		)
114		}
115		box_server <- function(id, x) {
116	1x	stopifnot(is.reactive(x))
117
118	1x	moduleServer(id, function(input, output, session) {
119	1x	output$value_dimensions <- renderUI({
120	5x	req(x())
121	3x	paste0(dim(x()), collapse = " x ")
122		})
123	1x	output$value_sparsity <- renderUI({
124	5x	req(x())
125	3x	paste0(round(arkhe::sparsity(x()) * 100, 2), "%")
126		})
127	1x	output$value_missing <- renderUI({
128	5x	req(x())
129	3x	sum(is.na(x()))
130		})
131
132		## Download -----
133	1x	export_table("export", x, name = "data", label = tr_("Download"))
134		})
135		}
136
137		## Clean -----------------------------------------------------------------------
138		clean_ui <- function(id) {
139	!	ns <- NS(id)
140
141	!	list(
142		## Input: remove whitespace
143	!	checkboxInput(
144	!	inputId = ns("remove_whitespace"),
145	!	label = tr_("Remove leading/trailing whitespace"),
146	!	value = FALSE,
147	!	width = "100%"
148		),
149		## Input: remove zero
150	!	checkboxInput(
151	!	inputId = ns("remove_zero_row"),
152	!	label = tr_("Remove rows with zero"),
153	!	value = FALSE,
154	!	width = "100%"
155		),
156	!	checkboxInput(
157	!	inputId = ns("remove_zero_column"),
158	!	label = tr_("Remove columns with zero"),
159	!	value = FALSE,
160	!	width = "100%"
161		),
162		## Input: remove constant
163	!	checkboxInput(
164	!	inputId = ns("remove_constant_column"),
165	!	label = tr_("Remove constant columns"),
166	!	value = FALSE,
167	!	width = "100%"
168		),
169		## Input: remove all?
170	!	checkboxInput(
171	!	inputId = ns("all"),
172	!	label = tr_("Remove only if all values meet the condition"),
173	!	value = TRUE,
174	!	width = "100%"
175		)
176		)
177		}
178
179		#' @param id A [`character`] string specifying the namespace.
180		#' @param x A reactive `matrix`-like object.
181		#' @param verbose A [`logical`] scalar: should \R report extra information on
182		#' progress?
183		#' @return A reactive [`data.frame`].
184		#' @noRd
185		clean_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
186	2x	stopifnot(is.reactive(x))
187
188	2x	moduleServer(id, function(input, output, session) {
189		## Clean whitespace
190	2x	no_ws <- reactive({
191	6x	req(x())
192	4x	if (!isTRUE(input$remove_whitespace)) return(x())
193	!	arkhe::clean_whitespace(x(), squish = TRUE)
194		})
195
196		## Remove (all) rows with zeros
197	2x	no_zero_row <- reactive({
198	8x	req(no_ws())
199	5x	if (!isTRUE(input$remove_zero_row)) return(no_ws())
200	1x	arkhe::remove_zero(no_ws(), margin = 1, all = isTRUE(input$all),
201	1x	verbose = verbose)
202		})
203
204		## Remove (all) columns with zeros
205	2x	no_zero_col <- reactive({
206	7x	req(no_zero_row())
207	4x	if (!isTRUE(input$remove_zero_column)) return(no_zero_row())
208	1x	arkhe::remove_zero(no_zero_row(), margin = 2, all = isTRUE(input$all),
209	1x	verbose = verbose)
210		})
211
212		## Remove constant columns
213	2x	no_cte <- reactive({
214	6x	req(no_zero_col())
215	4x	if (!isTRUE(input$remove_constant_column)) return(no_zero_col())
216	!	arkhe::remove_constant(no_zero_col(), verbose = verbose)
217		})
218
219	2x	no_cte
220		})
221		}
222
223		## Missing ---------------------------------------------------------------------
224		missing_ui <- function(id) {
225	!	ns <- NS(id)
226
227	!	layout_column_wrap(
228	!	width = 1/2,
229	!	list(
230		## Input: empty as missing
231	!	checkboxInput(
232	!	inputId = ns("empty_as_NA"),
233	!	label = tr_("Empty string as missing value"),
234	!	value = FALSE
235		),
236		## Input: zero as missing
237	!	checkboxInput(
238	!	inputId = ns("zero_as_NA"),
239	!	label = tr_("Zero as missing value"),
240	!	value = FALSE
241		),
242		## Input: remove missing
243	!	radioButtons(
244	!	inputId = ns("remove"),
245	!	label = tr_("Remove missing values:"),
246	!	choiceNames = c(
247	!	tr_("Keep as is"),
248	!	tr_("Replace missing values with zeros"),
249	!	tr_("Remove rows with missing values"),
250	!	tr_("Remove columns with missing values")
251		),
252	!	choiceValues = c("none", "zero", "row", "col")
253		)
254		),
255	!	output_plot(ns("heatmap"))
256		)
257		}
258
259		#' @param id A [`character`] string specifying the namespace.
260		#' @param x A reactive `matrix`-like object.
261		#' @param verbose A [`logical`] scalar: should \R report extra information on
262		#' progress?
263		#' @return A reactive [`data.frame`].
264		#' @noRd
265		missing_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
266	2x	stopifnot(is.reactive(x))
267
268	2x	moduleServer(id, function(input, output, session) {
269		## Replace empty strings
270	2x	empty_as_na <- reactive({
271	6x	req(x())
272	4x	if (!isTRUE(input$empty_as_NA)) return(x())
273	!	arkhe::replace_empty(x(), value = NA)
274		})
275
276		## Replace zeros
277	2x	zero_as_na <- reactive({
278	7x	req(empty_as_na())
279	5x	if (!isTRUE(input$zero_as_NA)) return(empty_as_na())
280	!	arkhe::replace_zero(empty_as_na(), value = NA)
281		})
282
283		## Remove missing values
284	2x	no_missing <- reactive({
285	11x	req(zero_as_na())
286
287	9x	choice <- input$remove %\|\|\|% ""
288	9x	fun <- switch(
289	9x	choice,
290	9x	zero = function(x) {
291	1x	arkhe::replace_NA(x, value = 0)
292		},
293	9x	row = function(x) {
294	1x	arkhe::remove_NA(x, margin = 1, all = FALSE, verbose = verbose)
295		},
296	9x	col = function(x) {
297	1x	arkhe::remove_NA(x, margin = 2, all = FALSE, verbose = verbose)
298		},
299	6x	function(x) { x }
300		)
301
302	9x	fun(zero_as_na())
303		})
304
305		## Render plot
306	2x	plot_missing <- reactive({
307	10x	req(all(dim(no_missing()) > 0))
308	8x	function() {
309	8x	col <- if (anyNA(no_missing())) c("#DDDDDD", "#BB5566") else "#DDDDDD"
310	8x	tabula::plot_heatmap(object = is.na(no_missing()), color = col,
311	8x	fixed_ratio = FALSE)
312		}
313		})
314	2x	render_plot("heatmap", x = plot_missing)
315
316	2x	no_missing
317		})
318		}

1		# Utilities ====================================================================
2		select_data <- function(x, names, drop = FALSE) {
3	2x	stopifnot(is.reactive(x))
4	2x	stopifnot(is.reactive(names))
5
6	2x	reactive({
7	!	if (!all(dim(x()) > 0)) return(NULL)
8
9	2x	cols <- arkhe::get_columns(x = x(), names = names())
10	!	if (!isTRUE(drop)) return(cols)
11	2x	unlist(cols, use.names = FALSE)
12		}) \|>
13	2x	bindEvent(names())
14		}
15		subset_data <- function(x, f = NULL) {
16	4x	stopifnot(is.reactive(x))
17
18	4x	reactive({
19	6x	req(x())
20	!	if (!is.function(f)) return(x())
21	4x	arkhe::keep_columns(x = x(), f = f, verbose = get_option("verbose", FALSE))
22		})
23		}
24		subset_quantitative <- function(x, positive = FALSE) {
25	2x	if (isTRUE(positive)) {
26	1x	f <- \(x) is.numeric(x) && all(x >= 0, na.rm = TRUE)
27		} else {
28	1x	f <- is.numeric
29		}
30	2x	subset_data(x, f)
31		}
32		subset_qualitative <- function(x) {
33	2x	f <- \(x) Negate(is.numeric)(x)
34	2x	subset_data(x, f)
35		}
36
37		# UI ===========================================================================
38		#' Updatable Select List
39		#'
40		#' @param id A [`character`] string specifying the namespace.
41		#' @return
42		#' A select list control that can be added to a UI definition
43		#' (see [shiny::selectizeInput()]).
44		#' @seealso [update_selectize_colnames()], [update_selectize_rownames()]
45		#' @keywords internal
46		selectize_ui <- function(id, label = "Choose", multiple = FALSE, help = NULL) {
47	!	ns <- NS(id)
48	!	plugins <- ifelse(isTRUE(multiple), "remove_button", "clear_button")
49	!	options <- list(plugins = plugins)
50
51	!	if (!is.null(help)) {
52	!	label <- bslib::tooltip(trigger = list(label, icon("info-circle")), help)
53		}
54
55	!	selectizeInput(
56	!	inputId = ns("names"),
57	!	label = label,
58	!	choices = NULL,
59	!	selected = NULL,
60	!	multiple = multiple,
61	!	options = options
62		)
63		}
64
65		#' Updatable Checkbox Group
66		#'
67		#' @param id A [`character`] vector to be used for the namespace.
68		#' @return
69		#' A checkbox group control that can be added to a UI definition
70		#' (see [shiny::checkboxGroupInput()]).
71		#' @seealso [update_checkbox_colnames()]
72		#' @keywords internal
73		checkbox_ui <- function(id, label = "Choose", inline = TRUE) {
74	!	ns <- NS(id)
75
76	!	checkboxGroupInput(
77	!	inputId = ns("names"),
78	!	label = label,
79	!	choices = NULL,
80	!	selected = NULL,
81	!	inline = inline
82		)
83		}
84
85		# Server =======================================================================
86		#' Update a Checkbox Group with Column Names
87		#'
88		#' @inheritParams update_input
89		#' @return
90		#' A reactive [`character`] vector of column names.
91		#'
92		#' Side effect: change the value of a checkbox group on the client.
93		#' @seealso [checkbox_ui()]
94		#' @keywords internal
95		update_checkbox_colnames <- function(id, x, exclude = reactive(NULL), select = TRUE) {
96	2x	update_input(id = id, x = x, exclude = exclude, select = select,
97	2x	control = updateCheckboxGroupInput)
98		}
99
100		#' Update a Select List with Column Names
101		#'
102		#' @inheritParams update_input
103		#' @return
104		#' A reactive [`character`] vector of column names.
105		#'
106		#' Side effect: change the value of a select list on the client.
107		#' @seealso [selectize_ui()]
108		#' @keywords internal
109		update_selectize_colnames <- function(id, x, exclude = reactive(NULL),
110		select = FALSE, placeholder = TRUE) {
111	11x	update_input(id = id, x = x, exclude = exclude, select = select,
112	11x	placeholder = placeholder,
113	11x	control = updateSelectizeInput)
114		}
115
116		#' Update a Select List with Row Names
117		#'
118		#' @inheritParams update_input
119		#' @return
120		#' A reactive [`character`] vector of row names.
121		#'
122		#' Side effect: change the value of a select list on the client.
123		#' @seealso [selectize_ui()]
124		#' @keywords internal
125		update_selectize_rownames <- function(id, x, exclude = reactive(NULL),
126		select = FALSE, placeholder = TRUE) {
127	1x	update_input(id = id, x = x, choices = rownames, exclude = exclude,
128	1x	select = select, placeholder = placeholder,
129	1x	control = updateSelectizeInput)
130		}
131
132		#' Update an Input Control with Column Names
133		#'
134		#' @param id A [`character`] string specifying the namespace.
135		#' @param x A reactive `matrix`-like object.
136		#' @param control An UI input updater.
137		#' @param choices A [`function`] that takes `x` as a single argument and returns
138		#' a `character` vector.
139		#' @param exclude A reactive [`character`] vector of values to be excluded from
140		#' choices.
141		#' @param select A [`logical`] scalar: should all choices be selected?
142		#' @param placeholder A [`logical`] scalar: should a placeholder be added?
143		#' @return
144		#' A reactive [`character`] vector of column names.
145		#'
146		#' Side effect: change the value of an input control on the client.
147		#' @seealso [update_checkbox_colnames()], [update_selectize_colnames()],
148		#' [update_selectize_rownames()]
149		#' @keywords internal
150		update_input <- function(id, x, control,
151		choices = colnames, exclude = reactive(NULL),
152		select = TRUE, placeholder = FALSE) {
153	14x	stopifnot(is.reactive(x))
154	14x	stopifnot(is.reactive(exclude))
155
156	14x	moduleServer(id, function(input, output, session) {
157	22x	trigger <- reactive({ exclude() %\|\|\|% x() })
158
159		## Update UI
160	14x	observe({
161	14x	opt <- choices(x())
162	14x	opt <- setdiff(opt, exclude())
163	14x	selected <- if (isTRUE(select)) opt else NULL
164
165	14x	if (length(opt) > 0) {
166		## Try to keep previous selection, if any
167	14x	keep <- intersect(opt, input$names)
168	1x	if (length(keep) > 0) selected <- keep
169		} else {
170	!	opt <- character(0)
171		}
172
173	14x	names(opt) <- opt
174
175		## Add placeholder
176	14x	if (isTRUE(placeholder)) {
177	12x	opt <- c("", opt)
178	12x	names(opt) <- c(tr_("Choose"), rep("", length(opt) - 1))
179		}
180
181	14x	freezeReactiveValue(input, "names")
182	14x	control(
183	14x	session,
184	14x	inputId = "names",
185	14x	choices = opt,
186	14x	selected = selected
187		)
188		}) \|>
189	14x	bindEvent(trigger())
190
191		## Return variable names
192	26x	reactive({ input$names })
193		})
194		}

1		# UI ===========================================================================
2		#' Aoristic Analysis UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [aoristic_server()]
9		#' @family chronology modules
10		#' @keywords internal
11		#' @export
12		aoristic_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Analysis"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Aoristic Analysis"),
22	!	numericInput(
23	!	inputId = ns("step"),
24	!	label = tr_("Temporal step size"),
25	!	value = 10,
26	!	min = 1,
27	!	max = 500
28		),
29	!	numericInput(
30	!	inputId = ns("start"),
31	!	label = tr_("Beginning of the time window"),
32	!	value = NULL
33		),
34	!	numericInput(
35	!	inputId = ns("end"),
36	!	label = tr_("End of the time window"),
37	!	value = NULL
38		),
39	!	select_calendar(ns("calendar")),
40	!	checkboxInput(
41	!	inputId = ns("weight"),
42	!	label = tr_("Weigth"),
43	!	value = FALSE
44		),
45	!	info_article("Ratcliffe", "2002", "10.1023/A:1013240828824"),
46	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
47	!	render_export_button(ns("export"))
48	!	), # sidebar
49	!	output_plot(id = ns("plot_ao"))
50	!	) # layout_sidebar
51	!	) # nav_panel
52		}
53
54		# Server =======================================================================
55		#' Aoristic Analysis Server
56		#'
57		#' @param id An ID string that corresponds with the ID used to call the module's
58		#' UI function.
59		#' @param x A reactive `list` (returned by [time_interval_server()])
60		#' @return A reactive [`kairos::AoristicSum-class`] object.
61		#' @seealso [aoristic_ui()]
62		#' @family chronology modules
63		#' @keywords internal
64		#' @export
65		aoristic_server <- function(id, x, y) {
66	!	stopifnot(is.reactive(x))
67	!	stopifnot(is.reactive(y))
68
69	!	moduleServer(id, function(input, output, session) {
70		## Update UI -----
71	!	calendar <- get_calendar("calendar")
72	!	lower <- reactive({
73	!	req(x()$results)
74	!	aion::start(x()$results, calendar = calendar())
75		})
76	!	upper <- reactive({
77	!	req(x()$results)
78	!	aion::end(x()$results, calendar = calendar())
79		})
80
81	!	observe({
82	!	updateNumericInput(inputId = "start", value = min(lower(), na.rm = TRUE))
83		}) \|>
84	!	bindEvent(lower())
85	!	observe({
86	!	updateNumericInput(inputId = "end", value = max(upper(), na.rm = TRUE))
87		}) \|>
88	!	bindEvent(upper())
89
90		## Compute analysis -----
91	!	compute_ao <- ExtendedTask$new(
92	!	function(x, y, step, start, end, calendar, weight, groups) {
93	!	mirai::mirai({
94	!	kairos::aoristic(x, y, step, start, end, calendar, weight, groups)
95	!	}, environment())
96		}
97		) \|>
98	!	bslib::bind_task_button("go")
99
100	!	observe({
101	!	compute_ao$invoke(x = lower(), y = upper(), step = input$step,
102	!	start = input$start, end = input$end,
103	!	calendar = calendar(), weight = input$weight,
104	!	groups = x()$groups)
105		}) \|>
106	!	bindEvent(input$go)
107
108	!	old <- reactive({ x() }) \|> bindEvent(input$go)
109	!	results <- reactive({
110	!	if (!identical(x(), old())) return(NULL) # Invalidate
111	!	notify(compute_ao$result(), title = tr_("Aoristic Analysis"))
112		})
113
114		## Plot -----
115	!	plot_ao <- reactive({
116	!	req(results())
117	!	function() {
118	!	kairos::plot(results(), calendar = calendar(), col = "grey")
119		}
120		})
121
122		## Render plots -----
123	!	render_plot("plot_ao", x = plot_ao)
124
125		## Export -----
126	!	export_table("export", results, name = "aoristic")
127
128	!	results
129		})
130		}

1		# UI ===========================================================================
2		#' Co-Occurrence UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [occurrence_server()]
9		#' @family count data modules
10		#' @keywords internal
11		#' @export
12		occurrence_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Co-Occurrence"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	title = tr_("Co-Occurrence"),
21	!	radioButtons(
22	!	inputId = ns("method"),
23	!	label = tr_("Method"),
24	!	choiceNames = c(tr_("Absolute frequency"),
25	!	tr_("Relative frequency"),
26	!	tr_("Z-score")),
27	!	choiceValues = c("absolute", "relative", "binomial")
28		),
29	!	info_article(author = "Kintigh", year = "2006", doi = "10.6067/XCV8J38QSS"),
30	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
31	!	render_export_button(ns("export_results"))
32	!	), # sidebar
33	!	layout_columns(
34	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
35	!	output_plot(
36	!	id = ns("plot"),
37	!	tools = graphics_ui(ns("par"), col_quali = FALSE,
38	!	pch = FALSE, lty = FALSE, cex = FALSE),
39		),
40	!	card(
41	!	gt::gt_output(outputId = ns("table"))
42		)
43		)
44	!	) # layout_sidebar
45	!	) # nav_panel
46		}
47
48		# Server =======================================================================
49		#' Co-Occurrence Server
50		#'
51		#' @param id An ID string that corresponds with the ID used to call the module's
52		#' UI function.
53		#' @param x A reactive `data.frame` returned by [diversity_server()].
54		#' @param verbose A [`logical`] scalar: should \R report extra information on
55		#' progress?
56		#' @return
57		#' No return value, called for side effects.
58		#' @seealso [occurrence_ui()]
59		#' @family count data modules
60		#' @keywords internal
61		#' @export
62		occurrence_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
63	!	stopifnot(is.reactive(x))
64
65	!	moduleServer(id, function(input, output, session) {
66		## Compute index -----
67	!	compute_occur <- ExtendedTask$new(
68	!	function(x, method) {
69	!	mirai::mirai({ tabula::occurrence(x, method = tolower(method)) }, environment())
70		}
71		) \|>
72	!	bslib::bind_task_button("go")
73
74	!	observe({
75	!	compute_occur$invoke(x = x(), method = input$method)
76		}) \|>
77	!	bindEvent(input$go)
78
79	!	old <- reactive({ x() }) \|> bindEvent(input$go)
80	!	results <- reactive({
81	!	if (!identical(x(), old())) return(NULL) # Invalidate
82	!	notify(compute_occur$result(), title = tr_("Co-Occurrence"))
83		})
84
85		## Graphical parameters -----
86	!	param <- graphics_server("par")
87
88		## Plot -----
89	!	map <- reactive({
90	!	req(results())
91	!	function() tabula::plot_heatmap(results(), color = param$pal_quant)
92		})
93
94		## Render table -----
95	!	output$table <- gt::render_gt({
96	!	req(results())
97	!	tbl <- as.data.frame(as.matrix(results()))
98	!	gt::gt(tbl, rownames_to_stub = TRUE) \|>
99	!	gt::tab_options(table.width = "100%")
100		})
101
102		## Render plot -----
103	!	render_plot("plot", x = map)
104
105		## Download -----
106	!	export_table("export_results", results, name = "occurrence")
107
108	!	results
109		})
110		}

1		# HELPERS
2
3		## https://michaelchirico.github.io/potools/articles/developers.html
4		tr_ <- function(...) {
5	36x	enc2utf8(gettext(paste0(...), domain = "R-kinesis"))
6		}
7
8		#' Bootstrap Theme
9		#'
10		#' @param version A [`character`] string specifying the major version of
11		#' Bootstrap to use.
12		#' @param ... Extra parameters to be passed to [bslib::bs_theme()].
13		#' @return
14		#' Returns a [sass::sass_bundle()] object (see [bslib::bs_theme()]).
15		#' @keywords internal
16		#' @export
17		theme_ui <- function(version = "5", ...) {
18	!	path_style <- system.file("static", "custom.scss", package = "kinesis")
19	!	scss <- sass::sass_file(path_style)
20
21	!	bs <- bslib::bs_theme(
22	!	version = version,
23	!	base_font = c("sans-serif"),
24	!	heading_font = c("sans-serif"),
25	!	code_font = NULL,
26		...
27		)
28	!	bslib::bs_add_rules(bs, scss)
29		}
30
31		# Helpers ======================================================================
32		validate_csv <- function(x) {
33	5x	validate(need(x, message = tr_("Import a CSV file first.")))
34		}
35		validate_rows <- function(x, n = 1) {
36	3x	rows <- ngettext(n, "Select at least %d row.", "Select at least %d rows.")
37	3x	validate(need(NROW(x) >= n, sprintf(rows, n)), errorClass = "kinesis")
38		}
39		validate_columns <- function(x, n = 1) {
40	3x	cols <- ngettext(n, "Select at least %d column.", "Select at least %d columns.")
41	3x	validate(need(NCOL(x) >= n, sprintf(cols, n)), errorClass = "kinesis")
42		}
43		validate_dim <- function(x, i = 1, j = 1) {
44	3x	validate_rows(x, n = i)
45	3x	validate_columns(x, n = j)
46		}
47		validate_na <- function(x) {
48	3x	validate(need(!anyNA(x), tr_("Your data should not contain missing values.")),
49	3x	errorClass = "kinesis")
50		}
51		validate_zero <- function(x) {
52	3x	validate(need(all(x != 0), tr_("Your data should not contain zeros.")),
53	3x	errorClass = "kinesis")
54		}
55
56		#' Default Value for Falsy
57		#'
58		#' Replaces a [falsy][shiny::isTruthy] value with a default value.
59		#' @param x,y An object.
60		#' @return If `x` is not [truthy][shiny::isTruthy()], returns `y`;
61		#' otherwise returns `x`.
62		#' @keywords internal
63		#' @name falsy
64		#' @rdname falsy
65		`%\|\|\|%` <- function(x, y) {
66	8x	if (isTruthy(x)) x else y
67		}
68
69		# Widgets ======================================================================
70		select_calendar <- function(id, default = "CE") {
71	!	ns <- NS(id)
72
73	!	selectizeInput(
74	!	inputId = ns("calendar"),
75	!	label = tr_("Calendar"),
76	!	choices = c("CE", "BCE", "BP", "AD", "BC"),
77	!	selected = default,
78	!	multiple = FALSE,
79	!	options = list(plugins = "remove_button")
80		)
81		}
82		get_calendar <- function(id) {
83	1x	moduleServer(id, function(input, output, session) {
84
85	1x	cal <- reactive({
86	1x	aion::calendar(input$calendar)
87		})
88
89	1x	cal
90		})
91		}
92
93		#' Build Numeric Input
94		#'
95		#' @param id A [`character`] string specifying the namespace.
96		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
97		#' @return
98		#' * `build_numeric_input()` returns a reactive [`numeric`] vector
99		#' (side effect: render numeric input controls).
100		#' * `render_numeric_input()` is called for its side effects
101		#' (creates UI elements).
102		#' @keywords internal
103		build_numeric_input <- function(id, x) {
104	1x	stopifnot(is.reactive(x))
105
106	1x	moduleServer(id, function(input, output, session) {
107		## Get variable names
108	1x	vars <- reactive({ names(x()) })
109
110		## Build UI
111	1x	output$controls <- renderUI({
112	1x	lapply(
113	1x	X = vars(),
114	1x	FUN = function(var) {
115	4x	numericInput(
116	4x	inputId = session$ns(paste0("num_", var)),
117	4x	label = var,
118	4x	value = 0
119		)
120		}
121		)
122		})
123
124		## Get values
125	1x	values <- reactive({
126	1x	vapply(
127	1x	X = paste0("num_", vars()),
128	1x	FUN = function(var, input) input[[var]],
129	1x	FUN.VALUE = numeric(1),
130	1x	input = input
131		)
132		})
133
134	1x	values
135		})
136		}
137
138		#' @rdname build_numeric_input
139		render_numeric_input <- function(id) {
140	!	uiOutput(NS(id, "controls"))
141		}
142
143		# Notification =================================================================
144		#' Toast Notification
145		#'
146		#' Shows a lightweight, temporary message.
147		#' @param text A [`character`] string giving the body content of the
148		#' notification.
149		#' @param title A [`character`] string giving the title of the notification.
150		#' @inheritParams bslib::toast
151		#' @return Invisibly returns the toast ID (string).
152		#' @keywords internal
153		#' @noRd
154		show_notification <- function(text, title = NULL, id = NULL, duration = 5,
155		closable = TRUE, type = "default") {
156		# text <- paste0(text, collapse = "\n")
157	2x	id <- show_toast(
158	2x	toast(
159	2x	markdown(text, hardbreaks = TRUE),
160	2x	header = title,
161	2x	icon = NULL,
162	2x	id = id,
163	2x	type = type,
164	2x	duration_s = duration,
165	2x	position = c("top", "center"),
166	2x	closable = closable
167		)
168		)
169	2x	invisible(id)
170		}
171
172		#' Notification
173		#'
174		#' Shows a notification if an expression raises an error or a warning.
175		#' @param expr An expression to be evaluated.
176		#' @param title A [`character`] string giving the title of the notification.
177		#' @return The result of `expr` or `NULL`.
178		#' @keywords internal
179		#' @noRd
180		notify <- function(expr, title = NULL) {
181	10x	warn <- err <- NULL
182
183	10x	res <- withCallingHandlers(
184	10x	tryCatch(
185	10x	expr,
186	10x	error = function(e) {
187	1x	if (!inherits(e, "shiny.silent.error")) { # Ignore silent error
188	1x	err <<- conditionMessage(e)
189		}
190	1x	return(NULL)
191		}
192		),
193	10x	warning = function(w) {
194	1x	warn <<- append(warn, conditionMessage(w))
195	1x	invokeRestart("muffleWarning")
196		}
197		)
198
199	10x	if (!is.null(err)) {
200	1x	show_notification(text = err, title = title, type = "error")
201		}
202	10x	if (!is.null(warn)) {
203	1x	warn <- unique(warn)
204	1x	show_notification(text = warn, title = title, type = "warning")
205		}
206
207	10x	res
208		}

1		# UI ===========================================================================
2		#' Scatter Plot UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [scatter_server()]
9		#' @family plot modules
10		#' @keywords internal
11		#' @export
12		scatter_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Scatter Plot"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Variables"),
22		## Input: select axes
23	!	selectize_ui(ns("axis1"), label = tr_("Component X")),
24	!	selectize_ui(ns("axis2"), label = tr_("Component Y")),
25		## Input: aesthetics mapping
26	!	selectize_ui(ns("extra_quali"), label = tr_("Extra qualitative variable")),
27	!	selectize_ui(ns("extra_quanti"), label = tr_("Extra quantitative variable")),
28		## Input: add ellipses
29	!	radioButtons(
30	!	inputId = ns("wrap"),
31	!	label = tr_("Wrap:"),
32	!	choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
33	!	tr_("Confidence ellipse"), tr_("Convex hull")),
34	!	choiceValues = c("none", "tol", "conf", "hull"),
35		),
36	!	checkboxGroupInput(
37	!	inputId = ns("level"),
38	!	label = tr_("Ellipse level:"),
39	!	selected = "0.95",
40	!	choiceNames = c("68%", "95%", "99%"),
41	!	choiceValues = c("0.68", "0.95", "0.99")
42		)
43	!	), # sidebar
44	!	helpText(
45	!	tr_("Click and drag to select an area, then double-click to zoom in."),
46	!	tr_("Double-click again to reset the zoom.")
47		),
48	!	layout_columns(
49	!	col_widths = c(8, 4),
50	!	output_plot(
51	!	id = ns("plot"),
52	!	tools = list(
53	!	graphics_ui(ns("par"), lty = FALSE, asp = TRUE),
54	!	checkboxInput(inputId = ns("grid"), label = tr_("Grid"), value = TRUE)
55		),
56	!	title = tr_("Scatter Plot"),
57	!	click = ns("plot_click"),
58	!	dblclick = ns("plot_dblclick"),
59	!	brush = brushOpts(
60	!	id = ns("plot_brush"),
61	!	resetOnNew = TRUE
62		),
63	!	height = "100%"
64		),
65	!	card(
66	!	helpText(tr_("Click the plot to select rows of data.")),
67	!	gt::gt_output(outputId = ns("info"))
68		)
69		)
70	!	) # layout_sidebar
71	!	) # nav_panel
72		}
73
74		# Server =======================================================================
75		#' Scatter Plot Server
76		#'
77		#' @param id An ID string that corresponds with the ID used to call the module's
78		#' UI function.
79		#' @param x A reactive [`data.frame`].
80		#' @return
81		#' No return value, called for side effects.
82		#' @seealso [scatter_ui()]
83		#' @family plot modules
84		#' @keywords internal
85		#' @export
86		scatter_server <- function(id, x) {
87	!	stopifnot(is.reactive(x))
88
89	!	moduleServer(id, function(input, output, session) {
90		## Update UI -----
91	!	quanti <- subset_quantitative(x)
92	!	quali <- subset_qualitative(x)
93
94	!	axis1 <- update_selectize_colnames("axis1", x = quanti)
95	!	axis2 <- update_selectize_colnames("axis2", x = quanti, exclude = axis1)
96	!	col_quali <- update_selectize_colnames("extra_quali", x = quali)
97	!	col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)
98
99		## Extra variables -----
100	!	extra_quali <- select_data(quali, col_quali, drop = TRUE)
101	!	extra_quanti <- select_data(quanti, col_quanti, drop = TRUE)
102
103		## Interactive zoom -----
104		## When a double-click happens, check if there's a brush on the plot.
105		## If so, zoom to the brush bounds; if not, reset the zoom.
106	!	range_plot <- reactiveValues(x = NULL, y = NULL)
107	!	observe({
108	!	range_plot$x <- brush_xlim(input$plot_brush)
109	!	range_plot$y <- brush_ylim(input$plot_brush)
110		}) \|>
111	!	bindEvent(input$plot_dblclick)
112	!	info <- reactive({
113		## With base graphics, need to tell it what the x and y variables are.
114	!	nearPoints(x(), input$plot_click, xvar = axis1(), yvar = axis2(),
115	!	threshold = 5)
116		})
117
118		## Ellipses -----
119	!	wrap <- reactive({
120	!	level <- as.numeric(input$level)
121	!	switch(
122	!	input$wrap,
123	!	tol = function(x, y, z, ...) dimensio::viz_tolerance(x, y, group = z, level = level, ...),
124	!	conf = function(x, y, z, ...) dimensio::viz_confidence(x, y, group = z, level = level, ...),
125	!	hull = function(x, y, z, ...) dimensio::viz_hull(x, y, group = z, ...),
126	!	function(...) invisible()
127		)
128		})
129
130		## Graphical parameters -----
131	!	param <- graphics_server("par")
132
133		## Build plot -----
134	!	plot_scatter <- reactive({
135		## Select data
136	!	req(x(), axis1(), axis2())
137
138	!	coord_x <- x()[[axis1()]]
139	!	coord_y <- x()[[axis2()]]
140
141
142	!	if (isTruthy(extra_quali())) {
143	!	col <- param$col_quali(extra_quali())
144		} else {
145	!	col <- param$col_quant(extra_quanti())
146		}
147	!	pch <- param$pch(extra_quali())
148	!	cex <- param$cex(extra_quanti())
149
150		## Keep NAs
151	!	if (isTruthy(extra_quali())) {
152	!	pch[which(is.na(extra_quali()))] <- 16
153		}
154
155		## Build plot
156	!	function() {
157	!	graphics::plot(
158	!	x = coord_x,
159	!	y = coord_y,
160	!	type = "p",
161	!	xlim = range_plot$x,
162	!	ylim = range_plot$y,
163	!	xlab = axis1(),
164	!	ylab = axis2(),
165	!	panel.first = if (isTRUE(input$grid)) graphics::grid() else NULL,
166	!	col = col,
167	!	pch = pch,
168	!	cex = cex,
169	!	asp = param$asp,
170	!	las = 1
171		)
172
173		## Add ellipses
174	!	wrap()(
175	!	x = coord_x,
176	!	y = coord_y,
177	!	z = extra_quali() %\|\|\|% rep("All", length(coord_x)),
178	!	color = param$pal_quali
179		)
180
181	!	if (isTruthy(extra_quali())) {
182		## Add legend
183	!	labels <- unique(extra_quali())
184	!	keep <- !is.na(labels)
185	!	cols <- unique(col)
186	!	symb <- unique(pch)
187	!	graphics::legend(
188	!	x = "topleft",
189	!	legend = labels[keep],
190	!	col = if (length(cols) == 1) cols else cols[keep],
191	!	pch = if (length(symb) == 1) symb else symb[keep]
192		)
193		}
194		}
195		})
196
197		## Render table -----
198	!	output$info <- gt::render_gt({
199	!	gt::gt(info(), rownames_to_stub = TRUE) \|>
200	!	gt::tab_options(table.width = "100%")
201		})
202
203		## Render plot -----
204	!	render_plot("plot", x = plot_scatter)
205		})
206		}

1		# UI ===========================================================================
2		#' Linear Model UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [lm_server()]
9		#' @family modeling modules
10		#' @keywords internal
11		#' @export
12		lm_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Linear Model"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Linear Model"),
22		## Input: select axes
23	!	selectize_ui(
24	!	id = ns("response"),
25	!	label = tr_("Dependent variable"),
26	!	multiple = FALSE
27		),
28	!	selectize_ui(
29	!	id = ns("explanatory"),
30	!	label = tr_("Independent variable"),
31	!	multiple = FALSE
32		),
33	!	selectize_ui(
34	!	id = ns("quali"),
35	!	label = tr_("Extra qualitative variable")
36		),
37	!	selectize_ui(
38	!	id = ns("group"),
39	!	label = tr_("Group")
40		)
41	!	), # sidebar
42	!	navset_card_pill(
43	!	nav_panel(
44	!	title = tr_("Prediction"),
45	!	layout_sidebar(
46	!	sidebar = sidebar(
47		## Input: prediction
48	!	radioButtons(
49	!	inputId = ns("interval"),
50	!	label = tr_("Interval"),
51	!	choiceNames = c(tr_("Confidence interval"), tr_("Prediction interval")),
52	!	choiceValues = c("confidence", "prediction")
53		),
54	!	radioButtons(
55	!	inputId = ns("level"),
56	!	label = tr_("Level:"),
57	!	selected = "0.95",
58	!	choiceNames = c("68%", "95%", "99%"),
59	!	choiceValues = c("0.68", "0.95", "0.99")
60		)
61		),
62	!	layout_columns(
63	!	col_widths = c(8, 4),
64	!	output_plot(
65	!	id = ns("plot_lm"),
66	!	title = tr_("Plot"),
67	!	tools = list(
68	!	graphics_ui(
69	!	id = ns("par"), col_quali = FALSE, col_quant = FALSE,
70	!	pch = FALSE, lty = FALSE, cex = FALSE, asp = TRUE
71		),
72	!	checkboxInput(inputId = ns("grid"), label = tr_("Grid"), value = TRUE)
73		)
74		),
75	!	gt::gt_output(outputId = ns("prediction"))
76		)
77		)
78		),
79	!	nav_panel(
80	!	title = tr_("Summary"),
81	!	verbatimTextOutput(outputId = ns("summary"))
82		),
83	!	nav_panel(
84	!	title = tr_("Diagnostic"),
85	!	layout_columns(
86	!	col_widths = breakpoints(xs = 12, sm = c(6, 6), md = c(4, 4, 4)),
87	!	output_plot(id = ns("plot_hist"), title = tr_("Residuals histogram")),
88	!	output_plot(id = ns("plot_qq"), title = tr_("Residual Q-Q plot")),
89	!	output_plot(id = ns("plot_fitted"), title = tr_("Residuals-Fitted")),
90	!	output_plot(id = ns("plot_scale"), title = tr_("Scale-Location")),
91	!	output_plot(id = ns("plot_cook"), title = tr_("Cook's distance")),
92	!	output_plot(id = ns("plot_lev"), title = tr_("Residuals-Leverage"))
93		)
94		)
95	!	) # navset_card_pill
96	!	) # layout_sidebar
97	!	) # nav_panel
98		}
99
100		# Server =======================================================================
101		#' Linear Model Server
102		#'
103		#' @param id An ID string that corresponds with the ID used to call the module's
104		#' UI function.
105		#' @param x A reactive [`data.frame`].
106		#' @return A reactive [`lm`] object.
107		#' @seealso [lm_ui()]
108		#' @family modeling modules
109		#' @keywords internal
110		#' @export
111		lm_server <- function(id, x) {
112	!	stopifnot(is.reactive(x))
113
114	!	moduleServer(id, function(input, output, session) {
115		## Update UI -----
116	!	quanti <- subset_quantitative(x)
117	!	quali <- subset_qualitative(x)
118
119	!	col_quali <- update_selectize_colnames("quali", x = quali)
120	!	resp <- update_selectize_colnames("response", x = quanti)
121	!	expl <- update_selectize_colnames("explanatory", x = quanti, exclude = resp)
122
123		## Subset -----
124	!	groups <- select_data(quali, col_quali, drop = TRUE)
125	!	group <- update_input("group", x = groups, control = updateSelectizeInput,
126	!	choices = unique, select = FALSE, placeholder = TRUE)
127	!	data <- reactive({
128	!	if (!isTruthy(group())) return(x())
129	!	x()[which(groups() == group()), , drop = FALSE]
130		})
131
132		## Linear regression -----
133	!	vars <- reactive({
134	!	req(resp(), expl())
135	!	stats::as.formula(paste0(resp(), " ~ ", paste0(expl(), collapse = " + ")))
136		}) \|>
137	!	bindEvent(expl()) \|>
138	!	debounce(500)
139
140	!	model <- reactive({
141	!	notify(
142	!	stats::lm(vars(), data = data(), na.action = stats::na.omit, y = TRUE)
143		)
144		}) \|>
145	!	bindEvent(vars(), data())
146
147	!	prediction <- reactive({
148	!	pred <- notify(
149	!	stats::predict(
150	!	object = model(),
151	!	se.fit = FALSE,
152	!	interval = input$interval,
153	!	level = as.numeric(input$level)
154		)
155		)
156	!	data.frame(y = model()$y, pred)
157		})
158
159		## Graphical parameters -----
160	!	param <- graphics_server("par")
161
162		## Build plot -----
163	!	plot_lm <- reactive({
164		## Select data
165	!	req(data(), prediction())
166
167	!	coord_x <- data()[[expl()]]
168	!	coord_y <- data()[[resp()]]
169
170		## Build plot
171	!	function() {
172	!	graphics::plot(
173	!	x = coord_x,
174	!	y = coord_y,
175	!	type = "p",
176	!	xlab = expl(),
177	!	ylab = resp(),
178	!	panel.first = if (isTRUE(input$grid)) graphics::grid() else NULL,
179	!	col = "black",
180	!	pch = 16,
181	!	cex = 1,
182	!	asp = param$asp,
183	!	las = 1
184		)
185
186	!	i <- order(coord_x)
187	!	graphics::polygon(
188	!	x = c(coord_x[i], rev(x = coord_x[i])),
189	!	y = c(prediction()$upr[i], rev(prediction()$lwr[i])),
190	!	col = grDevices::adjustcolor("grey", alpha.f = 0.5), border = NA
191		)
192	!	graphics::lines(x = coord_x[i], y = prediction()$upr[i],
193	!	lty = 2, lwd = 1, col = "#004488")
194	!	graphics::lines(x = coord_x[i], y = prediction()$lwr[i],
195	!	lty = 2, lwd = 1, col = "#004488")
196	!	graphics::lines(x = coord_x[i], y = prediction()$fit[i],
197	!	lty = 1, lwd = 1, col = "#BB5566")
198		}
199		})
200
201		## Diagnostic tests -----
202		# TODO?
203
204		## Diagnostic plots -----
205	!	plot_hist <- reactive({
206	!	function() {
207	!	graphics::hist(stats::residuals(model()), main = NULL,
208	!	xlab = tr_("Residuals"), ylab = tr_("Frequency"))
209		}
210		})
211	!	plot_fitted <- reactive({
212	!	function() {
213	!	plot(model(), which = 1, caption = "", sub.caption = "")
214		}
215		})
216	!	plot_qq <- reactive({
217	!	function() {
218	!	plot(model(), which = 2, caption = "", sub.caption = "")
219		}
220		})
221	!	plot_scale <- reactive({
222	!	function() {
223	!	plot(model(), which = 3, caption = "", sub.caption = "")
224		}
225		})
226	!	plot_cook <- reactive({
227	!	function() {
228	!	plot(model(), which = 4, caption = "", sub.caption = "")
229		}
230		})
231	!	plot_lev <- reactive({
232	!	function() {
233	!	plot(model(), which = 5, caption = "", sub.caption = "")
234		}
235		})
236
237		## Render plot -----
238	!	render_plot("plot_lm", plot_lm)
239	!	render_plot("plot_hist", plot_hist)
240	!	render_plot("plot_fitted", plot_fitted)
241	!	render_plot("plot_qq", plot_qq)
242	!	render_plot("plot_scale", plot_scale)
243	!	render_plot("plot_cook", plot_cook)
244	!	render_plot("plot_lev", plot_lev)
245
246		## Render table -----
247	!	output$prediction <- gt::render_gt({
248	!	lvl <- as.numeric(input$level)
249	!	int <- switch(
250	!	input$interval,
251	!	confidence = tr_("Confidence interval"),
252	!	prediction = tr_("Prediction interval")
253		)
254	!	gt::gt(prediction(), rownames_to_stub = TRUE) \|>
255	!	gt::tab_spanner(
256	!	label = sprintf("%s (%1.0f%%)", int, lvl * 100),
257	!	columns = c("lwr", "upr")
258		) \|>
259	!	gt::cols_label(
260	!	y = tr_("Response"),
261	!	fit = tr_("Fitted"),
262	!	lwr = tr_("Lower bound"),
263	!	upr = tr_("Upper bound")
264		)
265		})
266
267		## Render prints -----
268	!	output$summary <- renderPrint({ summary(model()) })
269
270	!	model
271		})
272		}

1		# UI ===========================================================================
2		#' Compositional Data Summary UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [coda_summary_server()]
9		#' @family coda modules
10		#' @keywords internal
11		#' @export
12		coda_summary_ui <- function(id) {
13		## Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Statistics"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Descriptive Statistics"),
22	!	helpText(tr_("Data summary and descriptive statistics.")),
23	!	render_export_button(ns("export"))
24		),
25	!	navset_card_pill(
26	!	placement = "above",
27	!	nav_panel(
28	!	title = tr_("Location"),
29	!	gt::gt_output(outputId = ns("mean")),
30	!	gt::gt_output(outputId = ns("quantile"))
31		),
32	!	nav_panel(
33	!	title = tr_("Covariance"),
34	!	gt::gt_output(outputId = ns("covariance"))
35		),
36	!	nav_panel(
37	!	title = tr_("PIP"),
38	!	gt::gt_output(outputId = ns("pip"))
39		),
40	!	nav_panel(
41	!	title = tr_("Variation Matrix"),
42	!	navset_pill(
43	!	nav_panel(
44	!	title = tr_("Table"),
45	!	class = "pt-3",
46	!	gt::gt_output(outputId = ns("variation"))
47		),
48	!	nav_panel(
49	!	title = tr_("Heatmap"),
50	!	class = "pt-3",
51	!	output_plot(id = ns("heatmap"))
52		),
53	!	nav_panel(
54	!	title = tr_("Dendrogram"),
55	!	class = "pt-3",
56	!	output_plot(id = ns("dendrogram"))
57		)
58		)
59		)
60	!	) # navset_card_underline
61	!	) # layout_sidebar
62	!	) # nav_panel
63		}
64
65		# Server =======================================================================
66		#' Compositional Data Summary Server
67		#'
68		#' @param id An ID string that corresponds with the ID used to call the module's
69		#' UI function.
70		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
71		#' @return
72		#' No return value, called for side effects.
73		#' @seealso [coda_summary_ui()]
74		#' @family coda modules
75		#' @keywords internal
76		#' @export
77		coda_summary_server <- function(id, x) {
78	2x	stopifnot(is.reactive(x))
79
80	2x	moduleServer(id, function(input, output, session) {
81		## Location -----
82	2x	data_loc <- reactive({
83	2x	req(x())
84	2x	if (nexus::is_grouped(x())) {
85	1x	nexus::aggregate(x(), FUN = nexus::mean, na.rm = FALSE)
86		} else {
87	1x	m <- nexus::mean(x(), na.rm = FALSE)
88	1x	matrix(m, nrow = 1, dimnames = list("center", names(m)))
89		}
90		})
91
92		## Spread -----
93		# TODO
94
95		## Percentiles -----
96	2x	data_quant <- reactive({
97	2x	req(x())
98	2x	nexus::quantile(x(), probs = seq(0, 1, 0.25))
99		})
100
101		## CLR covariance -----
102	2x	data_cov <- reactive({
103	2x	req(x())
104	2x	nexus::covariance(x(), center = TRUE)
105		})
106
107		## PIP -----
108	2x	data_pip <- reactive({
109	2x	req(x())
110	2x	nexus::pip(x())
111		})
112
113		## Variation matrix -----
114	2x	data_var <- reactive({
115	2x	req(x())
116	2x	nexus::variation(x())
117		})
118
119		## Clustering -----
120	2x	plot_clust <- reactive({
121	!	d <- stats::as.dist(data_var())
122	!	h <- stats::hclust(d, method = "ward.D2")
123
124	!	function() {
125	!	plot(h, hang = -1, main = "", sub = "",
126	!	xlab = "", ylab = tr_("Total variation"), las = 1)
127		}
128		})
129
130		## Heatmap -----
131	2x	plot_heatmap <- reactive({
132	!	req(data_var())
133	!	function() tabula::plot_heatmap(data_var(), fixed_ratio = TRUE)
134		})
135
136	2x	Aitchison1986 <- info_article(
137	2x	author = "Aitchison", year = "1986", html = FALSE
138		)
139	2x	Egozcue2023 <- info_article(
140	2x	author = "Egozcue & Pawlowsky-Glahn", year = "2023",
141	2x	doi = "10.57645/20.8080.02.7", html = FALSE
142		)
143
144		## Render table -----
145	2x	output$mean <- gt::render_gt({
146	!	req(x(), data_loc())
147	!	data_loc() \|>
148	!	as.data.frame() \|>
149	!	gt::gt(rownames_to_stub = nexus::is_grouped(x())) \|>
150	!	gt::fmt_percent(decimals = 3) \|>
151	!	gt::sub_missing() \|>
152	!	gt::tab_header(title = tr_("Compositional Mean"))
153		})
154	2x	output$quantile <- gt::render_gt({
155	!	req(data_quant())
156	!	data_quant() \|>
157	!	as.data.frame() \|>
158	!	gt::gt(rownames_to_stub = TRUE) \|>
159	!	gt::fmt_percent(decimals = 3) \|>
160	!	gt::sub_missing() \|>
161	!	gt::tab_header(title = tr_("Percentile Table"))
162		})
163	2x	output$covariance <- gt::render_gt({
164	!	req(data_cov())
165	!	covar <- data_cov()
166	!	covar[lower.tri(covar, diag = FALSE)] <- NA
167
168	!	covar \|>
169	!	as.data.frame() \|>
170	!	gt::gt(rownames_to_stub = TRUE) \|>
171	!	gt::fmt_number(decimals = 3) \|>
172	!	gt::sub_missing(missing_text = "") \|>
173	!	gt::tab_header(title = tr_("Centered Log-Ratio Covariance")) \|>
174	!	gt::tab_source_note(source_note = gt::html(Aitchison1986))
175		})
176	2x	output$pip <- gt::render_gt({
177	!	req(data_pip())
178	!	prop <- data_pip()
179	!	prop[lower.tri(prop, diag = TRUE)] <- NA
180
181	!	prop \|>
182	!	as.data.frame() \|>
183	!	gt::gt(rownames_to_stub = TRUE) \|>
184	!	gt::fmt_number(decimals = 3) \|>
185	!	gt::sub_missing(missing_text = "") \|>
186	!	gt::tab_style_body(
187	!	fn = function(x) x >= 0.75,
188	!	style = gt::cell_fill(color = "#FFAABB")
189		) \|>
190	!	gt::tab_header(title = tr_("Proportionality Index of Parts")) \|>
191	!	gt::tab_source_note(source_note = gt::html(Egozcue2023))
192		})
193	2x	output$variation <- gt::render_gt({
194	!	req(data_var())
195	!	varia <- data_var()
196	!	varia[lower.tri(varia, diag = TRUE)] <- NA
197
198	!	varia \|>
199	!	as.data.frame() \|>
200	!	gt::gt(rownames_to_stub = TRUE) \|>
201	!	gt::fmt_number(decimals = 3) \|>
202	!	gt::sub_missing(missing_text = "") \|>
203	!	gt::tab_header(title = tr_("Variation Matrix")) \|>
204	!	gt::tab_source_note(source_note = gt::html(Aitchison1986))
205		})
206
207		## Render plot -----
208	2x	render_plot("heatmap", x = plot_heatmap)
209	2x	render_plot("dendrogram", x = plot_clust)
210
211		## Download -----
212	2x	export_multiple(
213	2x	"export",
214	2x	mean = data_loc,
215	2x	quantiles = data_quant,
216	2x	covariance = data_cov,
217	2x	variation = data_var,
218	2x	pip = data_pip,
219	2x	name = "coda_summary",
220	2x	label = tr_("Download tables")
221		)
222		})
223		}

1		# UI ===========================================================================
2		#' Alpha Diversity UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [diversity_alpha_server()]
9		#' @family count data modules
10		#' @keywords internal
11		#' @export
12		diversity_alpha_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = HTML(tr_("α Diversity")),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	title = tr_("Diversity Measures"),
21	!	render_export_button(ns("export_results"))
22	!	), # sidebar
23	!	card(
24	!	gt::gt_output(outputId = ns("measures"))
25		)
26	!	) # layout_sidebar
27	!	) # nav_panel
28		}
29
30		# Server =======================================================================
31		#' Alpha Diversity Server
32		#'
33		#' @param id An ID string that corresponds with the ID used to call the module's
34		#' UI function.
35		#' @param x A reactive `data.frame` returned by [diversity_server()].
36		#' @param verbose A [`logical`] scalar: should \R report extra information on
37		#' progress?
38		#' @return A reactive [`data.frame`] (see [tabula::diversity()]).
39		#' @seealso [diversity_alpha_ui()]
40		#' @family count data modules
41		#' @keywords internal
42		#' @export
43		diversity_alpha_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
44	!	stopifnot(is.reactive(x))
45
46	!	moduleServer(id, function(input, output, session) {
47		## Compute index -----
48	!	results <- reactive({
49	!	req(x())
50	!	notify(tabula::diversity(x()), title = tr_("Alpha Diversity"))
51		})
52
53		## Render table -----
54	!	output$measures <- gt::render_gt({
55	!	req(results())
56	!	results() \|>
57	!	gt::gt(rownames_to_stub = TRUE) \|>
58	!	gt::tab_spanner(
59	!	label = tr_("Heterogeneity"),
60	!	columns = c(3, 4) + 1,
61	!	id = "heterogeneity"
62		) \|>
63	!	gt::tab_spanner(
64	!	label = tr_("Dominance"),
65	!	columns = c(5, 6) + 1,
66	!	id = "dominance"
67		) \|>
68	!	gt::tab_spanner(
69	!	label = tr_("Richness"),
70	!	columns = c(7, 8, 9, 10, 11) + 1,
71	!	id = "richness"
72		) \|>
73	!	gt::cols_label(
74	!	size = tr_("Sample size"),
75	!	observed = tr_("Observed richness"),
76	!	shannon = "Shannon",
77	!	brillouin = "Brillouin",
78	!	simpson = "Simpson",
79	!	berger = "Berger-Parker",
80	!	menhinick = "Menhinick",
81	!	margalef = "Margalef",
82	!	chao1 = "Chao1",
83	!	ace = "ACE",
84	!	squares = "Squares"
85		) \|>
86	!	gt::tab_header(title = tr_("Diversity Measures")) \|>
87	!	gt::fmt_number(decimals = 3) \|>
88	!	gt::sub_missing()
89		})
90
91		## Download -----
92	!	export_table("export_results", results, name = "alpha")
93
94	!	results
95		})
96		}

1		# UI ===========================================================================
2		#' Compositional Data Hierarchical Clustering UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [coda_hclust_server()]
9		#' @family coda modules
10		#' @keywords internal
11		#' @export
12		coda_hclust_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("HCLUST"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Hierarchical Clustering"),
22	!	selectInput(
23	!	inputId = ns("dist"),
24	!	label = tr_("Distance"),
25	!	choices = c(Aitchison = "euclidean")
26		),
27	!	selectInput(
28	!	inputId = ns("clust"),
29	!	label = tr_("Clustering linkage"),
30	!	choices = c("ward.D", "ward.D2", "single", "complete",
31	!	"average", "mcquitty", "median", "centroid"),
32	!	selected = "ward.D2"
33		),
34	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
35	!	numericInput(
36	!	inputId = ns("cut"),
37	!	label = tr_("Desired number of clusters"),
38	!	value = 1, min = 1, max = NA, step = 1
39		),
40	!	render_export_button(ns("export_dist")),
41	!	render_export_button(ns("export_clust"))
42	!	), # sidebar
43	!	output_plot(
44	!	id = ns("plot_dendro"),
45	!	tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, cex = FALSE),
46	!	title = tr_("Dendrogram")
47		),
48	!	border_radius = FALSE,
49	!	fillable = TRUE
50	!	) # layout_sidebar
51	!	) # nav_panel
52		}
53
54		# Server =======================================================================
55		#' Compositional Data Hierarchical Clustering Server
56		#'
57		#' @param id An ID string that corresponds with the ID used to call the module's
58		#' UI function.
59		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
60		#' @return
61		#' No return value, called for side effects.
62		#' @seealso [coda_hclust_ui()]
63		#' @family coda modules
64		#' @keywords internal
65		#' @export
66		coda_hclust_server <- function(id, x) {
67	!	stopifnot(is.reactive(x))
68
69	!	moduleServer(id, function(input, output, session) {
70		## Compute cluster -----
71	!	compute_hclust <- ExtendedTask$new(
72	!	function(x, method, clust) {
73	!	mirai::mirai({
74	!	clr <- nexus::transform_clr(x)
75	!	d <- nexus::dist(clr, method = method)
76	!	h <- stats::hclust(d, method = clust)
77	!	h$dist <- d
78	!	if (nexus::is_grouped(x)) h$groups <- nexus::group_names(x)
79	!	h
80	!	}, environment())
81		}
82		) \|>
83	!	bslib::bind_task_button("go")
84
85	!	observe({
86	!	compute_hclust$invoke(x = x(), method = input$dist, clust = input$clust)
87		}) \|>
88	!	bindEvent(input$go)
89
90	!	old <- reactive({ x() }) \|> bindEvent(input$go)
91	!	results <- reactive({
92	!	if (!identical(x(), old())) return(NULL) # Invalidate
93	!	notify(compute_hclust$result(), title = tr_("Hierarchical Clustering"))
94		})
95	!	distances <- reactive({
96	!	results()$dist
97		})
98	!	groups <- reactive({
99	!	req(results(), input$cut)
100	!	stats::cutree(results(), k = input$cut)
101		})
102
103		## Graphical parameters -----
104	!	param <- graphics_server("par")
105
106		## Dendrogram -----
107	!	plot_dendro <- reactive({
108	!	req(results(), input$cut)
109
110	!	function() {
111	!	xlab <- sprintf(tr_("Aitchison distance, %s linkage"), results()$method)
112	!	plot(results(), hang = -1, main = NULL, sub = "",
113	!	xlab = xlab, ylab = "Height", las = 1)
114
115	!	if (input$cut > 1) {
116	!	stats::rect.hclust(results(), k = input$cut)
117		}
118
119	!	i <- results()$order
120	!	g <- results()$groups
121	!	if (!is.null(g)) {
122	!	col <- param$col_quali(g)
123	!	pch <- param$pch(g)
124	!	graphics::points(
125	!	x = seq_along(i),
126	!	y = rep(0, length(i)),
127	!	col = col[i],
128	!	pch = pch[i]
129		)
130
131	!	arg <- list(x = "topright", pch = 16, bty = "n")
132	!	leg <- stats::aggregate(
133	!	data.frame(col = col, pch = pch),
134	!	by = list(legend = g),
135	!	FUN = unique
136		)
137	!	leg <- as.list(leg)
138	!	leg <- utils::modifyList(leg, arg)
139	!	do.call(graphics::legend, args = leg)
140		}
141		}
142		})
143
144		## Render plot -----
145	!	render_plot("plot_dendro", x = plot_dendro)
146
147		## Download -----
148	!	export_table("export_dist", distances, name = "distances", label = tr_("Download distances"))
149	!	export_table("export_clust", groups, name = "clusters", label = tr_("Download clusters"))
150		})
151		}

1		# UI ===========================================================================
2		#' About UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @param package A [`character`] vector of package names to be cited.
6		#' @return
7		#' A nav item that may be passed to a nav container
8		#' (e.g. [bslib::navset_tab()]).
9		#' @seealso [home_server()]
10		#' @family page modules
11		#' @keywords internal
12		#' @export
13		home_ui <- function(id, package = NULL) {
14		# Create a namespace function using the provided id
15	!	ns <- NS(id)
16
17	!	nav_panel(
18	!	title = tr_("Home"),
19	!	layout_sidebar(
20	!	sidebar = sidebar(
21	!	width = 300,
22	!	title = tr_("Welcome!"),
23	!	help_tesselle(),
24	!	help_license()
25	!	), # sidebar
26	!	navset_card_pill(
27	!	placement = "above",
28	!	nav_panel(
29	!	title = tr_("Overview"),
30	!	h3(get_title()),
31	!	markdown(get_description()),
32	!	help_data(),
33	!	help_warranty(),
34	!	tags$p(
35	!	class = "logo",
36	!	tags$a(href = "https://www.tesselle.org/", rel = "external",
37	!	tags$img(src = "static/tesselle.png", alt = tr_("Logo of the tesselle project."))),
38	!	tags$a(href = "https://www.archeosciences-bordeaux.fr/", rel = "external",
39	!	tags$img(src = "static/logo-archeosciences.svg", alt = "UMR 6034 Archéosciences Bordeaux")),
40	!	tags$a(href = "https://www.huma-num.fr/", rel = "external",
41	!	tags$img(src = "static/logo-humanum.svg", alt = "IR* Huma-Num"))
42		)
43		),
44	!	nav_panel(
45	!	title = tr_("How to cite"),
46	!	help_cite(package)
47		)
48	!	) # navset_card_pill
49	!	) # layout_sidebar
50	!	) # nav_panel
51		}
52
53		#' Footer UI
54		#'
55		#' @param id A [`character`] vector to be used for the namespace.
56		#' @return
57		#' A [`list`] that can be converted into an HTML `<footer>` tag
58		#' (see [htmltools::tags()]).
59		#' @seealso [footer_server()]
60		#' @family page modules
61		#' @keywords internal
62		#' @export
63		footer_ui <- function(id) {
64		# Create a namespace function using the provided id
65	!	ns <- NS(id)
66
67	!	tags$footer(
68	!	style = "border-top: 1px; margin-top: 1em; width: 100%; text-align: center;",
69	!	tags$p(
70	!	actionLink(inputId = ns("session"), label = tr_("Session info")),
71	!	HTML(" · "),
72	!	tags$a(href = "https://codeberg.org/tesselle/kinesis",
73	!	target = "_blank", rel = "external", tr_("Source code")),
74	!	HTML(" · "),
75	!	tags$a(href = "https://codeberg.org/tesselle/kinesis/issues",
76	!	target = "_blank", rel = "external", tr_("Report a bug or request"))
77		)
78		)
79		}
80
81		# Server =======================================================================
82		#' Home Server
83		#'
84		#' @param id An ID string that corresponds with the ID used to call the module's
85		#' UI function.
86		#' @return
87		#' No return value, called for side effects.
88		#' @seealso [home_ui()]
89		#' @family page modules
90		#' @keywords internal
91		#' @export
92		home_server <- function(id) {
93	!	moduleServer(id, function(input, output, session) {
94		## Render -----
95	!	output$session <- renderPrint({ utils::sessionInfo() })
96		})
97		}
98
99		#' Footer Server
100		#'
101		#' @param id An ID string that corresponds with the ID used to call the module's
102		#' UI function.
103		#' @return
104		#' No return value, called for side effects.
105		#' @seealso [footer_ui()]
106		#' @family page modules
107		#' @keywords internal
108		#' @export
109		footer_server <- function(id) {
110	!	moduleServer(id, function(input, output, session) {
111	!	observeEvent(input$session, {
112	!	showModal(
113	!	modalDialog(
114	!	title = tr_("Session info"),
115	!	info_session(),
116	!	size = "xl",
117	!	easyClose = TRUE,
118	!	footer = modalButton(tr_("Close"))
119		)
120		)
121		})
122		})
123		}
124
125		#' Collect Information About the Current R Session
126		#'
127		#' @param ... Currently not used.
128		#' @return Text marked as HTML.
129		#' @keywords internal
130		#' @noRd
131		info_session <- function(...) {
132	!	info <- paste0(utils::capture.output(utils::sessionInfo()), collapse = "\n")
133	!	markdown(sprintf("```\n%s\n```", info))
134		}

1		# SHINY
2
3		#' Run an App
4		#'
5		#' A wrapper for [shiny::shinyAppDir()].
6		#' @param app A [`character`] string specifying the \pkg{Shiny} application
7		#' to run (see details). Any unambiguous substring can be given.
8		#' @param options A [`list`] of named options that should be passed to the
9		#' [`shiny::shinyAppDir()`] call.
10		#' @details
11		#' \tabular{ll}{
12		#' Application name \tab Keyword \cr
13		#' Aoristic Analysis \tab `aoristic` \cr
14		#' Correspondence Analysis \tab `ca` \cr
15		#' Principal Components Analysis \tab `pca` \cr
16		#' Diversity Measures \tab `diversity` \cr
17		#' Mean Ceramic Date \tab `mcd` \cr
18		#' Radiocarbon Calibration \tab `radiocarbon` \cr
19		#' Scatter Plot \tab `scatter` \cr
20		#' Matrix Seriation \tab `seriation` \cr
21		#' Compositional Data Analysis \tab `source` \cr
22		#' Ternary Plot \tab `ternary` \cr
23		#' }
24		#' @examples
25		#' if (interactive()) {
26		#' run_app("seriation")
27		#' }
28		#' @return A \pkg{shiny} application object.
29		#' @family shiny apps
30		#' @author N. Frerebeau
31		#' @export
32		run_app <- function(app = c("diversity", "seriation", "aoristic", "mcd",
33		"radiocarbon", "source",
34		"scatter", "ternary", "ca", "pca"),
35		options = list(launch.browser = interactive())) {
36		## App selection
37	!	app <- match.arg(app, several.ok = FALSE)
38	!	app_dir <- system.file("app", app, package = "kinesis")
39	!	if (!nzchar(app_dir)) {
40	!	msg <- sprintf(tr_("Could not find the %s application."), sQuote(app))
41	!	stop(msg, call. = FALSE)
42		}
43
44		## Create a Shiny app object
45	!	obj <- shiny::shinyAppDir(appDir = app_dir, options = options)
46
47		## Bundle the options inside the shinyApp object
48	!	opt <- get_config(app, file = NULL)
49	!	obj$appOptions$kinesis_options <- opt
50
51	!	obj
52		}
53
54		#' Read Configuration Values
55		#'
56		#' @param app A [`character`] string specifying the Shiny application
57		#' to run (see [run_app()]).
58		#' @param file A [`character`] string specifying the configuration file to
59		#' read from. If `NA` (the default), use the value of the
60		#' `KINESIS_CONFIG_FILE` environment variable ("`config.yml`" if the variable
61		#' does not exist). If `NULL`, use the build-in configuration file.
62		#' @param active A [`character`] string specifying the name of configuration to
63		#' read from. If `NA` (the default), use the value of the
64		#' `KINESIS_CONFIG_ACTIVE` environment variable ("`default`" if the variable
65		#' does not exist).
66		#' @param use_parent A [`logical`] scalar: should parent directories be scanned
67		#' for configuration files if the specified config file isn't found?
68		#' @return A [`list`] of configuration values.
69		#' @author N. Frerebeau
70		#' @keywords internal
71		#' @export
72		get_config <- function(app, file = NA, active = NA, use_parent = TRUE) {
73		## Get config file
74	4x	if (is.null(file)) {
75	2x	file <- system.file("app", app, "config.yml", package = "kinesis")
76		}
77	4x	if (is.na(file)) {
78	1x	file <- Sys.getenv("KINESIS_CONFIG_FILE", "config.yml")
79		}
80	4x	if (!file.exists(file)) {
81	2x	msg <- sprintf(tr_("Could not find the configuration file for %s."), sQuote(app))
82	2x	stop(msg, call. = FALSE)
83		}
84
85		## Read config
86	2x	if (is.na(active)) {
87	1x	active <- Sys.getenv("KINESIS_CONFIG_ACTIVE", "default")
88		}
89	2x	config::get(value = NULL, config = active, file = file,
90	2x	use_parent = use_parent)
91		}
92
93		#' Get App Options
94		#'
95		#' @param name A [`character`] string specifying the name of an option to get.
96		#' If `NULL` (the default), all options are returned.
97		#' @param default A value to be returned if the option is not currently set.
98		#' @return
99		#' The value of a \pkg{Shiny} option (see [shiny::getShinyOption()]).
100		#' @author N. Frerebeau
101		#' @keywords internal
102		#' @export
103		get_option <- function(name = NULL, default = NULL) {
104	7x	if (is.null(name)) {
105	!	shiny::getShinyOption("kinesis_options")
106		} else {
107	7x	shiny::getShinyOption("kinesis_options")[[name]] %\|\|% default
108		}
109		}
110
111		#' Get Current Language
112		#'
113		#' @param default A [`character`] string specifying the default language
114		#' (ISO 639-2) if [`Sys.getenv("LANGUAGE")`][Sys.getenv] is not set. If `NULL`
115		#' (the default), uses [`Sys.getlocale("LC_COLLATE")`][Sys.getlocale].
116		#' @return A [`character`] string (ISO 639-2).
117		#' @author N. Frerebeau
118		#' @keywords internal
119		#' @noRd
120		get_language <- function(default = NULL) {
121		## Get current language
122	!	lang <- Sys.getenv("LANGUAGE", unset = NA)
123	!	if (is.na(lang) \|\| nchar(lang) < 2)
124	!	lang <- default %\|\|% Sys.getlocale("LC_COLLATE")
125	!	substr(lang, start = 1, stop = 2)
126		}
127
128		#' Get App Title
129		#'
130		#' @param default A [`character`] string specifying the default language
131		#' (see `get_language()`).
132		#' @return A [`character`] string.
133		#' @author N. Frerebeau
134		#' @keywords internal
135		#' @noRd
136		get_title <- function(default = NULL) {
137	!	lang <- get_language(default)
138	!	title <- get_option("title")[[lang]]
139	!	if (is.null(title)) title <- get_option("title")[["en"]] # Fallback to English
140	!	title
141		}
142
143		#' Get App Description
144		#'
145		#' @param default A [`character`] string specifying the default language
146		#' (see `get_language()`).
147		#' @return A [`character`] string.
148		#' @author N. Frerebeau
149		#' @keywords internal
150		#' @noRd
151		get_description <- function(default = NULL) {
152	!	lang <- get_language(default)
153	!	desc <- get_option("description")[[lang]]
154	!	if (is.null(desc)) desc <- get_option("description")[["en"]] # Fallback to English
155	!	desc
156		}

1		# UI ===========================================================================
2		#' Radiocarbon Calibration UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [calibrate_server()]
9		#' @family chronology modules
10		#' @keywords internal
11		#' @export
12		calibrate_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Calibration"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Calibration"),
22		## Input: checkbox if F14C calibration
23	!	checkboxInput(
24	!	inputId = ns("f14c"),
25	!	label = bslib::tooltip(
26	!	trigger = list(HTML("F<sup>14</sup>C"), icon("info-circle")),
27	!	HTML(tr_("Should the calibration be carried out in F<sup>14</sup>C space?"),
28	!	tr_("If so, your data must be expressed as F<sup>14</sup>C."))
29		),
30	!	value = FALSE
31		),
32	!	accordion(
33	!	accordion_panel(
34	!	title = tr_("Data"),
35		## Input: select variables
36	!	helpText(
37	!	tr_("Select the corresponding columns from your data set."),
38	!	tr_("Leave blank to use the default parameters.")
39		),
40	!	selectize_ui(id = ns("multi_names"), label = tr_("Laboratory codes")),
41	!	selectize_ui(id = ns("multi_values"), label = tr_("Values"),
42	!	help = tr_("BP ages or F<sup>14</sup>C values to be calibrated.")),
43	!	selectize_ui(id = ns("multi_errors"), label = tr_("Errors"),
44	!	help = tr_("Errors associated to the values to be calibrated.")),
45	!	selectize_ui(id = ns("multi_marine_offsets"), label = tr_("Reservoir offsets"),
46	!	help = tr_("Offset values for any marine reservoir effect.")),
47	!	selectize_ui(id = ns("multi_marine_errors"), label = tr_("Reservoir errors"),
48	!	help = tr_("Offset value errors for any marine reservoir effect.")),
49	!	selectize_ui(id = ns("multi_curves"), label = tr_("Curves"),
50	!	help = tr_("Calibration curves to be used.")),
51	!	selectize_ui(id = ns("multi_positions"), label = tr_("Positions"),
52	!	help = tr_("Position values (e.g. depths) for each age."))
53		),
54	!	accordion_panel(
55	!	title = tr_("Default parameters"),
56	!	radioButtons(
57	!	inputId = ns("calib_curve"),
58	!	label = tr_("Calibration curve:"),
59	!	choices = c("IntCal20", "Marine20", "SHCal20"),
60	!	selected = "IntCal20"
61		),
62	!	numericInput(
63	!	inputId = ns("calib_marine_offset"),
64	!	label = tr_("Reservoir offset"),
65	!	value = 0
66		),
67	!	numericInput(
68	!	inputId = ns("calib_marine_error"),
69	!	label = tr_("Reservoir error"),
70	!	value = 0
71		),
72	!	numericInput(
73	!	inputId = ns("calib_from"),
74	!	label = bslib::tooltip(
75	!	trigger = list(tr_("From"), icon("info-circle")),
76	!	tr_("Earliest date to calibrate for, in cal. BP years.")
77		),
78	!	value = 55000
79		),
80	!	numericInput(
81	!	inputId = ns("calib_to"),
82	!	label = bslib::tooltip(
83	!	trigger = list(tr_("To"), icon("info-circle")),
84	!	tr_("Latest date to calibrate for, in cal. BP years.")
85		),
86	!	value = 0
87		),
88	!	numericInput(
89	!	inputId = ns("calib_resolution"),
90	!	label = bslib::tooltip(
91	!	trigger = list(tr_("Resolution"), icon("info-circle")),
92	!	tr_("Temporal resolution of the calibration, in years.")
93		),
94	!	value = 1
95		)
96		)
97		),
98	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Calibrate")),
99	!	render_export_button(ns("export_results"))
100	!	), # sidebar
101	!	navset_card_pill(
102	!	sidebar = sidebar(
103	!	title = tr_("Options"),
104	!	select_calendar(ns("calendar")),
105	!	radioButtons(
106	!	inputId = ns("level"),
107	!	label = tr_("Level:"),
108	!	selected = "0.95",
109	!	choiceNames = c("68%", "95%", "99%"),
110	!	choiceValues = c("0.68", "0.95", "0.99")
111		)
112		),
113	!	nav_panel(
114	!	title = tr_("Results"),
115	!	gt::gt_output(outputId = ns("table_results"))
116		),
117	!	nav_panel(
118	!	title = tr_("Plot"),
119	!	output_plot(
120	!	id = ns("plot_density"),
121	!	tools = list(
122	!	checkboxInput(inputId = ns("fixed"), value = TRUE, label = tr_("Fixed scale")),
123	!	checkboxInput(inputId = ns("sort_density"), label = tr_("Decreasing order")),
124	!	selectize_ui(
125	!	id = ns("extra_quali"),
126	!	label = tr_("Extra qualitative variable")
127		),
128	!	graphics_ui(
129	!	id = ns("par_dens"),
130	!	col_quant = FALSE,
131	!	pch = FALSE,
132	!	lty = FALSE,
133	!	cex = FALSE
134		)
135		)
136		)
137		),
138	!	nav_panel(
139	!	title = tr_("Intervals"),
140	!	layout_column_wrap(
141	!	output_plot(
142	!	id = ns("plot_intervals"),
143	!	tools = list(
144	!	checkboxInput(inputId = ns("sort_intervals"), label = tr_("Decreasing order")),
145	!	graphics_ui(
146	!	id = ns("par_int"),
147	!	col_quali = FALSE,
148	!	col_quant = FALSE,
149	!	pch = FALSE,
150	!	lty = FALSE,
151	!	size_range = FALSE
152		)
153		)
154		),
155		# render_export_button(ns("export_intervals")),
156	!	tableOutput(outputId = ns("table_intervals"))
157		)
158		)
159	!	) # navset_card_pill
160	!	) # layout_sidebar
161	!	) # nav_panel
162		}
163
164		# Server =======================================================================
165		#' Radiocarbon Calibration Server
166		#'
167		#' @param id An ID string that corresponds with the ID used to call the module's
168		#' UI function.
169		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
170		#' @return A reactive [`ananke::CalibratedAges-class`] object.
171		#' @seealso [calibrate_ui()]
172		#' @family chronology modules
173		#' @keywords internal
174		#' @export
175		calibrate_server <- function(id, x) {
176	!	stopifnot(is.reactive(x))
177
178	!	moduleServer(id, function(input, output, session) {
179		## Update UI -----
180	!	quali <- subset_qualitative(x)
181	!	quanti <- subset_quantitative(x)
182
183	!	calendar <- get_calendar("calendar")
184	!	values <- update_selectize_colnames("multi_values", x = quanti)
185	!	errors <- update_selectize_colnames("multi_errors", x = quanti)
186	!	curves <- update_selectize_colnames("multi_curves", x = quali)
187	!	names <- update_selectize_colnames("multi_names", x = quali)
188	!	positions <- update_selectize_colnames("multi_positions", x = quanti)
189	!	res_off <- update_selectize_colnames("multi_marine_offsets", x = quanti)
190	!	res_err <- update_selectize_colnames("multi_marine_errors", x = quanti)
191
192	!	col_quali <- update_selectize_colnames("extra_quali", x = quali)
193	!	extra_quali <- select_data(quali, col_quali, drop = TRUE)
194
195		## Calibrate -----
196	!	compute_calib <- ExtendedTask$new(
197	!	function(x, ...) {
198	!	mirai::mirai({
199	!	param <- list(...)
200	!	do.call(ananke::c14_calibrate, param)
201	!	}, environment())
202		}
203		) \|>
204	!	bslib::bind_task_button("go")
205
206	!	observe({
207	!	req(values(), errors())
208	!	compute_calib$invoke(
209	!	values = x()[[values()]],
210	!	errors = x()[[errors()]],
211	!	curves = if (isTruthy(curves())) x()[[curves()]] else input$calib_curve,
212	!	names = if (isTruthy(names())) x()[[names()]] else NULL,
213	!	positions = if (isTruthy(positions())) x()[[positions()]] else NULL,
214	!	reservoir_offsets = if (isTruthy(res_off())) x()[[res_off()]] else input$calib_marine_offset %\|\|\|% 0,
215	!	reservoir_errors = if (isTruthy(res_err())) x()[[res_err()]] else input$calib_marine_error %\|\|\|% 0,
216	!	from = input$calib_from %\|\|\|% 55000,
217	!	to = input$calib_to %\|\|\|% 0,
218	!	resolution = input$calib_resolution %\|\|\|% 1
219		)
220		}) \|>
221	!	bindEvent(input$go)
222
223	!	old <- reactive({ x() }) \|> bindEvent(input$go)
224	!	results <- reactive({
225	!	if (!identical(x(), old())) return(NULL) # Invalidate
226	!	notify(compute_calib$result(), title = tr_("Radiocarbon Calibration"))
227		})
228
229		## Compute intervals -----
230	!	intervals <- reactive({
231	!	req(results())
232	!	ananke::interval_hdr(x = results(), level = as.numeric(input$level))
233		})
234
235		## Render table -----
236	!	data_calib <- reactive({
237	!	req(results())
238	!	df <- ananke::as.data.frame(
239	!	x = results(),
240	!	level = as.numeric(input$level),
241	!	calendar = calendar()
242		)
243	!	df[, -ncol(df)]
244		})
245	!	data_intervals <- reactive({
246	!	req(intervals())
247	!	ananke::as.data.frame(intervals(), calendar = calendar())
248		})
249	!	output$table_results <- gt::render_gt({
250	!	gt::gt(data_calib(), rownames_to_stub = TRUE) \|>
251	!	gt::tab_options(table.width = "100%") \|>
252	!	gt::tab_spanner(
253	!	label = tr_("Conventional Age"),
254	!	columns = gt::starts_with("BP14C")
255		) \|>
256	!	gt::tab_spanner(
257	!	label = "F14C",
258	!	columns = gt::starts_with("F14C")
259		) \|>
260	!	gt::tab_spanner(
261	!	label = tr_("Marine Reservoir"),
262	!	columns = gt::starts_with("reservoir")
263		) \|>
264	!	gt::tab_spanner(
265	!	label = tr_("Calibration"),
266	!	columns = gt::starts_with("calibration")
267		) \|>
268	!	gt::cols_label(
269	!	BP14C_value = tr_("Value"),
270	!	BP14C_error = tr_("Error"),
271	!	reservoir_offset = tr_("Offset"),
272	!	reservoir_error = tr_("Error"),
273	!	calibration_curve = tr_("Curve"),
274	!	calibration_hdr = tr_("HDR")
275		) \|>
276	!	gt::opt_interactive(
277	!	use_compact_mode = TRUE,
278	!	use_page_size_select = TRUE
279		)
280		})
281	!	output$table_intervals <- gt::render_gt({
282	!	gt::gt(data_intervals(), rowname_col = "label") \|>
283	!	gt::tab_options(table.width = "100%") \|>
284	!	gt::cols_label(
285	!	start = tr_("From"),
286	!	end = tr_("To"),
287	!	p = tr_("p")
288		) \|>
289	!	gt::opt_interactive(
290	!	use_compact_mode = TRUE,
291	!	use_page_size_select = TRUE
292		)
293		})
294
295		## Graphical parameters -----
296	!	param_dens <- graphics_server("par_dens")
297	!	param_int <- graphics_server("par_int")
298
299		## Render plot -----
300	!	plot_density <- reactive({
301	!	req(results())
302
303	!	col <- "grey"
304	!	if (isTruthy(extra_quali())) {
305	!	col <- param_dens$col_quali(extra_quali())
306		}
307
308	!	function() {
309	!	ananke::ridgelines(
310	!	x = results(),
311	!	calendar = calendar(),
312	!	interval = "hdr",
313	!	level = as.numeric(input$level),
314	!	fixed = isTRUE(input$fixed),
315	!	decreasing = isTRUE(input$sort_density),
316	!	col = col
317		)
318
319	!	if (isTruthy(extra_quali())) {
320	!	graphics::legend(
321	!	x = ifelse(isTRUE(input$sort_density), "topright", "topleft"),
322	!	legend = unique(extra_quali()),
323	!	fill = unique(col),
324	!	bty = "n"
325		)
326		}
327		}
328		})
329	!	plot_intervals <- reactive({
330	!	req(intervals())
331	!	function() {
332	!	aion::plot(
333	!	x = intervals(),
334	!	calendar = calendar(),
335	!	decreasing = isTRUE(input$sort_intervals),
336	!	lwd = param_int$pal_cex
337		)
338		}
339		})
340	!	render_plot("plot_density", x = plot_density)
341	!	render_plot("plot_intervals", x = plot_intervals)
342
343		## Download -----
344	!	export_table("export_results", data_calib, name = "calibration")
345		# export_table("export_interval", data_intervals, name = "intervals")
346
347	!	results
348		})
349		}

1		# UI ===========================================================================
2		#' Graphical Parameters UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A [`list`] of UI elements.
7		#' @seealso [graphics_server()]
8		#' @family plot modules
9		#' @keywords internal
10		#' @export
11		graphics_ui <- function(id, col_quali = TRUE, col_quant = TRUE,
12		pch = TRUE, lty = TRUE, cex = TRUE, asp = FALSE,
13		size_range = TRUE) {
14		## Create a namespace function using the provided id
15	!	ns <- NS(id)
16
17	!	if (isTRUE(col_quali)) {
18	!	col_quali <- select_color(
19	!	inputId = ns("col_quali"),
20	!	label = tr_("Qualitative scheme"),
21	!	type = "quali"
22		)
23		} else {
24	!	col_quali <- NULL
25		}
26	!	if (isTRUE(col_quant)) {
27	!	col_quant <- select_color(
28	!	inputId = ns("col_quant"),
29	!	label = tr_("Quantitative scheme"),
30	!	type = c("seq", "div")
31		)
32		} else {
33	!	col_quant <- NULL
34		}
35
36	!	size <- if (isTRUE(size_range)) c(1L, 2L) else 1L
37	!	pch <- if (isTRUE(pch)) select_pch(ns("pch"), default = NULL) else NULL
38	!	lty <- if (isTRUE(lty)) select_lty(ns("lty"), default = NULL) else NULL
39	!	cex <- if (isTRUE(cex)) select_cex(ns("cex"), default = size) else NULL
40	!	asp <- if (isTRUE(asp)) checkboxInput(ns("asp"), label = tr_("Fixed aspect ratio"), value = FALSE) else NULL
41
42	!	list(col_quali, col_quant, pch, lty, cex, asp)
43		}
44
45		select_cex <- function(inputId, default = c(1, 2)) {
46	!	sliderInput(
47	!	inputId = inputId,
48	!	label = tr_("Symbol size"),
49	!	min = 0.1,
50	!	max = 9,
51	!	value = default,
52	!	step = 0.1
53		)
54		}
55
56		select_pch <- function(inputId, default = c(16, 17, 15, 3, 7, 8)) {
57	!	x <- c(
58	!	square = 0, circle = 1, `triangle up` = 2, plus = 3, cross = 4,
59	!	diamond = 5, `triangle down` = 6, `square cross` = 7, star = 8,
60	!	`diamond plus` = 9, `circle plus` = 10, `triangles up and down` = 11,
61	!	`square plus` = 12, `circle cross` = 13, `square triangle` = 14,
62	!	`filled square` = 15, `filled circle` = 16, `filled triangle` = 17,
63	!	`filled diamond` = 18, `solid circle` = 19, bullet = 20
64		)
65
66	!	selectizeInput(
67	!	inputId = inputId,
68	!	label = tr_("Symbol"),
69	!	choices = x,
70	!	selected = default,
71	!	multiple = TRUE,
72	!	options = list(plugins = "clear_button")
73		)
74		}
75
76		select_lty <- function(inputId, default = 1) {
77	!	x <- c(solid = 1, dashed = 2, dotted = 3,
78	!	dotdash = 4, longdash = 5, twodash = 6)
79
80	!	selectizeInput(
81	!	inputId = inputId,
82	!	label = tr_("Line type"),
83	!	choices = x,
84	!	selected = default,
85	!	multiple = TRUE,
86	!	options = list(plugins = "clear_button")
87		)
88		}
89
90		select_color <- function(inputId, label,
91		type = c("qualitative", "sequential", "diverging")) {
92	!	type <- match.arg(type, several.ok = TRUE)
93
94	!	schemes <- list(
95	!	qualitative = c("discreterainbow", "bright", "vibrant", "muted",
96	!	"highcontrast", "mediumcontrast", "light", "okabeito"),
97	!	diverging = c("sunset", "nightfall", "BuRd", "PRGn"),
98	!	sequential = c("YlOrBr", "iridescent", "incandescent", "smoothrainbow")
99		)
100
101	!	schemes <- schemes[type]
102	!	default <- "discreterainbow"
103	!	if (length(type) == 1) {
104	!	if ("diverging" %in% type) default <- "BuRd"
105	!	if ("sequential" %in% type) default <- "YlOrBr"
106		}
107
108	!	selectizeInput(
109	!	inputId = inputId,
110	!	label = label,
111	!	choices = schemes,
112	!	selected = default,
113	!	multiple = FALSE,
114	!	options = list(plugins = list("clear_button"))
115		)
116		}
117
118		# Server =======================================================================
119		#' Graphical Parameters Server
120		#'
121		#' @param id An ID string that corresponds with the ID used to call the module's
122		#' UI function.
123		#' @return
124		#' A [`reactiveValues`][shiny::reactiveValues] object with elements:
125		#' \describe{
126		#' \item{`col_quali`, `col_quant`}{A palette function that when called with a
127		#' single argument returns a character vector of colors.}
128		#' \item{`pch`}{A palette function that when called with a single argument
129		#' returns a character vector of symbols.}
130		#' \item{`lty`}{A palette function that when called with a single argument
131		#' returns a character vector of symbols.}
132		#' \item{`cex`}{A palette function that when called with a single argument
133		#' returns a numeric vector giving the amount by which plotting text and
134		#' symbols should be magnified relative to the default.}
135		#' \item{`asp`}{A [`numeric`] giving the aspect ratio y/x.}
136		#' }
137		#' @seealso [graphics_ui()]
138		#' @family plot modules
139		#' @keywords internal
140		#' @export
141		graphics_server <- function(id) {
142
143	3x	moduleServer(id, function(input, output, session) {
144	3x	param <- reactiveValues(
145	3x	col_quali = recycle("black"),
146	3x	col_quant = recycle("black"),
147	3x	pch = recycle(16L),
148	3x	lty = recycle(1L),
149	3x	cex = recycle(1L),
150	3x	asp = NA
151		)
152
153	3x	observe({
154	!	if (isTRUE(input$asp)) {
155	!	param$asp <- 1
156		} else {
157	!	param$asp <- NA
158		}
159		}) \|>
160	3x	bindEvent(input$asp)
161
162	3x	observe({
163	2x	param$pal_quali <- color(input$col_quali)
164	2x	param$col_quali <- protect(khroma::palette_color_discrete, "black", param$pal_quali)
165		}) \|>
166	3x	bindEvent(input$col_quali, ignoreNULL = FALSE)
167
168	3x	observe({
169	!	param$pal_quant <- color(input$col_quant)
170	!	param$col_quant <- protect(khroma::palette_color_continuous, "black", param$pal_quant)
171		}) \|>
172	3x	bindEvent(input$col_quant, ignoreNULL = TRUE)
173
174	3x	observe({
175	2x	pch_in <- as.integer(input$pch)
176	2x	pch <- pch_in %\|\|\|% 16L
177	2x	if (isTruthy(input$pch)) {
178	!	param$pch <- protect(khroma::palette_shape, pch[[1L]], pch)
179		} else {
180	2x	param$pch <- recycle(pch[[1L]])
181		}
182	2x	if (!is.null(input$pch)) {
183	!	param$pal_pch <- pch_in
184		}
185		}) \|>
186	3x	bindEvent(input$pch, ignoreNULL = FALSE)
187
188	3x	observe({
189	2x	lty_in <- as.integer(input$lty)
190	2x	lty <- lty_in %\|\|\|% 1L
191	2x	if (isTruthy(input$lty)) {
192	!	param$lty <- protect(khroma::palette_line, lty[[1L]], lty)
193		} else {
194	2x	param$lty <- recycle(lty[[1L]])
195		}
196	2x	if (!is.null(input$lty)) {
197	!	param$pal_lty <- lty_in
198		}
199		}) \|>
200	3x	bindEvent(input$lty, ignoreNULL = FALSE)
201
202	3x	observe({
203	!	cex <- range(as.integer(input$cex)) %\|\|\|% 1L
204	!	param$pal_cex <- input$cex
205	!	if (isTruthy(input$cex)) {
206	!	param$cex <- protect(khroma::palette_size_sequential, cex[[1L]], cex)
207		} else {
208	!	param$cex <- recycle(cex[[1L]])
209		}
210		}) \|>
211	3x	bindEvent(input$cex)
212
213	3x	param
214		})
215		}
216
217		color <- function(scheme, default = "black") {
218	2x	if (!isTruthy(scheme)) {
219	2x	function(n) {
220	1x	rep(default, n)
221		}
222		} else {
223	!	function(n) {
224	!	notify(khroma::color(scheme)(n))
225		}
226		}
227		}
228		recycle <- function(x) {
229	19x	force(x)
230
231	19x	function(n) {
232	!	if (missing(n) \|\| length(n) < 1) n <- 1
233	2x	rep(x, length(n))
234		}
235		}
236		protect <- function(f, default, ...) {
237	2x	force(default)
238
239	2x	function(x) {
240	!	if (!isTruthy(x)) return(default)
241	1x	notify(f(...)(x))
242		}
243		}
244

1		# UI ===========================================================================
2		#' Diversity UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [diversity_server()]
9		#' @family count data modules
10		#' @keywords internal
11		#' @export
12		diversity_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Indices"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21		# title = tr_("Count data"),
22	!	checkbox_ui(ns("count"), label = tr_("Count data"))
23	!	), # sidebar
24	!	navset_card_pill(
25	!	bertin_ui(ns("plot"), title = tr_("Plot")),
26	!	diversity_alpha_ui(ns("alpha")),
27	!	diversity_beta_ui(ns("beta")),
28	!	occurrence_ui(ns("occurrence"))
29	!	) # navset_card_pill
30	!	) # layout_sidebar
31	!	) # nav_panel
32		}
33
34		# Server =======================================================================
35		#' Alpha Diversity Server
36		#'
37		#' @param id An ID string that corresponds with the ID used to call the module's
38		#' UI function.
39		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
40		#' @param verbose A [`logical`] scalar: should \R report extra information on
41		#' progress?
42		#' @return A reactive [`data.frame`] (see [tabula::diversity()]).
43		#' @seealso [diversity_ui()]
44		#' @family count data modules
45		#' @keywords internal
46		#' @export
47		diversity_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
48	!	stopifnot(is.reactive(x))
49
50	!	moduleServer(id, function(input, output, session) {
51		## Get count data -----
52	!	quanti <- subset_quantitative(x, positive = TRUE)
53	!	quali <- subset_qualitative(x)
54
55		## Update UI -----
56	!	vars <- update_checkbox_colnames("count", x = quanti)
57
58		## Select variables -----
59	!	counts <- select_data(quanti, vars, drop = FALSE) \|>
60	!	debounce(500)
61
62		## Diversity -----
63	!	bertin_server("plot", x = counts)
64	!	alpha <- diversity_alpha_server("alpha", x = counts)
65	!	diversity_beta_server("beta", x = counts, quanti = alpha, quali = quali)
66	!	occ <- occurrence_server("occurrence", x = counts)
67
68	!	counts
69		})
70		}
71

1		# UI ===========================================================================
2		#' Beta Diversity UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [diversity_beta_server()]
9		#' @family count data modules
10		#' @keywords internal
11		#' @export
12		diversity_beta_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = HTML(tr_("β Diversity")),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	title = tr_("Principal Coordinates Analysis"),
21	!	selectInput(
22	!	inputId = ns("method"),
23	!	label = tr_("Dissimilarity measure"),
24		# TODO: change 'sorenson' to 'sorensen'
25	!	choices = c(`Bray-Curtis` = "bray", `Dice-Sorensen` = "sorenson",
26	!	`Morisita-Horn` = "morisita"),
27	!	multiple = FALSE
28		),
29	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
30	!	render_export_button(ns("export_beta")),
31	!	uiOutput(outputId = ns("download_button")),
32	!	hr(),
33	!	checkboxInput(
34	!	inputId = ns("pcoa_labels"),
35	!	label = tr_("Display labels"),
36	!	value = FALSE
37		),
38		## Input: variable mapping
39	!	selectize_ui(
40	!	id = ns("extra_quanti"),
41	!	label = tr_("Alpha diversity")
42		),
43	!	selectize_ui(
44	!	id = ns("extra_quali"),
45	!	label = tr_("Groups")
46		),
47	!	checkboxInput(
48	!	inputId = ns("hull"),
49	!	label = tr_("Convex hull"),
50	!	value = FALSE
51		)
52	!	), # sidebar
53	!	layout_columns(
54	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
55	!	output_plot(
56	!	id = ns("plot_diss"),
57	!	title = tr_("Dissimilarity"),
58	!	tools = graphics_ui(ns("par_diss"), col_quali = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
59	!	height = "100%"
60		),
61	!	output_plot(
62	!	id = ns("plot_pcoa"),
63	!	title = tr_("PCoA"),
64	!	tools = graphics_ui(ns("par_pcoa"), lty = FALSE),
65	!	height = "100%"
66		)
67		)
68	!	) # layout_sidebar
69	!	) # nav_panel
70		}
71
72		# Server =======================================================================
73		#' Beta Diversity Server
74		#'
75		#' @param id An ID string that corresponds with the ID used to call the module's
76		#' UI function.
77		#' @param x A reactive `data.frame` returned by [diversity_server()].
78		#' @param quanti A reactive `data.frame` returned by [diversity_alpha_server()].
79		#' @param quali A reactive `data.frame` (typically returned by [import_server()]).
80		#' @return
81		#' No return value, called for side effects.
82		#' @seealso [diversity_beta_ui()]
83		#' @family count data modules
84		#' @keywords internal
85		#' @export
86		diversity_beta_server <- function(id, x, quanti, quali) {
87	!	stopifnot(is.reactive(x))
88	!	stopifnot(is.reactive(quanti))
89	!	stopifnot(is.reactive(quali))
90
91	!	moduleServer(id, function(input, output, session) {
92		## Update UI -----
93	!	col_quali <- update_selectize_colnames("extra_quali", x = quali)
94	!	col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)
95
96		## Extra variables -----
97	!	extra_quali <- select_data(quali, col_quali, drop = TRUE)
98	!	extra_quanti <- select_data(quanti, col_quanti, drop = TRUE)
99
100		## Compute similarity -----
101	!	compute_beta <- ExtendedTask$new(
102	!	function(x, method) {
103	!	mirai::mirai({ 1 - tabula::similarity(x, method) }, environment())
104		}
105		) \|>
106	!	bslib::bind_task_button("go")
107
108	!	observe({
109	!	compute_beta$invoke(x = x(), method = input$method)
110		}) \|>
111	!	bindEvent(input$go)
112
113	!	old <- reactive({ x() }) \|> bindEvent(input$go)
114	!	results <- reactive({
115	!	if (!identical(x(), old())) return(NULL) # Invalidate
116	!	notify(compute_beta$result(), title = tr_("Beta Diversity"))
117		})
118
119		## Compute PCoA -----
120	!	analysis <- reactive({
121	!	req(results())
122	!	validate_na(results())
123	!	notify(dimensio::pcoa(results(), rank = 2))
124		})
125
126		## Graphical parameters -----
127	!	param_diss <- graphics_server("par_diss")
128	!	param_pcoa <- graphics_server("par_pcoa")
129
130		## Plot -----
131	!	plot_diss <- reactive({
132	!	req(results())
133
134	!	function() {
135	!	tabula::plot_heatmap(
136	!	object = results(),
137	!	color = param_diss$pal_quant,
138	!	diag = FALSE,
139	!	upper = FALSE,
140	!	fixed_ratio = TRUE
141		)
142		}
143		})
144
145	!	plot_pcoa <- reactive({
146	!	req(analysis())
147
148	!	if (!isTruthy(extra_quali()) && isTruthy(extra_quanti())) {
149	!	col <- param_pcoa$pal_quanti
150		} else {
151	!	col <- param_pcoa$pal_quali
152		}
153
154	!	function() {
155	!	dimensio::plot(
156	!	x = analysis(),
157	!	labels = input$pcoa_labels,
158	!	extra_quali = extra_quali(),
159	!	extra_quanti = extra_quanti(),
160	!	color = col,
161	!	symbol = param_pcoa$pal_pch,
162	!	size = param_pcoa$pal_cex,
163	!	panel.first = graphics::grid()
164		)
165
166	!	if (isTRUE(input$hull)) {
167	!	dimensio::viz_hull(
168	!	x = analysis(),
169	!	group = extra_quali(),
170	!	color = param_pcoa$pal_quali
171		)
172		}
173		}
174		})
175
176		## Render plot -----
177	!	render_plot("plot_diss", x = plot_diss)
178	!	render_plot("plot_pcoa", x = plot_pcoa)
179
180		## Download -----
181	!	export_table("export_beta", results, name = "beta", label = tr_("Download dissimilarity matrix"))
182	!	output$download_button <- renderUI({
183	!	req(results())
184	!	downloadButton(
185	!	outputId = session$ns("download"),
186	!	label = tr_("Download PCoA results")
187		)
188		})
189	!	output$download <- downloadHandler(
190	!	filename = function() { make_file_name("pcoa", "zip") },
191	!	content = function(file) {
192	!	dimensio::export(analysis(), file = file, flags = "-r9Xj")
193		},
194	!	contentType = "application/zip"
195		)
196		})
197		}

1		# UI ===========================================================================
2		#' CA Seriation UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [seriate_server()]
9		#' @family chronology modules
10		#' @keywords internal
11		#' @export
12		seriate_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Seriation"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Permutation"),
22		## Input: checkbox if permute rows
23	!	checkboxInput(
24	!	inputId = ns("margin_row"),
25	!	label = tr_("Permute rows"),
26	!	value = TRUE
27		),
28		## Input: checkbox if permute columns
29	!	checkboxInput(
30	!	inputId = ns("margin_col"),
31	!	label = tr_("Permute columns"),
32	!	value = TRUE
33		),
34		## Input: select CA axes
35	!	numericInput(
36	!	inputId = ns("axes"),
37	!	label = tr_("CA dimension"),
38	!	value = 1,
39	!	min = 1,
40	!	max = 10,
41	!	step = 1
42		),
43		## Output: download
44	!	render_export_button(ns("export_results"))
45	!	), # sidebar
46		## Output: plot reordered matrix
47	!	navset_card_pill(
48	!	bertin_ui(
49	!	id = ns("plot"),
50	!	title = tr_("Rearranged matrix")
51		)
52		)
53	!	) # layout_sidebar
54	!	) # nav_panel
55		}
56
57		# Server =======================================================================
58		#' CA Seriation Server
59		#'
60		#' @param id An ID string that corresponds with the ID used to call the module's
61		#' UI function.
62		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
63		#' @param order A reactive \R object (coercible by [kairos::as_seriation()]).
64		#' @return A reactive [`kairos::AveragePermutationOrder-class`] object.
65		#' @seealso [seriate_ui()]
66		#' @family chronology modules
67		#' @keywords internal
68		#' @export
69		seriate_server <- function(id, x, order) {
70	!	stopifnot(is.reactive(x))
71	!	stopifnot(is.reactive(order))
72
73	!	moduleServer(id, function(input, output, session) {
74		## Seriate -----
75	!	data_seriate <- reactive({
76	!	validate(need(order(), tr_("Compute the seriation order first.")))
77
78	!	margin <- NULL
79	!	if (input$margin_row) margin <- c(margin, 1)
80	!	if (input$margin_col) margin <- c(margin, 2)
81
82	!	kairos::as_seriation(order(), margin = margin, axes = input$axes)
83		})
84
85		## Permute -----
86	!	data_permute <- reactive({
87	!	req(x())
88	!	req(data_seriate())
89	!	kairos::permute(x(), data_seriate())
90		})
91
92		## Render plot -----
93	!	bertin_server("plot", x = data_permute)
94
95		## Download -----
96	!	export_table("export_results", data_permute, name = "permuted")
97
98	!	data_seriate
99		})
100		}

1		# UI ===========================================================================
2		#' Principal Components Analysis UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @param center A [`logical`] scalar: should the variables be shifted to be
6		#' zero centered?
7		#' @param scale A [`logical`] scalar: should the variables be scaled to unit
8		#' variance?
9		#' @param help A [`character`] string giving a short help text.
10		#' @return
11		#' A nav item that may be passed to a nav container
12		#' (e.g. [bslib::navset_tab()]).
13		#' @seealso [pca_server()]
14		#' @family multivariate analysis modules
15		#' @keywords internal
16		#' @export
17		pca_ui <- function(id, center = TRUE, scale = TRUE, help = NULL) {
18		# Create a namespace function using the provided id
19	!	ns <- NS(id)
20
21	!	nav_panel(
22	!	title = tr_("PCA"),
23	!	layout_sidebar(
24	!	sidebar = sidebar(
25	!	width = 400,
26	!	title = tr_("Principal Components Analysis"),
27	!	helpText(textOutput(ns("help"))),
28	!	checkboxInput(
29	!	inputId = ns("center"),
30	!	label = tr_("Center"),
31	!	value = center
32		),
33	!	checkboxInput(
34	!	inputId = ns("scale"),
35	!	label = tr_("Scale"),
36	!	value = scale
37		),
38	!	selectize_ui(
39	!	id = ns("sup_row"),
40	!	label = tr_("Supplementary individuals"),
41	!	multiple = TRUE
42		),
43	!	selectize_ui(
44	!	id = ns("sup_col"),
45	!	label = tr_("Supplementary quantitative variables"),
46	!	multiple = TRUE
47		),
48	!	selectize_ui(
49	!	id = ns("sup_quali"),
50	!	label = tr_("Supplementary qualitative variables"),
51	!	multiple = TRUE
52		),
53	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
54	!	uiOutput(outputId = ns("download_button"))
55	!	), # sidebar
56	!	multivariate_ui(ns("pca")),
57	!	border_radius = FALSE,
58	!	fillable = TRUE
59	!	) # layout_sidebar
60	!	) # nav_panel
61		}
62
63		# Server =======================================================================
64		#' Principal Components Analysis Server
65		#'
66		#' @param id An ID string that corresponds with the ID used to call the module's
67		#' UI function.
68		#' @param x A reactive `data.frame`.
69		#' @return A reactive [`dimensio::PCA-class`] object.
70		#' @seealso [pca_ui()]
71		#' @family multivariate analysis modules
72		#' @keywords internal
73		#' @export
74		pca_server <- function(id, x) {
75	!	stopifnot(is.reactive(x))
76
77	!	moduleServer(id, function(input, output, session) {
78		## Update UI -----
79	!	quanti <- subset_quantitative(x)
80	!	quali <- subset_qualitative(x)
81
82	!	sup_row <- update_selectize_rownames("sup_row", x = x)
83	!	sup_col <- update_selectize_colnames("sup_col", x = quanti)
84	!	sup_quali <- update_selectize_colnames("sup_quali", x = quali, select = TRUE)
85
86		## Check data -----
87	!	output$help <- renderText({
88	!	if (inherits(x(), "LogRatio")) {
89	!	txt <- tr_("PCA is computed on centered log-ratio (CLR), you should check the data transformation first.")
90	!	return(txt)
91		}
92		})
93
94		## Compute PCA -----
95	!	compute_pca <- ExtendedTask$new(
96	!	function(x, center, scale, rank, sup_row, sup_col, sup_quali) {
97	!	mirai::mirai({
98	!	param <- list(object = x, center = center, scale = scale, rank = rank,
99	!	sup_row = arkhe::seek_rows(x, names = sup_row),
100	!	sup_col = sup_col)
101	!	if (is.data.frame(x)) {
102	!	param$sup_quali <- sup_quali
103		}
104	!	do.call(dimensio::pca, param)
105	!	}, environment())
106		}
107		) \|>
108	!	bslib::bind_task_button("go")
109
110	!	observe({
111	!	compute_pca$invoke(x = x(), center = input$center, scale = input$scale,
112	!	rank = input$rank, sup_row = sup_row(),
113	!	sup_col = sup_col(), sup_quali = sup_quali())
114		}) \|>
115	!	bindEvent(input$go)
116
117	!	old <- reactive({ x() }) \|> bindEvent(input$go)
118	!	results <- reactive({
119	!	if (!identical(x(), old())) return(NULL) # Invalidate
120	!	notify(compute_pca$result(), title = tr_("Principal Components Analysis"))
121		})
122
123	!	multivariate_server("pca", x = results, y = x)
124
125		## Export -----
126	!	output$download_button <- renderUI({
127	!	req(results())
128	!	downloadButton(
129	!	outputId = session$ns("download"),
130	!	label = tr_("Download results")
131		)
132		})
133	!	output$download <- downloadHandler(
134	!	filename = function() { make_file_name("pca", "zip") },
135	!	content = function(file) {
136	!	req(results())
137	!	dimensio::export(results(), file = file, flags = "-r9Xj")
138		},
139	!	contentType = "application/zip"
140		)
141
142	!	results
143		})
144		}

1		# UI ===========================================================================
2		#' Compositional Data Navigation UI
3		#'
4		#' @param ... Currently not used.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @family coda modules
9		#' @keywords internal
10		#' @name coda_nav
11		#' @rdname coda_nav
12		NULL
13
14		#' @rdname coda_nav
15		#' @export
16		coda_nav_plot <- function(...) {
17	!	nav_menu(
18	!	title = tr_("Plot"),
19	!	coda_hist_ui("hist"),
20	!	coda_barplot_ui("barplot"),
21	!	ternary_ui("ternary")
22		)
23		}
24
25		#' @rdname coda_nav
26		#' @export
27		coda_nav_logratio <- function(...) {
28	!	nav_menu(
29	!	title = tr_("Transform"),
30	!	logratio_ui("clr", title = "CLR"),
31	!	logratio_ui("alr", title = "ALR"),
32	!	logratio_ui("ilr", title = "ILR"),
33	!	logratio_ui("plr", title = "PLR")
34		)
35		}
36
37		#' @rdname coda_nav
38		#' @export
39		coda_nav_analysis <- function(...) {
40	!	nav_menu(
41	!	title = tr_("Analysis"),
42		#coda_outliers_ui("outliers"),
43	!	pca_ui("pca", scale = FALSE),
44	!	coda_hclust_ui("clust")
45		)
46		}
47
48		#' Compositional Data UI
49		#'
50		#' @param id A [`character`] vector to be used for the namespace.
51		#' @return
52		#' A nav item that may be passed to a nav container
53		#' (e.g. [bslib::navset_tab()]).
54		#' @seealso [coda_server()]
55		#' @family coda modules
56		#' @keywords internal
57		#' @export
58		coda_ui <- function(id) {
59		# Create a namespace function using the provided id
60	!	ns <- NS(id)
61
62	!	nav_panel(
63	!	title = tr_("Data"),
64	!	value = "data",
65	!	layout_sidebar(
66	!	sidebar = sidebar(
67	!	width = 400,
68	!	title = tr_("Compositional Data"),
69	!	import_ui(ns("import"))
70	!	), # sidebar
71		## Output: value box
72	!	box_ui(ns("box")),
73	!	navset_card_pill(
74	!	placement = "above",
75	!	nav_panel(
76	!	title = tr_("Data"),
77	!	layout_sidebar(
78	!	sidebar = sidebar(
79	!	checkbox_ui(
80	!	id = ns("parts"),
81	!	label = tooltip(
82	!	trigger = span(
83	!	tr_("Compositional parts"),
84	!	icon("info-circle")
85		),
86	!	tr_("Select the variables you want to use.")
87		)
88		),
89	!	selectize_ui(
90	!	id = ns("group"),
91	!	label = tooltip(
92	!	trigger = span(
93	!	tr_("Group by"),
94	!	icon("info-circle")
95		),
96	!	tr_("You can use a qualitative variable to assign each sample to a (reference) group."),
97	!	tr_("Missing values will be interpreted as unassigned samples.")
98		),
99	!	multiple = TRUE
100		),
101	!	selectize_ui(
102	!	id = ns("condense"),
103	!	label = tooltip(
104	!	trigger = span(
105	!	tr_("Condense by"),
106	!	icon("info-circle")
107		),
108	!	tr_("You can use one or more categorical variable to split the data into subsets and compute the compositional mean for each."),
109	!	tr_("Usefull if your data contain several observations for the same sample (e.g. repeated measurements).")
110		),
111	!	multiple = TRUE
112		),
113	!	), # sidebar
114		## Output: display data
115	!	checkboxInput(
116	!	inputId = ns("head"),
117	!	label = tr_("Table overview"),
118	!	value = TRUE
119		),
120	!	gt::gt_output(outputId = ns("table"))
121	!	) # layout_sidebar
122		),
123	!	nav_panel(
124	!	title = tr_("Clean values"),
125	!	clean_ui(ns("clean"))
126		),
127	!	nav_panel(
128	!	title = tr_("Missing values"),
129	!	missing_ui(ns("missing"))
130		)
131		),
132	!	border_radius = FALSE,
133	!	fillable = TRUE,
134	!	) # layout_sidebar
135	!	) # nav_panel
136		}
137
138		# Server =======================================================================
139		#' Compositional Data Server
140		#'
141		#' @param id An ID string that corresponds with the ID used to call the module's
142		#' UI function.
143		#' @param demo A [`character`] string specifying the name of a dataset (see
144		#' [import_server()]).
145		#' @param verbose A [`logical`] scalar: should \R report extra information
146		#' on progress?
147		#' @return A reactive [`nexus::CompositionMatrix-class`] object.
148		#' @seealso [coda_ui()]
149		#' @family coda modules
150		#' @keywords internal
151		#' @export
152		coda_server <- function(id, demo = NULL, verbose = get_option("verbose", FALSE)) {
153	1x	moduleServer(id, function(input, output, session) {
154		## Prepare data -----
155	1x	data_raw <- import_server("import", demo = demo)
156	1x	quanti <- subset_quantitative(data_raw, positive = TRUE)
157	1x	quali <- subset_qualitative(data_raw)
158
159		## Update UI -----
160	1x	var_parts <- update_checkbox_colnames("parts", x = quanti)
161	1x	var_group <- update_selectize_colnames("group", x = quali)
162	1x	var_condense <- update_selectize_colnames("condense", x = data_raw)
163
164		## Compositions -----
165	1x	data_coda <- reactive({
166	1x	notify(
167	1x	nexus::as_composition(
168	1x	from = quanti(),
169	1x	parts = var_parts(),
170	1x	autodetect = FALSE,
171	1x	verbose = verbose
172		),
173	1x	title = tr_("Compositional Data")
174		)
175		}) \|>
176	1x	bindEvent(var_parts()) \|>
177	1x	debounce(500)
178
179		## Group -----
180	1x	data_group <- reactive({
181	4x	if (!isTruthy(var_group()) \|\| !isTruthy(data_coda()))
182	3x	return(data_coda())
183
184	1x	nexus::group(data_coda(), by = quali()[var_group()],
185	1x	verbose = verbose)
186		})
187
188		## Condense -----
189	1x	data_condense <- reactive({
190	5x	if (!isTruthy(var_condense()) \|\| !isTruthy(data_group()))
191	4x	return(data_group())
192
193	1x	nexus::condense(data_group(), by = data_raw()[var_condense()],
194	1x	ignore_na = FALSE, verbose = verbose)
195		})
196
197		## Missing values -----
198	1x	data_clean <- clean_server("clean", x = data_condense)
199	1x	data_missing <- missing_server("missing", x = data_clean)
200
201		## Zeros -----
202		# TODO
203
204		## Check -----
205	1x	data_valid <- reactive({
206	5x	validate_csv(data_missing())
207	3x	validate_dim(data_missing(), i = 1, j = 3)
208	3x	validate_na(data_missing())
209	3x	validate_zero(data_missing())
210
211	3x	data_missing()
212		})
213
214		## Render tables -----
215	1x	output$table <- gt::render_gt({
216	5x	req(data_missing())
217	3x	tbl <- as.data.frame(data_missing(), group_var = tr_("Group"))
218	3x	tbl <- if (isTRUE(input$head)) utils::head(tbl) else tbl
219	3x	gt::gt(tbl, rownames_to_stub = TRUE) \|>
220	3x	gt::tab_options(table.width = "100%")
221		})
222
223		## Value box -----
224	1x	box_server("box", x = data_valid)
225
226	1x	data_valid
227		})
228		}
229
230		# Modules ======================================================================
231		## Imputation ------------------------------------------------------------------
232		coda_zero_ui <- function(id) {
233	!	ns <- NS(id)
234
235	!	list(
236	!	helpText(
237	!	tr_("If your data contains zeros, these can be considered as values below the detection limit (i.e. small unknown values)."),
238	!	tr_("In this case, you can define the detection limit for each compositional part below."),
239	!	tr_("If all limits are specified, zeros will be replaced by a fraction of these limits."),
240	!	tr_("For computational details, see"),
241	!	cite_article("Martin-Fernandez et al.", "2003", doi = "10.1023/A:1023866030544", text = TRUE)
242		),
243	!	numericInput(
244	!	inputId = ns("delta"),
245	!	label = tr_("Fraction"),
246	!	value = 2 / 3,
247	!	min = 0,
248	!	max = 1
249		),
250	!	uiOutput(outputId = ns("values")),
251	!	actionButton(inputId = ns("go"), tr_("Replace zero"))
252		)
253		}
254		coda_zero_server <- function(id, x) {
255	1x	stopifnot(is.reactive(x))
256
257	1x	moduleServer(id, function(input, output, session) {
258	1x	data <- reactiveValues(values = NULL)
259
260		## Build UI
261	1x	ids <- reactive({
262	!	if (is.null(colnames(x()))) return(NULL)
263	1x	data$values <- x()
264	1x	paste0("limit_", colnames(x()))
265		})
266
267	1x	ui <- reactive({
268	1x	req(ids())
269
270	1x	ui <- lapply(
271	1x	X = ids(),
272	1x	FUN = function(i) {
273	3x	numericInput(
274	3x	inputId = session$ns(i),
275	3x	label = paste(sub("limit_", "", i, fixed = TRUE), "(%)", sep = " "),
276	3x	value = 0, min = 0, max = 100
277		)
278		}
279		)
280
281	1x	do.call(layout_column_wrap, args = c(ui, width = 1/4))
282		})
283	1x	output$values <- renderUI({ ui() })
284	1x	outputOptions(output, "values", suspendWhenHidden = FALSE)
285
286		## Compute
287	1x	observe({
288	1x	req(ids())
289	1x	limits <- lapply(X = ids(), FUN = function(i, x) x[[i]], x = input)
290	1x	if (all(lengths(limits) != 0) \|\| all(limits > 0)) {
291	1x	limits <- unlist(limits) / 100
292	1x	data$values <- nexus::replace_zero(
293	1x	x = x(),
294	1x	value = limits,
295	1x	delta = input$delta
296		)
297		}
298		}) \|>
299	1x	bindEvent(input$go)
300
301	2x	reactive({ data$values })
302		})
303		}

1		# HELP TEXT
2
3		#' Make File Name
4		#'
5		#' @param name A [`character`] string specifying the name of the file
6		#' (without extension and the leading dot).
7		#' @param ext A [`character`] string specifying the file extension.
8		#' @param project A [`character`] string specifying the name of the project.
9		#' @param timestamp A [`character`] string specifying the timestamp
10		#' (defaults to current date and time).
11		#' @return A [`character`] string.
12		#' @family widgets
13		#' @keywords internal
14		#' @noRd
15		make_file_name <- function(name, ext, project = NULL, timestamp = NULL) {
16	2x	project <- if (is.null(project)) "" else paste0(project, "_")
17	2x	timestamp <- timestamp %\|\|% format(Sys.time(), "%y%m%d_%H%M%S")
18
19	2x	sprintf("%s%s_%s.%s", project, name, timestamp, ext)
20		}
21
22		#' Build an URL
23		#'
24		#' @param package A [`character`] string giving the name of a package.
25		#' @return A [`character`] string (URL).
26		#' @keywords internal
27		#' @noRd
28		url_tesselle <- function(package = NULL) {
29	1x	if (is.null(package)) return("https://www.tesselle.org/")
30	1x	sprintf("https://packages.tesselle.org/%s/", package)
31		}
32
33		#' Citing \R Packages
34		#'
35		#' @param x A [`character`] vector giving the name of one or more package.
36		#' @return Citations properly formated in HTML.
37		#' @keywords internal
38		#' @noRd
39		cite_package <- function(x = NULL) {
40	2x	x <- c("kinesis", x)
41	2x	lapply(
42	2x	X = x,
43	2x	FUN = function(x) {
44	4x	bib <- format(utils::citation(x), style = "text")
45	4x	txt <- paste0(vapply(X = bib, FUN = markdown, FUN.VALUE = character(1)))
46	4x	HTML(txt)
47		}
48		)
49		}
50
51		#' Citing a Publication
52		#'
53		#' @param author A [`character`] string giving the name of the author(s).
54		#' @param author An [`integer`] or a [`character`] string giving the publication
55		#' year.
56		#' @param doi A [`character`] string giving the DOI. If not `NULL`, it will be
57		#' used to create a link.
58		#' @param text A [`logical`] scalar. If `FALSE`, the citation will be printed
59		#' in parentheses.
60		#' @param before,after A [`character`] string to be inserted before and after
61		#' the citation, resp.
62		#' @param html A [`logical`] scalar. If `TRUE` (the default), the text is marked
63		#' as HTML.
64		#' @return An author-date citation in HTML.
65		#' @keywords internal
66		#' @noRd
67		cite_article <- function(author, year, doi = NULL, text = TRUE,
68		before = "", after = "", html = TRUE) {
69	9x	right <- paste0(")", after)
70	9x	if (is.null(doi)) {
71	5x	link <- tags$span(year, .noWS = "outside")
72		} else {
73	4x	link <- url_doi(doi, label = year)
74		}
75
76	9x	if (text) {
77	8x	cite <- tags$span(before, author, "(", link, right)
78		} else {
79	1x	cite <- tags$span(paste0("(", author, ", "), link, right,
80	1x	.noWS = c("after-begin", "before-end"))
81		}
82	9x	if (!html) cite <- as.character(cite)
83	9x	cite
84		}
85
86		info_article <- function(...) {
87	6x	cite_article(..., before = icon("info-circle"), after = ".")
88		}
89
90		url_doi <- function(x, label = NULL, prefix = FALSE) {
91	!	if (is.null(label)) label <- x
92	4x	url <- sprintf("https://doi.org/%s", x)
93	4x	no_ws <- if (prefix) c("after") else c("before", "after")
94	4x	link <- tags$a(label, href = url, target = "_blank", role="doc-biblioref", .noWS = no_ws)
95	4x	if (!prefix) return(link)
96	!	list("DOI:", link, ".")
97		}
98
99		help_warranty <- function(...) {
100	!	tags$p(
101	!	tr_("This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY.")
102		)
103		}
104
105		help_data <- function(...) {
106	!	withTags(
107	!	p(
108	!	tr_("You can import your data in CSV format."),
109	!	tr_("It assumes that you keep your data tidy:"),
110	!	tr_("each variable must be saved in its own column and each sample must be saved in its own row.")
111		)
112		)
113		}
114
115		help_cite <- function(package = NULL) {
116	!	list(
117	!	tags$p(
118	!	tr_("If you use this application in your research, you must report and cite it properly to ensure transparency of your results."),
119	!	tr_("Moreover, authors and maintainers of this project are more likely to continue their work if they see that it's being used and valued by the research community.")
120		),
121	!	tags$p(tr_("To cite in your publications, please use:")),
122	!	cite_package(package)
123		)
124		}
125
126		help_license <- function(...) {
127	!	withTags(
128	!	p(
129	!	tr_("This app is distributed as a free and open source R package:"),
130	!	a("packages.tesselle.org/kinesis", href = url_tesselle("kinesis"),
131	!	target = "_blank", rel = "external", .noWS = "after"), "."
132		)
133		)
134		}
135
136		help_tesselle <- function(...) {
137	!	withTags(
138	!	list(
139	!	p(HTML(
140	!	tr_("This app is a part of the <strong>tesselle</strong> project, a collection of packages for research and teaching in archaeology."),
141	!	tr_("The <strong>tesselle</strong> packages focus on quantitative analysis methods developed for archaeology."),
142	!	tr_("They can be used to explore and analyze common data types in archaeology.")
143		)),
144	!	p(
145	!	tr_("For more information and relevant links, see"),
146	!	a("tesselle.org", href = url_tesselle(), target = "_blank",
147	!	rel = "external", .noWS = "after"), "."
148		)
149		)
150		)
151		}

1		# UI ===========================================================================
2		#' Time Intervals UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [time_interval_server()]
9		#' @family chronology modules
10		#' @keywords internal
11		#' @export
12		time_interval_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Intervals"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Time Intervals"),
22	!	selectize_ui(
23	!	id = ns("lower"),
24	!	label = tr_("Lower temporal boundary")
25		),
26	!	selectize_ui(
27	!	id = ns("upper"),
28	!	label = tr_("Upper temporal boundary")
29		),
30	!	select_calendar(ns("calendar")),
31	!	selectize_ui(
32	!	id = ns("groups"),
33	!	label = tr_("Groups")
34		)
35	!	), # sidebar
36	!	output_plot(
37	!	id = ns("plot"),
38	!	tools = graphics_ui(ns("par"), col_quant = FALSE, pch = FALSE,
39	!	lty = FALSE, cex = FALSE)
40		)
41	!	) # layout_sidebar
42	!	) # nav_panel
43		}
44
45		# Server =======================================================================
46		#' Aoristic Analysis Server
47		#'
48		#' @param id An ID string that corresponds with the ID used to call the module's
49		#' UI function.
50		#' @param x A reactive `data.frame`.
51		#' @return A reactive [`list`].
52		#' @seealso [time_interval_ui()]
53		#' @family chronology modules
54		#' @keywords internal
55		#' @export
56		time_interval_server <- function(id, x) {
57	!	stopifnot(is.reactive(x))
58
59	!	moduleServer(id, function(input, output, session) {
60		## Update UI -----
61	!	quanti <- subset_quantitative(x)
62	!	quali <- subset_qualitative(x)
63	!	col_lower <- update_selectize_colnames("lower", x = quanti)
64	!	col_upper <- update_selectize_colnames("upper", x = quanti, exclude = col_lower)
65	!	col_groups <- update_selectize_colnames("groups", x = quali)
66
67	!	lower <- select_data(x, col_lower, drop = TRUE)
68	!	upper <- select_data(x, col_upper, drop = TRUE)
69	!	groups <- select_data(x, col_groups, drop = TRUE)
70
71	!	calendar <- get_calendar("calendar")
72
73		## Time Intervals -----
74	!	results <- reactive({
75	!	req(x(), lower(), upper(), calendar())
76	!	notify(
77		{
78	!	aion::intervals(start = lower(), end = upper(),
79	!	calendar = calendar(), names = rownames(x()))
80		},
81	!	title = tr_("Aoristic Analysis")
82		)
83		})
84
85		## Graphical parameters -----
86	!	param <- graphics_server("par")
87
88		## Plot -----
89	!	plot <- reactive({
90	!	req(results())
91	!	grp <- NULL
92	!	col <- "black"
93
94	!	if (isTruthy(groups())) {
95	!	grp <- groups()
96	!	col <- param$col_quali(grp)
97		}
98
99	!	function() {
100	!	aion::plot(results(), calendar = aion::CE(), groups = grp, col = col)
101	!	if (isTruthy(groups())) {
102	!	graphics::legend(x = "topleft", legend = unique(grp), fill = unique(col))
103		}
104		}
105		})
106
107		## Render plots -----
108	!	render_plot("plot", x = plot)
109
110	!	reactive({ list(results = results(), groups = groups()) })
111		})
112		}

1		# UI ===========================================================================
2		#' MCD UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [mcd_server()]
9		#' @family ceramic data modules
10		#' @keywords internal
11		#' @export
12		mcd_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Date"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	h5(tr_("Mean Ceramic Date")),
22	!	helpText(tr_("Set the date midpoint (in years) of each ceramic type.")),
23	!	render_numeric_input(ns("dates")),
24	!	select_calendar(ns("calendar_input")),
25	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
26	!	render_export_button(ns("export_results")),
27	!	), # sidebar
28	!	layout_columns(
29	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
30	!	output_plot(
31	!	id = ns("plot"),
32	!	tools = list(
33	!	select_calendar(ns("calendar_output"))
34		)
35		),
36	!	card(
37	!	gt::gt_output(outputId = ns("table"))
38		)
39		)
40	!	) # layout_sidebar
41	!	) # nav_panel
42		}
43
44		# Server =======================================================================
45		#' MCD Server
46		#'
47		#' @param id An ID string that corresponds with the ID used to call the module's
48		#' UI function.
49		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
50		#' @return
51		#' No return value, called for side effects.
52		#' @seealso [mcd_ui()]
53		#' @family ceramic data modules
54		#' @keywords internal
55		#' @export
56		mcd_server <- function(id, x) {
57	!	stopifnot(is.reactive(x))
58
59	!	moduleServer(id, function(input, output, session) {
60		## Update UI -----
61	!	dates <- build_numeric_input("dates", x)
62	!	cal_in <- get_calendar("calendar_input")
63	!	cal_out <- get_calendar("calendar_output")
64
65		## Compute MCD -----
66	!	compute_mcd <- ExtendedTask$new(
67	!	function(x, dates, calendar) {
68	!	mirai::mirai({ kairos::mcd(x, dates, calendar) }, environment())
69		}
70		) \|>
71	!	bslib::bind_task_button("go")
72
73	!	observe({
74	!	compute_mcd$invoke(x = x(), dates = dates(), calendar = cal_in())
75		}) \|>
76	!	bindEvent(input$go)
77
78	!	old <- reactive({ x() }) \|> bindEvent(input$go)
79	!	results <- reactive({
80	!	if (!identical(x(), old())) return(NULL) # Invalidate
81	!	notify(compute_mcd$result(), title = tr_("MCD"))
82		})
83
84		## Plot -----
85	!	map <- reactive({
86	!	req(results())
87	!	function() kairos::plot(results(), calendar = cal_out())
88		})
89
90		## Table -----
91	!	tbl <- reactive({
92	!	req(results())
93	!	as.data.frame(results(), calendar = cal_out())
94		})
95
96		## Render table -----
97	!	output$table <- gt::render_gt({
98	!	req(tbl())
99	!	tbl() \|>
100	!	gt::gt(rowname_col = "sample") \|>
101	!	gt::fmt_number(decimals = 2) \|>
102	!	gt::sub_missing()
103		})
104
105		## Render plot -----
106	!	render_plot("plot", x = map)
107
108		## Download -----
109	!	export_table("export_results", tbl, name = "mcd")
110		})
111		}

1		# UI ===========================================================================
2		#' Mutlivariate Analysis UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return A tab that can be passed to [shiny::tabsetPanel()].
6		#' @return
7		#' A navigation container (see [bslib::navset_card_pill()]).
8		#' @seealso [multivariate_server()]
9		#' @family multivariate analysis modules
10		#' @keywords internal
11		#' @export
12		multivariate_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	navset_card_pill(
17	!	sidebar = sidebar(
18	!	title = tr_("Factor maps"),
19		## Input: display options
20	!	selectizeInput(
21	!	inputId = ns("axis1"),
22	!	label = tr_("Horizontal axis"),
23	!	choices = NULL,
24	!	multiple = FALSE
25		),
26	!	selectizeInput(
27	!	inputId = ns("axis2"),
28	!	label = tr_("Vertical axis"),
29	!	choices = NULL,
30	!	multiple = FALSE
31		),
32	!	checkboxInput(
33	!	inputId = ns("lab_ind"),
34	!	label = tr_("Label individuals"),
35	!	value = FALSE
36		),
37	!	checkboxInput(
38	!	inputId = ns("lab_var"),
39	!	label = tr_("Label variables"),
40	!	value = TRUE
41		),
42	!	checkboxInput(
43	!	inputId = ns("sup_ind"),
44	!	label = tr_("Display supplementary individuals"),
45	!	value = TRUE
46		),
47	!	checkboxInput(
48	!	inputId = ns("sup_var"),
49	!	label = tr_("Display supplementary variables"),
50	!	value = TRUE
51		),
52	!	selectize_ui(
53	!	id = ns("extra_quanti"),
54	!	label = tr_("Extra quantitative variable")
55		),
56	!	selectize_ui(
57	!	id = ns("extra_quali"),
58	!	label = tr_("Extra qualitative variable")
59		),
60		## Input: add ellipses
61	!	radioButtons(
62	!	inputId = ns("wrap"),
63	!	label = tr_("Wrap:"),
64	!	choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
65	!	tr_("Confidence ellipse"), tr_("Convex hull")),
66	!	choiceValues = c("none", "tolerance", "confidence", "hull"),
67		),
68	!	checkboxGroupInput(
69	!	inputId = ns("ellipse_level"),
70	!	label = tr_("Ellipse level:"),
71	!	selected = "0.95",
72	!	choiceNames = c("68%", "95%", "99%"),
73	!	choiceValues = c("0.68", "0.95", "0.99")
74		)
75		# TODO: legend
76		),
77		## Results -----
78	!	nav_panel(
79	!	title = tr_("Results"),
80	!	helpText(
81	!	tr_("Click and drag to select an area, then double-click to zoom in."),
82	!	tr_("Double-click again to reset the zoom.")
83		),
84	!	layout_column_wrap(
85	!	output_plot(
86	!	id = ns("plot_ind"),
87	!	tools = graphics_ui(ns("par_ind"), lty = FALSE),
88	!	title = tr_("Individuals factor map"),
89	!	dblclick = ns("plot_ind_dblclick"),
90	!	brush = brushOpts(
91	!	id = ns("plot_ind_brush"),
92	!	resetOnNew = TRUE
93		),
94	!	height = "100%"
95		),
96	!	output_plot(
97	!	id = ns("plot_var"),
98	!	tools = graphics_ui(ns("par_var"), col_quant = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
99	!	title = tr_("Variables factor map"),
100	!	dblclick = ns("plot_var_dblclick"),
101	!	brush = brushOpts(
102	!	id = ns("plot_var_brush"),
103	!	resetOnNew = TRUE
104		),
105	!	height = "100%"
106		)
107	!	) # layout_columns
108		),
109		## Individuals -----
110	!	nav_panel(
111	!	title = tr_("Individuals"),
112	!	layout_column_wrap(
113	!	output_plot(id = ns("plot_cos2_1")),
114	!	output_plot(id = ns("plot_cos2_2")),
115	!	min_height = "50%"
116		),
117	!	gt::gt_output(outputId = ns("info_ind"))
118		),
119		## Variables -----
120	!	nav_panel(
121	!	title = tr_("Variables"),
122	!	layout_column_wrap(
123	!	output_plot(id = ns("plot_contrib_1")),
124	!	output_plot(id = ns("plot_contrib_2")),
125	!	min_height = "50%"
126		),
127	!	gt::gt_output(outputId = ns("info_var"))
128		),
129		## Screeplot -----
130	!	nav_panel(
131	!	title = tr_("Screeplot"),
132	!	layout_column_wrap(
133	!	output_plot(id = ns("screeplot"), title = tr_("Screeplot")),
134	!	tableOutput(outputId = ns("variance"))
135		)
136		)
137		)
138		}
139
140		# Server =======================================================================
141		#' Multivariate Analysis Server
142		#'
143		#' @param id An ID string that corresponds with the ID used to call the module's
144		#' UI function.
145		#' @param x A reactive [`dimensio::MultivariateAnalysis-class`] object.
146		#' @param y A reactive `matrix`-like object use to compute the multivariate
147		#' analysis.
148		#' @return
149		#' No return value, called for side effects.
150		#' @seealso [multivariate_ui]
151		#' @family multivariate analysis modules
152		#' @keywords internal
153		#' @export
154		multivariate_server <- function(id, x, y) {
155	!	stopifnot(is.reactive(x))
156
157	!	moduleServer(id, function(input, output, session) {
158		## Illustrative variables -----
159		## Set group_var for nexus::GroupedComposition objects
160	!	extra <- reactive({ as.data.frame(y(), group_var = tr_("Group")) })
161	!	quanti <- subset_quantitative(extra)
162	!	quali <- subset_qualitative(extra)
163
164	!	col_quali <- update_selectize_colnames("extra_quali", x = quali)
165	!	col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)
166
167		## Extra variables -----
168	!	extra_quali <- select_data(quali, col_quali, drop = TRUE)
169	!	extra_quanti <- select_data(quanti, col_quanti, drop = TRUE)
170
171		## Eigenvalues -----
172	!	eigen <- reactive({
173	!	req(x())
174	!	dimensio::get_eigenvalues(x())
175		})
176
177		## Update UI -----
178	!	axes <- reactive({
179	!	choices <- seq_len(nrow(eigen()))
180	!	names(choices) <- rownames(eigen())
181	!	choices
182		})
183	!	observe({
184	!	freezeReactiveValue(input, "axis1")
185	!	updateSelectizeInput(inputId = "axis1", choices = axes())
186		}) \|>
187	!	bindEvent(axes())
188	!	observe({
189	!	choices <- axes()[-axis1()]
190	!	freezeReactiveValue(input, "axis2")
191	!	updateSelectizeInput(inputId = "axis2", choices = choices)
192		}) \|>
193	!	bindEvent(axis1())
194
195		## Select axes -----
196	!	axis1 <- reactive({
197	!	req(input$axis1)
198	!	as.numeric(input$axis1)
199		})
200	!	axis2 <- reactive({
201	!	req(input$axis2)
202	!	as.numeric(input$axis2)
203		})
204
205		## Graphical parameters -----
206	!	param_ind <- graphics_server("par_ind")
207	!	param_var <- graphics_server("par_var")
208
209		## Plot -----
210		## Interactive zoom
211		## When a double-click happens, check if there's a brush on the plot.
212		## If so, zoom to the brush bounds; if not, reset the zoom.
213	!	range_ind <- reactiveValues(x = NULL, y = NULL)
214	!	range_var <- reactiveValues(x = NULL, y = NULL)
215	!	observe({
216	!	range_ind$x <- brush_xlim(input$plot_ind_brush)
217	!	range_ind$y <- brush_ylim(input$plot_ind_brush)
218		}) \|>
219	!	bindEvent(input$plot_ind_dblclick)
220
221	!	observe({
222	!	range_var$x <- brush_xlim(input$plot_var_brush)
223	!	range_var$y <- brush_ylim(input$plot_var_brush)
224		}) \|>
225	!	bindEvent(input$plot_var_dblclick)
226
227		## Individuals
228	!	plot_ind <- reactive({
229	!	req(x())
230
231	!	col <- param_ind$pal_quali
232	!	if (isTruthy(extra_quali())) {
233	!	quali <- extra_quali()
234	!	} else if (isTruthy(extra_quanti())) {
235	!	quali <- NULL
236	!	col <- param_ind$pal_quanti
237		} else {
238	!	quali <- "observation"
239		}
240
241	!	add_ellipses <- any(input$wrap %in% c("confidence", "tolerance"))
242	!	add_hull <- identical(input$wrap, "hull")
243
244	!	function() {
245	!	dimensio::viz_rows(
246	!	x = x(),
247	!	axes = c(axis1(), axis2()),
248	!	active = TRUE,
249	!	sup = isTRUE(input$sup_ind),
250	!	labels = isTRUE(input$lab_ind),
251	!	extra_quali = quali,
252	!	extra_quanti = extra_quanti(),
253	!	color = col,
254	!	symbol = param_ind$pal_pch,
255	!	size = param_ind$pal_cex,
256	!	xlim = range_ind$x,
257	!	ylim = range_ind$y,
258	!	panel.first = graphics::grid(),
259	!	na_show = TRUE # /!\ Undocumented feature /!\
260		)
261
262	!	if (add_ellipses) {
263	!	dimensio::viz_ellipses(
264	!	x = x(),
265	!	group = extra_quali(),
266	!	type = input$wrap,
267	!	level = as.numeric(input$ellipse_level),
268	!	color = param_ind$pal_quali
269		)
270		}
271	!	if (add_hull) {
272	!	dimensio::viz_hull(
273	!	x = x(),
274	!	group = extra_quali(),
275	!	color = param_ind$pal_quali
276		)
277		}
278		}
279		})
280
281		## Variables
282	!	plot_var <- reactive({
283	!	req(x())
284
285	!	function() {
286	!	dimensio::viz_variables(
287	!	x = x(),
288	!	axes = c(axis1(), axis2()),
289	!	active = TRUE,
290	!	sup = isTRUE(input$sup_var),
291	!	labels = isTRUE(input$lab_var),
292	!	extra_quali = "observation",
293	!	color = param_var$pal_quali,
294	!	symbol = c(1, 3),
295	!	xlim = range_var$x,
296	!	ylim = range_var$y,
297	!	panel.first = graphics::grid()
298		)
299		}
300		})
301
302	!	plot_cos2_1 <- reactive({
303	!	req(x())
304	!	function() {
305	!	dimensio::viz_cos2(x = x(), margin = 1, axes = axis1())
306		}
307		})
308
309	!	plot_cos2_2 <- reactive({
310	!	req(x())
311	!	function() {
312	!	dimensio::viz_cos2(x = x(), margin = 1, axes = axis2())
313		}
314		})
315
316	!	plot_contrib_1 <- reactive({
317	!	req(x())
318	!	function() {
319	!	dimensio::viz_contributions(x = x(), margin = 2, axes = axis1())
320		}
321		})
322
323	!	plot_contrib_2 <- reactive({
324	!	req(x())
325	!	function() {
326	!	dimensio::viz_contributions(x = x(), margin = 2, axes = axis2())
327		}
328		})
329
330	!	plot_eigen <- reactive({
331	!	req(x())
332	!	function() {
333	!	dimensio::screeplot(
334	!	x = x(),
335	!	cumulative = TRUE,
336	!	labels = FALSE,
337	!	limit = sum(eigen()[, 3] <= 99)
338		)
339		}
340		})
341
342		## Render plots -----
343	!	render_plot("plot_ind", x = plot_ind)
344	!	render_plot("plot_var", x = plot_var)
345	!	render_plot("plot_cos2_1", x = plot_cos2_1)
346	!	render_plot("plot_cos2_2", x = plot_cos2_2)
347	!	render_plot("plot_contrib_1", x = plot_contrib_1)
348	!	render_plot("plot_contrib_2", x = plot_contrib_2)
349	!	render_plot("screeplot", x = plot_eigen)
350
351		## Render tables -----
352	!	output$variance <- gt::render_gt({
353	!	gt::gt(eigen(), rownames_to_stub = TRUE) \|>
354	!	gt::tab_options(table.width = "100%") \|>
355	!	gt::fmt_number(
356	!	columns = c("eigenvalues"),
357	!	decimals = 3
358		) \|>
359	!	gt::fmt_percent(
360	!	columns = c("variance", "cumulative"),
361	!	scale_values = FALSE
362		) \|>
363	!	gt::cols_label(
364	!	eigenvalues = tr_("Eigenvalues"),
365	!	variance = tr_("Explained var. (%)"),
366	!	cumulative = tr_("Cumulative var. (%)")
367		)
368		})
369
370	!	output$info_ind <- gt::render_gt({
371	!	req(x())
372	!	multivariate_summary(x(), axes = c(axis1(), axis2()), margin = 1)
373		})
374	!	output$info_var <- gt::render_gt({
375	!	req(x())
376	!	multivariate_summary(x(), axes = c(axis1(), axis2()), margin = 2)
377		})
378		})
379		}
380
381		multivariate_summary <- function(x, axes, margin) {
382	!	dimensio::summary(x, axes = axes, margin = margin) \|>
383	!	as.data.frame() \|>
384	!	gt::gt(rownames_to_stub = TRUE) \|>
385	!	gt::fmt_number(decimals = 3) \|>
386	!	gt::tab_spanner(
387	!	label = tr_("Coordinates"),
388	!	columns = gt::ends_with("coord"),
389	!	id = "coord"
390		) \|>
391	!	gt::tab_spanner(
392	!	label = tr_("Contribution"),
393	!	columns = gt::ends_with("contrib"),
394	!	id = "contrib"
395		) \|>
396	!	gt::tab_spanner(
397	!	label = tr_("Squared cosinus"),
398	!	columns = gt::ends_with("cos2"),
399	!	id = "cos2"
400		) \|>
401	!	gt::cols_label_with(
402	!	columns = gt::matches("dist"),
403	!	fn = function(x) tr_("Distance")
404		) \|>
405	!	gt::cols_label_with(
406	!	columns = gt::matches("inertia"),
407	!	fn = function(x) tr_("Inertia")
408		) \|>
409	!	gt::cols_label_with(
410	!	columns = gt::starts_with("F"),
411	!	fn = function(x) {
412	!	paste(tr_("Axis"), regmatches(x, regexpr("[0-9]", x)), sep = " ")
413		}
414		) \|>
415	!	gt::opt_interactive(
416	!	use_compact_mode = TRUE,
417	!	use_page_size_select = TRUE
418		)
419		}

1		# UI ===========================================================================
2		#' Ternary Plot UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [ternary_server()]
9		#' @family plot modules
10		#' @keywords internal
11		#' @export
12		ternary_ui <- function(id) {
13		## Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Ternary Plot"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Ternary Plot"),
22	!	accordion(
23	!	accordion_panel(
24	!	title = tr_("Variables"),
25		## Input: select axes
26	!	selectize_ui(id = ns("axis1"), label = tr_("Component X")),
27	!	selectize_ui(id = ns("axis2"), label = tr_("Component Y")),
28	!	selectize_ui(id = ns("axis3"), label = tr_("Component Z")),
29		## Input: aesthetics mapping
30	!	selectize_ui(id = ns("extra_quali"), label = tr_("Extra qualitative variable")),
31	!	selectize_ui(id = ns("extra_quanti"), label = tr_("Extra quantitative variable")),
32		),
33	!	accordion_panel(
34	!	title = tr_("Layers"),
35		## Input: add points
36	!	checkboxInput(
37	!	inputId = ns("points"),
38	!	label = tr_("Show points"),
39	!	value = TRUE
40		),
41		## Input: add density
42	!	checkboxInput(
43	!	inputId = ns("density"),
44	!	label = tr_("Density contour"),
45	!	value = FALSE
46		),
47	!	radioButtons(
48	!	inputId = ns("tile"),
49	!	label = tr_("Heatmap"),
50	!	choiceNames = c(tr_("None"), tr_("Bin"), tr_("Density")),
51	!	choiceValues = c("none", "bin", "dens"),
52	!	selected = "none"
53		),
54	!	sliderInput(
55	!	inputId = ns("bin"),
56	!	label = tr_("Number of bins"),
57	!	min = 5, max = 20,
58	!	value = 10, step = 1
59		)
60		),
61	!	accordion_panel(
62	!	title = tr_("Transform"),
63	!	checkboxInput(
64	!	inputId = ns("center"),
65	!	label = tr_("Center"),
66	!	value = FALSE
67		),
68	!	checkboxInput(
69	!	inputId = ns("scale"),
70	!	label = tr_("Scale"),
71	!	value = FALSE
72		)
73		),
74	!	accordion_panel(
75	!	title = tr_("Envelopes"),
76		## Input: add ellipses
77	!	radioButtons(
78	!	inputId = ns("wrap"),
79	!	label = tr_("Wrap:"),
80	!	choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
81	!	tr_("Confidence ellipse"), tr_("Convex hull")),
82	!	choiceValues = c("none", "tol", "conf", "hull"),
83		),
84	!	checkboxGroupInput(
85	!	inputId = ns("level"),
86	!	label = tr_("Ellipse level:"),
87	!	selected = "0.95",
88	!	choiceNames = c("68%", "95%", "99%"),
89	!	choiceValues = c("0.68", "0.95", "0.99")
90		)
91		),
92	!	accordion_panel(
93	!	title = tr_("Annotations"),
94		## Input: add a grid
95	!	checkboxInput(
96	!	inputId = ns("grid"),
97	!	label = tr_("Grid"),
98	!	value = TRUE
99		),
100		## Input: add labels
101	!	checkboxInput(
102	!	inputId = ns("labels"),
103	!	label = tr_("Labels"),
104	!	value = FALSE
105		)
106		## Input: add a legend
107		# TODO
108		# checkboxInput(
109		# inputId = ns("legend"),
110		# label = tr_("Legend"),
111		# value = TRUE
112		# )
113		)
114		)
115	!	), # sidebar
116	!	helpText(
117	!	tr_("Visualize your data in the ternary space."),
118	!	tr_("Click and drag to select an area, then double-click to zoom in."),
119	!	tr_("Double-click again to reset the zoom.")
120		),
121	!	output_plot(
122	!	id = ns("ternplot"),
123	!	tools = graphics_ui(ns("par"), lty = FALSE),
124	!	title = tr_("Plot"),
125	!	dblclick = ns("ternplot_dblclick"),
126	!	brush = brushOpts(
127	!	id = ns("ternplot_brush"),
128	!	resetOnNew = TRUE
129		),
130	!	height = "100%"
131		)
132	!	) # layout_sidebar
133	!	) # nav_panel
134		}
135
136		# Server =======================================================================
137		#' Ternary Plot Server
138		#'
139		#' @param id An ID string that corresponds with the ID used to call the module's
140		#' UI function.
141		#' @param x A reactive `matrix`-like object.
142		#' @return
143		#' No return value, called for side effects.
144		#' @seealso [ternary_ui()]
145		#' @family plot modules
146		#' @keywords internal
147		#' @export
148		ternary_server <- function(id, x) {
149	1x	stopifnot(is.reactive(x))
150
151	1x	moduleServer(id, function(input, output, session) {
152		## Update UI -----
153	1x	data_raw <- reactive({ as.data.frame(x()) })
154	1x	quanti <- subset_quantitative(data_raw)
155	1x	quali <- subset_qualitative(data_raw)
156
157	1x	axis1 <- update_selectize_colnames("axis1", x = quanti)
158	1x	axis2 <- update_selectize_colnames("axis2", x = quanti, exclude = axis1)
159	3x	axis12 <- reactive({ c(axis1(), axis2()) })
160	1x	axis3 <- update_selectize_colnames("axis3", x = quanti, exclude = axis12)
161	1x	col_quali <- update_selectize_colnames("extra_quali", x = quali)
162	1x	col_quanti <- update_selectize_colnames("extra_quanti", x = quanti)
163
164		## Extra variables -----
165	1x	extra_quali <- select_data(data_raw, col_quali, drop = TRUE)
166	1x	extra_quanti <- select_data(data_raw, col_quanti, drop = TRUE)
167
168		## Interactive zoom -----
169		## When a double-click happens, check if there's a brush on the plot.
170		## If so, zoom to the brush bounds; if not, reset the zoom.
171	1x	range_ternplot <- reactiveValues(x = NULL, y = NULL)
172	1x	observe({
173	!	range_ternplot$x <- brush_xlim(input$ternplot_brush)
174	!	range_ternplot$y <- brush_ylim(input$ternplot_brush)
175		}) \|>
176	1x	bindEvent(input$ternplot_dblclick)
177
178		## Get ternary data -----
179	1x	data_tern <- reactive({
180	4x	req(data_raw(), axis1(), axis2(), axis3())
181	1x	tern <- data_raw()[, c(axis1(), axis2(), axis3())]
182	1x	tern[rowSums(tern, na.rm = TRUE) != 0, , drop = FALSE]
183		})
184
185		## Graphical parameters -----
186	1x	param <- graphics_server("par")
187
188		## Heatmap
189	1x	tile <- reactive({
190	1x	switch(
191	!	input$tile,
192	!	bin = isopleuros::tile_bin,
193	!	dens = isopleuros::tile_density,
194	!	NULL
195		)
196		})
197
198		## Envelope
199	1x	wrap <- reactive({
200	!	level <- as.numeric(input$level)
201	1x	switch(
202	!	input$wrap,
203	!	tol = function(x, ...) isopleuros::ternary_tolerance(x, level = level, ...),
204	!	conf = function(x, ...) isopleuros::ternary_confidence(x, level = level, ...),
205	!	hull = function(x, ...) isopleuros::ternary_hull(x, ...),
206	!	NULL
207		)
208		})
209
210		## Build plot -----
211	1x	plot_ternary <- reactive({
212		## Select data
213	5x	req(data_tern())
214	2x	tern <- data_tern()
215	2x	n <- nrow(tern)
216
217		## Compute center and scale
218	2x	no_scale <- isFALSE(input$center) && isFALSE(input$scale)
219
220		## Graphical parameters
221	2x	if (isTruthy(extra_quali())) {
222	1x	col <- param$col_quali(extra_quali())
223		} else {
224	!	col <- param$col_quant(extra_quanti())
225		}
226	1x	pch <- param$pch(extra_quali())
227	1x	cex <- param$cex(extra_quanti())
228
229		## Window
230	1x	range_coord <- list(x = NULL, y = NULL, z = NULL)
231	1x	if (isTruthy(range_ternplot$x) && isTruthy(range_ternplot$y)) {
232	!	x_pts <- c(range_ternplot$x, mean(range_ternplot$x))
233	!	y_pts <- c(range_ternplot$y, sqrt(3) * diff(range_ternplot$y) / 2)
234	!	range_coord <- isopleuros::coordinates_cartesian(x = x_pts, y = y_pts)
235		}
236
237		## Build plot
238	1x	function() {
239	1x	oldpar <- graphics::par(mar = c(1, 1, 1, 1), no.readonly = TRUE)
240	1x	on.exit(graphics::par(oldpar))
241
242	1x	z <- isopleuros::ternary_plot(
243	1x	x = tern,
244	1x	type = "n",
245	1x	xlim = range_coord$x,
246	1x	ylim = range_coord$y,
247	1x	zlim = range_coord$z,
248	1x	xlab = axis1(),
249	1x	ylab = axis2(),
250	1x	zlab = axis3(),
251	1x	center = input$center,
252	1x	scale = input$scale
253		)
254
255		## Add grid
256	1x	if (isTRUE(input$grid)) {
257	!	isopleuros::ternary_grid(center = z$center, scale = z$scale)
258		}
259
260	1x	if (no_scale) {
261		## Heatmap
262	!	if (isTruthy(tile())) {
263	!	isopleuros::ternary_image(
264	!	f = tile()(tern),
265	!	n = as.numeric(input$bin),
266	!	palette = param$col_quant
267		)
268		}
269
270		## Density contours
271	!	if (isTRUE(input$density)) {
272	!	isopleuros::ternary_density(tern)
273		}
274
275		## Envelope
276	!	if (isTruthy(extra_quali()) && isTruthy(wrap())) {
277	!	for (i in split(seq_len(n), f = extra_quali())) {
278	!	z <- tern[i, , drop = FALSE]
279	!	if (nrow(z) < 3) next
280	!	wrap()(z, lty = 1, border = col[i])
281		}
282		}
283		}
284
285		## Add points
286	1x	if (isTRUE(input$points)) {
287	!	isopleuros::ternary_points(tern, col = col, pch = pch, cex = cex,
288	!	center = z$center, scale = z$scale)
289		}
290
291		## Add labels
292	1x	if (isTRUE(input$labels)) {
293	!	isopleuros::ternary_labels(tern, center = z$center, scale = z$scale,
294	!	labels = rownames(tern), col = col)
295		}
296
297		## Add legend
298	1x	if (isTruthy(extra_quali())) {
299	1x	labels <- unique(extra_quali())
300	1x	keep <- !is.na(labels)
301	1x	cols <- unique(col)
302	1x	symb <- unique(pch)
303	1x	graphics::legend(
304	1x	x = "topleft",
305	1x	legend = labels[keep],
306	1x	col = if (length(cols) == 1) cols else cols[keep],
307	1x	pch = if (length(symb) == 1) symb else symb[keep],
308	1x	bty = "n"
309		)
310		}
311		}
312		})
313
314		## Render plot -----
315	1x	render_plot("ternplot", x = plot_ternary)
316		})
317		}

1		# UI ===========================================================================
2		#' Plot UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @param tools A (list of) input elements.
6		#' @param title A [`character`] string giving the card title.
7		#' @param note A [`character`] string giving a note to be placed in the footer.
8		#' @param ... Further parameters to be passed to [shiny::plotOutput()].
9		#' @return A [htmltools::div()] tag.
10		#' @family widgets
11		#' @keywords internal
12		output_plot <- function(id, ..., tools = NULL, title = NULL, note = NULL) {
13		## Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	if (!is.null(tools)) {
17	!	tools <- popover(
18	!	placement = "auto",
19	!	toolbar_input_button(
20	!	id = ns("chart_settings"),
21	!	label = tr_("Settings"),
22	!	icon = icon("sliders"),
23	!	tooltip = FALSE,
24	!	show_label = FALSE,
25	!	title = tr_("Settings")
26		),
27	!	tools
28		)
29		}
30	!	footer <- if (!is.null(note)) card_footer(note) else NULL
31
32	!	card(
33	!	id = ns("card"),
34	!	full_screen = TRUE,
35	!	card_header(
36	!	title,
37	!	toolbar(
38	!	tools,
39	!	toolbar_input_button(
40	!	id = ns("download"),
41	!	label = tr_("Download"),
42	!	icon = icon("download"),
43	!	show_label = TRUE
44		)
45		),
46	!	class = "d-flex justify-content-between"
47		),
48	!	card_body(
49	!	plotOutput(outputId = ns("plot"), ...)
50		),
51	!	footer
52		)
53		}
54
55		brush_xlim <- function(e) {
56	!	if (is.null(e)) return(NULL)
57	!	c(e$xmin, e$xmax)
58		}
59
60		brush_ylim <- function(e) {
61	!	if (is.null(e)) return(NULL)
62	!	c(e$ymin, e$ymax)
63		}
64
65		# Server =======================================================================
66		# https://stackoverflow.com/a/46961131
67		#' Plot Server
68		#'
69		#' @param id An ID string that corresponds with the ID used to call the module's
70		#' UI function.
71		#' @param x A reactive [`function`] recording the plot.
72		#' @param ... Further parameters to be passed to [shiny::renderPlot()].
73		#' @return
74		#' No return value, called for side effects.
75		#' @family widgets
76		#' @keywords internal
77		render_plot <- function(id, x, ...) {
78	9x	stopifnot(is.reactive(x))
79
80	9x	moduleServer(id, function(input, output, session) {
81		## Show modal dialog
82	!	observe({ showModal(download_plot(session$ns)) }) \|>
83	9x	bindEvent(input$download)
84
85		## Plot
86	9x	output$plot <- renderPlot(x()(), ...)
87
88		## Preview
89	9x	output$preview <- renderImage({
90	16x	req(x())
91
92		## Write to a temporary PNG file
93	9x	outfile <- tempfile(fileext = ".png")
94
95	9x	grDevices::png(
96	9x	filename = outfile,
97	9x	width = input$width,
98	9x	height = input$height,
99	9x	units = "in",
100	9x	res = 72
101		)
102	!	x()()
103	!	grDevices::dev.off()
104
105		## Return a list containing information about the image
106	!	list(
107	!	src = outfile,
108	!	contentType = "image/png",
109	!	style = "height:300px; width:auto; max-width:100%;"
110		)
111	9x	}, deleteFile = TRUE)
112
113		## Download
114	9x	output[["pdf"]] <- export_plot(input, x, format = "pdf")
115	9x	output[["png"]] <- export_plot(input, x, format = "png")
116		})
117		}
118
119		#' Export Plot Modal
120		#'
121		#' @param ns A [namespace][shiny::NS()] function.
122		#' @keywords internal
123		#' @noRd
124		download_plot <- function(ns) {
125	!	modalDialog(
126	!	title = tr_("Save plot - Preview"),
127	!	size = "l",
128	!	easyClose = FALSE,
129	!	fade = FALSE,
130	!	div(
131	!	plotOutput(outputId = ns("preview")),
132	!	style = "text-align: center;"
133		),
134	!	layout_column_wrap(
135	!	width = 1/3,
136	!	textInput(
137	!	inputId = ns("name"),
138	!	label = tr_("File name"),
139	!	value = "plot"
140		),
141	!	numericInput(
142	!	inputId = ns("width"),
143	!	label = tr_("Width (in)"),
144	!	min = 0.5,
145	!	value = 7
146		),
147	!	numericInput(
148	!	inputId = ns("height"),
149	!	label = tr_("Height (in)"),
150	!	min = 0.5,
151	!	value = 7
152		)
153		),
154	!	footer = tagList(
155	!	modalButton(tr_("Cancel")),
156	!	downloadButton(
157	!	outputId = ns("pdf"),
158	!	label = "PDF",
159	!	icon = icon("download")
160		),
161	!	downloadButton(
162	!	outputId = ns("png"),
163	!	label = "PNG",
164	!	icon = icon("download")
165		)
166		)
167		)
168		}
169
170		#' Download Plot
171		#'
172		#' Save and Download a graphic.
173		#' @param input Inputs selected by the user.
174		#' @param x A reactive [`function`] recording the plot.
175		#' @param format A [`character`] string specifying the file extension.
176		#' @return
177		#' No return value, called for side effects.
178		#' @keywords internal
179		#' @noRd
180		export_plot <- function(input, x, format) {
181	18x	downloadHandler(
182	!	filename = function() { make_file_name(input$name, format) },
183	18x	content = function(file) {
184	!	device <- switch (
185	!	format,
186	!	pdf = function(x, ...) grDevices::pdf(x, ...),
187	!	png = function(x, ...) grDevices::png(x, ..., units = "in", res = 300),
188	!	stop(tr_("Unknown graphics device."), call. = FALSE)
189		)
190
191	!	device(file, width = input$width, height = input$height)
192	!	x()()
193	!	grDevices::dev.off()
194		}
195		)
196		}

1		# UI ===========================================================================
2		#' Correspondence Analysis UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [ca_server()]
9		#' @family multivariate analysis modules
10		#' @keywords internal
11		#' @export
12		ca_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("CA"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Correspondence Analysis"),
22	!	selectize_ui(
23	!	id = ns("sup_row"),
24	!	label = tr_("Supplementary individuals"),
25	!	multiple = TRUE
26		),
27	!	selectize_ui(
28	!	id = ns("sup_col"),
29	!	label = tr_("Supplementary quantitative variables"),
30	!	multiple = TRUE
31		),
32	!	selectize_ui(
33	!	id = ns("sup_quali"),
34	!	label = tr_("Supplementary qualitative variables"),
35	!	multiple = TRUE
36		),
37	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
38	!	uiOutput(outputId = ns("download_button")),
39	!	uiOutput(outputId = ns("chi2"))
40	!	), # sidebar
41	!	multivariate_ui(ns("ca")),
42	!	border_radius = FALSE,
43	!	fillable = TRUE
44	!	) # layout_sidebar
45	!	) # nav_panel
46		}
47
48		# Server =======================================================================
49		#' Correspondence Analysis Server
50		#'
51		#' @param id An ID string that corresponds with the ID used to call the module's
52		#' UI function.
53		#' @param x A reactive `data.frame`.
54		#' @return A reactive [`dimensio::PCA-class`] object.
55		#' @seealso [ca_ui()]
56		#' @family multivariate analysis modules
57		#' @keywords internal
58		#' @export
59		ca_server <- function(id, x) {
60	!	stopifnot(is.reactive(x))
61
62	!	moduleServer(id, function(input, output, session) {
63		## Update UI -----
64	!	quanti <- subset_quantitative(x)
65	!	quali <- subset_qualitative(x)
66
67	!	sup_row <- update_selectize_rownames("sup_row", x = x)
68	!	sup_col <- update_selectize_colnames("sup_col", x = quanti)
69	!	sup_quali <- update_selectize_colnames("sup_quali", x = quali, select = TRUE)
70
71		## Compute CA -----
72	!	compute_ca <- ExtendedTask$new(
73	!	function(x, rank, sup_row, sup_col, sup_quali) {
74	!	mirai::mirai({
75	!	param <- list(object = x, rank = rank,
76	!	sup_row = arkhe::seek_rows(x, names = sup_row),
77	!	sup_col = sup_col)
78	!	if (is.data.frame(x)) param$sup_quali <- sup_quali
79	!	do.call(dimensio::ca, param)
80	!	}, environment())
81		}
82		) \|>
83	!	bslib::bind_task_button("go")
84
85	!	observe({
86	!	compute_ca$invoke(x = x(), rank = input$rank, sup_row = sup_row(),
87	!	sup_col = sup_col(), sup_quali = sup_quali())
88		}) \|>
89	!	bindEvent(input$go)
90
91	!	old <- reactive({ x() }) \|> bindEvent(input$go)
92	!	results <- reactive({
93	!	if (!identical(x(), old())) return(NULL) # Invalidate
94	!	notify(compute_ca$result(), title = tr_("Correspondence Analysis"))
95		})
96
97	!	multivariate_server("ca", x = results, y = x)
98
99		## Chi-squared -----
100	!	chi2_test <- reactive({
101	!	req(results())
102	!	x <- dimensio::get_data(results())
103	!	z <- suppressWarnings(stats::chisq.test(x = x))
104
105		# Adjusted Cramer's V [95%CI]
106	!	k <- ncol(x)
107	!	r <- nrow(x)
108	!	n <- sum(x)
109	!	phi <- max(0, (z$statistic / n) - (k - 1) * (r - 1) / (n - 1))
110
111	!	k_bias <- k - (k - 1)^2 / (n - 1)
112	!	r_bias <- r - (r - 1)^2 / (n - 1)
113	!	V <- sqrt(phi / min(k_bias - 1, r_bias - 1))
114
115	!	z$cramer <- V
116	!	z
117		})
118
119	!	output$chi2 <- renderUI({
120	!	list(
121	!	h5(tr_("Chi-squared Test")),
122	!	tags$ul(
123	!	tags$li(
124	!	sprintf(tr_("Statistic: %.0f"), chi2_test()$statistic)
125		),
126	!	tags$li(
127	!	sprintf(tr_("Degrees of freedom: %.0f"), chi2_test()$parameter)
128		),
129	!	tags$li(
130	!	sprintf(tr_("p-value: %s"), format.pval(chi2_test()$p.value, eps = 0.001))
131		),
132	!	tags$li(
133	!	sprintf(tr_("Cramer's V: %.2f"), chi2_test()$cramer)
134		)
135		)
136		)
137		})
138
139		## Export -----
140	!	output$download_button <- renderUI({
141	!	req(results())
142	!	downloadButton(
143	!	outputId = session$ns("download"),
144	!	label = tr_("Download results")
145		)
146		})
147	!	output$download <- downloadHandler(
148	!	filename = function() { make_file_name("ca", "zip") },
149	!	content = function(file) {
150	!	dimensio::export(results(), file = file, flags = "-r9Xj")
151		},
152	!	contentType = "application/zip"
153		)
154
155	!	results
156		})
157		}

1		# UI ===========================================================================
2		#' Import Data UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A [`list`] of UI elements.
7		#' @seealso [import_server()]
8		#' @family generic modules
9		#' @keywords internal
10		#' @export
11		import_ui <- function(id) {
12		## Create a namespace function using the provided id
13	!	ns <- NS(id)
14
15	!	list(
16	!	helpText(tr_("Import your data and perform basic data cleansing and preparation steps.")),
17	!	actionButton(
18	!	inputId = ns("upload"),
19	!	label = tr_("Upload"),
20	!	icon = icon("upload")
21		),
22	!	actionButton(
23	!	inputId = ns("demo"),
24	!	label = tr_("Example data"),
25	!	icon = icon("book")
26		),
27	!	selectize_ui(
28	!	id = ns("rownames"),
29	!	label = tr_("Row names"),
30	!	multiple = FALSE
31		)
32		)
33		}
34
35		#' Import Data Modal
36		#'
37		#' @param ns A [namespace][shiny::NS()] function.
38		#' @return
39		#' A [`list`] of UI elements.
40		#' @seealso [import_server()]
41		#' @keywords internal
42		#' @noRd
43		import_modal <- function(ns) {
44	!	modalDialog(
45	!	size = "xl",
46	!	easyClose = FALSE,
47	!	fade = FALSE,
48	!	title = tr_("Import Data"),
49	!	footer = tagList(
50	!	modalButton(tr_("Cancel")),
51	!	actionButton(inputId = ns("go"), label = "OK", class = "btn-primary")
52		),
53	!	layout_column_wrap(
54	!	width = 1/3,
55		## Input: select a file
56	!	div(
57	!	tags$p(
58	!	helpText(tr_("Select the location of, and the file you want to upload.")),
59	!	helpText(tr_("Please check the default settings and adjust them to your data.")),
60	!	helpText(tr_("This application only supports data encoded in UFT-8.")),
61		),
62	!	tags$p(
63	!	helpText(tr_("It assumes that you keep your data tidy:")),
64	!	helpText(tr_("each variable must be saved in its own column and each sample must be saved in its own row."))
65		),
66	!	fileInput(
67	!	inputId = ns("file"),
68	!	label = tr_("Choose a CSV or a TSV file:"),
69	!	multiple = FALSE,
70	!	accept = c(".csv", ".tsv", "text/csv", "text/tsv",
71	!	"text/comma-separated-values", "text/tab-separated-values")
72		)
73		),
74	!	div(
75		## Input: checkbox if file has header
76	!	input_switch(
77	!	id = ns("header"),
78	!	label = tr_("Header"),
79	!	value = TRUE
80		),
81		## Input: select decimal
82	!	radioButtons(
83	!	inputId = ns("dec"),
84	!	label = tr_("Decimal"),
85	!	choiceNames = c(tr_("Dot"), tr_("Comma")),
86	!	choiceValues = c(".", ","),
87	!	selected = "."
88		),
89		## Input: select separator
90	!	radioButtons(
91	!	inputId = ns("sep"),
92	!	label = tr_("Separator"),
93	!	choiceNames = c(tr_("Comma"), tr_("Semicolon"), tr_("Tab")),
94	!	choiceValues = c(",", ";", "\t"),
95	!	selected = ","
96		),
97		## Input: select quotes
98	!	radioButtons(
99	!	inputId = ns("quote"),
100	!	label = tr_("Quote"),
101	!	choiceNames = c(tr_("None"), tr_("Double quote"), tr_("Single quote")),
102	!	choiceValues = c("", '"', "'"),
103	!	selected = '"'
104		)
105		),
106	!	div(
107		## Input: lines of the data to skip
108	!	numericInput(
109	!	inputId = ns("skip"),
110	!	label = tr_("Lines of the data file to skip:"),
111	!	value = 0,
112	!	min = 0,
113	!	step = 1
114		),
115		## Input: missing string
116	!	textInput(
117	!	inputId = ns("na.strings"),
118	!	label = tr_("String to be interpreted as missing value:"),
119	!	value = ""
120		),
121		## Input: comment
122	!	textInput(
123	!	inputId = ns("comment"),
124	!	label = tr_("Character to be interpreted as comment:"),
125	!	value = "#"
126		)
127		)
128		)
129		)
130		}
131
132		# Server =======================================================================
133		#' Import Data Server
134		#'
135		#' @param id An ID string that corresponds with the ID used to call the module's
136		#' UI function.
137		#' @param demo A [`character`] string specifying the name of a dataset from
138		#' \pkg{folio} or \pkg{datasets}.
139		#' @return A reactive [`data.frame`].
140		#' @seealso [import_ui()]
141		#' @family generic modules
142		#' @keywords internal
143		#' @export
144		import_server <- function(id, demo = NULL) {
145	3x	moduleServer(id, function(input, output, session) {
146		## Store data -----
147	3x	values <- reactiveVal()
148
149		## Show modal dialog -----
150	!	observe({ showModal(import_modal(session$ns)) }) \|>
151	3x	bindEvent(input$upload)
152
153		## Read from connection -----
154		## Parse query parameters
155	3x	data_url <- reactive({
156	3x	params <- parseQueryString(session$clientData$url_search)
157	3x	params[["data"]]
158		})
159	3x	observe({
160	!	msg <- tr_("Reading data...")
161		# detail <- tags$a(href = data_url(), target = "_blank", data_url())
162		# id <- showNotification(msg, action = detail, duration = 3, type = "message")
163		# on.exit(removeNotification(id), add = TRUE)
164
165	!	csv <- notify(
166	!	withProgress(
167	!	utils::read.csv(file = url(data_url())),
168	!	message = msg
169		),
170	!	title = tr_("Data Input")
171		)
172
173	!	values(csv)
174		}) \|>
175	3x	bindEvent(data_url())
176
177		## Load example data -----
178	3x	observe({
179	2x	req(demo)
180
181	2x	msg <- sprintf(tr_("Loading \"%s\" data..."), demo)
182		# id <- showNotification(msg, duration = 3, type = "message")
183		# on.exit(removeNotification(id), add = TRUE)
184
185	2x	path <- system.file("extdata", paste0(demo, ".csv"), package = "kinesis")
186	2x	csv <- notify(
187	2x	withProgress(
188	2x	utils::read.csv(file = path),
189	2x	message = msg
190		),
191	2x	title = tr_("Data Upload")
192		)
193
194	2x	values(csv)
195		}) \|>
196	3x	bindEvent(input$demo)
197
198		## Read data file -----
199	3x	observe({
200	2x	msg <- tr_("Reading data...")
201		# id <- showNotification(msg, duration = 3, type = "message")
202		# on.exit(removeNotification(id), add = TRUE)
203
204	2x	csv <- notify(
205	2x	withProgress(
206	2x	utils::read.table(
207	2x	file = input$file$datapath,
208	2x	header = input$header,
209	2x	sep = input$sep,
210	2x	dec = input$dec,
211	2x	quote = input$quote,
212	2x	row.names = NULL,
213	2x	na.strings = input$na.strings,
214	2x	skip = if (!is.na(input$skip)) input$skip else 0,
215	2x	comment.char = input$comment
216		),
217	2x	message = msg
218		),
219	2x	title = tr_("Data Upload")
220		)
221
222	1x	if (!is.null(csv)) removeModal()
223	2x	values(csv)
224		}) \|>
225	3x	bindEvent(input$go)
226
227		## Update UI -----
228	3x	rows <- update_selectize_colnames("rownames", values)
229
230		## Assign row names -----
231	3x	reactive({
232	3x	if (!isTruthy(rows())) return(values())
233
234	1x	notify(
235		{
236	1x	column <- arkhe::seek_columns(values(), names = rows())
237	1x	arkhe::assign_rownames(values(), column = column %\|\|\|% 0, remove = TRUE)
238		},
239	1x	title = tr_("Row names")
240		)
241		})
242		})
243		}

1		# UI ===========================================================================
2		#' Compositional Bar Plot UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [coda_barplot_server()]
9		#' @family coda modules
10		#' @keywords internal
11		#' @export
12		coda_barplot_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Bar Plot"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Bar Plot"),
22	!	checkboxInput(
23	!	inputId = ns("select_major"),
24	!	label = tr_("Major elements"),
25	!	value = TRUE
26		),
27	!	checkboxInput(
28	!	inputId = ns("select_minor"),
29	!	label = tr_("Minor elements"),
30	!	value = TRUE
31		),
32	!	checkboxInput(
33	!	inputId = ns("select_trace"),
34	!	label = tr_("Trace elements"),
35	!	value = TRUE
36		),
37	!	hr(),
38	!	checkboxInput(
39	!	inputId = ns("order_columns"),
40	!	label = tr_("Sort columns"),
41	!	value = FALSE
42		),
43	!	selectize_ui(id = ns("order_rows"), label = tr_("Row order")),
44	!	checkboxInput(
45	!	inputId = ns("decreasing"),
46	!	label = tr_("Decreasing row order"),
47	!	value = FALSE
48		)
49	!	), # sidebar
50	!	output_plot(
51	!	id = ns("plot"),
52	!	tools = list(
53	!	graphics_ui(ns("par"), col_quant = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
54	!	numericInput(
55	!	inputId = ns("space"),
56	!	label = tr_("Gutter"),
57	!	value = 0.2,
58	!	min = 0, max = 0.5, step = 0.1
59		)
60		),
61	!	height = "100%",
62	!	title = tr_("Plot")
63		)
64	!	) # layout_sidebar
65	!	) # nav_panel
66		}
67
68		# Server =======================================================================
69		#' Bar Plot Server
70		#'
71		#' @param id An ID string that corresponds with the ID used to call the module's
72		#' UI function.
73		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
74		#' @return
75		#' No return value, called for side effects.
76		#' @seealso [coda_barplot_ui()]
77		#' @family coda modules
78		#' @keywords internal
79		#' @export
80		coda_barplot_server <- function(id, x) {
81	!	stopifnot(is.reactive(x))
82
83	!	moduleServer(id, function(input, output, session) {
84		## Subset -----
85	!	data_bar <- reactive({
86	!	req(x())
87
88	!	elements <- logical(ncol(x()))
89	!	is_major <- nexus::is_element_major(x())
90	!	is_minor <- nexus::is_element_minor(x())
91	!	is_trace <- nexus::is_element_trace(x())
92
93	!	elements[which(is_major)] <- isTRUE(input$select_major)
94	!	elements[which(is_minor)] <- isTRUE(input$select_minor)
95	!	elements[which(is_trace)] <- isTRUE(input$select_trace)
96
97	!	z <- x()[, which(elements), drop = FALSE]
98	!	validate_dim(z, j = 3)
99	!	z
100		})
101
102		## Select column -----
103	!	col_bar <- update_selectize_colnames("order_rows", x = data_bar)
104
105		## Graphical parameters -----
106	!	param <- graphics_server("par")
107
108		## Build barplot -----
109	!	plot_bar <- reactive({
110	!	req(data_bar())
111
112	!	col <- notify({
113	!	pal <- khroma::palette_color_discrete(param$pal_quali, domain = colnames(x()))
114	!	pal(colnames(data_bar()))
115		})
116
117	!	function() {
118	!	nexus::barplot(
119	!	height = data_bar(),
120	!	order_columns = isTRUE(input$order_columns),
121	!	order_rows = col_bar() %\|\|\|% NULL,
122	!	decreasing = isTRUE(input$decreasing),
123	!	color = col,
124	!	space = input$space %\|\|\|% 0
125		)
126		}
127		})
128
129		## Render barplot -----
130	!	render_plot("plot", x = plot_bar)
131		})
132		}

1		# UI ===========================================================================
2		#' Log-Ratio UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @param title A [`character`] string giving the sidebar title.
6		#' @return
7		#' A nav item that may be passed to a nav container
8		#' (e.g. [bslib::navset_tab()]).
9		#' @seealso [logratio_server()]
10		#' @family coda modules
11		#' @keywords internal
12		#' @export
13		logratio_ui <- function(id, title) {
14		# Create a namespace function using the provided id
15	!	ns <- NS(id)
16
17	!	nav_panel(
18	!	title = title,
19	!	layout_sidebar(
20	!	sidebar = sidebar(
21	!	width = 400,
22	!	title = textOutput(
23	!	outputId = ns("title"),
24	!	container = function(...) tags$header(..., class = "sidebar-title")
25		),
26	!	helpText(tr_("Compute log-ratio transformation of compositional data.")),
27	!	checkboxInput(
28	!	inputId = ns("weights"),
29	!	label = tr_("Weighted log-ratio"),
30	!	value = FALSE
31		),
32	!	uiOutput(outputId = ns("settings")),
33	!	radioButtons(
34	!	inputId = ns("type"),
35	!	label = tr_("Plot type"),
36	!	selected = "scatter",
37	!	choiceNames = c(tr_("Scatter plot"), tr_("Boxplot")),
38	!	choiceValues = c("scatter", "boxplot")
39		),
40	!	render_export_button(ns("export_results")),
41		## Output: graph
42	!	plotOutput(outputId = ns("graph"))
43	!	), # sidebar
44		## Output: plot
45	!	output_plot(
46	!	id = ns("plot"),
47	!	tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, cex = FALSE),
48	!	height = "100%",
49	!	title = tr_("Density")
50		)
51	!	) # layout_sidebar
52	!	) # nav_panel
53		}
54
55		# Server =======================================================================
56		#' Log-Ratio Server
57		#'
58		#' @param id An ID string that corresponds with the ID used to call the module's
59		#' UI function.
60		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
61		#' @param method A [`character`] string specifying the log-ratio to be computed.
62		#' @return A reactive [`nexus::LogRatio-class`] object.
63		#' @seealso [logratio_ui()]
64		#' @family coda modules
65		#' @keywords internal
66		#' @export
67		logratio_server <- function(id, x, method) {
68	2x	stopifnot(is.reactive(x))
69
70	2x	moduleServer(id, function(input, output, session) {
71		## Render settings -----
72	2x	output$settings <- renderUI({
73	!	if (!(method == "alr" \|\| method == "plr")) return(NULL)
74	1x	label <- switch (
75	1x	method,
76	1x	alr = tr_("Rationing part:"),
77	1x	plr = tr_("Pivotal variable:")
78		)
79	1x	selectizeInput(
80	1x	inputId = session$ns("pivot"),
81	1x	label = label,
82	1x	choices = colnames(x()),
83	1x	selected = NULL,
84	1x	multiple = FALSE,
85		)
86		})
87
88		## Compute -----
89	2x	logratio <- reactive({
90	3x	req(x())
91
92	3x	pivot <- input$pivot %\|\|\|% 1
93	3x	trans <- switch (
94	3x	method,
95	3x	clr = function(x) nexus::transform_clr(x, weights = input$weights),
96	3x	alr = function(x) nexus::transform_alr(x, j = pivot, weights = input$weights),
97	3x	ilr = function(x) nexus::transform_ilr(x),
98	3x	plr = function(x) nexus::transform_plr(x, pivot = pivot)
99		)
100
101	3x	notify(trans(x()), title = toupper(method))
102		})
103
104		## Graphical parameters -----
105	2x	param <- graphics_server("par")
106
107		## Plot -----
108	2x	plot_log <- reactive({
109	1x	req(logratio())
110
111	1x	lvl <- ""
112	!	if (nexus::is_grouped(logratio())) lvl <- nexus::group_levels(logratio())
113	1x	fun <- switch(
114	1x	input$type,
115	1x	scatter = function(x)
116	1x	plot(x, color = param$col_quali(lvl), symbol = param$pch(lvl)),
117	1x	boxplot = function(x)
118	1x	nexus::boxplot(x, color = param$col_quali(lvl))
119		)
120
121	!	function() {
122	!	fun(logratio())
123		}
124		})
125
126		## Graph -----
127	2x	plot_graph <- reactive({
128	1x	req(logratio())
129	!	if (inherits(logratio(), "CLR")) return(NULL)
130	1x	graph <- nexus::as_graph(logratio())
131
132	!	plot(graph)
133	!	grDevices::recordPlot()
134		})
135
136		## Render title -----
137	2x	output$title <- renderText({
138	2x	switch(
139	1x	method,
140	!	clr = tr_("Centered Log-Ratio"),
141	1x	alr = tr_("Additive Log-Ratio"),
142	!	ilr = tr_("Isometric Log-Ratio"),
143	!	plr = tr_("Pivot Log-Ratio"),
144		""
145		)
146		})
147
148		## Render table -----
149		# TODO?
150
151		## Render plot -----
152	2x	render_plot("plot", x = plot_log)
153
154		## Render graph -----
155	2x	output$graph <- renderPlot({
156	1x	req(plot_graph())
157	!	grDevices::replayPlot(plot_graph())
158		})
159
160		## Download -----
161	2x	export_table("export_results", logratio, name = paste0("coda_", method), label = tr_("Download log-ratio"))
162
163	2x	logratio
164		})
165		}

1		# UI ===========================================================================
2		#' Count Data UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [count_server()]
9		#' @family count data modules
10		#' @keywords internal
11		#' @export
12		count_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Data"),
18	!	value = "data",
19	!	layout_sidebar(
20	!	sidebar = sidebar(
21	!	width = 400,
22	!	title = tr_("Data"),
23	!	import_ui(ns("import"))
24	!	), # sidebar
25		## Output: value box
26	!	box_ui(ns("box")),
27	!	navset_card_pill(
28	!	placement = "above",
29	!	nav_panel(
30	!	title = tr_("Data"),
31	!	layout_sidebar(
32	!	sidebar = sidebar(
33	!	checkbox_ui(
34	!	id = ns("parts"),
35	!	label = tooltip(
36	!	trigger = span(
37	!	tr_("Count data"),
38	!	icon("info-circle")
39		),
40	!	tr_("Select the variables you want to use.")
41		)
42		)
43		),
44	!	checkboxInput(
45	!	inputId = ns("head"),
46	!	label = tr_("Table overview"),
47	!	value = TRUE
48		),
49	!	gt::gt_output(outputId = ns("table"))
50	!	) # sidebar
51	!	), # layout_sidebar
52	!	nav_panel(
53	!	title = tr_("Clean values"),
54	!	clean_ui(ns("clean"))
55		),
56	!	nav_panel(
57	!	title = tr_("Missing values"),
58	!	missing_ui(ns("missing"))
59		)
60		),
61	!	border_radius = FALSE,
62	!	fillable = TRUE,
63	!	) # layout_sidebar
64	!	) # nav_panel
65		}
66
67		# Server =======================================================================
68		#' Count Data Server
69		#'
70		#' @param id An ID string that corresponds with the ID used to call the module's
71		#' UI function.
72		#' @param demo A [`character`] string specifying the name of a dataset (see
73		#' [import_server()]).
74		#' @return A reactive [`data.frame`].
75		#' @seealso [count_ui()]
76		#' @family count data modules
77		#' @keywords internal
78		#' @export
79		count_server <- function(id, demo = NULL) {
80	!	moduleServer(id, function(input, output, session) {
81		## Prepare data -----
82	!	data_raw <- import_server("import", demo = demo)
83	!	quanti <- subset_quantitative(data_raw, positive = TRUE)
84
85		## Update UI -----
86	!	parts <- update_checkbox_colnames("parts", x = quanti)
87
88		## Select variables -----
89	!	data_count <- select_data(quanti, names = parts, drop = FALSE) \|>
90	!	debounce(500)
91
92		## Clean data -----
93	!	data_clean <- clean_server("clean", x = data_count)
94	!	data_missing <- missing_server("missing", x = data_clean)
95
96		## Check -----
97	!	data_valid <- reactive({
98	!	validate_csv(data_missing())
99	!	validate_dim(data_missing(), i = 1, j = 1)
100	!	validate_na(data_missing())
101
102	!	data_missing()
103		})
104
105		## Render description -----
106	!	box_server("box", x = data_valid)
107
108		## Render table -----
109	!	output$table <- gt::render_gt({
110	!	req(data_missing())
111	!	tbl <- if (isTRUE(input$head)) utils::head(data_missing()) else data_missing()
112	!	gt::gt(tbl, rownames_to_stub = TRUE) \|>
113	!	gt::tab_options(table.width = "100%")
114		})
115
116	!	data_valid
117		})
118		}