kinesis coverage - 22.23%

Files
Source

# 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,
        selected = NULL,
        multiple = FALSE
      ),
      selectizeInput(
        inputId = ns("axis2"),
        label = tr_("Vertical axis"),
        choices = NULL,
        selected = 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"))
      ),
      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"))
      ),
      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")) })
    col_quali <- update_selectize_variables("extra_quali", x = extra,
                                            find = Negate(is.numeric),
                                            selected = tr_("Group"))
    col_quanti <- update_selectize_variables("extra_quanti", x = extra,
                                             find = is.numeric)

    ## 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())

    ## Bookmark -----
    onRestored(function(state) {
      updateSelectizeInput(session, inputId = "axis1",
                           selected = state$input$axis1)
      updateSelectizeInput(session, inputId = "axis2",
                           selected = state$input$axis2)
    })

    ## 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(), extra())

      ## Extra variables
      extra_quanti <- arkhe::seek_columns(extra(), names = col_quanti())
      if (!is.null(extra_quanti)) extra_quanti <- extra()[[extra_quanti]]
      extra_quali <- arkhe::seek_columns(extra(), names = col_quali())
      if (!is.null(extra_quali)) extra_quali <- extra()[[extra_quali]]

      col <- "black"
      if (isTruthy(extra_quanti)) {
        col <- param_ind$col_quant(extra_quanti)
      }
      if (isTruthy(extra_quali)) {
        col <- param_ind$col_quali(extra_quali)
      }
      cex <- param_ind$cex(extra_quanti)
      pch <- param_ind$pch(extra_quali)

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

      function() {
        dimensio::viz_rows(
          x = x(),
          axes = c(axis1(), axis2()),
          active = TRUE,
          sup = input$sup_ind,
          labels = input$lab_ind,
          extra_quali = extra_quali %|||% "observation",
          extra_quanti = extra_quanti,
          col = col,
          pch = pch,
          cex = cex,
          xlim = range_ind$x,
          ylim = range_ind$y,
          panel.first = graphics::grid()
        )

        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 = input$sup_var,
          labels = 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(
      dist = tr_("Distance")
    ) |>
    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 ===========================================================================
#' 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
        downloadButton(
          outputId = ns("export_table"),
          label = tr_("Export matrix")
        )
      ), # 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 -----
    output$export_table <- export_table(data_permute, name = "permuted")

    data_seriate
  })
}

# 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)

  gear <- popover(
    icon("gear"),
    title = tr_("Tools"),
    placement = "auto",
    tools,
    actionButton(
      inputId = ns("download"),
      label = tr_("Download"),
      icon = icon("download")
    )
  )

  footer <- if (!is.null(note)) card_footer(note) else NULL

  card(
    id = ns("card"),
    full_screen = TRUE,
    card_header(
      title, gear,
      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)

    setBookmarkExclude(c("download", "name", "width", "height"))

    ## 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 ===========================================================================
#' 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")),
        select_ui(ns("select")),
        clean_ui(ns("clean"))
      ), # 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_("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 choose A predicate [`function`] used to select columns.
#' @param select A predicate [`function`] used to select columns.
#' @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, choose = \(...) TRUE, select = \(...) TRUE,
                           demo = NULL) {
  moduleServer(id, function(input, output, session) {
    ## Prepare data -----
    data_clean <- import_server("import", demo = demo) |>
      select_server("select", x = _, find_col = choose, use_col = select) |>
      clean_server("clean", x = _) |>
      missing_server("missing", x = _)

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

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

    data_clean
  })
}

# 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"),
      value = textOutput(outputId = ns("value_dimensions"))
    ),
    value_box(
      title = tr_("Sparsity"),
      value = textOutput(outputId = ns("value_sparsity"))
    ),
    value_box(
      title = tr_("Missing values"),
      value = textOutput(outputId = ns("value_missing"))
    ),
    card(
      helpText(tr_("Export your data for futur use.")),
      downloadButton(
        outputId = ns("download"),
        label = tr_("Download")
      )
    )
  )
}
box_server <- function(id, x) {
  stopifnot(is.reactive(x))

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

    ## Download -----
    output$download <- export_table(x, "data")
  })
}

## Select ----------------------------------------------------------------------
select_ui <- function(id) {
  ns <- NS(id)

  tags$div(
    h5(tr_("Select data")),
    selectize_ui(id = ns("rownames"), label = tr_("Sample names")),
    selectize_ui(id = ns("colnames"), label = tr_("Variables"), multiple = TRUE)
  )
}

#' @param id A [`character`] string specifying the namespace.
#' @param x A reactive `matrix`-like object.
#' @param find_col A predicate [`function`] for column detection
#'  (see [arkhe::detect()]).
#' @param use_col A predicate [`function`] for column selection
#'  (see [arkhe::detect()]).
#' @param min_row An [`interger`] specifying the expected minimum number of rows.
#' @param min_col An [`interger`] specifying the expected minimum number of columns.
#' @return A reactive [`data.frame`].
#' @noRd
select_server <- function(id, x, find_col = NULL, use_col = NULL,
                          min_row = 1, min_col = 1) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI
    row_names <- update_selectize_variables(id = "rownames", x = x)

    ## Assign row names
    named <- reactive({
      req(x())
      out <- notify(
        {
          column <- arkhe::seek_columns(x(), names = row_names())
          arkhe::assign_rownames(x(), column = column %|||% 0, remove = TRUE)
        },
        title = tr_("Row names")
      )
      out
    }) |>
      bindEvent(row_names())

    ## Update UI
    col_names <- update_selectize_variables(
      id = "colnames",
      x = named,
      find = find_col,
      use = use_col
    )

    ## Select variables
    selected <- reactive({
      out <- arkhe::get_columns(named(), names = col_names())
      validate_dim(out, i = min_row, j = min_col)
      out
    }) |>
      bindEvent(col_names(), ignoreNULL = FALSE) |>
      debounce(500)

    selected
  })
}

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

  tags$div(
    h5(tr_("Clean values")),
    ## Input: remove whitespace
    checkboxInput(
      inputId = ns("remove_whitespace"),
      label = tr_("Remove leading/trailing whitespace"),
      value = FALSE
    ),
    ## Input: remove zero
    checkboxInput(
      inputId = ns("remove_zero_row"),
      label = tr_("Remove rows with zero"),
      value = FALSE
    ),
    checkboxInput(
      inputId = ns("remove_zero_column"),
      label = tr_("Remove columns with zero"),
      value = FALSE
    ),
    ## Input: remove constant
    checkboxInput(
      inputId = ns("remove_constant_column"),
      label = tr_("Remove constant columns"),
      value = FALSE
    ),
    ## 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) {
    reactive({
      out <- x()

      ## Clean whitespace
      if (isTruthy(out) && isTRUE(input$remove_whitespace)) {
        out <- arkhe::clean_whitespace(out, squish = TRUE)
      }

      ## Remove rows
      ## If only zeros
      if (isTruthy(out) && isTRUE(input$remove_zero_row)) {
        out <- arkhe::remove_zero(out, margin = 1, all = input$all,
                                  verbose = verbose)
      }

      ## Remove columns
      ## If only zeros
      if (isTruthy(out) && isTRUE(input$remove_zero_column)) {
        out <- arkhe::remove_zero(out, margin = 2, all = input$all,
                                  verbose = verbose)
      }
      ## If constant
      if (isTruthy(out) && isTRUE(input$remove_constant_column)) {
        out <- arkhe::remove_constant(out, verbose = verbose)
      }

      validate_dim(out)

      out
    })
  })
}

## 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) {
    data_replace <- reactive({
      out <- x()

      ## Replace empty strings
      if (isTRUE(input$empty_as_NA)) {
        out <- arkhe::replace_empty(out, value = NA)
      }

      ## Replace zeros
      if (isTRUE(input$zero_as_NA)) {
        out <- arkhe::replace_zero(out, value = NA)
      }

      out
    })

    data_missing <- reactive({
      out <- data_replace()

      ## Remove missing values
      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 }
      )
      out <- fun(out)

      validate_dim(out)

      out
    })

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

    data_missing
  })
}

# 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 bookmark A [`logical`] scalar: should server-side bookmarking of the
#'  application be enabled (see [shiny::enableBookmarking()])?
#' @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
#'   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",
                            "source", "scatter", "ternary", "ca", "pca"),
                    bookmark = FALSE,
                    options = list(launch.browser = interactive())) {
  ## App selection
  app <- match.arg(app, several.ok = FALSE)
  app_dir <- system.file("app", app, package = "kinesis")
  if (app_dir == "") {
    msg <- sprintf(tr_("Could not find the %s application."), sQuote(app))
    stop(msg, call. = FALSE)
  }

  ## Enable bookmarking
  bookmark <- isTRUE(bookmark)
  shiny::enableBookmarking(store = ifelse(bookmark, "server", "disable"))

  ## 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)
  opt$bookmark <- bookmark
  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 ===========================================================================
#' 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")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download 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) {
    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, old, title = tr_("MCD"))

    ## 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)

    results <- reactive({
      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 -----
    output$download <- export_table(tbl, "mcd")
  })
}

# 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
        ),
        downloadButton(
          outputId = ns("download_dist"),
          label = tr_("Download distances")
        ),
        downloadButton(
          outputId = ns("download_clust"),
          label = tr_("Download clusters")
        )
      ), # 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) {
    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, old, title = tr_("HCLUST"))

    ## 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)

    results <- reactive({
      notify(compute_hclust$result(), title = tr_("Hierarchical Clustering"))
    })
    distances <- reactive({
      results()$dist
    })
    groups <- reactive({
      req(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 -----
    output$download_dist <- export_table(distances, name = "distances")
    output$download_clust <- export_table(groups, name = "clusters")
  })
}

# 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(id = ns("axis1"), label = tr_("Component X")),
        selectize_ui(id = ns("axis2"), label = tr_("Component Y")),
        ## 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")),
        ## Input: linear regression
        checkboxInput(
          inputId = ns("regression"),
          label = tr_("Linear regression"),
          value = FALSE
        ),
        ## 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")
        ),
        checkboxInput(inputId = ns("grid"), label = tr_("Grid"), value = TRUE)
      ), # 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 = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, asp = 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) {
    ## Select columns -----
    quanti <- reactive({
      req(x())
      i <- which(arkhe::detect(x = x(), f = is.numeric, margin = 2))
      colnames(x())[i]
    })
    quali <- reactive({
      req(x())
      i <- which(arkhe::detect(x = x(), f = is.numeric, margin = 2, negate = TRUE))
      colnames(x())[i]
    })
    axis1 <- update_selectize_values("axis1", x = quanti)
    axis2 <- update_selectize_values("axis2", x = quanti, exclude = axis1)
    extra_quali <- update_selectize_values("extra_quali", x = quali)
    extra_quanti <- update_selectize_values("extra_quanti", x = quanti)

    ## 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)
    })

    ## Linear regression -----
    model <- reactive({
      req(x(), axis2(), axis1())
      if (!isTRUE(input$regression)) return(NULL)

      n <- nrow(x())
      group <- if (isTruthy(extra_quali())) x()[[extra_quali()]] else rep("", n)
      by(
        data = x(),
        INDICES = group,
        FUN = function(x) {
          vars <- stats::as.formula(sprintf("%s~%s", axis2(), axis1()))
          fit <- stats::lm(vars, data = x)
          pred <- stats::predict(fit, interval = "confidence", level = as.numeric(input$level))
          list(model = fit, predict = pred, response = x[[axis1()]])
        },
        simplify = FALSE
      )
    })

    ## Ellipses -----
    wrap <- reactive({
      req(x())
      level <- as.numeric(input$level)
      group <- if (isTruthy(extra_quali())) x()[[extra_quali()]] else NULL
      switch(
        input$wrap,
        tol = function(x, y, ...) dimensio::viz_tolerance(x, y, group = group, level = level, ...),
        conf = function(x, y, ...) dimensio::viz_confidence(x, y, group = group, level = level, ...),
        hull = function(x, y, ...) dimensio::viz_hull(x, y, group = group, ...),
        function(...) invisible()
      )
    })

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

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

      col <- param$col_quali(x()[[extra_quali()]])
      pch <- param$pch(x()[[extra_quali()]])
      cex <- param$cex(x()[[extra_quanti()]])

      ## Build plot
      function() {
        graphics::plot(
          x = x()[[axis1()]],
          y = x()[[axis2()]],
          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 regression
        if (length(model()) > 0) {
          col_lines <- param$col_quali(names(model()))
          for (i in seq_along(model())) {
            fit <- model()[[i]]
            k <- order(fit$response)
            graphics::lines(x = fit$response[k], y = fit$predict[k, 1],
                            col = col_lines[i], lwd = 2)
          }
        }

        ## Add ellipses
        wrap()(x = x()[[axis1()]], y = x()[[axis2()]], color = param$pal_quali)

        ## Add legend
        if (isTruthy(extra_quali())) {
          graphics::legend(
            x = "topleft",
            legend = unique(x()[[extra_quali()]]),
            col = unique(col),
            pch = unique(pch)
          )
        }
      }
    })

    ## 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)
  })
}

# 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_dim <- function(x, i = 1, j = 1) {
  rows <- ngettext(i, "Select at least %d row.", "Select at least %d rows.")
  cols <- ngettext(j, "Select at least %d column.", "Select at least %d columns.")
  validate(need(NROW(x) >= i, sprintf(rows, i)), errorClass = "kinesis")
  validate(need(NCOL(x) >= j, sprintf(cols, j)), errorClass = "kinesis")
}
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
#' @noRd
`%|||%` <- 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"))
}

#' 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()]).
#' @keywords internal
selectize_ui <- function(id, label = "Choose", multiple = FALSE) {
  ns <- NS(id)
  plugins <- ifelse(isTRUE(multiple), "remove_button", "clear_button")
  options <- list(plugins = plugins)

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

#' Update a Select List with Column Names
#'
#' @param id A [`character`] string specifying the namespace (must match
#'  [selectize_ui()]).
#' @param x A reactive `matrix`-like object.
#' @param find A predicate [`function`] for column detection
#'  (see [arkhe::detect()]).
#' @param find A predicate [`function`] for column selection
#'  (see [arkhe::detect()]).
#' @param selected A [`character`] vector specifying the initially selected
#'  value(s).
#' @param preserve A [`logical`] scalar: should existing selection be preserved
#'  on update?
#' @param none A [`logical`] scalar: should a placeholder be added as the first
#'  element?
#' @param server A [`logical`] scalar: should server-side selectize be used?
#' @return
#'  A reactive [`character`] vector of column names.
#'
#'  Side effect: change the value of a select input on the client.
#' @seealso [selectize_ui()]
#' @keywords internal
update_selectize_variables <- function(id, x, find = NULL, use = NULL,
                                       selected = NULL, preserve = TRUE,
                                       none = TRUE, server = TRUE) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI
    observe({
      choices <- colnames(x())
      found <- rep(TRUE, length(choices))
      if (!is.null(choices) && is.function(find)) {
        found <- which(arkhe::detect(x = x(), f = find, margin = 2))
        choices <- choices[found]
      }
      if (length(choices) > 0 && is.function(use)) {
        used <- arkhe::detect(x = x(), f = use, margin = 2)
        selected <- choices[which(found & used)]
      }
      if (isTRUE(preserve)) {
        ## Try to keep previous selection, if any
        keep <- intersect(choices, input$selected)
        if (length(keep) > 0) selected <- keep
      }
      if (isTRUE(none)) {
        choices <- c(Choose = "", choices)
      }

      freezeReactiveValue(input, "selected")
      updateSelectizeInput(
        inputId = "selected",
        choices = choices,
        selected = selected,
        server = server
      )
    }) |>
      bindEvent(x())

    ## Bookmark
    onRestored(function(state) {
      updateSelectizeInput(session, "selected", selected = state$input$selected)
    })

    reactive({
      req(x()) # Allow to display validation message
      input$selected[which(input$selected != "")] # Remove placeholder
    }) |>
      debounce(500)
  })
}

#' Update a Select List with a Vector
#'
#' @param id A [`character`] string specifying the namespace (must match
#'  [selectize_ui()]).
#' @param x A reactive [`character`] vector.
#' @param exclude A reactive [`character`] vector of values to exclude.
#' @param preserve A [`logical`] scalar: should existing selection be preserved
#'  on update?
#' @param none A [`logical`] scalar: should a placeholder be added as the first
#'  element?
#' @param server A [`logical`] scalar: should server-side selectize be used?
#' @return
#'  A reactive [`character`] vector of column names.
#'
#'  Side effect: change the value of a select input on the client.
#' @seealso [selectize_ui()]
#' @keywords internal
update_selectize_values <- function(id, x, exclude = reactive({ NULL }),
                                    preserve = TRUE, none = TRUE,
                                    server = TRUE) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(exclude))

  moduleServer(id, function(input, output, session) {
    ## Update UI
    observe({
      choices <- x()
      selected <- NULL
      if (!is.null(exclude())) {
        choices <- setdiff(choices, exclude())
      }
      if (isTRUE(preserve)) {
        ## Try to keep previous selection, if any
        keep <- intersect(choices, input$selected)
        if (length(keep) > 0) selected <- keep
      }
      if (isTRUE(none)) {
        choices <- c(Choose = "", choices)
      }

      freezeReactiveValue(input, "selected")
      updateSelectizeInput(
        inputId = "selected",
        choices = choices,
        selected = selected,
        server = server
      )
    }) |>
      bindEvent(x(), exclude())

    ## Bookmark
    onRestored(function(state) {
      updateSelectizeInput(session, "selected", selected = state$input$selected)
    })

    reactive({ input$selected })
  })
}

# Notification =================================================================
show_notification <- function(text, title = NULL, id = NULL, duration = 5,
                              closeButton = TRUE, type = "default") {
  # text <- paste0(text, collapse = "\n")
  if (!is.null(title)) text <- sprintf("**%s**\n%s", title, text)
  id <- showNotification(
    ui = markdown(text, hardbreaks = TRUE),
    duration = duration,
    closeButton = closeButton,
    id = id,
    type = type
  )
  invisible(id)
}

#' Notify
#'
#' Shows a notification if an expression raises an error or a warning.
#' @param expr An expression to be evaluated.
#' @param what 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))
    show_notification(text = warn, title = title, type = "warning")

  res
}

#' Compare Two \R Objects
#'
#' Shows a notification if `x` and `y` are not [identical][identical()].
#' @param x A reactive object.
#' @param y A reactive object.
#' @param title A [`character`] string giving the title of the notification.
#' @return
#'  No return value, called for side effects.
#' @keywords internal
#' @noRd
notify_change <- function(id, x, y, title = "Important message") {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(y))

  moduleServer(id, function(input, output, session) {
    observe({
      if (identical(x(), y())) {
        removeNotification(id)
      } else {
        txt <- paste(tr_("Your data seem to have changed."),
                     tr_("You should perform your analysis again."), sep = " ")
        show_notification(id = id, text = txt, title = title,
                          duration = NULL, closeButton = FALSE,
                          type = "warning")
      }
    }) |>
      bindEvent(x(), y())
  })
}

# 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) {
    ## Get count data -----
    counts <- reactive({
      req(x())
      arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
    })

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

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

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

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

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

# 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) {
  # 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)
        ),
        nav_panel(
          title = tr_("Bookmark"),
          tags$p(
            tr_("You can save the state of the application and get a URL which will restore the application with that state."),
            tr_("You can then copy the URL and save it for later, or share it with others so they can visit the application in the bookmarked state.")
          ),
          tags$p(
            tr_("This is not intended for long-term storage."),
            tr_("There is no guarantee as to how long your bookmark will last.")
          ),
          if (get_option("bookmark", FALSE)) {
            tags$div(class = "d-grid d-md-block", bookmarkButton())
          } else {
            tags$p(tr_("Bookmarking is currently disabled."))
          }
        )
      ) # 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) {
    ## Bookmark -----
    onBookmark(function(state) {
      saved_time <- Sys.time()

      msg <- sprintf(tr_("Last saved at %s."), saved_time)
      showNotification(
        ui = msg,
        duration = 5,
        closeButton = TRUE,
        type = "message",
        session = session
      )
      message(msg)

      # state is a mutable reference object,
      # we can add arbitrary values to it.
      state$values$time <- saved_time
    })

    onRestore(function(state) {
      msg <- sprintf(tr_("Restoring from state bookmarked at %s."), state$values$time)
      showNotification(
        ui = msg,
        duration = 5,
        closeButton = TRUE,
        type = "message",
        session = session
      )
      message(msg)
    })

    ## 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))
}

# UI ===========================================================================
#' 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")),
        select_ui(ns("select")),
        clean_ui(ns("clean"))
      ), # sidebar
      ## Output: value box
      box_ui(ns("box")),
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Data"),
          layout_sidebar(
            sidebar = sidebar(
              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_("Overview"), value = TRUE),
            gt::gt_output(outputId = ns("table"))
          ) # layout_sidebar
        ),
        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)
    data_clean <- data_raw |>
      select_server("select", x = _, find_col = is.numeric, min_col = 3) |>
      clean_server("clean", x = _)

    ## Update UI -----
    col_group <- update_selectize_variables(id = "group", x = data_raw, find = Negate(is.numeric))
    col_condense <- update_selectize_variables(id = "condense", x = data_raw)

    ## Compositions -----
    coda <- reactive({
      req(data_clean())

      notify(
        nexus::as_composition(
          from = data_clean(),
          parts = seq_len(ncol(data_clean())),
          autodetect = FALSE,
          verbose = verbose
        ),
        title = tr_("Compositional Data")
      )
    })

    ## Group -----
    data_group <- reactive({
      req(coda())

      out <- coda()
      if (isTruthy(col_group())) {
        by <- data_raw()[col_group()]
        if (all(lengths(by) == nrow(out))) {
          out <- nexus::group(out, by = by, verbose = verbose)
        }
      }

      out
    })

    ## Condense -----
    data_condense <- reactive({
      req(data_group())

      out <- data_group()
      if (isTruthy(col_condense())) {
        by <- data_raw()[col_condense()]
        if (all(lengths(by) == nrow(out))) {
          out <- nexus::condense(out, by = by, ignore_na = FALSE, verbose = verbose)
        }
      }

      out
    })

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

    ## Zeros -----
    # TODO

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

    ## Check -----
    data_valid <- reactive({
      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_valid())
        tbl <- as.data.frame(data_valid(), 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%")
      })

    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), "(%)", 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)

    ## Bookmark
    onRestored(function(state) {
      req(ui())
      for (i in ids()) {
        updateNumericInput(session, session$ns(i), value = state$input[[i]])
      }
    })

    reactive({ data$values })
  })
}

# 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) {
  ## 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
  }

  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")) 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`}{}
#'  }
#' @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(16),
      lty = recycle(1),
      cex = recycle(1),
      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 <- as.integer(input$pch) %|||% 16
      if (isTruthy(input$pch)) {
        param$pch <- protect(khroma::palette_shape, pch[[1L]], pch)
      } else {
        param$pch <- recycle(pch[[1L]])
      }
    }) |>
      bindEvent(input$pch, ignoreNULL = FALSE)

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

    observe({
      cex <- range(as.integer(input$cex)) %|||% 1
      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 ===========================================================================
#' 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")),
        downloadButton(outputId = ns("download"), tr_("Download 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 -----
    output$download <- export_table(results, name = "coda_outliers")

    out
  })
}

# 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) {
    ## Select columns -----
    data_raw <- reactive({
      as.data.frame(x())
    })
    quanti <- reactive({
      req(data_raw())
      i <- which(arkhe::detect(x = data_raw(), f = is.numeric, margin = 2))
      colnames(data_raw())[i]
    })
    quali <- reactive({
      req(data_raw())
      i <- which(arkhe::detect(x = data_raw(), f = Negate(is.numeric), margin = 2))
      colnames(data_raw())[i]
    })
    axis1 <- update_selectize_values("axis1", x = quanti)
    axis2 <- update_selectize_values("axis2", x = quanti, exclude = axis1)
    axis12 <- reactive({ c(axis1(), axis2()) })
    axis3 <- update_selectize_values("axis3", x = quanti, exclude = axis12)
    extra_quali <- update_selectize_values("extra_quali", x = quali)
    extra_quanti <- update_selectize_values("extra_quanti", x = quanti)

    ## 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")

    ## 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())) {
        symbol_group <- data_raw()[[extra_quali()]]
        col <- param$col_quali(symbol_group)
      } else {
        symbol_group <- rep("", n)
        col <- param$col_quant(data_raw()[[extra_quanti()]])
      }
      pch <- param$pch(data_raw()[[extra_quali()]])
      cex <- param$cex(data_raw()[[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)
      }

      ## Heatmap
      bin <- as.numeric(input$bin)
      fun_tile <- switch(
        input$tile,
        bin = isopleuros::tile_bin(tern),
        dens = isopleuros::tile_density(tern),
        NULL
      )

      ## Envelope
      level <- as.numeric(input$level)
      fun_wrap <- 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, ...),
        function(...) invisible()
      )

      ## 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(fun_tile)) {
            isopleuros::ternary_image(
              f = fun_tile,
              n = bin,
              palette = param$col_quant
            )
          }

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

          ## Envelope
          for (i in split(seq_len(n), f = symbol_group)) {
            z <- tern[i, , drop = FALSE]
            if (nrow(z) < 3) next
            fun_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())) {
          graphics::legend(
            x = "topleft",
            legend = unique(symbol_group),
            col = unique(col),
            pch = unique(pch),
            bty = "n"
          )
        }
      }
    })

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

# 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_variables("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 ===========================================================================
#' 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")
    )
  )
}

#' 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) {
    data <- reactiveValues(values = NULL)

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

    ## Read from connection -----
    obs <- observe({
      params <- parseQueryString(session$clientData$url_search)
      query <- params[["data"]]

      if (!is.null(query)) {
        msg <- sprintf(tr_("Reading data from %s..."), query)
        id <- showNotification(msg, duration = NULL, closeButton = FALSE,
                               type = "message")
        on.exit(removeNotification(id), add = TRUE)

        data$values <- notify(utils::read.csv(file = url(query)), tr_("Data Input"))
      }
      obs$destroy()
    })

    ## Load example data -----
    observe({
      req(demo)
      tmp <- new.env(parent = emptyenv())
      on.exit(rm(tmp), add = TRUE)

      data(list = demo, package = c("folio", "datasets"), envir = tmp)
      data$values <- get(demo, envir = tmp)
    }) |>
      bindEvent(input$demo)

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

      x <- notify({
        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
        )},
        title = "Data Upload"
      )

      if (!is.null(x)) removeModal()
      data$values <- x
    }) |>
      bindEvent(input$go)

    ## Bookmark -----
    setBookmarkExclude(c("upload", "go"))
    onBookmark(function(state) state$values$data <- data$values)
    onRestore(function(state) data$values <- state$values$data)

    reactive({
      validate_csv(data$values)
      data$values
    })
  })
}

# 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")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download results")
        ),
        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 -----
    row_names <- reactive({ rownames(x()) })
    sup_row <- update_selectize_values("sup_row", x = row_names)
    sup_col <- update_selectize_variables("sup_col", x = x, find = is.numeric)
    sup_quali <- update_selectize_variables("sup_quali", x = x, find = Negate(is.numeric))

    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, old, title = tr_("CA"))

    ## 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 = arkhe::seek_columns(x, names = sup_col))
          if (is.data.frame(x)) {
            param$sup_quali <- arkhe::seek_columns(x, names = 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)

    results <- reactive({
      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 = .001))
          ),
          tags$li(
            sprintf(tr_("Cramer's V: %.2f"), chi2_test()$cramer)
          )
        )
      )
    })

    ## Export -----
    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 ===========================================================================
#' 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")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download results")
        )
      ), # 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())


    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, old, title = tr_("Aoristic Analysis"))

    ## 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)

    results <- reactive({
      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 -----
    output$download <- export_table(results, "aoristic")

    results
  })
}

# 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.")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download tables")
        ),
        selectize_ui(id = ns("hist_select"), label = tr_("Select a part")),
        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")
        )
      ),
      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"),
          tabsetPanel(
            type = c("pills"),
            tabPanel(
              title = tr_("Table"),
              class = "pt-3",
              gt::gt_output(outputId = ns("variation"))
            ),
            tabPanel(
              title = tr_("Heatmap"),
              class = "pt-3",
              output_plot(id = ns("heatmap"))
            ),
            tabPanel(
              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))
    })

    ## Histogram -----
    col_hist <- update_selectize_variables("hist_select", x = x, preserve = FALSE, none = FALSE)
    plot_hist <- reactive({
      req(x(), col_hist())
      function() nexus::hist(x(), select = col_hist())
    })

    ## 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)
    render_plot("hist", x = plot_hist)

    ## Download -----
    output$download <- export_multiple(
      location = data_loc,
      quantiles = data_quant,
      covariance = data_cov,
      variation = data_var,
      name = "coda_summary"
    )
  })
}

# 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(
        width = 400,
        h5(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")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download 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` (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 [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) {
    ## Get count data -----
    counts <- reactive({
      req(x())
      arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
    })

    ## Check data -----
    old <- reactive({ counts() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), counts, old, title = tr_("Co-Occurrence"))

    ## 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 = counts(), method = input$method)
    }) |>
      bindEvent(input$go)

    results <- reactive({
      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 -----
    output$download <- export_table(results, "occurrence")
  })
}

# 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")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download results")
        )
      ), # 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 -----
    row_names <- reactive({ rownames(x()) })
    sup_row <- update_selectize_values("sup_row", x = row_names)
    sup_col <- update_selectize_variables("sup_col", x = x, find = is.numeric)
    sup_quali <- update_selectize_variables("sup_quali", x = x, find = Negate(is.numeric))

    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, old, title = tr_("PCA"))
    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 = arkhe::seek_columns(x, names = sup_col))
          if (is.data.frame(x)) {
            param$sup_quali <- arkhe::seek_columns(x, names = 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)

    results <- reactive({
      notify(compute_pca$result(), title = tr_("Principal Components Analysis"))
    })

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

    ## Export -----
    output$download <- downloadHandler(
      filename = function() { make_file_name("pca", "zip") },
      content = function(file) {
        dimensio::export(results(), file = file, flags = "-r9Xj")
      },
      contentType = "application/zip"
    )

    results
  })
}

# 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")
        ),
        downloadButton(outputId = ns("download_table"),
                       label = tr_("Download log-ratio")),
        ## 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 -----
    output$download_table <- export_table(logratio, name = paste0("coda_", method))

    logratio
  })
}

#' @details
#'  \tabular{ll}{
#'   **Version** \tab 0.2.0 \cr
#'   **License** \tab GPL-3 \cr
#'   **Zenodo DOI** \tab \doi{10.5281/zenodo.14645671} \cr
#'  }
#'
#'  Archéosciences Bordeaux (UMR 6034)\cr
#'  Maison de l'Archéologie\cr
#'  Université Bordeaux Montaigne\cr
#'  F-33607 Pessac cedex\cr
#'  France
#'
#' @section Package options:
#'  \pkg{kinesis} uses the following [options()] to configure behavior:
#'  * `kinesis.workers`: an [`integer`] specifying the number of \R sessions
#'  to be used for asynchronous (parallel) computing. Defaults to 1.
#'
#' @name kinesis-package
#' @aliases kinesis-package kinesis
#' @docType package
#' @keywords internal
"_PACKAGE"

#' @import shiny
#' @import bslib
NULL

# Suppress R CMD check note "All declared Imports should be used."
unused <- function() {
  folio::boves
  datasets::iris
}

# 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")
        ),
        selectizeInput(
          inputId = ns("calendar"),
          label = tr_("Calendar"),
          choices = c("CE", "BCE", "BP"),
          selected = "CE"
        ),
        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 -----
    col_lower <- update_selectize_variables("lower", x = x, find = is.numeric)
    col_upper <- update_selectize_variables("upper", x = x, find = is.numeric)
    col_groups <- update_selectize_variables("groups", x = x, find = Negate(is.numeric))

    lower <- reactive({
      req(col_lower())
      x()[[col_lower()]]
    })
    upper <- reactive({
      req(col_upper())
      x()[[col_upper()]]
    })
    groups <- reactive({
      if (isTruthy(col_groups())) x()[[col_groups()]] else NULL
    })
    calendar <- reactive({
      req(input$calendar)
      aion::calendar(input$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 (length(groups()) > 0) {
        grp <- groups()
        col <- param$col_quali(grp)
      }
      function() {
        aion::plot(results(), calendar = aion::CE(), groups = grp, col = col)
        if (length(groups()) > 0) {
          graphics::legend(x = "topleft", legend = unique(grp),
                           fill = unique(col))
        }
      }
    })

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

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

# 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(
        width = 400,
        h5(tr_("Diversity Measures")),
        downloadButton(
          outputId = ns("download"),
          label = tr_("Download 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` (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_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) {
    ## Get count data -----
    counts <- reactive({
      req(x())
      arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
    })

    ## Compute index -----
    alpha <- reactive({
      req(counts())
      notify({ tabula::diversity(counts()) }, title = "Alpha diversity")
    })

    ## Render table -----
    output$measures <- gt::render_gt({
      alpha() |>
        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 -----
    output$download <- export_table(alpha, "alpha")

    alpha
  })
}

# 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(
        width = 400,
        h5(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")),
        downloadButton(
          outputId = ns("download_beta"),
          label = tr_("Download dissimilarity matrix")
        ),
        downloadButton(
          outputId = ns("download_pcoa"),
          label = tr_("Download PCoA results")
        ),
        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` (typically returned by [import_server()]).
#' @param y A reactive `data.frame` returned by [diversity_alpha_server()].
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @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, y, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    col_quali <- update_selectize_variables("extra_quali", x = x, find = Negate(is.numeric))
    col_quanti <- update_selectize_variables("extra_quanti", x = y, find = is.numeric)

    ## Get count data -----
    counts <- reactive({
      req(x())
      arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
    })

    ## Check data -----
    old <- reactive({ counts() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), counts, old, title = tr_("Beta Diversity"))

    ## 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 = counts(), method = input$method)
    }) |>
      bindEvent(input$go)

    results <- reactive({
      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(), x(), y())

      ## Extra variables
      extra_quanti <- arkhe::seek_columns(y(), names = col_quanti())
      if (!is.null(extra_quanti)) extra_quanti <- y()[[extra_quanti]]
      extra_quali <- arkhe::seek_columns(x(), names = col_quali())
      if (!is.null(extra_quali)) extra_quali <- x()[[extra_quali]]

      col <- "black"
      if (isTruthy(extra_quanti)) {
        col <- param_pcoa$col_quant(extra_quanti)
      }
      if (isTruthy(extra_quali)) {
        col <- param_pcoa$col_quali(extra_quali)
      }
      cex <- param_pcoa$cex(extra_quanti)
      pch <- param_pcoa$pch(extra_quali)

      function() {
        dimensio::plot(
          x = analysis(),
          labels = input$pcoa_labels,
          extra_quali = extra_quali,
          extra_quanti = extra_quanti,
          col = col,
          pch = pch,
          cex = cex,
          panel.first = graphics::grid()
        )

        if (isTRUE(input$hull)) {
          dimensio::viz_hull(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 -----
    output$download_beta <- export_table(results, "beta")
    output$download_pcoa <- downloadHandler(
      filename = function() { make_file_name("pcoa", "zip") },
      content = function(file) {
        dimensio::export(analysis(), file = file, flags = "-r9Xj")
      },
      contentType = "application/zip"
    )
  })
}

# Server =======================================================================
#' Download a CSV File
#'
#' Save and Download a [`data.frame`] (CSV).
#' @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).
#' @return
#'  No return value, called for side effects.
#' @family widgets
#' @keywords internal
#' @noRd
export_table <- function(x, name) {
  stopifnot(is.reactive(x))

  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).
#' @param name A [`character`] string specifying the name of the file
#'  (without extension and the leading dot).
#' @return
#'  No return value, called for side effects.
#' @family widgets
#' @keywords internal
#' @noRd
export_multiple <- function(..., name = "archive") {
  tbl <- list(...)
  stopifnot(!is.null(names(tbl)))

  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 = "-r9Xj")
    },
    contentType = "application/zip"
  )
}

# 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)[[1]], 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) {
  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 ===========================================================================
#' 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		#' 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	!	selected = NULL,
25	!	multiple = FALSE
26		),
27	!	selectizeInput(
28	!	inputId = ns("axis2"),
29	!	label = tr_("Vertical axis"),
30	!	choices = NULL,
31	!	selected = NULL,
32	!	multiple = FALSE,
33		),
34	!	checkboxInput(
35	!	inputId = ns("lab_ind"),
36	!	label = tr_("Label individuals"),
37	!	value = FALSE
38		),
39	!	checkboxInput(
40	!	inputId = ns("lab_var"),
41	!	label = tr_("Label variables"),
42	!	value = TRUE
43		),
44	!	checkboxInput(
45	!	inputId = ns("sup_ind"),
46	!	label = tr_("Display supplementary individuals"),
47	!	value = TRUE
48		),
49	!	checkboxInput(
50	!	inputId = ns("sup_var"),
51	!	label = tr_("Display supplementary variables"),
52	!	value = TRUE
53		),
54	!	selectize_ui(
55	!	id = ns("extra_quanti"),
56	!	label = tr_("Extra quantitative variable")
57		),
58	!	selectize_ui(
59	!	id = ns("extra_quali"),
60	!	label = tr_("Extra qualitative variable")
61		),
62		## Input: add ellipses
63	!	radioButtons(
64	!	inputId = ns("wrap"),
65	!	label = tr_("Wrap:"),
66	!	choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
67	!	tr_("Confidence ellipse"), tr_("Convex hull")),
68	!	choiceValues = c("none", "tolerance", "confidence", "hull"),
69		),
70	!	checkboxGroupInput(
71	!	inputId = ns("ellipse_level"),
72	!	label = tr_("Ellipse level:"),
73	!	selected = "0.95",
74	!	choiceNames = c("68%", "95%", "99%"),
75	!	choiceValues = c("0.68", "0.95", "0.99")
76		)
77		# TODO: legend
78		),
79		## Results -----
80	!	nav_panel(
81	!	title = tr_("Results"),
82	!	helpText(
83	!	tr_("Click and drag to select an area, then double-click to zoom in."),
84	!	tr_("Double-click again to reset the zoom.")
85		),
86	!	layout_column_wrap(
87	!	output_plot(
88	!	id = ns("plot_ind"),
89	!	tools = graphics_ui(ns("par_ind"), lty = FALSE),
90	!	title = tr_("Individuals factor map"),
91	!	dblclick = ns("plot_ind_dblclick"),
92	!	brush = brushOpts(
93	!	id = ns("plot_ind_brush"),
94	!	resetOnNew = TRUE
95		),
96	!	height = "100%"
97		),
98	!	output_plot(
99	!	id = ns("plot_var"),
100	!	tools = graphics_ui(ns("par_var"), col_quant = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
101	!	title = tr_("Variables factor map"),
102	!	dblclick = ns("plot_var_dblclick"),
103	!	brush = brushOpts(
104	!	id = ns("plot_var_brush"),
105	!	resetOnNew = TRUE
106		),
107	!	height = "100%"
108		)
109	!	) # layout_columns
110		),
111		## Individuals -----
112	!	nav_panel(
113	!	title = tr_("Individuals"),
114	!	layout_column_wrap(
115	!	output_plot(id = ns("plot_cos2_1")),
116	!	output_plot(id = ns("plot_cos2_2"))
117		),
118	!	gt::gt_output(outputId = ns("info_ind"))
119		),
120		## Variables -----
121	!	nav_panel(
122	!	title = tr_("Variables"),
123	!	layout_column_wrap(
124	!	output_plot(id = ns("plot_contrib_1")),
125	!	output_plot(id = ns("plot_contrib_2"))
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	!	col_quali <- update_selectize_variables("extra_quali", x = extra,
162	!	find = Negate(is.numeric),
163	!	selected = tr_("Group"))
164	!	col_quanti <- update_selectize_variables("extra_quanti", x = extra,
165	!	find = is.numeric)
166
167		## Eigenvalues -----
168	!	eigen <- reactive({
169	!	req(x())
170	!	dimensio::get_eigenvalues(x())
171		})
172
173		## Update UI -----
174	!	axes <- reactive({
175	!	choices <- seq_len(nrow(eigen()))
176	!	names(choices) <- rownames(eigen())
177	!	choices
178		})
179	!	observe({
180	!	freezeReactiveValue(input, "axis1")
181	!	updateSelectizeInput(inputId = "axis1", choices = axes())
182		}) \|>
183	!	bindEvent(axes())
184	!	observe({
185	!	choices <- axes()[-axis1()]
186	!	freezeReactiveValue(input, "axis2")
187	!	updateSelectizeInput(inputId = "axis2", choices = choices)
188		}) \|>
189	!	bindEvent(axis1())
190
191		## Bookmark -----
192	!	onRestored(function(state) {
193	!	updateSelectizeInput(session, inputId = "axis1",
194	!	selected = state$input$axis1)
195	!	updateSelectizeInput(session, inputId = "axis2",
196	!	selected = state$input$axis2)
197		})
198
199		## Select axes -----
200	!	axis1 <- reactive({
201	!	req(input$axis1)
202	!	as.numeric(input$axis1)
203		})
204	!	axis2 <- reactive({
205	!	req(input$axis2)
206	!	as.numeric(input$axis2)
207		})
208
209		## Graphical parameters -----
210	!	param_ind <- graphics_server("par_ind")
211	!	param_var <- graphics_server("par_var")
212
213		## Plot -----
214		## Interactive zoom
215		## When a double-click happens, check if there's a brush on the plot.
216		## If so, zoom to the brush bounds; if not, reset the zoom.
217	!	range_ind <- reactiveValues(x = NULL, y = NULL)
218	!	range_var <- reactiveValues(x = NULL, y = NULL)
219	!	observe({
220	!	range_ind$x <- brush_xlim(input$plot_ind_brush)
221	!	range_ind$y <- brush_ylim(input$plot_ind_brush)
222		}) \|>
223	!	bindEvent(input$plot_ind_dblclick)
224
225	!	observe({
226	!	range_var$x <- brush_xlim(input$plot_var_brush)
227	!	range_var$y <- brush_ylim(input$plot_var_brush)
228		}) \|>
229	!	bindEvent(input$plot_var_dblclick)
230
231		## Individuals
232	!	plot_ind <- reactive({
233	!	req(x(), extra())
234
235		## Extra variables
236	!	extra_quanti <- arkhe::seek_columns(extra(), names = col_quanti())
237	!	if (!is.null(extra_quanti)) extra_quanti <- extra()[[extra_quanti]]
238	!	extra_quali <- arkhe::seek_columns(extra(), names = col_quali())
239	!	if (!is.null(extra_quali)) extra_quali <- extra()[[extra_quali]]
240
241	!	col <- "black"
242	!	if (isTruthy(extra_quanti)) {
243	!	col <- param_ind$col_quant(extra_quanti)
244		}
245	!	if (isTruthy(extra_quali)) {
246	!	col <- param_ind$col_quali(extra_quali)
247		}
248	!	cex <- param_ind$cex(extra_quanti)
249	!	pch <- param_ind$pch(extra_quali)
250
251	!	add_ellipses <- any(input$wrap %in% c("confidence", "tolerance"))
252	!	add_hull <- isTRUE(input$wrap == "hull")
253
254	!	function() {
255	!	dimensio::viz_rows(
256	!	x = x(),
257	!	axes = c(axis1(), axis2()),
258	!	active = TRUE,
259	!	sup = input$sup_ind,
260	!	labels = input$lab_ind,
261	!	extra_quali = extra_quali %\|\|\|% "observation",
262	!	extra_quanti = extra_quanti,
263	!	col = col,
264	!	pch = pch,
265	!	cex = cex,
266	!	xlim = range_ind$x,
267	!	ylim = range_ind$y,
268	!	panel.first = graphics::grid()
269		)
270
271	!	if (add_ellipses) {
272	!	dimensio::viz_ellipses(
273	!	x = x(),
274	!	group = extra_quali,
275	!	type = input$wrap,
276	!	level = as.numeric(input$ellipse_level),
277	!	color = param_ind$pal_quali
278		)
279		}
280	!	if (add_hull) {
281	!	dimensio::viz_hull(
282	!	x = x(),
283	!	group = extra_quali,
284	!	color = param_ind$pal_quali
285		)
286		}
287		}
288		})
289
290		## Variables
291	!	plot_var <- reactive({
292	!	req(x())
293
294	!	function() {
295	!	dimensio::viz_variables(
296	!	x = x(),
297	!	axes = c(axis1(), axis2()),
298	!	active = TRUE,
299	!	sup = input$sup_var,
300	!	labels = input$lab_var,
301	!	extra_quali = "observation",
302	!	color = param_var$pal_quali,
303	!	symbol = c(1, 3),
304	!	xlim = range_var$x,
305	!	ylim = range_var$y,
306	!	panel.first = graphics::grid()
307		)
308		}
309		})
310
311	!	plot_cos2_1 <- reactive({
312	!	req(x())
313	!	function() {
314	!	dimensio::viz_cos2(x = x(), margin = 1, axes = axis1())
315		}
316		})
317
318	!	plot_cos2_2 <- reactive({
319	!	req(x())
320	!	function() {
321	!	dimensio::viz_cos2(x = x(), margin = 1, axes = axis2())
322		}
323		})
324
325	!	plot_contrib_1 <- reactive({
326	!	req(x())
327	!	function() {
328	!	dimensio::viz_contributions(x = x(), margin = 2, axes = axis1())
329		}
330		})
331
332	!	plot_contrib_2 <- reactive({
333	!	req(x())
334	!	function() {
335	!	dimensio::viz_contributions(x = x(), margin = 2, axes = axis2())
336		}
337		})
338
339	!	plot_eigen <- reactive({
340	!	req(x())
341	!	function() {
342	!	dimensio::screeplot(
343	!	x = x(),
344	!	cumulative = TRUE,
345	!	labels = FALSE,
346	!	limit = sum(eigen()[, 3] <= 99)
347		)
348		}
349		})
350
351		## Render plots -----
352	!	render_plot("plot_ind", x = plot_ind)
353	!	render_plot("plot_var", x = plot_var)
354	!	render_plot("plot_cos2_1", x = plot_cos2_1)
355	!	render_plot("plot_cos2_2", x = plot_cos2_2)
356	!	render_plot("plot_contrib_1", x = plot_contrib_1)
357	!	render_plot("plot_contrib_2", x = plot_contrib_2)
358	!	render_plot("screeplot", x = plot_eigen)
359
360		## Render tables -----
361	!	output$variance <- gt::render_gt({
362	!	gt::gt(eigen(), rownames_to_stub = TRUE) \|>
363	!	gt::tab_options(table.width = "100%") \|>
364	!	gt::fmt_number(
365	!	columns = c("eigenvalues"),
366	!	decimals = 3
367		) \|>
368	!	gt::fmt_percent(
369	!	columns = c("variance", "cumulative"),
370	!	scale_values = FALSE
371		) \|>
372	!	gt::cols_label(
373	!	eigenvalues = tr_("Eigenvalues"),
374	!	variance = tr_("Explained var. (%)"),
375	!	cumulative = tr_("Cumulative var. (%)")
376		)
377		})
378
379	!	output$info_ind <- gt::render_gt({
380	!	req(x())
381	!	multivariate_summary(x(), axes = c(axis1(), axis2()), margin = 1)
382		})
383	!	output$info_var <- gt::render_gt({
384	!	req(x())
385	!	multivariate_summary(x(), axes = c(axis1(), axis2()), margin = 2)
386		})
387		})
388		}
389
390		multivariate_summary <- function(x, axes, margin) {
391	!	dimensio::summary(x, axes = axes, margin = margin) \|>
392	!	as.data.frame() \|>
393	!	gt::gt(rownames_to_stub = TRUE) \|>
394	!	gt::fmt_number(decimals = 3) \|>
395	!	gt::tab_spanner(
396	!	label = tr_("Coordinates"),
397	!	columns = gt::ends_with("coord"),
398	!	id = "coord"
399		) \|>
400	!	gt::tab_spanner(
401	!	label = tr_("Contribution"),
402	!	columns = gt::ends_with("contrib"),
403	!	id = "contrib"
404		) \|>
405	!	gt::tab_spanner(
406	!	label = tr_("Squared cosinus"),
407	!	columns = gt::ends_with("cos2"),
408	!	id = "cos2"
409		) \|>
410	!	gt::cols_label(
411	!	dist = tr_("Distance")
412		) \|>
413	!	gt::cols_label_with(
414	!	columns = gt::starts_with("F"),
415	!	fn = function(x) {
416	!	paste(tr_("Axis"), regmatches(x, regexpr("[0-9]", x)), sep = " ")
417		}
418		) \|>
419	!	gt::opt_interactive(
420	!	use_compact_mode = TRUE,
421	!	use_page_size_select = TRUE
422		)
423		}

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	!	downloadButton(
45	!	outputId = ns("export_table"),
46	!	label = tr_("Export matrix")
47		)
48	!	), # sidebar
49		## Output: plot reordered matrix
50	!	navset_card_pill(
51	!	bertin_ui(
52	!	id = ns("plot"),
53	!	title = tr_("Rearranged matrix")
54		)
55		)
56	!	) # layout_sidebar
57	!	) # nav_panel
58		}
59
60		# Server =======================================================================
61		#' CA Seriation Server
62		#'
63		#' @param id An ID string that corresponds with the ID used to call the module's
64		#' UI function.
65		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
66		#' @param order A reactive \R object (coercible by [kairos::as_seriation()]).
67		#' @return A reactive [`kairos::AveragePermutationOrder-class`] object.
68		#' @seealso [seriate_ui()]
69		#' @family chronology modules
70		#' @keywords internal
71		#' @export
72		seriate_server <- function(id, x, order) {
73	!	stopifnot(is.reactive(x))
74	!	stopifnot(is.reactive(order))
75
76	!	moduleServer(id, function(input, output, session) {
77		## Seriate -----
78	!	data_seriate <- reactive({
79	!	validate(need(order(), tr_("Compute the seriation order first.")))
80
81	!	margin <- NULL
82	!	if (input$margin_row) margin <- c(margin, 1)
83	!	if (input$margin_col) margin <- c(margin, 2)
84
85	!	kairos::as_seriation(order(), margin = margin, axes = input$axes)
86		})
87
88		## Permute -----
89	!	data_permute <- reactive({
90	!	req(x())
91	!	req(data_seriate())
92	!	kairos::permute(x(), data_seriate())
93		})
94
95		## Render plot -----
96	!	bertin_server("plot", x = data_permute)
97
98		## Download -----
99	!	output$export_table <- export_table(data_permute, name = "permuted")
100
101	!	data_seriate
102		})
103		}

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

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	!	select_ui(ns("select")),
25	!	clean_ui(ns("clean"))
26	!	), # sidebar
27		## Output: value box
28	!	box_ui(ns("box")),
29	!	navset_card_pill(
30	!	placement = "above",
31	!	nav_panel(
32	!	title = tr_("Data"),
33	!	checkboxInput(
34	!	inputId = ns("head"),
35	!	label = tr_("Table overview"),
36	!	value = TRUE),
37	!	gt::gt_output(outputId = ns("table"))
38		),
39	!	nav_panel(
40	!	title = tr_("Missing values"),
41	!	missing_ui(ns("missing"))
42		)
43		),
44	!	border_radius = FALSE,
45	!	fillable = TRUE,
46	!	) # layout_sidebar
47	!	) # nav_panel
48		}
49
50		# Server =======================================================================
51		#' Prepare Data Server
52		#'
53		#' @param id An ID string that corresponds with the ID used to call the module's
54		#' UI function.
55		#' @param choose A predicate [`function`] used to select columns.
56		#' @param select A predicate [`function`] used to select columns.
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, choose = \(...) TRUE, select = \(...) TRUE,
65		demo = NULL) {
66	!	moduleServer(id, function(input, output, session) {
67		## Prepare data -----
68	!	data_clean <- import_server("import", demo = demo) \|>
69	!	select_server("select", x = _, find_col = choose, use_col = select) \|>
70	!	clean_server("clean", x = _) \|>
71	!	missing_server("missing", x = _)
72
73		## Render description -----
74	!	box_server("box", x = data_clean)
75
76		## Render table -----
77	!	output$table <- gt::render_gt({
78	!	tbl <- if (isTRUE(input$head)) utils::head(data_clean()) else data_clean()
79	!	gt::gt(tbl, rownames_to_stub = TRUE) \|>
80	!	gt::tab_options(table.width = "100%")
81		})
82
83	!	data_clean
84		})
85		}
86
87		# Modules ======================================================================
88		## Value box -------------------------------------------------------------------
89		box_ui <- function(id) {
90	!	ns <- NS(id)
91
92	!	layout_columns(
93	!	col_widths = breakpoints(
94	!	xs = c(12, 12, 12, 12),
95	!	md = c(6, 6, 6, 6),
96	!	lg = c(3, 3, 3, 3)
97		),
98	!	fill = FALSE,
99	!	value_box(
100	!	title = tr_("Dimensions"),
101	!	value = textOutput(outputId = ns("value_dimensions"))
102		),
103	!	value_box(
104	!	title = tr_("Sparsity"),
105	!	value = textOutput(outputId = ns("value_sparsity"))
106		),
107	!	value_box(
108	!	title = tr_("Missing values"),
109	!	value = textOutput(outputId = ns("value_missing"))
110		),
111	!	card(
112	!	helpText(tr_("Export your data for futur use.")),
113	!	downloadButton(
114	!	outputId = ns("download"),
115	!	label = tr_("Download")
116		)
117		)
118		)
119		}
120		box_server <- function(id, x) {
121	1x	stopifnot(is.reactive(x))
122
123	1x	moduleServer(id, function(input, output, session) {
124	1x	output$value_dimensions <- renderText({
125	4x	req(x())
126	3x	paste0(dim(x()), collapse = " x ")
127		})
128	1x	output$value_sparsity <- renderText({
129	4x	req(x())
130	3x	paste0(round(arkhe::sparsity(x()) * 100, 2), "%")
131		})
132	1x	output$value_missing <- renderText({
133	4x	req(x())
134	3x	sum(is.na(x()))
135		})
136
137		## Download -----
138	1x	output$download <- export_table(x, "data")
139		})
140		}
141
142		## Select ----------------------------------------------------------------------
143		select_ui <- function(id) {
144	!	ns <- NS(id)
145
146	!	tags$div(
147	!	h5(tr_("Select data")),
148	!	selectize_ui(id = ns("rownames"), label = tr_("Sample names")),
149	!	selectize_ui(id = ns("colnames"), label = tr_("Variables"), multiple = TRUE)
150		)
151		}
152
153		#' @param id A [`character`] string specifying the namespace.
154		#' @param x A reactive `matrix`-like object.
155		#' @param find_col A predicate [`function`] for column detection
156		#' (see [arkhe::detect()]).
157		#' @param use_col A predicate [`function`] for column selection
158		#' (see [arkhe::detect()]).
159		#' @param min_row An [`interger`] specifying the expected minimum number of rows.
160		#' @param min_col An [`interger`] specifying the expected minimum number of columns.
161		#' @return A reactive [`data.frame`].
162		#' @noRd
163		select_server <- function(id, x, find_col = NULL, use_col = NULL,
164		min_row = 1, min_col = 1) {
165	2x	stopifnot(is.reactive(x))
166
167	2x	moduleServer(id, function(input, output, session) {
168		## Update UI
169	2x	row_names <- update_selectize_variables(id = "rownames", x = x)
170
171		## Assign row names
172	2x	named <- reactive({
173	2x	req(x())
174	2x	out <- notify(
175		{
176	2x	column <- arkhe::seek_columns(x(), names = row_names())
177	2x	arkhe::assign_rownames(x(), column = column %\|\|\|% 0, remove = TRUE)
178		},
179	2x	title = tr_("Row names")
180		)
181	2x	out
182		}) \|>
183	2x	bindEvent(row_names())
184
185		## Update UI
186	2x	col_names <- update_selectize_variables(
187	2x	id = "colnames",
188	2x	x = named,
189	2x	find = find_col,
190	2x	use = use_col
191		)
192
193		## Select variables
194	2x	selected <- reactive({
195	3x	out <- arkhe::get_columns(named(), names = col_names())
196	3x	validate_dim(out, i = min_row, j = min_col)
197	3x	out
198		}) \|>
199	2x	bindEvent(col_names(), ignoreNULL = FALSE) \|>
200	2x	debounce(500)
201
202	2x	selected
203		})
204		}
205
206		## Clean -----------------------------------------------------------------------
207		clean_ui <- function(id) {
208	!	ns <- NS(id)
209
210	!	tags$div(
211	!	h5(tr_("Clean values")),
212		## Input: remove whitespace
213	!	checkboxInput(
214	!	inputId = ns("remove_whitespace"),
215	!	label = tr_("Remove leading/trailing whitespace"),
216	!	value = FALSE
217		),
218		## Input: remove zero
219	!	checkboxInput(
220	!	inputId = ns("remove_zero_row"),
221	!	label = tr_("Remove rows with zero"),
222	!	value = FALSE
223		),
224	!	checkboxInput(
225	!	inputId = ns("remove_zero_column"),
226	!	label = tr_("Remove columns with zero"),
227	!	value = FALSE
228		),
229		## Input: remove constant
230	!	checkboxInput(
231	!	inputId = ns("remove_constant_column"),
232	!	label = tr_("Remove constant columns"),
233	!	value = FALSE
234		),
235		## Input: remove all?
236	!	checkboxInput(
237	!	inputId = ns("all"),
238	!	label = tr_("Remove only if all values meet the condition"),
239	!	value = TRUE,
240	!	width = "100%"
241		)
242		)
243		}
244
245		#' @param id A [`character`] string specifying the namespace.
246		#' @param x A reactive `matrix`-like object.
247		#' @param verbose A [`logical`] scalar: should \R report extra information on
248		#' progress?
249		#' @return A reactive [`data.frame`].
250		#' @noRd
251		clean_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
252	2x	stopifnot(is.reactive(x))
253
254	2x	moduleServer(id, function(input, output, session) {
255	2x	reactive({
256	5x	out <- x()
257
258		## Clean whitespace
259	4x	if (isTruthy(out) && isTRUE(input$remove_whitespace)) {
260	!	out <- arkhe::clean_whitespace(out, squish = TRUE)
261		}
262
263		## Remove rows
264		## If only zeros
265	4x	if (isTruthy(out) && isTRUE(input$remove_zero_row)) {
266	1x	out <- arkhe::remove_zero(out, margin = 1, all = input$all,
267	1x	verbose = verbose)
268		}
269
270		## Remove columns
271		## If only zeros
272	4x	if (isTruthy(out) && isTRUE(input$remove_zero_column)) {
273	1x	out <- arkhe::remove_zero(out, margin = 2, all = input$all,
274	1x	verbose = verbose)
275		}
276		## If constant
277	4x	if (isTruthy(out) && isTRUE(input$remove_constant_column)) {
278	!	out <- arkhe::remove_constant(out, verbose = verbose)
279		}
280
281	4x	validate_dim(out)
282
283	4x	out
284		})
285		})
286		}
287
288		## Missing ---------------------------------------------------------------------
289		missing_ui <- function(id) {
290	!	ns <- NS(id)
291
292	!	layout_column_wrap(
293	!	width = 1/2,
294	!	list(
295		## Input: empty as missing
296	!	checkboxInput(
297	!	inputId = ns("empty_as_NA"),
298	!	label = tr_("Empty string as missing value"),
299	!	value = FALSE
300		),
301		## Input: zero as missing
302	!	checkboxInput(
303	!	inputId = ns("zero_as_NA"),
304	!	label = tr_("Zero as missing value"),
305	!	value = FALSE
306		),
307		## Input: remove missing
308	!	radioButtons(
309	!	inputId = ns("remove"),
310	!	label = tr_("Remove missing values:"),
311	!	choiceNames = c(
312	!	tr_("Keep as is"),
313	!	tr_("Replace missing values with zeros"),
314	!	tr_("Remove rows with missing values"),
315	!	tr_("Remove columns with missing values")
316		),
317	!	choiceValues = c("none", "zero", "row", "col")
318		)
319		),
320	!	output_plot(ns("heatmap"))
321		)
322		}
323
324		#' @param id A [`character`] string specifying the namespace.
325		#' @param x A reactive `matrix`-like object.
326		#' @param verbose A [`logical`] scalar: should \R report extra information on
327		#' progress?
328		#' @return A reactive [`data.frame`].
329		#' @noRd
330		missing_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
331	2x	stopifnot(is.reactive(x))
332
333	2x	moduleServer(id, function(input, output, session) {
334	2x	data_replace <- reactive({
335	6x	out <- x()
336
337		## Replace empty strings
338	5x	if (isTRUE(input$empty_as_NA)) {
339	!	out <- arkhe::replace_empty(out, value = NA)
340		}
341
342		## Replace zeros
343	5x	if (isTRUE(input$zero_as_NA)) {
344	!	out <- arkhe::replace_zero(out, value = NA)
345		}
346
347	5x	out
348		})
349
350	2x	data_missing <- reactive({
351	10x	out <- data_replace()
352
353		## Remove missing values
354	9x	choice <- input$remove %\|\|\|% ""
355	9x	fun <- switch(
356	9x	choice,
357	9x	zero = function(x) {
358	1x	arkhe::replace_NA(x, value = 0)
359		},
360	9x	row = function(x) {
361	1x	arkhe::remove_NA(x, margin = 1, all = FALSE, verbose = verbose)
362		},
363	9x	col = function(x) {
364	1x	arkhe::remove_NA(x, margin = 2, all = FALSE, verbose = verbose)
365		},
366	6x	function(x) { x }
367		)
368	9x	out <- fun(out)
369
370	9x	validate_dim(out)
371
372	9x	out
373		})
374
375		## Render plot
376	2x	plot_missing <- reactive({
377	9x	req(data_missing())
378	8x	function() {
379	8x	col <- if (anyNA(data_missing())) c("#DDDDDD", "#BB5566") else "#DDDDDD"
380	8x	tabula::plot_heatmap(object = is.na(data_missing()), color = col,
381	8x	fixed_ratio = FALSE)
382		}
383		})
384	2x	render_plot("heatmap", x = plot_missing)
385
386	2x	data_missing
387		})
388		}

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

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	!	downloadButton(
27	!	outputId = ns("download"),
28	!	label = tr_("Download results")
29		)
30	!	), # sidebar
31	!	layout_columns(
32	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
33	!	output_plot(
34	!	id = ns("plot"),
35	!	tools = list(
36	!	select_calendar(ns("calendar_output"))
37		)
38		),
39	!	card(
40	!	gt::gt_output(outputId = ns("table"))
41		)
42		)
43	!	) # layout_sidebar
44	!	) # nav_panel
45		}
46
47		# Server =======================================================================
48		#' MCD Server
49		#'
50		#' @param id An ID string that corresponds with the ID used to call the module's
51		#' UI function.
52		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
53		#' @return
54		#' No return value, called for side effects.
55		#' @seealso [mcd_ui()]
56		#' @family ceramic data modules
57		#' @keywords internal
58		#' @export
59		mcd_server <- function(id, x) {
60	!	stopifnot(is.reactive(x))
61
62	!	moduleServer(id, function(input, output, session) {
63		## Check data -----
64	!	old <- reactive({ x() }) \|> bindEvent(input$go)
65	!	notify_change(session$ns("change"), x, old, title = tr_("MCD"))
66
67		## Update UI -----
68	!	dates <- build_numeric_input("dates", x)
69	!	cal_in <- get_calendar("calendar_input")
70	!	cal_out <- get_calendar("calendar_output")
71
72		## Compute MCD -----
73	!	compute_mcd <- ExtendedTask$new(
74	!	function(x, dates, calendar) {
75	!	mirai::mirai({ kairos::mcd(x, dates, calendar) }, environment())
76		}
77		) \|>
78	!	bslib::bind_task_button("go")
79
80	!	observe({
81	!	compute_mcd$invoke(x = x(), dates = dates(), calendar = cal_in())
82		}) \|>
83	!	bindEvent(input$go)
84
85	!	results <- reactive({
86	!	notify(compute_mcd$result(), title = tr_("MCD"))
87		})
88
89		## Plot -----
90	!	map <- reactive({
91	!	req(results())
92	!	function() kairos::plot(results(), calendar = cal_out())
93		})
94
95		## Table -----
96	!	tbl <- reactive({
97	!	req(results())
98	!	as.data.frame(results(), calendar = cal_out())
99		})
100
101		## Render table -----
102	!	output$table <- gt::render_gt({
103	!	req(tbl())
104	!	tbl() \|>
105	!	gt::gt(rowname_col = "sample") \|>
106	!	gt::fmt_number(decimals = 2) \|>
107	!	gt::sub_missing()
108		})
109
110		## Render plot -----
111	!	render_plot("plot", x = map)
112
113		## Download -----
114	!	output$download <- export_table(tbl, "mcd")
115		})
116		}

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	!	downloadButton(
41	!	outputId = ns("download_dist"),
42	!	label = tr_("Download distances")
43		),
44	!	downloadButton(
45	!	outputId = ns("download_clust"),
46	!	label = tr_("Download clusters")
47		)
48	!	), # sidebar
49	!	output_plot(
50	!	id = ns("plot_dendro"),
51	!	tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, cex = FALSE),
52	!	title = tr_("Dendrogram")
53		),
54	!	border_radius = FALSE,
55	!	fillable = TRUE
56	!	) # layout_sidebar
57	!	) # nav_panel
58		}
59
60		# Server =======================================================================
61		#' Compositional Data Hierarchical Clustering Server
62		#'
63		#' @param id An ID string that corresponds with the ID used to call the module's
64		#' UI function.
65		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
66		#' @return
67		#' No return value, called for side effects.
68		#' @seealso [coda_hclust_ui()]
69		#' @family coda modules
70		#' @keywords internal
71		#' @export
72		coda_hclust_server <- function(id, x) {
73	!	stopifnot(is.reactive(x))
74
75	!	moduleServer(id, function(input, output, session) {
76		## Check data -----
77	!	old <- reactive({ x() }) \|> bindEvent(input$go)
78	!	notify_change(session$ns("change"), x, old, title = tr_("HCLUST"))
79
80		## Compute cluster -----
81	!	compute_hclust <- ExtendedTask$new(
82	!	function(x, method, clust) {
83	!	mirai::mirai({
84	!	clr <- nexus::transform_clr(x)
85	!	d <- nexus::dist(clr, method = method)
86	!	h <- stats::hclust(d, method = clust)
87	!	h$dist <- d
88	!	if (nexus::is_grouped(x)) h$groups <- nexus::group_names(x)
89	!	h
90	!	}, environment())
91		}
92		) \|>
93	!	bslib::bind_task_button("go")
94
95	!	observe({
96	!	compute_hclust$invoke(x = x(), method = input$dist, clust = input$clust)
97		}) \|>
98	!	bindEvent(input$go)
99
100	!	results <- reactive({
101	!	notify(compute_hclust$result(), title = tr_("Hierarchical Clustering"))
102		})
103	!	distances <- reactive({
104	!	results()$dist
105		})
106	!	groups <- reactive({
107	!	req(input$cut)
108	!	stats::cutree(results(), k = input$cut)
109		})
110
111		## Graphical parameters -----
112	!	param <- graphics_server("par")
113
114		## Dendrogram -----
115	!	plot_dendro <- reactive({
116	!	req(results(), input$cut)
117
118	!	function() {
119	!	xlab <- sprintf(tr_("Aitchison distance, %s linkage"), results()$method)
120	!	plot(results(), hang = -1, main = NULL, sub = "",
121	!	xlab = xlab, ylab = "Height", las = 1)
122
123	!	if (input$cut > 1) {
124	!	stats::rect.hclust(results(), k = input$cut)
125		}
126
127	!	i <- results()$order
128	!	g <- results()$groups
129	!	if (!is.null(g)) {
130	!	col <- param$col_quali(g)
131	!	pch <- param$pch(g)
132	!	graphics::points(
133	!	x = seq_along(i),
134	!	y = rep(0, length(i)),
135	!	col = col[i],
136	!	pch = pch[i]
137		)
138
139	!	arg <- list(x = "topright", pch = 16, bty = "n")
140	!	leg <- stats::aggregate(
141	!	data.frame(col = col, pch = pch),
142	!	by = list(legend = g),
143	!	FUN = unique
144		)
145	!	leg <- as.list(leg)
146	!	leg <- utils::modifyList(leg, arg)
147	!	do.call(graphics::legend, args = leg)
148		}
149		}
150		})
151
152		## Render plot -----
153	!	render_plot("plot_dendro", x = plot_dendro)
154
155		## Download -----
156	!	output$download_dist <- export_table(distances, name = "distances")
157	!	output$download_clust <- export_table(groups, name = "clusters")
158		})
159		}

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(id = ns("axis1"), label = tr_("Component X")),
24	!	selectize_ui(id = ns("axis2"), label = tr_("Component Y")),
25		## Input: aesthetics mapping
26	!	selectize_ui(id = ns("extra_quali"), label = tr_("Extra qualitative variable")),
27	!	selectize_ui(id = ns("extra_quanti"), label = tr_("Extra quantitative variable")),
28		## Input: linear regression
29	!	checkboxInput(
30	!	inputId = ns("regression"),
31	!	label = tr_("Linear regression"),
32	!	value = FALSE
33		),
34		## Input: add ellipses
35	!	radioButtons(
36	!	inputId = ns("wrap"),
37	!	label = tr_("Wrap:"),
38	!	choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
39	!	tr_("Confidence ellipse"), tr_("Convex hull")),
40	!	choiceValues = c("none", "tol", "conf", "hull"),
41		),
42	!	checkboxGroupInput(
43	!	inputId = ns("level"),
44	!	label = tr_("Ellipse level:"),
45	!	selected = "0.95",
46	!	choiceNames = c("68%", "95%", "99%"),
47	!	choiceValues = c("0.68", "0.95", "0.99")
48		),
49	!	checkboxInput(inputId = ns("grid"), label = tr_("Grid"), value = TRUE)
50	!	), # sidebar
51	!	helpText(
52	!	tr_("Click and drag to select an area, then double-click to zoom in."),
53	!	tr_("Double-click again to reset the zoom.")
54		),
55	!	layout_columns(
56	!	col_widths = c(8, 4),
57	!	output_plot(
58	!	id = ns("plot"),
59	!	tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, asp = TRUE),
60	!	title = tr_("Scatter Plot"),
61	!	click = ns("plot_click"),
62	!	dblclick = ns("plot_dblclick"),
63	!	brush = brushOpts(
64	!	id = ns("plot_brush"),
65	!	resetOnNew = TRUE
66		),
67	!	height = "100%"
68		),
69	!	card(
70	!	helpText(tr_("Click the plot to select rows of data.")),
71	!	gt::gt_output(outputId = ns("info"))
72		)
73		)
74	!	) # layout_sidebar
75	!	) # nav_panel
76		}
77
78		# Server =======================================================================
79		#' Scatter Plot Server
80		#'
81		#' @param id An ID string that corresponds with the ID used to call the module's
82		#' UI function.
83		#' @param x A reactive [`data.frame`].
84		#' @return
85		#' No return value, called for side effects.
86		#' @seealso [scatter_ui()]
87		#' @family plot modules
88		#' @keywords internal
89		#' @export
90		scatter_server <- function(id, x) {
91	!	stopifnot(is.reactive(x))
92
93	!	moduleServer(id, function(input, output, session) {
94		## Select columns -----
95	!	quanti <- reactive({
96	!	req(x())
97	!	i <- which(arkhe::detect(x = x(), f = is.numeric, margin = 2))
98	!	colnames(x())[i]
99		})
100	!	quali <- reactive({
101	!	req(x())
102	!	i <- which(arkhe::detect(x = x(), f = is.numeric, margin = 2, negate = TRUE))
103	!	colnames(x())[i]
104		})
105	!	axis1 <- update_selectize_values("axis1", x = quanti)
106	!	axis2 <- update_selectize_values("axis2", x = quanti, exclude = axis1)
107	!	extra_quali <- update_selectize_values("extra_quali", x = quali)
108	!	extra_quanti <- update_selectize_values("extra_quanti", x = quanti)
109
110		## Interactive zoom -----
111		## When a double-click happens, check if there's a brush on the plot.
112		## If so, zoom to the brush bounds; if not, reset the zoom.
113	!	range_plot <- reactiveValues(x = NULL, y = NULL)
114	!	observe({
115	!	range_plot$x <- brush_xlim(input$plot_brush)
116	!	range_plot$y <- brush_ylim(input$plot_brush)
117		}) \|>
118	!	bindEvent(input$plot_dblclick)
119	!	info <- reactive({
120		## With base graphics, need to tell it what the x and y variables are.
121	!	nearPoints(x(), input$plot_click, xvar = axis1(), yvar = axis2(),
122	!	threshold = 5)
123		})
124
125		## Linear regression -----
126	!	model <- reactive({
127	!	req(x(), axis2(), axis1())
128	!	if (!isTRUE(input$regression)) return(NULL)
129
130	!	n <- nrow(x())
131	!	group <- if (isTruthy(extra_quali())) x()[[extra_quali()]] else rep("", n)
132	!	by(
133	!	data = x(),
134	!	INDICES = group,
135	!	FUN = function(x) {
136	!	vars <- stats::as.formula(sprintf("%s~%s", axis2(), axis1()))
137	!	fit <- stats::lm(vars, data = x)
138	!	pred <- stats::predict(fit, interval = "confidence", level = as.numeric(input$level))
139	!	list(model = fit, predict = pred, response = x[[axis1()]])
140		},
141	!	simplify = FALSE
142		)
143		})
144
145		## Ellipses -----
146	!	wrap <- reactive({
147	!	req(x())
148	!	level <- as.numeric(input$level)
149	!	group <- if (isTruthy(extra_quali())) x()[[extra_quali()]] else NULL
150	!	switch(
151	!	input$wrap,
152	!	tol = function(x, y, ...) dimensio::viz_tolerance(x, y, group = group, level = level, ...),
153	!	conf = function(x, y, ...) dimensio::viz_confidence(x, y, group = group, level = level, ...),
154	!	hull = function(x, y, ...) dimensio::viz_hull(x, y, group = group, ...),
155	!	function(...) invisible()
156		)
157		})
158
159		## Graphical parameters -----
160	!	param <- graphics_server("par")
161
162		## Build plot -----
163	!	plot_scatter <- reactive({
164		## Select data
165	!	req(x(), axis1(), axis2())
166
167	!	col <- param$col_quali(x()[[extra_quali()]])
168	!	pch <- param$pch(x()[[extra_quali()]])
169	!	cex <- param$cex(x()[[extra_quanti()]])
170
171		## Build plot
172	!	function() {
173	!	graphics::plot(
174	!	x = x()[[axis1()]],
175	!	y = x()[[axis2()]],
176	!	type = "p",
177	!	xlim = range_plot$x,
178	!	ylim = range_plot$y,
179	!	xlab = axis1(),
180	!	ylab = axis2(),
181	!	panel.first = if (isTRUE(input$grid)) graphics::grid() else NULL,
182	!	col = col,
183	!	pch = pch,
184	!	cex = cex,
185	!	asp = param$asp,
186	!	las = 1
187		)
188
189		## Add regression
190	!	if (length(model()) > 0) {
191	!	col_lines <- param$col_quali(names(model()))
192	!	for (i in seq_along(model())) {
193	!	fit <- model()[[i]]
194	!	k <- order(fit$response)
195	!	graphics::lines(x = fit$response[k], y = fit$predict[k, 1],
196	!	col = col_lines[i], lwd = 2)
197		}
198		}
199
200		## Add ellipses
201	!	wrap()(x = x()[[axis1()]], y = x()[[axis2()]], color = param$pal_quali)
202
203		## Add legend
204	!	if (isTruthy(extra_quali())) {
205	!	graphics::legend(
206	!	x = "topleft",
207	!	legend = unique(x()[[extra_quali()]]),
208	!	col = unique(col),
209	!	pch = unique(pch)
210		)
211		}
212		}
213		})
214
215		## Render table -----
216	!	output$info <- gt::render_gt({
217	!	gt::gt(info(), rownames_to_stub = TRUE) \|>
218	!	gt::tab_options(table.width = "100%")
219		})
220
221		## Render plot -----
222	!	render_plot("plot", x = plot_scatter)
223		})
224		}

1		# HELPERS
2
3		## https://michaelchirico.github.io/potools/articles/developers.html
4		tr_ <- function(...) {
5	23x	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	2x	validate(need(x, message = tr_("Import a CSV file first.")))
34		}
35		validate_dim <- function(x, i = 1, j = 1) {
36	20x	rows <- ngettext(i, "Select at least %d row.", "Select at least %d rows.")
37	20x	cols <- ngettext(j, "Select at least %d column.", "Select at least %d columns.")
38	20x	validate(need(NROW(x) >= i, sprintf(rows, i)), errorClass = "kinesis")
39	19x	validate(need(NCOL(x) >= j, sprintf(cols, j)), errorClass = "kinesis")
40		}
41		validate_na <- function(x) {
42	3x	validate(need(!anyNA(x), tr_("Your data should not contain missing values.")),
43	3x	errorClass = "kinesis")
44		}
45		validate_zero <- function(x) {
46	3x	validate(need(all(x != 0), tr_("Your data should not contain zeros.")),
47	3x	errorClass = "kinesis")
48		}
49
50		#' Default Value for Falsy
51		#'
52		#' Replaces a [falsy][shiny::isTruthy] value with a default value.
53		#' @param x,y An object.
54		#' @return If `x` is not [truthy][shiny::isTruthy()], returns `y`;
55		#' otherwise returns `x`.
56		#' @keywords internal
57		#' @noRd
58		`%\|\|\|%` <- function(x, y) {
59	5x	if (isTruthy(x)) x else y
60		}
61
62		# Widgets ======================================================================
63		select_calendar <- function(id, default = "CE") {
64	1x	ns <- NS(id)
65
66	1x	selectizeInput(
67	1x	inputId = ns("calendar"),
68	1x	label = tr_("Calendar"),
69	1x	choices = c("CE", "BCE", "BP", "AD", "BC"),
70	1x	selected = default,
71	1x	multiple = FALSE,
72	1x	options = list(plugins = "remove_button")
73		)
74		}
75		get_calendar <- function(id) {
76	1x	moduleServer(id, function(input, output, session) {
77
78	1x	cal <- reactive({
79	1x	aion::calendar(input$calendar)
80		})
81
82	1x	cal
83		})
84		}
85
86		#' Build Numeric Input
87		#'
88		#' @param id A [`character`] string specifying the namespace.
89		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
90		#' @return
91		#' * `build_numeric_input()` returns a reactive [`numeric`] vector
92		#' (side effect: render numeric input controls).
93		#' * `render_numeric_input()` is called for its side effects
94		#' (creates UI elements).
95		#' @keywords internal
96		build_numeric_input <- function(id, x) {
97	1x	stopifnot(is.reactive(x))
98
99	1x	moduleServer(id, function(input, output, session) {
100		## Get variable names
101	1x	vars <- reactive({ names(x()) })
102
103		## Build UI
104	1x	output$controls <- renderUI({
105	1x	lapply(
106	1x	X = vars(),
107	1x	FUN = function(var) {
108	4x	numericInput(
109	4x	inputId = session$ns(paste0("num_", var)),
110	4x	label = var,
111	4x	value = 0
112		)
113		}
114		)
115		})
116
117		## Get values
118	1x	values <- reactive({
119	1x	vapply(
120	1x	X = paste0("num_", vars()),
121	1x	FUN = function(var, input) input[[var]],
122	1x	FUN.VALUE = numeric(1),
123	1x	input = input
124		)
125		})
126
127	1x	values
128		})
129		}
130
131		#' @rdname build_numeric_input
132		render_numeric_input <- function(id) {
133	!	uiOutput(NS(id, "controls"))
134		}
135
136		#' Updatable Select List
137		#'
138		#' @param id A [`character`] string specifying the namespace.
139		#' @return
140		#' A select list control that can be added to a UI definition
141		#' (see [shiny::selectizeInput()]).
142		#' @keywords internal
143		selectize_ui <- function(id, label = "Choose", multiple = FALSE) {
144	!	ns <- NS(id)
145	!	plugins <- ifelse(isTRUE(multiple), "remove_button", "clear_button")
146	!	options <- list(plugins = plugins)
147
148	!	selectizeInput(
149	!	inputId = ns("selected"),
150	!	label = label,
151	!	choices = NULL,
152	!	selected = NULL,
153	!	multiple = multiple,
154	!	options = options
155		)
156		}
157
158		#' Update a Select List with Column Names
159		#'
160		#' @param id A [`character`] string specifying the namespace (must match
161		#' [selectize_ui()]).
162		#' @param x A reactive `matrix`-like object.
163		#' @param find A predicate [`function`] for column detection
164		#' (see [arkhe::detect()]).
165		#' @param find A predicate [`function`] for column selection
166		#' (see [arkhe::detect()]).
167		#' @param selected A [`character`] vector specifying the initially selected
168		#' value(s).
169		#' @param preserve A [`logical`] scalar: should existing selection be preserved
170		#' on update?
171		#' @param none A [`logical`] scalar: should a placeholder be added as the first
172		#' element?
173		#' @param server A [`logical`] scalar: should server-side selectize be used?
174		#' @return
175		#' A reactive [`character`] vector of column names.
176		#'
177		#' Side effect: change the value of a select input on the client.
178		#' @seealso [selectize_ui()]
179		#' @keywords internal
180		update_selectize_variables <- function(id, x, find = NULL, use = NULL,
181		selected = NULL, preserve = TRUE,
182		none = TRUE, server = TRUE) {
183	9x	stopifnot(is.reactive(x))
184
185	9x	moduleServer(id, function(input, output, session) {
186		## Update UI
187	9x	observe({
188	7x	choices <- colnames(x())
189	7x	found <- rep(TRUE, length(choices))
190	7x	if (!is.null(choices) && is.function(find)) {
191	2x	found <- which(arkhe::detect(x = x(), f = find, margin = 2))
192	2x	choices <- choices[found]
193		}
194	7x	if (length(choices) > 0 && is.function(use)) {
195	!	used <- arkhe::detect(x = x(), f = use, margin = 2)
196	!	selected <- choices[which(found & used)]
197		}
198	7x	if (isTRUE(preserve)) {
199		## Try to keep previous selection, if any
200	7x	keep <- intersect(choices, input$selected)
201	2x	if (length(keep) > 0) selected <- keep
202		}
203	7x	if (isTRUE(none)) {
204	7x	choices <- c(Choose = "", choices)
205		}
206
207	7x	freezeReactiveValue(input, "selected")
208	7x	updateSelectizeInput(
209	7x	inputId = "selected",
210	7x	choices = choices,
211	7x	selected = selected,
212	7x	server = server
213		)
214		}) \|>
215	9x	bindEvent(x())
216
217		## Bookmark
218	9x	onRestored(function(state) {
219	!	updateSelectizeInput(session, "selected", selected = state$input$selected)
220		})
221
222	9x	reactive({
223	16x	req(x()) # Allow to display validation message
224	12x	input$selected[which(input$selected != "")] # Remove placeholder
225		}) \|>
226	9x	debounce(500)
227		})
228		}
229
230		#' Update a Select List with a Vector
231		#'
232		#' @param id A [`character`] string specifying the namespace (must match
233		#' [selectize_ui()]).
234		#' @param x A reactive [`character`] vector.
235		#' @param exclude A reactive [`character`] vector of values to exclude.
236		#' @param preserve A [`logical`] scalar: should existing selection be preserved
237		#' on update?
238		#' @param none A [`logical`] scalar: should a placeholder be added as the first
239		#' element?
240		#' @param server A [`logical`] scalar: should server-side selectize be used?
241		#' @return
242		#' A reactive [`character`] vector of column names.
243		#'
244		#' Side effect: change the value of a select input on the client.
245		#' @seealso [selectize_ui()]
246		#' @keywords internal
247	4x	update_selectize_values <- function(id, x, exclude = reactive({ NULL }),
248		preserve = TRUE, none = TRUE,
249		server = TRUE) {
250	6x	stopifnot(is.reactive(x))
251	6x	stopifnot(is.reactive(exclude))
252
253	6x	moduleServer(id, function(input, output, session) {
254		## Update UI
255	6x	observe({
256	6x	choices <- x()
257	6x	selected <- NULL
258	6x	if (!is.null(exclude())) {
259	2x	choices <- setdiff(choices, exclude())
260		}
261	6x	if (isTRUE(preserve)) {
262		## Try to keep previous selection, if any
263	6x	keep <- intersect(choices, input$selected)
264	!	if (length(keep) > 0) selected <- keep
265		}
266	6x	if (isTRUE(none)) {
267	6x	choices <- c(Choose = "", choices)
268		}
269
270	6x	freezeReactiveValue(input, "selected")
271	6x	updateSelectizeInput(
272	6x	inputId = "selected",
273	6x	choices = choices,
274	6x	selected = selected,
275	6x	server = server
276		)
277		}) \|>
278	6x	bindEvent(x(), exclude())
279
280		## Bookmark
281	6x	onRestored(function(state) {
282	!	updateSelectizeInput(session, "selected", selected = state$input$selected)
283		})
284
285	12x	reactive({ input$selected })
286		})
287		}
288
289		# Notification =================================================================
290		show_notification <- function(text, title = NULL, id = NULL, duration = 5,
291		closeButton = TRUE, type = "default") {
292		# text <- paste0(text, collapse = "\n")
293	2x	if (!is.null(title)) text <- sprintf("%s\n%s", title, text)
294	2x	id <- showNotification(
295	2x	ui = markdown(text, hardbreaks = TRUE),
296	2x	duration = duration,
297	2x	closeButton = closeButton,
298	2x	id = id,
299	2x	type = type
300		)
301	2x	invisible(id)
302		}
303
304		#' Notify
305		#'
306		#' Shows a notification if an expression raises an error or a warning.
307		#' @param expr An expression to be evaluated.
308		#' @param what A [`character`] string giving the title of the notification.
309		#' @return The result of `expr` or `NULL`.
310		#' @keywords internal
311		#' @noRd
312		notify <- function(expr, title = NULL) {
313	10x	warn <- err <- NULL
314
315	10x	res <- withCallingHandlers(
316	10x	tryCatch(
317	10x	expr,
318	10x	error = function(e) {
319	1x	if (!inherits(e, "shiny.silent.error")) { # Ignore silent error
320	1x	err <<- conditionMessage(e)
321		}
322	1x	return(NULL)
323		}
324		),
325	10x	warning = function(w) {
326	1x	warn <<- append(warn, conditionMessage(w))
327	1x	invokeRestart("muffleWarning")
328		}
329		)
330
331	10x	if (!is.null(err))
332	1x	show_notification(text = err, title = title, type = "error")
333	10x	if (!is.null(warn))
334	1x	show_notification(text = warn, title = title, type = "warning")
335
336	10x	res
337		}
338
339		#' Compare Two \R Objects
340		#'
341		#' Shows a notification if `x` and `y` are not [identical][identical()].
342		#' @param x A reactive object.
343		#' @param y A reactive object.
344		#' @param title A [`character`] string giving the title of the notification.
345		#' @return
346		#' No return value, called for side effects.
347		#' @keywords internal
348		#' @noRd
349		notify_change <- function(id, x, y, title = "Important message") {
350	!	stopifnot(is.reactive(x))
351	!	stopifnot(is.reactive(y))
352
353	!	moduleServer(id, function(input, output, session) {
354	!	observe({
355	!	if (identical(x(), y())) {
356	!	removeNotification(id)
357		} else {
358	!	txt <- paste(tr_("Your data seem to have changed."),
359	!	tr_("You should perform your analysis again."), sep = " ")
360	!	show_notification(id = id, text = txt, title = title,
361	!	duration = NULL, closeButton = FALSE,
362	!	type = "warning")
363		}
364		}) \|>
365	!	bindEvent(x(), y())
366		})
367		}

1		# UI ===========================================================================
2		#' Bertin Diagrams UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @param title A [`character`] string giving the plot title.
6		#' @return
7		#' A nav item that may be passed to a nav container
8		#' (e.g. [bslib::navset_tab()]).
9		#' @seealso [bertin_server()]
10		#' @family count data modules
11		#' @keywords internal
12		#' @export
13		bertin_ui <- function(id, title = NULL) {
14		# Create a namespace function using the provided id
15	!	ns <- NS(id)
16
17	!	nav_panel(
18	!	title = tr_("Plot"),
19	!	layout_sidebar(
20	!	sidebar = sidebar(
21		## Input: select plot
22	!	radioButtons(
23	!	inputId = ns("type"),
24	!	label = tr_("Plot type"),
25	!	selected = "ford",
26	!	choiceNames = c(tr_("Ford diagram"), tr_("Bertin barplot"),
27	!	tr_("Bertin scalogram"), tr_("Heatmap")),
28	!	choiceValues = c("ford", "barplot", "scalogram", "heatmap")
29		),
30	!	conditionalPanel(
31	!	condition = "input.type == 'ford'",
32	!	ns = ns,
33	!	checkboxInput(
34	!	inputId = ns("eppm"),
35	!	label = "EPPM",
36	!	value = FALSE
37		),
38	!	checkboxInput(
39	!	inputId = ns("weights"),
40	!	label = tr_("Weights"),
41	!	value = FALSE
42		),
43	!	helpText(info_article(author = "Desachy", year = "2004", doi = "10.3406/pica.2004.2396")),
44		),
45	!	conditionalPanel(
46	!	condition = "input.type == 'barplot'",
47	!	ns = ns,
48	!	radioButtons(
49	!	inputId = ns("threshold"),
50	!	label = tr_("Threshold"),
51	!	selected = "none",
52	!	choiceNames = c(tr_("None"), tr_("Mean"), tr_("Median")),
53	!	choiceValues = c("none", "mean", "median")
54		)
55		)
56		),
57	!	output_plot(
58	!	id = ns("plot"),
59	!	height = "100%",
60	!	title = title,
61	!	tools = graphics_ui(ns("par"), pch = FALSE, lty = FALSE, cex = FALSE)
62		)
63		)
64		)
65		}
66
67		# Server =======================================================================
68		#' Bertin Diagrams Server
69		#'
70		#' @param id An ID string that corresponds with the ID used to call the module's
71		#' UI function.
72		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
73		#' @param verbose A [`logical`] scalar: should \R report extra information on
74		#' progress?
75		#' @return
76		#' No return value, called for side effects.
77		#' @seealso [bertin_ui()]
78		#' @family count data modules
79		#' @keywords internal
80		#' @export
81		bertin_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
82	!	stopifnot(is.reactive(x))
83
84	!	moduleServer(id, function(input, output, session) {
85		## Get count data -----
86	!	counts <- reactive({
87	!	req(x())
88	!	arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
89		})
90
91		## Graphical parameters -----
92	!	param <- graphics_server("par")
93
94		## Plot -----
95	!	plot_permute <- reactive({
96	!	req(counts())
97
98	!	threshold <- switch(
99	!	input$threshold,
100	!	mean = mean,
101	!	median = stats::median,
102	!	none = NULL
103		)
104
105	!	switch(
106	!	input$type,
107	!	ford = function()
108	!	tabula::plot_ford(counts(), weights = input$weights, EPPM = input$eppm),
109	!	barplot = function()
110	!	tabula::plot_bertin(counts(), threshold = threshold),
111	!	scalogram = function()
112	!	tabula::plot_spot(counts(), color = "black", legend = FALSE),
113	!	heatmap = function()
114	!	tabula::plot_heatmap(counts(), color = param$pal_quant, fixed_ratio = FALSE)
115		)
116		})
117
118		## Render plot -----
119	!	render_plot("plot", x = plot_permute)
120		})
121		}

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) {
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	!	nav_panel(
49	!	title = tr_("Bookmark"),
50	!	tags$p(
51	!	tr_("You can save the state of the application and get a URL which will restore the application with that state."),
52	!	tr_("You can then copy the URL and save it for later, or share it with others so they can visit the application in the bookmarked state.")
53		),
54	!	tags$p(
55	!	tr_("This is not intended for long-term storage."),
56	!	tr_("There is no guarantee as to how long your bookmark will last.")
57		),
58	!	if (get_option("bookmark", FALSE)) {
59	!	tags$div(class = "d-grid d-md-block", bookmarkButton())
60		} else {
61	!	tags$p(tr_("Bookmarking is currently disabled."))
62		}
63		)
64	!	) # navset_card_pill
65	!	) # layout_sidebar
66	!	) # nav_panel
67		}
68
69		#' Footer UI
70		#'
71		#' @param id A [`character`] vector to be used for the namespace.
72		#' @return
73		#' A [`list`] that can be converted into an HTML `<footer>` tag
74		#' (see [htmltools::tags()]).
75		#' @seealso [footer_server()]
76		#' @family page modules
77		#' @keywords internal
78		#' @export
79		footer_ui <- function(id) {
80		# Create a namespace function using the provided id
81	!	ns <- NS(id)
82
83	!	tags$footer(
84	!	style = "border-top: 1px; margin-top: 1em; width: 100%; text-align: center;",
85	!	tags$p(
86	!	actionLink(inputId = ns("session"), label = tr_("Session info")),
87	!	HTML(" · "),
88	!	tags$a(href = "https://codeberg.org/tesselle/kinesis",
89	!	target = "_blank", rel = "external", tr_("Source code")),
90	!	HTML(" · "),
91	!	tags$a(href = "https://codeberg.org/tesselle/kinesis/issues",
92	!	target = "_blank", rel = "external", tr_("Report a bug or request"))
93		)
94		)
95		}
96
97		# Server =======================================================================
98		#' Home Server
99		#'
100		#' @param id An ID string that corresponds with the ID used to call the module's
101		#' UI function.
102		#' @return
103		#' No return value, called for side effects.
104		#' @seealso [home_ui()]
105		#' @family page modules
106		#' @keywords internal
107		#' @export
108		home_server <- function(id) {
109	!	moduleServer(id, function(input, output, session) {
110		## Bookmark -----
111	!	onBookmark(function(state) {
112	!	saved_time <- Sys.time()
113
114	!	msg <- sprintf(tr_("Last saved at %s."), saved_time)
115	!	showNotification(
116	!	ui = msg,
117	!	duration = 5,
118	!	closeButton = TRUE,
119	!	type = "message",
120	!	session = session
121		)
122	!	message(msg)
123
124		# state is a mutable reference object,
125		# we can add arbitrary values to it.
126	!	state$values$time <- saved_time
127		})
128
129	!	onRestore(function(state) {
130	!	msg <- sprintf(tr_("Restoring from state bookmarked at %s."), state$values$time)
131	!	showNotification(
132	!	ui = msg,
133	!	duration = 5,
134	!	closeButton = TRUE,
135	!	type = "message",
136	!	session = session
137		)
138	!	message(msg)
139		})
140
141		## Render -----
142	!	output$session <- renderPrint({ utils::sessionInfo() })
143		})
144		}
145
146		#' Footer Server
147		#'
148		#' @param id An ID string that corresponds with the ID used to call the module's
149		#' UI function.
150		#' @return
151		#' No return value, called for side effects.
152		#' @seealso [footer_ui()]
153		#' @family page modules
154		#' @keywords internal
155		#' @export
156		footer_server <- function(id) {
157	!	moduleServer(id, function(input, output, session) {
158	!	observeEvent(input$session, {
159	!	showModal(
160	!	modalDialog(
161	!	title = tr_("Session info"),
162	!	info_session(),
163	!	size = "xl",
164	!	easyClose = TRUE,
165	!	footer = modalButton(tr_("Close"))
166		)
167		)
168		})
169		})
170		}
171
172		#' Collect Information About the Current R Session
173		#'
174		#' @param ... Currently not used.
175		#' @return Text marked as HTML.
176		#' @keywords internal
177		#' @noRd
178		info_session <- function(...) {
179	!	info <- paste0(utils::capture.output(utils::sessionInfo()), collapse = "\n")
180	!	markdown(sprintf("```\n%s\n```", info))
181		}

1		# UI ===========================================================================
2		#' Compositional 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 [coda_server()]
9		#' @family coda modules
10		#' @keywords internal
11		#' @export
12		coda_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_("Compositional Data"),
23	!	import_ui(ns("import")),
24	!	select_ui(ns("select")),
25	!	clean_ui(ns("clean"))
26	!	), # sidebar
27		## Output: value box
28	!	box_ui(ns("box")),
29	!	navset_card_pill(
30	!	placement = "above",
31	!	nav_panel(
32	!	title = tr_("Data"),
33	!	layout_sidebar(
34	!	sidebar = sidebar(
35	!	selectize_ui(
36	!	id = ns("group"),
37	!	label = tooltip(
38	!	trigger = span(
39	!	tr_("Group by"),
40	!	icon("info-circle")
41		),
42	!	tr_("You can use a qualitative variable to assign each sample to a (reference) group."),
43	!	tr_("Missing values will be interpreted as unassigned samples.")
44		),
45	!	multiple = TRUE
46		),
47	!	selectize_ui(
48	!	id = ns("condense"),
49	!	label = tooltip(
50	!	trigger = span(
51	!	tr_("Condense by"),
52	!	icon("info-circle")
53		),
54	!	tr_("You can use one or more categorical variable to split the data into subsets and compute the compositional mean for each."),
55	!	tr_("Usefull if your data contain several observations for the same sample (e.g. repeated measurements).")
56		),
57	!	multiple = TRUE
58		),
59	!	), # sidebar
60		## Output: display data
61	!	checkboxInput(inputId = ns("head"), label = tr_("Overview"), value = TRUE),
62	!	gt::gt_output(outputId = ns("table"))
63	!	) # layout_sidebar
64		),
65	!	nav_panel(
66	!	title = tr_("Missing values"),
67	!	missing_ui(ns("missing"))
68		)
69		),
70	!	border_radius = FALSE,
71	!	fillable = TRUE,
72	!	) # layout_sidebar
73	!	) # nav_panel
74		}
75
76		# Server =======================================================================
77		#' Compositional Data Server
78		#'
79		#' @param id An ID string that corresponds with the ID used to call the module's
80		#' UI function.
81		#' @param demo A [`character`] string specifying the name of a dataset (see
82		#' [import_server()]).
83		#' @param verbose A [`logical`] scalar: should \R report extra information
84		#' on progress?
85		#' @return A reactive [`nexus::CompositionMatrix-class`] object.
86		#' @seealso [coda_ui()]
87		#' @family coda modules
88		#' @keywords internal
89		#' @export
90		coda_server <- function(id, demo = NULL, verbose = get_option("verbose", FALSE)) {
91	1x	moduleServer(id, function(input, output, session) {
92		## Prepare data -----
93	1x	data_raw <- import_server("import", demo = demo)
94	1x	data_clean <- data_raw \|>
95	1x	select_server("select", x = _, find_col = is.numeric, min_col = 3) \|>
96	1x	clean_server("clean", x = _)
97
98		## Update UI -----
99	1x	col_group <- update_selectize_variables(id = "group", x = data_raw, find = Negate(is.numeric))
100	1x	col_condense <- update_selectize_variables(id = "condense", x = data_raw)
101
102		## Compositions -----
103	1x	coda <- reactive({
104	2x	req(data_clean())
105
106	1x	notify(
107	1x	nexus::as_composition(
108	1x	from = data_clean(),
109	1x	parts = seq_len(ncol(data_clean())),
110	1x	autodetect = FALSE,
111	1x	verbose = verbose
112		),
113	1x	title = tr_("Compositional Data")
114		)
115		})
116
117		## Group -----
118	1x	data_group <- reactive({
119	3x	req(coda())
120
121	2x	out <- coda()
122	2x	if (isTruthy(col_group())) {
123	1x	by <- data_raw()[col_group()]
124	1x	if (all(lengths(by) == nrow(out))) {
125	1x	out <- nexus::group(out, by = by, verbose = verbose)
126		}
127		}
128
129	2x	out
130		})
131
132		## Condense -----
133	1x	data_condense <- reactive({
134	4x	req(data_group())
135
136	3x	out <- data_group()
137	3x	if (isTruthy(col_condense())) {
138	1x	by <- data_raw()[col_condense()]
139	1x	if (all(lengths(by) == nrow(out))) {
140	1x	out <- nexus::condense(out, by = by, ignore_na = FALSE, verbose = verbose)
141		}
142		}
143
144	3x	out
145		})
146
147		## Missing values -----
148	1x	data_missing <- missing_server("missing", x = data_condense)
149
150		## Zeros -----
151		# TODO
152
153		## Value box -----
154	1x	box_server("box", x = data_missing)
155
156		## Check -----
157	1x	data_valid <- reactive({
158	4x	validate_dim(data_missing(), i = 1, j = 3)
159	3x	validate_na(data_missing())
160	3x	validate_zero(data_missing())
161
162	3x	data_missing()
163		})
164
165		## Render tables -----
166	1x	output$table <- gt::render_gt({
167	4x	req(data_valid())
168	3x	tbl <- as.data.frame(data_valid(), group_var = tr_("Group"))
169	3x	tbl <- if (isTRUE(input$head)) utils::head(tbl) else tbl
170	3x	gt::gt(tbl, rownames_to_stub = TRUE) \|>
171	3x	gt::tab_options(table.width = "100%")
172		})
173
174	1x	data_valid
175		})
176		}
177
178		# Modules ======================================================================
179		## Imputation ------------------------------------------------------------------
180		coda_zero_ui <- function(id) {
181	!	ns <- NS(id)
182
183	!	list(
184	!	helpText(
185	!	tr_("If your data contains zeros, these can be considered as values below the detection limit (i.e. small unknown values)."),
186	!	tr_("In this case, you can define the detection limit for each compositional part below."),
187	!	tr_("If all limits are specified, zeros will be replaced by a fraction of these limits."),
188	!	tr_("For computational details, see"),
189	!	cite_article("Martin-Fernandez et al.", "2003", doi = "10.1023/A:1023866030544", text = TRUE)
190		),
191	!	numericInput(
192	!	inputId = ns("delta"),
193	!	label = tr_("Fraction"),
194	!	value = 2 / 3,
195	!	min = 0,
196	!	max = 1
197		),
198	!	uiOutput(outputId = ns("values")),
199	!	actionButton(inputId = ns("go"), tr_("Replace zero"))
200		)
201		}
202		coda_zero_server <- function(id, x) {
203	1x	stopifnot(is.reactive(x))
204
205	1x	moduleServer(id, function(input, output, session) {
206	1x	data <- reactiveValues(values = NULL)
207
208		## Build UI
209	1x	ids <- reactive({
210	!	if (is.null(colnames(x()))) return(NULL)
211	1x	data$values <- x()
212	1x	paste0("limit_", colnames(x()))
213		})
214
215	1x	ui <- reactive({
216	1x	req(ids())
217
218	1x	ui <- lapply(
219	1x	X = ids(),
220	1x	FUN = function(i) {
221	3x	numericInput(
222	3x	inputId = session$ns(i),
223	3x	label = paste(sub("limit_", "", i), "(%)", sep = " "),
224	3x	value = 0, min = 0, max = 100
225		)
226		}
227		)
228
229	1x	do.call(layout_column_wrap, args = c(ui, width = 1/4))
230		})
231	1x	output$values <- renderUI({ ui() })
232	1x	outputOptions(output, "values", suspendWhenHidden = FALSE)
233
234		## Compute
235	1x	observe({
236	1x	req(ids())
237	1x	limits <- lapply(X = ids(), FUN = function(i, x) x[[i]], x = input)
238	1x	if (all(lengths(limits) != 0) \|\| all(limits > 0)) {
239	1x	limits <- unlist(limits) / 100
240	1x	data$values <- nexus::replace_zero(
241	1x	x = x(),
242	1x	value = limits,
243	1x	delta = input$delta
244		)
245		}
246		}) \|>
247	1x	bindEvent(input$go)
248
249		## Bookmark
250	1x	onRestored(function(state) {
251	!	req(ui())
252	!	for (i in ids()) {
253	!	updateNumericInput(session, session$ns(i), value = state$input[[i]])
254		}
255		})
256
257	2x	reactive({ data$values })
258		})
259		}

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

1		# UI ===========================================================================
2		#' Compositional Data Outliers 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_outliers_server()]
9		#' @family coda modules
10		#' @keywords internal
11		#' @export
12		coda_outliers_ui <- function(id) {
13		## Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Outliers"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	h5(tr_("Outliers Detection")),
22	!	helpText(
23	!	tr_("See"),
24	!	cite_article("Filzmoser & Hron", "2008", "10.1007/s11004-007-9141-5", after = ";"),
25	!	cite_article("Filzmoser, Hron & Reimann", "2012", "10.1016/j.cageo.2011.06.014", after = ".")
26		),
27	!	radioButtons(
28	!	inputId = ns("method"),
29	!	label = tr_("Multivariate location estimation"),
30	!	choiceNames = c(tr_("Minimum volume ellipsoid"),
31	!	tr_("Minimum covariance determinant")),
32	!	choiceValues = c("mve", "mcd")
33		),
34	!	sliderInput(
35	!	inputId = ns("quantile"),
36	!	label = tr_("Quantile"),
37	!	min = 0.025, max = 0.995,
38	!	value = 0.975, step = 0.005
39		),
40	!	actionButton(inputId = ns("go"), label = tr_("(Re)Detect")),
41	!	downloadButton(outputId = ns("download"), tr_("Download results"))
42	!	), # sidebar
43	!	layout_columns(
44	!	col_widths = "50%",
45	!	output_plot(
46	!	id = ns("plot"),
47	!	title = tr_("Plot")
48		),
49	!	div(
50	!	radioButtons(
51	!	inputId = ns("type"),
52	!	label = tr_("Plot type"),
53	!	choices = c("dotchart", "distance")
54		),
55	!	tableOutput(outputId = ns("info"))
56		)
57	!	) # layout_columns
58	!	) # layout_sidebar
59	!	) # nav_panel
60		}
61
62		# Server =======================================================================
63		#' Compositional Data Outliers Server
64		#'
65		#' @param id An ID string that corresponds with the ID used to call the module's
66		#' UI function.
67		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
68		#' @return A reactive [`nexus::OutlierIndex-class`] object.
69		#' @seealso [coda_outliers_ui()]
70		#' @family coda modules
71		#' @keywords internal
72		#' @export
73		coda_outliers_server <- function(id, x) {
74	!	stopifnot(is.reactive(x))
75
76	!	moduleServer(id, function(input, output, session) {
77		## Detect outliers -----
78	!	out <- reactive({
79	!	validate(need(x(), tr_("Check your data.")))
80
81	!	notify(
82		{
83	!	nexus::detect_outlier(
84	!	x(),
85	!	method = input$method,
86	!	quantile = input$quantile
87		)
88		},
89	!	title = tr_("Outliers Detection")
90		)
91		}) \|>
92	!	bindEvent(input$go)
93
94		## Plot -----
95	!	plot <- reactive({
96	!	req(out())
97	!	function() {
98	!	plot(out(), type = input$type)
99		}
100		})
101	!	render_plot("plot", x = plot)
102
103		## Get data -----
104	!	results <- reactive({
105	!	req(out())
106	!	as.data.frame(out())
107		})
108
109		## Download results -----
110	!	output$download <- export_table(results, name = "coda_outliers")
111
112	!	out
113		})
114		}

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		## Select columns -----
153	1x	data_raw <- reactive({
154	1x	as.data.frame(x())
155		})
156	1x	quanti <- reactive({
157	1x	req(data_raw())
158	1x	i <- which(arkhe::detect(x = data_raw(), f = is.numeric, margin = 2))
159	1x	colnames(data_raw())[i]
160		})
161	1x	quali <- reactive({
162	1x	req(data_raw())
163	1x	i <- which(arkhe::detect(x = data_raw(), f = Negate(is.numeric), margin = 2))
164	1x	colnames(data_raw())[i]
165		})
166	1x	axis1 <- update_selectize_values("axis1", x = quanti)
167	1x	axis2 <- update_selectize_values("axis2", x = quanti, exclude = axis1)
168	3x	axis12 <- reactive({ c(axis1(), axis2()) })
169	1x	axis3 <- update_selectize_values("axis3", x = quanti, exclude = axis12)
170	1x	extra_quali <- update_selectize_values("extra_quali", x = quali)
171	1x	extra_quanti <- update_selectize_values("extra_quanti", x = quanti)
172
173		## Interactive zoom -----
174		## When a double-click happens, check if there's a brush on the plot.
175		## If so, zoom to the brush bounds; if not, reset the zoom.
176	1x	range_ternplot <- reactiveValues(x = NULL, y = NULL)
177	1x	observe({
178	!	range_ternplot$x <- brush_xlim(input$ternplot_brush)
179	!	range_ternplot$y <- brush_ylim(input$ternplot_brush)
180		}) \|>
181	1x	bindEvent(input$ternplot_dblclick)
182
183		## Get ternary data -----
184	1x	data_tern <- reactive({
185	4x	req(data_raw(), axis1(), axis2(), axis3())
186	1x	tern <- data_raw()[, c(axis1(), axis2(), axis3())]
187	1x	tern[rowSums(tern, na.rm = TRUE) != 0, , drop = FALSE]
188		})
189
190		## Graphical parameters -----
191	1x	param <- graphics_server("par")
192
193		## Build plot -----
194	1x	plot_ternary <- reactive({
195		## Select data
196	6x	req(data_tern())
197	3x	tern <- data_tern()
198	3x	n <- nrow(tern)
199
200		## Compute center and scale
201	3x	no_scale <- isFALSE(input$center) && isFALSE(input$scale)
202
203		## Graphical parameters
204	3x	if (isTruthy(extra_quali())) {
205	1x	symbol_group <- data_raw()[[extra_quali()]]
206	1x	col <- param$col_quali(symbol_group)
207		} else {
208	2x	symbol_group <- rep("", n)
209	2x	col <- param$col_quant(data_raw()[[extra_quanti()]])
210		}
211	2x	pch <- param$pch(data_raw()[[extra_quali()]])
212	1x	cex <- param$cex(data_raw()[[extra_quanti()]])
213
214		## Window
215	1x	range_coord <- list(x = NULL, y = NULL, z = NULL)
216	1x	if (isTruthy(range_ternplot$x) && isTruthy(range_ternplot$y)) {
217	!	x_pts <- c(range_ternplot$x, mean(range_ternplot$x))
218	!	y_pts <- c(range_ternplot$y, sqrt(3) * diff(range_ternplot$y) / 2)
219	!	range_coord <- isopleuros::coordinates_cartesian(x = x_pts, y = y_pts)
220		}
221
222		## Heatmap
223	1x	bin <- as.numeric(input$bin)
224	1x	fun_tile <- switch(
225	1x	input$tile,
226	1x	bin = isopleuros::tile_bin(tern),
227	1x	dens = isopleuros::tile_density(tern),
228	1x	NULL
229		)
230
231		## Envelope
232	!	level <- as.numeric(input$level)
233	!	fun_wrap <- switch(
234	!	input$wrap,
235	!	tol = function(x, ...) isopleuros::ternary_tolerance(x, level = level, ...),
236	!	conf = function(x, ...) isopleuros::ternary_confidence(x, level = level, ...),
237	!	hull = function(x, ...) isopleuros::ternary_hull(x, ...),
238	!	function(...) invisible()
239		)
240
241		## Build plot
242	!	function() {
243	!	oldpar <- graphics::par(mar = c(1, 1, 1, 1), no.readonly = TRUE)
244	!	on.exit(graphics::par(oldpar))
245
246	!	z <- isopleuros::ternary_plot(
247	!	x = tern,
248	!	type = "n",
249	!	xlim = range_coord$x,
250	!	ylim = range_coord$y,
251	!	zlim = range_coord$z,
252	!	xlab = axis1(),
253	!	ylab = axis2(),
254	!	zlab = axis3(),
255	!	center = input$center,
256	!	scale = input$scale
257		)
258
259		## Add grid
260	!	if (isTRUE(input$grid)) {
261	!	isopleuros::ternary_grid(center = z$center, scale = z$scale)
262		}
263
264	!	if (no_scale) {
265		## Heatmap
266	!	if (isTruthy(fun_tile)) {
267	!	isopleuros::ternary_image(
268	!	f = fun_tile,
269	!	n = bin,
270	!	palette = param$col_quant
271		)
272		}
273
274		## Density contours
275	!	if (isTRUE(input$density)) {
276	!	isopleuros::ternary_density(tern)
277		}
278
279		## Envelope
280	!	for (i in split(seq_len(n), f = symbol_group)) {
281	!	z <- tern[i, , drop = FALSE]
282	!	if (nrow(z) < 3) next
283	!	fun_wrap(z, lty = 1, border = col[i])
284		}
285		}
286
287		## Add points
288	!	if (isTRUE(input$points)) {
289	!	isopleuros::ternary_points(tern, col = col, pch = pch, cex = cex,
290	!	center = z$center, scale = z$scale)
291		}
292
293		## Add labels
294	!	if (isTRUE(input$labels)) {
295	!	isopleuros::ternary_labels(tern, center = z$center, scale = z$scale,
296	!	labels = rownames(tern), col = col)
297		}
298
299		## Add legend
300	!	if (isTruthy(extra_quali())) {
301	!	graphics::legend(
302	!	x = "topleft",
303	!	legend = unique(symbol_group),
304	!	col = unique(col),
305	!	pch = unique(pch),
306	!	bty = "n"
307		)
308		}
309		}
310		})
311
312		## Render plot -----
313	1x	render_plot("ternplot", x = plot_ternary)
314		})
315		}

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_variables("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		#' 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		)
28		}
29
30		#' Import Data Modal
31		#'
32		#' @param ns A [namespace][shiny::NS()] function.
33		#' @return
34		#' A [`list`] of UI elements.
35		#' @seealso [import_server()]
36		#' @keywords internal
37		#' @noRd
38		import_modal <- function(ns) {
39	!	modalDialog(
40	!	size = "xl",
41	!	easyClose = FALSE,
42	!	fade = FALSE,
43	!	title = tr_("Import Data"),
44	!	footer = tagList(
45	!	modalButton(tr_("Cancel")),
46	!	actionButton(inputId = ns("go"), label = "OK", class = "btn-primary")
47		),
48	!	layout_column_wrap(
49	!	width = 1/3,
50		## Input: select a file
51	!	div(
52	!	tags$p(
53	!	helpText(tr_("Select the location of, and the file you want to upload.")),
54	!	helpText(tr_("Please check the default settings and adjust them to your data.")),
55	!	helpText(tr_("This application only supports data encoded in UFT-8.")),
56		),
57	!	tags$p(
58	!	helpText(tr_("It assumes that you keep your data tidy:")),
59	!	helpText(tr_("each variable must be saved in its own column and each sample must be saved in its own row."))
60		),
61	!	fileInput(
62	!	inputId = ns("file"),
63	!	label = tr_("Choose a CSV or a TSV file:"),
64	!	multiple = FALSE,
65	!	accept = c(".csv", ".tsv", "text/csv", "text/tsv",
66	!	"text/comma-separated-values", "text/tab-separated-values")
67		)
68		),
69	!	div(
70		## Input: checkbox if file has header
71	!	input_switch(
72	!	id = ns("header"),
73	!	label = tr_("Header"),
74	!	value = TRUE
75		),
76		## Input: select decimal
77	!	radioButtons(
78	!	inputId = ns("dec"),
79	!	label = tr_("Decimal"),
80	!	choiceNames = c(tr_("Dot"), tr_("Comma")),
81	!	choiceValues = c(".", ","),
82	!	selected = "."
83		),
84		## Input: select separator
85	!	radioButtons(
86	!	inputId = ns("sep"),
87	!	label = tr_("Separator"),
88	!	choiceNames = c(tr_("Comma"), tr_("Semicolon"), tr_("Tab")),
89	!	choiceValues = c(",", ";", "\t"),
90	!	selected = ","
91		),
92		## Input: select quotes
93	!	radioButtons(
94	!	inputId = ns("quote"),
95	!	label = tr_("Quote"),
96	!	choiceNames = c(tr_("None"), tr_("Double quote"), tr_("Single quote")),
97	!	choiceValues = c("", '"', "'"),
98	!	selected = '"'
99		)
100		),
101	!	div(
102		## Input: lines of the data to skip
103	!	numericInput(
104	!	inputId = ns("skip"),
105	!	label = tr_("Lines of the data file to skip:"),
106	!	value = 0,
107	!	min = 0,
108	!	step = 1
109		),
110		## Input: missing string
111	!	textInput(
112	!	inputId = ns("na.strings"),
113	!	label = tr_("String to be interpreted as missing value:"),
114	!	value = ""
115		),
116		## Input: comment
117	!	textInput(
118	!	inputId = ns("comment"),
119	!	label = tr_("Character to be interpreted as comment:"),
120	!	value = "#"
121		)
122		)
123		)
124		)
125		}
126
127		# Server =======================================================================
128		#' Import Data Server
129		#'
130		#' @param id An ID string that corresponds with the ID used to call the module's
131		#' UI function.
132		#' @param demo A [`character`] string specifying the name of a dataset from
133		#' \pkg{folio} or \pkg{datasets}.
134		#' @return A reactive [`data.frame`].
135		#' @seealso [import_ui()]
136		#' @family generic modules
137		#' @keywords internal
138		#' @export
139		import_server <- function(id, demo = NULL) {
140	2x	moduleServer(id, function(input, output, session) {
141	2x	data <- reactiveValues(values = NULL)
142
143		## Show modal dialog -----
144	!	observe({ showModal(import_modal(session$ns)) }) \|>
145	2x	bindEvent(input$upload)
146
147		## Read from connection -----
148	2x	obs <- observe({
149	2x	params <- parseQueryString(session$clientData$url_search)
150	2x	query <- params[["data"]]
151
152	2x	if (!is.null(query)) {
153	!	msg <- sprintf(tr_("Reading data from %s..."), query)
154	!	id <- showNotification(msg, duration = NULL, closeButton = FALSE,
155	!	type = "message")
156	!	on.exit(removeNotification(id), add = TRUE)
157
158	!	data$values <- notify(utils::read.csv(file = url(query)), tr_("Data Input"))
159		}
160	2x	obs$destroy()
161		})
162
163		## Load example data -----
164	2x	observe({
165	!	req(demo)
166	!	tmp <- new.env(parent = emptyenv())
167	!	on.exit(rm(tmp), add = TRUE)
168
169	!	data(list = demo, package = c("folio", "datasets"), envir = tmp)
170	!	data$values <- get(demo, envir = tmp)
171		}) \|>
172	2x	bindEvent(input$demo)
173
174		## Read data file -----
175	2x	observe({
176	3x	id <- showNotification(tr_("Reading data..."), duration = NULL,
177	3x	closeButton = FALSE, type = "message")
178	3x	on.exit(removeNotification(id), add = TRUE)
179
180	3x	x <- notify({
181	3x	utils::read.table(
182	3x	file = input$file$datapath,
183	3x	header = input$header,
184	3x	sep = input$sep,
185	3x	dec = input$dec,
186	3x	quote = input$quote,
187	3x	row.names = NULL,
188	3x	na.strings = input$na.strings,
189	3x	skip = if (!is.na(input$skip)) input$skip else 0,
190	3x	comment.char = input$comment
191		)},
192	3x	title = "Data Upload"
193		)
194
195	2x	if (!is.null(x)) removeModal()
196	3x	data$values <- x
197		}) \|>
198	2x	bindEvent(input$go)
199
200		## Bookmark -----
201	2x	setBookmarkExclude(c("upload", "go"))
202	2x	onBookmark(function(state) state$values$data <- data$values)
203	2x	onRestore(function(state) data$values <- state$values$data)
204
205	2x	reactive({
206	2x	validate_csv(data$values)
207	1x	data$values
208		})
209		})
210		}

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	!	downloadButton(
39	!	outputId = ns("download"),
40	!	label = tr_("Download results")
41		),
42	!	uiOutput(outputId = ns("chi2"))
43	!	), # sidebar
44	!	multivariate_ui(ns("ca")),
45	!	border_radius = FALSE,
46	!	fillable = TRUE
47	!	) # layout_sidebar
48	!	) # nav_panel
49		}
50
51		# Server =======================================================================
52		#' Correspondence Analysis Server
53		#'
54		#' @param id An ID string that corresponds with the ID used to call the module's
55		#' UI function.
56		#' @param x A reactive `data.frame`.
57		#' @return A reactive [`dimensio::PCA-class`] object.
58		#' @seealso [ca_ui()]
59		#' @family multivariate analysis modules
60		#' @keywords internal
61		#' @export
62		ca_server <- function(id, x) {
63	!	stopifnot(is.reactive(x))
64
65	!	moduleServer(id, function(input, output, session) {
66		## Update UI -----
67	!	row_names <- reactive({ rownames(x()) })
68	!	sup_row <- update_selectize_values("sup_row", x = row_names)
69	!	sup_col <- update_selectize_variables("sup_col", x = x, find = is.numeric)
70	!	sup_quali <- update_selectize_variables("sup_quali", x = x, find = Negate(is.numeric))
71
72		## Check data -----
73	!	old <- reactive({ x() }) \|> bindEvent(input$go)
74	!	notify_change(session$ns("change"), x, old, title = tr_("CA"))
75
76		## Compute CA -----
77	!	compute_ca <- ExtendedTask$new(
78	!	function(x, rank, sup_row, sup_col, sup_quali) {
79	!	mirai::mirai({
80	!	param <- list(object = x, rank = rank,
81	!	sup_row = arkhe::seek_rows(x, names = sup_row),
82	!	sup_col = arkhe::seek_columns(x, names = sup_col))
83	!	if (is.data.frame(x)) {
84	!	param$sup_quali <- arkhe::seek_columns(x, names = sup_quali)
85		}
86	!	do.call(dimensio::ca, param)
87	!	}, environment())
88		}
89		) \|>
90	!	bslib::bind_task_button("go")
91
92	!	observe({
93	!	compute_ca$invoke(x = x(), rank = input$rank, sup_row = sup_row(),
94	!	sup_col = sup_col(), sup_quali = sup_quali())
95		}) \|>
96	!	bindEvent(input$go)
97
98	!	results <- reactive({
99	!	notify(compute_ca$result(), title = tr_("Correspondence Analysis"))
100		})
101
102	!	multivariate_server("ca", x = results, y = x)
103
104		## Chi-squared -----
105	!	chi2_test <- reactive({
106	!	req(results())
107	!	x <- dimensio::get_data(results())
108	!	z <- suppressWarnings(stats::chisq.test(x = x))
109
110		# Adjusted Cramer's V [95%CI]
111	!	k <- ncol(x)
112	!	r <- nrow(x)
113	!	n <- sum(x)
114	!	phi <- max(0, (z$statistic / n) - (k - 1) * (r - 1) / (n - 1))
115
116	!	k_bias <- k - (k - 1)^2 / (n - 1)
117	!	r_bias <- r - (r - 1)^2 / (n - 1)
118	!	V <- sqrt(phi / min(k_bias - 1, r_bias - 1))
119
120	!	z$cramer <- V
121	!	z
122		})
123
124	!	output$chi2 <- renderUI({
125	!	list(
126	!	h5(tr_("Chi-squared Test")),
127	!	tags$ul(
128	!	tags$li(
129	!	sprintf(tr_("Statistic: %.0f"), chi2_test()$statistic)
130		),
131	!	tags$li(
132	!	sprintf(tr_("Degrees of freedom: %.0f"), chi2_test()$parameter)
133		),
134	!	tags$li(
135	!	sprintf(tr_("p-value: %s"), format.pval(chi2_test()$p.value, eps = .001))
136		),
137	!	tags$li(
138	!	sprintf(tr_("Cramer's V: %.2f"), chi2_test()$cramer)
139		)
140		)
141		)
142		})
143
144		## Export -----
145	!	output$download <- downloadHandler(
146	!	filename = function() { make_file_name("ca", "zip") },
147	!	content = function(file) {
148	!	dimensio::export(results(), file = file, flags = "-r9Xj")
149		},
150	!	contentType = "application/zip"
151		)
152
153	!	results
154		})
155		}

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	!	downloadButton(
48	!	outputId = ns("download"),
49	!	label = tr_("Download results")
50		)
51	!	), # sidebar
52	!	output_plot(id = ns("plot_ao"))
53	!	) # layout_sidebar
54	!	) # nav_panel
55		}
56
57		# Server =======================================================================
58		#' Aoristic Analysis 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 `list` (returned by [time_interval_server()])
63		#' @return A reactive [`kairos::AoristicSum-class`] object.
64		#' @seealso [aoristic_ui()]
65		#' @family chronology modules
66		#' @keywords internal
67		#' @export
68		aoristic_server <- function(id, x, y) {
69	!	stopifnot(is.reactive(x))
70	!	stopifnot(is.reactive(y))
71
72	!	moduleServer(id, function(input, output, session) {
73		## Update UI -----
74	!	calendar <- get_calendar("calendar")
75	!	lower <- reactive({
76	!	req(x()$results)
77	!	aion::start(x()$results, calendar = calendar())
78		})
79	!	upper <- reactive({
80	!	req(x()$results)
81	!	aion::end(x()$results, calendar = calendar())
82		})
83
84	!	observe({
85	!	updateNumericInput(inputId = "start", value = min(lower(), na.rm = TRUE))
86		}) \|>
87	!	bindEvent(lower())
88	!	observe({
89	!	updateNumericInput(inputId = "end", value = max(upper(), na.rm = TRUE))
90		}) \|>
91	!	bindEvent(upper())
92
93
94		## Check data -----
95	!	old <- reactive({ x() }) \|> bindEvent(input$go)
96	!	notify_change(session$ns("change"), x, old, title = tr_("Aoristic Analysis"))
97
98		## Compute analysis -----
99	!	compute_ao <- ExtendedTask$new(
100	!	function(x, y, step, start, end, calendar, weight, groups) {
101	!	mirai::mirai({
102	!	kairos::aoristic(x, y, step, start, end, calendar, weight, groups)
103	!	}, environment())
104		}
105		) \|>
106	!	bslib::bind_task_button("go")
107
108	!	observe({
109	!	compute_ao$invoke(x = lower(), y = upper(), step = input$step,
110	!	start = input$start, end = input$end,
111	!	calendar = calendar(), weight = input$weight,
112	!	groups = x()$groups)
113		}) \|>
114	!	bindEvent(input$go)
115
116	!	results <- reactive({
117	!	notify(compute_ao$result(), title = tr_("Aoristic Analysis"))
118		})
119
120		## Plot -----
121	!	plot_ao <- reactive({
122	!	req(results())
123	!	function() {
124	!	kairos::plot(results(), calendar = calendar(), col = "grey")
125		}
126		})
127
128		## Render plots -----
129	!	render_plot("plot_ao", x = plot_ao)
130
131		## Export -----
132	!	output$download <- export_table(results, "aoristic")
133
134	!	results
135		})
136		}

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

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	!	width = 400,
21	!	h5(tr_("Co-Occurrence")),
22	!	radioButtons(
23	!	inputId = ns("method"),
24	!	label = tr_("Method"),
25	!	choiceNames = c(tr_("Absolute frequency"),
26	!	tr_("Relative frequency"),
27	!	tr_("Z-score")),
28	!	choiceValues = c("absolute", "relative", "binomial")
29		),
30	!	info_article(author = "Kintigh", year = "2006", doi = "10.6067/XCV8J38QSS"),
31	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
32	!	downloadButton(
33	!	outputId = ns("download"),
34	!	label = tr_("Download results")
35		)
36	!	), # sidebar
37	!	layout_columns(
38	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
39	!	output_plot(
40	!	id = ns("plot"),
41	!	tools = graphics_ui(ns("par"), col_quali = FALSE,
42	!	pch = FALSE, lty = FALSE, cex = FALSE),
43		),
44	!	card(
45	!	gt::gt_output(outputId = ns("table"))
46		)
47		)
48	!	) # layout_sidebar
49	!	) # nav_panel
50		}
51
52		# Server =======================================================================
53		#' Co-Occurrence Server
54		#'
55		#' @param id An ID string that corresponds with the ID used to call the module's
56		#' UI function.
57		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
58		#' @param verbose A [`logical`] scalar: should \R report extra information on
59		#' progress?
60		#' @return
61		#' No return value, called for side effects.
62		#' @seealso [occurrence_ui()]
63		#' @family count data modules
64		#' @keywords internal
65		#' @export
66		occurrence_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
67	!	stopifnot(is.reactive(x))
68
69	!	moduleServer(id, function(input, output, session) {
70		## Get count data -----
71	!	counts <- reactive({
72	!	req(x())
73	!	arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
74		})
75
76		## Check data -----
77	!	old <- reactive({ counts() }) \|> bindEvent(input$go)
78	!	notify_change(session$ns("change"), counts, old, title = tr_("Co-Occurrence"))
79
80		## Compute index -----
81	!	compute_occur <- ExtendedTask$new(
82	!	function(x, method) {
83	!	mirai::mirai({ tabula::occurrence(x, method = tolower(method)) }, environment())
84		}
85		) \|>
86	!	bslib::bind_task_button("go")
87
88	!	observe({
89	!	compute_occur$invoke(x = counts(), method = input$method)
90		}) \|>
91	!	bindEvent(input$go)
92
93	!	results <- reactive({
94	!	notify(compute_occur$result(), title = tr_("Co-Occurrence"))
95		})
96
97		## Graphical parameters -----
98	!	param <- graphics_server("par")
99
100		## Plot -----
101	!	map <- reactive({
102	!	req(results())
103	!	function() tabula::plot_heatmap(results(), color = param$pal_quant)
104		})
105
106		## Render table -----
107	!	output$table <- gt::render_gt({
108	!	req(results())
109	!	tbl <- as.data.frame(as.matrix(results()))
110	!	gt::gt(tbl, rownames_to_stub = TRUE) \|>
111	!	gt::tab_options(table.width = "100%")
112		})
113
114		## Render plot -----
115	!	render_plot("plot", x = map)
116
117		## Download -----
118	!	output$download <- export_table(results, "occurrence")
119		})
120		}

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	!	downloadButton(
55	!	outputId = ns("download"),
56	!	label = tr_("Download results")
57		)
58	!	), # sidebar
59	!	multivariate_ui(ns("pca")),
60	!	border_radius = FALSE,
61	!	fillable = TRUE
62	!	) # layout_sidebar
63	!	) # nav_panel
64		}
65
66		# Server =======================================================================
67		#' Principal Components Analysis 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 `data.frame`.
72		#' @return A reactive [`dimensio::PCA-class`] object.
73		#' @seealso [pca_ui()]
74		#' @family multivariate analysis modules
75		#' @keywords internal
76		#' @export
77		pca_server <- function(id, x) {
78	!	stopifnot(is.reactive(x))
79
80	!	moduleServer(id, function(input, output, session) {
81		## Update UI -----
82	!	row_names <- reactive({ rownames(x()) })
83	!	sup_row <- update_selectize_values("sup_row", x = row_names)
84	!	sup_col <- update_selectize_variables("sup_col", x = x, find = is.numeric)
85	!	sup_quali <- update_selectize_variables("sup_quali", x = x, find = Negate(is.numeric))
86
87		## Check data -----
88	!	old <- reactive({ x() }) \|> bindEvent(input$go)
89	!	notify_change(session$ns("change"), x, old, title = tr_("PCA"))
90	!	output$help <- renderText({
91	!	if (inherits(x(), "LogRatio")) {
92	!	txt <- tr_("PCA is computed on centered log-ratio (CLR), you should check the data transformation first.")
93	!	return(txt)
94		}
95		})
96
97		## Compute PCA -----
98	!	compute_pca <- ExtendedTask$new(
99	!	function(x, center, scale, rank, sup_row, sup_col, sup_quali) {
100	!	mirai::mirai({
101	!	param <- list(object = x, center = center, scale = scale, rank = rank,
102	!	sup_row = arkhe::seek_rows(x, names = sup_row),
103	!	sup_col = arkhe::seek_columns(x, names = sup_col))
104	!	if (is.data.frame(x)) {
105	!	param$sup_quali <- arkhe::seek_columns(x, names = sup_quali)
106		}
107	!	do.call(dimensio::pca, param)
108	!	}, environment())
109		}
110		) \|>
111	!	bslib::bind_task_button("go")
112
113	!	observe({
114	!	compute_pca$invoke(x = x(), center = input$center, scale = input$scale,
115	!	rank = input$rank, sup_row = sup_row(),
116	!	sup_col = sup_col(), sup_quali = sup_quali())
117		}) \|>
118	!	bindEvent(input$go)
119
120	!	results <- reactive({
121	!	notify(compute_pca$result(), title = tr_("Principal Components Analysis"))
122		})
123
124	!	multivariate_server("pca", x = results, y = x)
125
126		## Export -----
127	!	output$download <- downloadHandler(
128	!	filename = function() { make_file_name("pca", "zip") },
129	!	content = function(file) {
130	!	dimensio::export(results(), file = file, flags = "-r9Xj")
131		},
132	!	contentType = "application/zip"
133		)
134
135	!	results
136		})
137		}

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	!	downloadButton(outputId = ns("download_table"),
41	!	label = tr_("Download log-ratio")),
42		## Output: graph
43	!	plotOutput(outputId = ns("graph"))
44	!	), # sidebar
45		## Output: plot
46	!	output_plot(
47	!	id = ns("plot"),
48	!	tools = graphics_ui(ns("par"), col_quant = FALSE, lty = FALSE, cex = FALSE),
49	!	height = "100%",
50	!	title = tr_("Density")
51		)
52	!	) # layout_sidebar
53	!	) # nav_panel
54		}
55
56		# Server =======================================================================
57		#' Log-Ratio Server
58		#'
59		#' @param id An ID string that corresponds with the ID used to call the module's
60		#' UI function.
61		#' @param x A reactive [`nexus::CompositionMatrix-class`] object.
62		#' @param method A [`character`] string specifying the log-ratio to be computed.
63		#' @return A reactive [`nexus::LogRatio-class`] object.
64		#' @seealso [logratio_ui()]
65		#' @family coda modules
66		#' @keywords internal
67		#' @export
68		logratio_server <- function(id, x, method) {
69	2x	stopifnot(is.reactive(x))
70
71	2x	moduleServer(id, function(input, output, session) {
72		## Render settings -----
73	2x	output$settings <- renderUI({
74	!	if (!(method == "alr" \|\| method == "plr")) return(NULL)
75	1x	label <- switch (
76	1x	method,
77	1x	alr = tr_("Rationing part:"),
78	1x	plr = tr_("Pivotal variable:")
79		)
80	1x	selectizeInput(
81	1x	inputId = session$ns("pivot"),
82	1x	label = label,
83	1x	choices = colnames(x()),
84	1x	selected = NULL,
85	1x	multiple = FALSE,
86		)
87		})
88
89		## Compute -----
90	2x	logratio <- reactive({
91	3x	req(x())
92
93	3x	pivot <- input$pivot %\|\|\|% 1
94	3x	trans <- switch (
95	3x	method,
96	3x	clr = function(x) nexus::transform_clr(x, weights = input$weights),
97	3x	alr = function(x) nexus::transform_alr(x, j = pivot, weights = input$weights),
98	3x	ilr = function(x) nexus::transform_ilr(x),
99	3x	plr = function(x) nexus::transform_plr(x, pivot = pivot)
100		)
101
102	3x	notify(trans(x()), title = toupper(method))
103		})
104
105		## Graphical parameters -----
106	2x	param <- graphics_server("par")
107
108		## Plot -----
109	2x	plot_log <- reactive({
110	1x	req(logratio())
111
112	1x	lvl <- ""
113	!	if (nexus::is_grouped(logratio())) lvl <- nexus::group_levels(logratio())
114	1x	fun <- switch(
115	1x	input$type,
116	1x	scatter = function(x)
117	1x	plot(x, color = param$col_quali(lvl), symbol = param$pch(lvl)),
118	1x	boxplot = function(x)
119	1x	nexus::boxplot(x, color = param$col_quali(lvl))
120		)
121
122	!	function() {
123	!	fun(logratio())
124		}
125		})
126
127		## Graph -----
128	2x	plot_graph <- reactive({
129	1x	req(logratio())
130	!	if (inherits(logratio(), "CLR")) return(NULL)
131	1x	graph <- nexus::as_graph(logratio())
132
133	!	plot(graph)
134	!	grDevices::recordPlot()
135		})
136
137		## Render title -----
138	2x	output$title <- renderText({
139	2x	switch(
140	1x	method,
141	!	clr = tr_("Centered Log-Ratio"),
142	1x	alr = tr_("Additive Log-Ratio"),
143	!	ilr = tr_("Isometric Log-Ratio"),
144	!	plr = tr_("Pivot Log-Ratio"),
145		""
146		)
147		})
148
149		## Render table -----
150		# TODO?
151
152		## Render plot -----
153	2x	render_plot("plot", x = plot_log)
154
155		## Render graph -----
156	2x	output$graph <- renderPlot({
157	1x	req(plot_graph())
158	!	grDevices::replayPlot(plot_graph())
159		})
160
161		## Download -----
162	2x	output$download_table <- export_table(logratio, name = paste0("coda_", method))
163
164	2x	logratio
165		})
166		}

1		#' @details
2		#' \tabular{ll}{
3		#' Version \tab 0.2.0 \cr
4		#' License \tab GPL-3 \cr
5		#' Zenodo DOI \tab \doi{10.5281/zenodo.14645671} \cr
6		#' }
7		#'
8		#' Archéosciences Bordeaux (UMR 6034)\cr
9		#' Maison de l'Archéologie\cr
10		#' Université Bordeaux Montaigne\cr
11		#' F-33607 Pessac cedex\cr
12		#' France
13		#'
14		#' @section Package options:
15		#' \pkg{kinesis} uses the following [options()] to configure behavior:
16		#' * `kinesis.workers`: an [`integer`] specifying the number of \R sessions
17		#' to be used for asynchronous (parallel) computing. Defaults to 1.
18		#'
19		#' @name kinesis-package
20		#' @aliases kinesis-package kinesis
21		#' @docType package
22		#' @keywords internal
23		"_PACKAGE"
24
25		#' @import shiny
26		#' @import bslib
27		NULL
28
29		# Suppress R CMD check note "All declared Imports should be used."
30		unused <- function() {
31	!	folio::boves
32	!	datasets::iris
33		}

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	!	selectizeInput(
31	!	inputId = ns("calendar"),
32	!	label = tr_("Calendar"),
33	!	choices = c("CE", "BCE", "BP"),
34	!	selected = "CE"
35		),
36	!	selectize_ui(
37	!	id = ns("groups"),
38	!	label = tr_("Groups")
39		)
40	!	), # sidebar
41	!	output_plot(
42	!	id = ns("plot"),
43	!	tools = graphics_ui(ns("par"), col_quant = FALSE, pch = FALSE,
44	!	lty = FALSE, cex = FALSE)
45		)
46	!	) # layout_sidebar
47	!	) # nav_panel
48		}
49
50		# Server =======================================================================
51		#' Aoristic Analysis Server
52		#'
53		#' @param id An ID string that corresponds with the ID used to call the module's
54		#' UI function.
55		#' @param x A reactive `data.frame`.
56		#' @return A reactive [`list`].
57		#' @seealso [time_interval_ui()]
58		#' @family chronology modules
59		#' @keywords internal
60		#' @export
61		time_interval_server <- function(id, x) {
62	!	stopifnot(is.reactive(x))
63
64	!	moduleServer(id, function(input, output, session) {
65		## Update UI -----
66	!	col_lower <- update_selectize_variables("lower", x = x, find = is.numeric)
67	!	col_upper <- update_selectize_variables("upper", x = x, find = is.numeric)
68	!	col_groups <- update_selectize_variables("groups", x = x, find = Negate(is.numeric))
69
70	!	lower <- reactive({
71	!	req(col_lower())
72	!	x()[[col_lower()]]
73		})
74	!	upper <- reactive({
75	!	req(col_upper())
76	!	x()[[col_upper()]]
77		})
78	!	groups <- reactive({
79	!	if (isTruthy(col_groups())) x()[[col_groups()]] else NULL
80		})
81	!	calendar <- reactive({
82	!	req(input$calendar)
83	!	aion::calendar(input$calendar)
84		})
85
86		## Time Intervals -----
87	!	results <- reactive({
88	!	req(x(), lower(), upper(), calendar())
89	!	notify(
90		{
91	!	aion::intervals(start = lower(), end = upper(),
92	!	calendar = calendar(), names = rownames(x()))
93		},
94	!	title = tr_("Aoristic Analysis")
95		)
96		})
97
98		## Graphical parameters -----
99	!	param <- graphics_server("par")
100
101		## Plot -----
102	!	plot <- reactive({
103	!	req(results())
104	!	grp <- NULL
105	!	col <- "black"
106	!	if (length(groups()) > 0) {
107	!	grp <- groups()
108	!	col <- param$col_quali(grp)
109		}
110	!	function() {
111	!	aion::plot(results(), calendar = aion::CE(), groups = grp, col = col)
112	!	if (length(groups()) > 0) {
113	!	graphics::legend(x = "topleft", legend = unique(grp),
114	!	fill = unique(col))
115		}
116		}
117		})
118
119		## Render plots -----
120	!	render_plot("plot", x = plot)
121
122	!	reactive({ list(results = results(), groups = groups()) })
123		})
124		}

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	!	width = 400,
21	!	h5(tr_("Diversity Measures")),
22	!	downloadButton(
23	!	outputId = ns("download"),
24	!	label = tr_("Download results")
25		)
26	!	), # sidebar
27	!	card(
28	!	gt::gt_output(outputId = ns("measures"))
29		)
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_alpha_ui()]
44		#' @family count data modules
45		#' @keywords internal
46		#' @export
47		diversity_alpha_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	!	counts <- reactive({
53	!	req(x())
54	!	arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
55		})
56
57		## Compute index -----
58	!	alpha <- reactive({
59	!	req(counts())
60	!	notify({ tabula::diversity(counts()) }, title = "Alpha diversity")
61		})
62
63		## Render table -----
64	!	output$measures <- gt::render_gt({
65	!	alpha() \|>
66	!	gt::gt(rownames_to_stub = TRUE) \|>
67	!	gt::tab_spanner(
68	!	label = tr_("Heterogeneity"),
69	!	columns = c(3, 4) + 1,
70	!	id = "heterogeneity"
71		) \|>
72	!	gt::tab_spanner(
73	!	label = tr_("Dominance"),
74	!	columns = c(5, 6) + 1,
75	!	id = "dominance"
76		) \|>
77	!	gt::tab_spanner(
78	!	label = tr_("Richness"),
79	!	columns = c(7, 8, 9, 10, 11) + 1,
80	!	id = "richness"
81		) \|>
82	!	gt::cols_label(
83	!	size = tr_("Sample size"),
84	!	observed = tr_("Observed richness"),
85	!	shannon = "Shannon",
86	!	brillouin = "Brillouin",
87	!	simpson = "Simpson",
88	!	berger = "Berger-Parker",
89	!	menhinick = "Menhinick",
90	!	margalef = "Margalef",
91	!	chao1 = "Chao1",
92	!	ace = "ACE",
93	!	squares = "Squares"
94		) \|>
95	!	gt::tab_header(title = tr_("Diversity Measures")) \|>
96	!	gt::fmt_number(decimals = 3) \|>
97	!	gt::sub_missing()
98		})
99
100		## Download -----
101	!	output$download <- export_table(alpha, "alpha")
102
103	!	alpha
104		})
105		}

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	!	width = 400,
21	!	h5(tr_("Principal Coordinates Analysis")),
22	!	selectInput(
23	!	inputId = ns("method"),
24	!	label = tr_("Dissimilarity measure"),
25		# TODO: change 'sorenson' to 'sorensen'
26	!	choices = c(`Bray-Curtis` = "bray", `Dice-Sorensen` = "sorenson",
27	!	`Morisita-Horn` = "morisita"),
28	!	multiple = FALSE
29		),
30	!	bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
31	!	downloadButton(
32	!	outputId = ns("download_beta"),
33	!	label = tr_("Download dissimilarity matrix")
34		),
35	!	downloadButton(
36	!	outputId = ns("download_pcoa"),
37	!	label = tr_("Download PCoA results")
38		),
39	!	hr(),
40	!	checkboxInput(
41	!	inputId = ns("pcoa_labels"),
42	!	label = tr_("Display labels"),
43	!	value = FALSE
44		),
45		## Input: variable mapping
46	!	selectize_ui(
47	!	id = ns("extra_quanti"),
48	!	label = tr_("Alpha diversity")
49		),
50	!	selectize_ui(
51	!	id = ns("extra_quali"),
52	!	label = tr_("Groups")
53		),
54	!	checkboxInput(
55	!	inputId = ns("hull"),
56	!	label = tr_("Convex hull"),
57	!	value = FALSE
58		)
59	!	), # sidebar
60	!	layout_columns(
61	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
62	!	output_plot(
63	!	id = ns("plot_diss"),
64	!	title = tr_("Dissimilarity"),
65	!	tools = graphics_ui(ns("par_diss"), col_quali = FALSE, pch = FALSE, lty = FALSE, cex = FALSE),
66	!	height = "100%"
67		),
68	!	output_plot(
69	!	id = ns("plot_pcoa"),
70	!	title = tr_("PCoA"),
71	!	tools = graphics_ui(ns("par_pcoa"), lty = FALSE),
72	!	height = "100%"
73		)
74		)
75	!	) # layout_sidebar
76	!	) # nav_panel
77		}
78
79		# Server =======================================================================
80		#' Beta Diversity Server
81		#'
82		#' @param id An ID string that corresponds with the ID used to call the module's
83		#' UI function.
84		#' @param x A reactive `data.frame` (typically returned by [import_server()]).
85		#' @param y A reactive `data.frame` returned by [diversity_alpha_server()].
86		#' @param verbose A [`logical`] scalar: should \R report extra information on
87		#' progress?
88		#' @return
89		#' No return value, called for side effects.
90		#' @seealso [diversity_beta_ui()]
91		#' @family count data modules
92		#' @keywords internal
93		#' @export
94		diversity_beta_server <- function(id, x, y, verbose = get_option("verbose", FALSE)) {
95	!	stopifnot(is.reactive(x))
96
97	!	moduleServer(id, function(input, output, session) {
98		## Update UI -----
99	!	col_quali <- update_selectize_variables("extra_quali", x = x, find = Negate(is.numeric))
100	!	col_quanti <- update_selectize_variables("extra_quanti", x = y, find = is.numeric)
101
102		## Get count data -----
103	!	counts <- reactive({
104	!	req(x())
105	!	arkhe::keep_columns(x(), f = is.numeric, verbose = verbose)
106		})
107
108		## Check data -----
109	!	old <- reactive({ counts() }) \|> bindEvent(input$go)
110	!	notify_change(session$ns("change"), counts, old, title = tr_("Beta Diversity"))
111
112		## Compute similarity -----
113	!	compute_beta <- ExtendedTask$new(
114	!	function(x, method) {
115	!	mirai::mirai({ 1 - tabula::similarity(x, method) }, environment())
116		}
117		) \|>
118	!	bslib::bind_task_button("go")
119
120	!	observe({
121	!	compute_beta$invoke(x = counts(), method = input$method)
122		}) \|>
123	!	bindEvent(input$go)
124
125	!	results <- reactive({
126	!	notify(compute_beta$result(), title = tr_("Beta Diversity"))
127		})
128
129		## Compute PCoA -----
130	!	analysis <- reactive({
131	!	req(results())
132	!	validate_na(results())
133	!	notify(dimensio::pcoa(results(), rank = 2))
134		})
135
136		## Graphical parameters -----
137	!	param_diss <- graphics_server("par_diss")
138	!	param_pcoa <- graphics_server("par_pcoa")
139
140		## Plot -----
141	!	plot_diss <- reactive({
142	!	req(results())
143
144	!	function() {
145	!	tabula::plot_heatmap(
146	!	object = results(),
147	!	color = param_diss$pal_quant,
148	!	diag = FALSE,
149	!	upper = FALSE,
150	!	fixed_ratio = TRUE
151		)
152		}
153		})
154
155	!	plot_pcoa <- reactive({
156	!	req(analysis(), x(), y())
157
158		## Extra variables
159	!	extra_quanti <- arkhe::seek_columns(y(), names = col_quanti())
160	!	if (!is.null(extra_quanti)) extra_quanti <- y()[[extra_quanti]]
161	!	extra_quali <- arkhe::seek_columns(x(), names = col_quali())
162	!	if (!is.null(extra_quali)) extra_quali <- x()[[extra_quali]]
163
164	!	col <- "black"
165	!	if (isTruthy(extra_quanti)) {
166	!	col <- param_pcoa$col_quant(extra_quanti)
167		}
168	!	if (isTruthy(extra_quali)) {
169	!	col <- param_pcoa$col_quali(extra_quali)
170		}
171	!	cex <- param_pcoa$cex(extra_quanti)
172	!	pch <- param_pcoa$pch(extra_quali)
173
174	!	function() {
175	!	dimensio::plot(
176	!	x = analysis(),
177	!	labels = input$pcoa_labels,
178	!	extra_quali = extra_quali,
179	!	extra_quanti = extra_quanti,
180	!	col = col,
181	!	pch = pch,
182	!	cex = cex,
183	!	panel.first = graphics::grid()
184		)
185
186	!	if (isTRUE(input$hull)) {
187	!	dimensio::viz_hull(analysis(), group = extra_quali,
188	!	color = param_pcoa$pal_quali)
189		}
190		}
191		})
192
193		## Render plot -----
194	!	render_plot("plot_diss", x = plot_diss)
195	!	render_plot("plot_pcoa", x = plot_pcoa)
196
197		## Download -----
198	!	output$download_beta <- export_table(results, "beta")
199	!	output$download_pcoa <- downloadHandler(
200	!	filename = function() { make_file_name("pcoa", "zip") },
201	!	content = function(file) {
202	!	dimensio::export(analysis(), file = file, flags = "-r9Xj")
203		},
204	!	contentType = "application/zip"
205		)
206		})
207		}

1		# Server =======================================================================
2		#' Download a CSV File
3		#'
4		#' Save and Download a [`data.frame`] (CSV).
5		#' @param x A reactive [`data.frame`] to be saved.
6		#' @param name A [`character`] string specifying the name of the file
7		#' (without extension and the leading dot).
8		#' @return
9		#' No return value, called for side effects.
10		#' @family widgets
11		#' @keywords internal
12		#' @noRd
13		export_table <- function(x, name) {
14	3x	stopifnot(is.reactive(x))
15
16	3x	downloadHandler(
17	!	filename = function() { make_file_name(name, "csv") },
18	3x	content = function(file) {
19	!	x <- x()
20	!	if (!is.data.frame(x) && !is.matrix(x)) x <- as.matrix(x)
21	!	utils::write.csv(
22	!	x = x,
23	!	file = file,
24	!	fileEncoding = "utf-8"
25		)
26		},
27	3x	contentType = "text/csv"
28		)
29		}
30
31		#' Download Multiple CSV Files
32		#'
33		#' Save and Download several [`data.frame`] (Zip).
34		#' @param ... Further named arguments ([`data.frame`] to be saved).
35		#' @param name A [`character`] string specifying the name of the file
36		#' (without extension and the leading dot).
37		#' @return
38		#' No return value, called for side effects.
39		#' @family widgets
40		#' @keywords internal
41		#' @noRd
42		export_multiple <- function(..., name = "archive") {
43	2x	tbl <- list(...)
44	2x	stopifnot(!is.null(names(tbl)))
45
46	2x	downloadHandler(
47	!	filename = function() { make_file_name(name, "zip") },
48	2x	content = function(file) {
49	!	tmpdir <- tempdir()
50	!	on.exit(unlink(tmpdir))
51
52		## Write CSV files
53	!	fs <- vapply(
54	!	X = names(tbl),
55	!	FUN = function(f) {
56	!	path <- file.path(tmpdir, paste0(f, ".csv"))
57	!	utils::write.csv(
58	!	x = tbl[[f]](),
59	!	file = path,
60	!	row.names = TRUE,
61	!	fileEncoding = "utf-8"
62		)
63	!	return(path)
64		},
65	!	FUN.VALUE = character(1)
66		)
67
68		## Create Zip file
69	!	utils::zip(zipfile = file, files = fs, flags = "-r9Xj")
70		},
71	2x	contentType = "application/zip"
72		)
73		}

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)[[1]], 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) {
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		#' Diversity Definitions 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		#' @family count data modules
9		#' @keywords internal
10		#' @export
11		diversity_docs_ui <- function(id) {
12		# Create a namespace function using the provided id
13	!	ns <- NS(id)
14
15	!	nav_panel(
16	!	title = tr_("Definitions"),
17	!	layout_columns(
18	!	col_widths = breakpoints(xs = c(12, 12), lg = c(6, 6)),
19	!	card(
20	!	card_title(tr_("Alpha Diversity")),
21	!	tags$dl(
22	!	tags$dt(tr_("Heterogeneity index")),
23	!	tags$dd(tr_("The higher the heterogeneity value, the more diverse the individuals are in the dataset.")),
24	!	tags$dl(
25	!	tags$dt("Shannon"),
26	!	tags$dd(
27	!	"Shannon, C. E. (1948). A Mathematical Theory of Communication.",
28	!	tags$em("The Bell System Technical Journal"), "27, 379-423.",
29	!	url_doi("10.1002/j.1538-7305.1948.tb01338.x", prefix = TRUE)
30		),
31	!	tags$dt("Brillouin"),
32	!	tags$dd(
33	!	"Brillouin, L. (1956).", tags$em("Science and information theory."), "New York: Academic Press."
34		)
35		),
36
37	!	tags$dt(tr_("Dominance index")),
38	!	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).")),
39	!	tags$dl(
40	!	tags$dt("Simpson"),
41	!	tags$dd(
42	!	"Simpson, E. H. (1949). Measurement of Diversity.",
43	!	tags$em("Nature"), "163(4148), 688-688.",
44	!	url_doi("10.1038/163688a0", prefix = TRUE)
45		),
46	!	tags$dt("Berger-Parker"),
47	!	tags$dd(
48	!	"Berger, W. H. & Parker, F. L. (1970). Diversity of Planktonic Foraminifera in Deep-Sea Sediments.",
49	!	tags$em("Science"), "168(3937), 1345-1347.",
50	!	url_doi("10.1126/science.168.3937.1345", prefix = TRUE)
51		)
52		),
53
54	!	tags$dt(tr_("Richness index")),
55	!	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.")),
56	!	tags$dl(
57	!	tags$dt("Menhinick"),
58	!	tags$dd(
59	!	"Menhinick, E. F. (1964). A Comparison of Some Species-Individuals Diversity Indices Applied to Samples of Field Insects.",
60	!	tags$em("Ecology"), "45(4), 859-861.",
61	!	url_doi("10.2307/1934933", prefix = TRUE)
62		),
63	!	tags$dt("Margalef"),
64	!	tags$dd(
65	!	"Margalef, R. (1958). Information Theory in Ecology.",
66	!	tags$em("General Systems"), "3, 36-71."
67		),
68	!	tags$dt("Chao 1"),
69	!	tags$dd(
70	!	"Chao, A. (1984). Nonparametric Estimation of the Number of Classes in a Population.",
71	!	tags$em("Scandinavian Journal of Statistics"), "11(4), 265-270."
72		),
73	!	tags$dt("ACE"),
74	!	tags$dd(
75	!	"Chao, A. & Lee, S.-M. (1992). Estimating the Number of Classes via Sample Coverage.",
76	!	tags$em("Journal of the American Statistical Association"), "87(417), 210-217.",
77	!	url_doi("10.1080/01621459.1992.10475194", prefix = TRUE)
78		),
79	!	tags$dt("Squares Estimator"),
80	!	tags$dd(
81	!	"Alroy, J. (2018). Limits to Species Richness in Terrestrial Communities.",
82	!	tags$em("Ecology Letters"), "21(12), 1781-1789.",
83	!	url_doi("10.1111/ele.13152", prefix = TRUE)
84		)
85		)
86		)
87		),
88	!	card(
89	!	card_title(tr_("Beta Diversity")),
90	!	tags$dl(
91	!	tags$dt("Bray-Curtis"),
92	!	tags$dd(
93	!	"Bray, J. R. & Curtis, J. T. (1957). An Ordination of the Upland Forest Communities of Southern Wisconsin.",
94	!	tags$em("Ecological Monographs"), "27(4), 325-349.",
95	!	url_doi("10.2307/1942268", prefix = TRUE)
96		),
97	!	tags$dt("Dice-Sorensen"),
98	!	tags$dd(
99	!	"Dice, L. R. (1945). Measures of the Amount of Ecologic Association Between Species.",
100	!	tags$em("Ecology"), "26(3): 297-302.",
101	!	url_doi("10.2307/1932409", prefix = TRUE)
102		),
103	!	tags$dd(
104	!	"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.",
105	!	tags$em("Kongelige Danske Videnskabernes Selskab"), "5(4): 1-34."
106		),
107	!	tags$dt("Morisita-Horn (Horn modified version of the Morisita index)"),
108	!	tags$dd(
109	!	"Horn, H. S. (1966). Measurement of \"Overlap\" in Comparative Ecological Studies.",
110	!	tags$em("The American Naturalist"), "100(914): 419-424.",
111	!	url_doi("10.1086/282436", prefix = TRUE)
112		),
113	!	tags$dd(
114	!	"Mosrisita, M. (1959). Measuring of interspecific association and similarity between communities.",
115	!	tags$em("Memoirs of the Faculty of Science, Kyushu University, Series E"), "3:65-80."
116		)
117		)
118		)
119	!	) # layout_columns
120	!	) # nav_panel
121		}