kinesis coverage - 19.07%

Files
Source

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

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

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

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

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

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

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

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

    counts
  })
}


# UI ===========================================================================
#' 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
      param$pal_pch <- input$pch
      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
      param$pal_lty <- input$lty
      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
      param$pal_cex <- input$cex
      if (isTruthy(input$cex)) {
        param$cex <- protect(khroma::palette_size_sequential, cex[[1L]], cex)
      } else {
        param$cex <- recycle(cex[[1L]])
      }
    }) |>
      bindEvent(input$cex)

    param
  })
}

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

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

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


# UI ===========================================================================
#' Diversity 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
}

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

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

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

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

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

    data_miss
  })
}

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

  layout_columns(
    col_widths = breakpoints(
      xs = c(12, 12, 12, 12),
      md = c(6, 6, 6, 6),
      lg = c(3, 3, 3, 3)
    ),
    fill = FALSE,
    value_box(
      title = tr_("Dimensions"),
      uiOutput(outputId = ns("value_dimensions"))
    ),
    value_box(
      title = tr_("Sparsity"),
      uiOutput(outputId = ns("value_sparsity"))
    ),
    value_box(
      title = tr_("Missing values"),
      uiOutput(outputId = ns("value_missing"))
    ),
    card(
      helpText(tr_("Export your data for futur use.")),
      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 <- renderUI({
      req(x())
      paste0(dim(x()), collapse = " x ")
    })
    output$value_sparsity <- renderUI({
      req(x())
      paste0(round(arkhe::sparsity(x()) * 100, 2), "%")
    })
    output$value_missing <- renderUI({
      req(x())
      sum(is.na(x()))
    })

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

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

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

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

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

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

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

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

    no_cte
  })
}

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

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

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

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

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

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

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

      fun(zero_as_na())
    })

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

    no_missing
  })
}

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

  nav_panel(
    title = tr_("Co-Occurrence"),
    layout_sidebar(
      sidebar = sidebar(
        title = tr_("Co-Occurrence"),
        radioButtons(
          inputId = ns("method"),
          label = tr_("Method"),
          choiceNames = c(tr_("Absolute frequency"),
                          tr_("Relative frequency"),
                          tr_("Z-score")),
          choiceValues = c("absolute", "relative", "binomial")
        ),
        info_article(author = "Kintigh", year = "2006", doi = "10.6067/XCV8J38QSS"),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        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` returned by [diversity_server()].
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return
#'  No return value, called for side effects.
#' @seealso [occurrence_ui()]
#' @family count data modules
#' @keywords internal
#' @export
occurrence_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

  moduleServer(id, function(input, output, session) {
    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, 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 = x(), 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")

    results
  })
}

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

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

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

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

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

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

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

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

  nav_panel(
    title = HTML(tr_("&#946; Diversity")),
    layout_sidebar(
      sidebar = sidebar(
        title = tr_("Principal Coordinates Analysis"),
        selectInput(
          inputId = ns("method"),
          label = tr_("Dissimilarity measure"),
          # TODO: change 'sorenson' to 'sorensen'
          choices = c(`Bray-Curtis` = "bray", `Dice-Sorensen` = "sorenson",
                      `Morisita-Horn` = "morisita"),
          multiple = FALSE
        ),
        bslib::input_task_button(id = ns("go"), label = tr_("(Re)Compute")),
        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` returned by [diversity_server()].
#' @param quanti A reactive `data.frame` returned by [diversity_alpha_server()].
#' @param quali A reactive `data.frame` (typically returned by [import_server()]).
#' @return
#'  No return value, called for side effects.
#' @seealso [diversity_beta_ui()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_beta_server <- function(id, x, quanti, quali) {
  stopifnot(is.reactive(x))
  stopifnot(is.reactive(quanti))
  stopifnot(is.reactive(quali))

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

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

    ## Check data -----
    old <- reactive({ x() }) |> bindEvent(input$go)
    notify_change(session$ns("change"), x, 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 = x(), 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())

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      default_quali <- "observation"
      if (!isTruthy(extra_quali()) && isTruthy(extra_quanti())) {
        default_quali <- NULL
        col <- param_ind$pal_quanti
      } else {
        col <- param_ind$pal_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 = isTRUE(input$sup_ind),
          labels = isTRUE(input$lab_ind),
          extra_quali = extra_quali() %|||% default_quali,
          extra_quanti = extra_quanti(),
          color = col,
          symbol = param_ind$pal_pch,
          size = param_ind$pal_cex,
          xlim = range_ind$x,
          ylim = range_ind$y,
          panel.first = graphics::grid()
        )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

# UI ===========================================================================
#' 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)

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

# HELP TEXT

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  nav_panel(
    title = tr_("Linear Model"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Linear Model"),
        ## Input: select axes
        selectize_ui(
          id = ns("response"),
          label = tr_("Dependent variable"),
          multiple = FALSE
        ),
        checkbox_ui(
          id = ns("explanatory"),
          label = tr_("Independent variables")
        )
      ), # sidebar
      navset_card_pill(
        nav_panel(
          title = tr_("Summary"),
          verbatimTextOutput(outputId = ns("summary"))
        ),
        nav_panel(
          title = tr_("Diagnostic"),
          layout_columns(
            col_widths = breakpoints(xs = 12, sm = c(6, 6), md = c(4, 4, 4)),
            output_plot(id = ns("plot_hist"), title = tr_("Residuals histogram")),
            output_plot(id = ns("plot_qq"), title = tr_("Residual Q-Q plot")),
            output_plot(id = ns("plot_fitted"), title = tr_("Residuals-Fitted")),
            output_plot(id = ns("plot_scale"), title = tr_("Scale-Location")),
            output_plot(id = ns("plot_cook"), title = tr_("Cook's distance")),
            output_plot(id = ns("plot_lev"), title = tr_("Residuals-Leverage"))
          )
        ),
        nav_panel(
          title = tr_("Prediction"),
          layout_sidebar(
            sidebar = sidebar(
              ## Input: prediction
              radioButtons(
                inputId = ns("interval"),
                label = tr_("Interval"),
                choiceNames = c(tr_("Confidence interval")), # tr_("Prediction interval")
                choiceValues = c("confidence") # "prediction"
              ),
              radioButtons(
                inputId = ns("level"),
                label = tr_("Level"),
                selected = "0.95",
                choiceNames = c("68%", "95%", "99%"),
                choiceValues = c("0.68", "0.95", "0.99")
              )
            ),
            gt::gt_output(outputId = ns("prediction"))
          )
        )
      ) # navset_card_pill
    ) # layout_sidebar
  ) # nav_panel
}

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

  moduleServer(id, function(input, output, session) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    resp <- update_selectize_colnames("response", x = quanti)
    expl <- update_checkbox_colnames("explanatory", x = quanti, exclude = resp)

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

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

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

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

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

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

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

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

    model
  })
}

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

  nav_panel(
    title = tr_("Scatter Plot"),
    layout_sidebar(
      sidebar = sidebar(
        width = 400,
        title = tr_("Variables"),
        ## Input: select axes
        selectize_ui(ns("axis1"), label = tr_("Component X")),
        selectize_ui(ns("axis2"), label = tr_("Component Y")),
        ## Input: aesthetics mapping
        selectize_ui(ns("extra_quali"), label = tr_("Extra qualitative variable")),
        selectize_ui(ns("extra_quanti"), label = tr_("Extra quantitative variable")),
        ## Input: add ellipses
        radioButtons(
          inputId = ns("wrap"),
          label = tr_("Wrap:"),
          choiceNames = c(tr_("None"), tr_("Tolerance ellipse"),
                          tr_("Confidence ellipse"), tr_("Convex hull")),
          choiceValues = c("none", "tol", "conf", "hull"),
        ),
        checkboxGroupInput(
          inputId = ns("level"),
          label = tr_("Ellipse level:"),
          selected = "0.95",
          choiceNames = c("68%", "95%", "99%"),
          choiceValues = c("0.68", "0.95", "0.99")
        ),
        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) {
    ## Update UI -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

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

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

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

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

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

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

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

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

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

        if (isTruthy(extra_quali())) {
          ## Add ellipses
          wrap()(x = coord_x, y = coord_y, z = extra_quali(), color = param$pal_quali)

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

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

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

# HELPERS

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

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

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

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

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

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

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

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

    cal
  })
}

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

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

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

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

    values
  })
}

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

# Notification =================================================================
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)) {
    warn <- unique(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())
  })
}

# SHINY

#' Run an App
#'
#' A wrapper for [shiny::shinyAppDir()].
#' @param app A [`character`] string specifying the \pkg{Shiny} application
#'  to run (see details). Any unambiguous substring can be given.
#' @param options A [`list`] of named options that should be passed to the
#'  [`shiny::shinyAppDir()`] call.
#' @details
#'  \tabular{ll}{
#'   **Application name**          \tab  **Keyword** \cr
#'   Aoristic Analysis             \tab `aoristic`   \cr
#'   Correspondence Analysis       \tab `ca`         \cr
#'   Principal Components Analysis \tab `pca`        \cr
#'   Diversity Measures            \tab `diversity`  \cr
#'   Mean Ceramic Date             \tab `mcd`        \cr
#'   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"),
                    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)
  }

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

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

  obj
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

# UI ===========================================================================
#' 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 -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

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

    ## Check data -----
    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 = sup_col)
          if (is.data.frame(x)) param$sup_quali <- sup_quali
          do.call(dimensio::ca, param)
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

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

    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 ===========================================================================
#' 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 -----
    quanti <- subset_quantitative(x)
    quali <- subset_qualitative(x)

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

    ## Check data -----
    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 = sup_col)
          if (is.data.frame(x)) {
            param$sup_quali <- sup_quali
          }
          do.call(dimensio::pca, param)
        }, environment())
      }
    ) |>
      bslib::bind_task_button("go")

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

    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 ===========================================================================
#' 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")
        )
      ),
      navset_card_pill(
        placement = "above",
        nav_panel(
          title = tr_("Location"),
          gt::gt_output(outputId = ns("mean")),
          gt::gt_output(outputId = ns("quantile"))
        ),
        nav_panel(
          title = tr_("Covariance"),
          gt::gt_output(outputId = ns("covariance"))
        ),
        nav_panel(
          title = tr_("PIP"),
          gt::gt_output(outputId = ns("pip"))
        ),
        nav_panel(
          title = tr_("Variation Matrix"),
          navset_pill(
            nav_panel(
              title = tr_("Table"),
              class = "pt-3",
              gt::gt_output(outputId = ns("variation"))
            ),
            nav_panel(
              title = tr_("Heatmap"),
              class = "pt-3",
              output_plot(id = ns("heatmap"))
            ),
            nav_panel(
              title = tr_("Dendrogram"),
              class = "pt-3",
              output_plot(id = ns("dendrogram"))
            )
          )
        )
      ) # navset_card_underline
    ) # layout_sidebar
  ) # nav_panel
}

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

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

    ## Spread -----
    # TODO

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    ## Zeros -----
    # TODO

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

      data_missing()
    })

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

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

    data_valid
  })
}

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

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

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

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

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

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

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

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

    reactive({ data$values })
  })
}

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

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

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

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

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

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

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

      data_missing()
    })

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

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

    data_valid
  })
}

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

  nav_panel(
    title = HTML(tr_("&#945; Diversity")),
    layout_sidebar(
      sidebar = sidebar(
        title = tr_("Diversity Measures"),
        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` returned by [diversity_server()].
#' @param verbose A [`logical`] scalar: should \R report extra information on
#'  progress?
#' @return A reactive [`data.frame`] (see [tabula::diversity()]).
#' @seealso [diversity_alpha_ui()]
#' @family count data modules
#' @keywords internal
#' @export
diversity_alpha_server <- function(id, x, verbose = get_option("verbose", FALSE)) {
  stopifnot(is.reactive(x))

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

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

    ## Download -----
    output$download <- export_table(results, "alpha")

    results
  })
}

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

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


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

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

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

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

# UI ===========================================================================
#' 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
  })
}

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

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

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

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

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

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

    calendar <- get_calendar("calendar")

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

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

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

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

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

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

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

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

1		# UI ===========================================================================
2		#' 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	!	sliderInput(
45	!	inputId = inputId,
46	!	label = tr_("Symbol size"),
47	!	min = 0.1,
48	!	max = 9,
49	!	value = default,
50	!	step = 0.1
51		)
52		}
53
54		select_pch <- function(inputId, default = c(16, 17, 15, 3, 7, 8)) {
55	!	x <- c(
56	!	square = 0, circle = 1, `triangle up` = 2, plus = 3, cross = 4,
57	!	diamond = 5, `triangle down` = 6, `square cross` = 7, star = 8,
58	!	`diamond plus` = 9, `circle plus` = 10, `triangles up and down` = 11,
59	!	`square plus` = 12, `circle cross` = 13, `square triangle` = 14,
60	!	`filled square` = 15, `filled circle` = 16, `filled triangle` = 17,
61	!	`filled diamond` = 18, `solid circle` = 19, bullet = 20
62		)
63
64	!	selectizeInput(
65	!	inputId = inputId,
66	!	label = tr_("Symbol"),
67	!	choices = x,
68	!	selected = default,
69	!	multiple = TRUE,
70	!	options = list(plugins = "clear_button")
71		)
72		}
73
74		select_lty <- function(inputId, default = 1) {
75	!	x <- c(solid = 1, dashed = 2, dotted = 3,
76	!	dotdash = 4, longdash = 5, twodash = 6)
77
78	!	selectizeInput(
79	!	inputId = inputId,
80	!	label = tr_("Line type"),
81	!	choices = x,
82	!	selected = default,
83	!	multiple = TRUE,
84	!	options = list(plugins = "clear_button")
85		)
86		}
87
88		select_color <- function(inputId, label,
89		type = c("qualitative", "sequential", "diverging")) {
90	!	type <- match.arg(type, several.ok = TRUE)
91
92	!	schemes <- list(
93	!	qualitative = c("discreterainbow", "bright", "vibrant", "muted",
94	!	"highcontrast", "mediumcontrast", "light", "okabeito"),
95	!	diverging = c("sunset", "nightfall", "BuRd", "PRGn"),
96	!	sequential = c("YlOrBr", "iridescent", "incandescent", "smoothrainbow")
97		)
98
99	!	schemes <- schemes[type]
100	!	default <- "discreterainbow"
101	!	if (length(type) == 1) {
102	!	if ("diverging" %in% type) default <- "BuRd"
103	!	if ("sequential" %in% type) default <- "YlOrBr"
104		}
105
106	!	selectizeInput(
107	!	inputId = inputId,
108	!	label = label,
109	!	choices = schemes,
110	!	selected = default,
111	!	multiple = FALSE,
112	!	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	param$pal_pch <- input$pch
175	2x	if (isTruthy(input$pch)) {
176	!	param$pch <- protect(khroma::palette_shape, pch[[1L]], pch)
177		} else {
178	2x	param$pch <- recycle(pch[[1L]])
179		}
180		}) \|>
181	3x	bindEvent(input$pch, ignoreNULL = FALSE)
182
183	3x	observe({
184	2x	lty <- as.integer(input$lty) %\|\|\|% 1
185	2x	param$pal_lty <- input$lty
186	2x	if (isTruthy(input$lty)) {
187	!	param$lty <- protect(khroma::palette_line, lty[[1L]], lty)
188		} else {
189	2x	param$lty <- recycle(lty[[1L]])
190		}
191		}) \|>
192	3x	bindEvent(input$lty, ignoreNULL = FALSE)
193
194	3x	observe({
195	!	cex <- range(as.integer(input$cex)) %\|\|\|% 1
196	!	param$pal_cex <- input$cex
197	!	if (isTruthy(input$cex)) {
198	!	param$cex <- protect(khroma::palette_size_sequential, cex[[1L]], cex)
199		} else {
200	!	param$cex <- recycle(cex[[1L]])
201		}
202		}) \|>
203	3x	bindEvent(input$cex)
204
205	3x	param
206		})
207		}
208
209		color <- function(scheme, default = "black") {
210	2x	if (!isTruthy(scheme)) {
211	2x	function(n) {
212	1x	rep(default, n)
213		}
214		} else {
215	!	function(n) {
216	!	notify(khroma::color(scheme)(n))
217		}
218		}
219		}
220		recycle <- function(x) {
221	19x	force(x)
222
223	19x	function(n) {
224	!	if (missing(n) \|\| length(n) < 1) n <- 1
225	2x	rep(x, length(n))
226		}
227		}
228		protect <- function(f, default, ...) {
229	2x	force(default)
230
231	2x	function(x) {
232	!	if (!isTruthy(x)) return(default)
233	1x	notify(f(...)(x))
234		}
235		}
236

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		}

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

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

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

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

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

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

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

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

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

1		# UI ===========================================================================
2		#' 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		#' 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		#' 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		#' Linear Model UI
3		#'
4		#' @param id A [`character`] vector to be used for the namespace.
5		#' @return
6		#' A nav item that may be passed to a nav container
7		#' (e.g. [bslib::navset_tab()]).
8		#' @seealso [lm_server()]
9		#' @family modeling modules
10		#' @keywords internal
11		#' @export
12		lm_ui <- function(id) {
13		# Create a namespace function using the provided id
14	!	ns <- NS(id)
15
16	!	nav_panel(
17	!	title = tr_("Linear Model"),
18	!	layout_sidebar(
19	!	sidebar = sidebar(
20	!	width = 400,
21	!	title = tr_("Linear Model"),
22		## Input: select axes
23	!	selectize_ui(
24	!	id = ns("response"),
25	!	label = tr_("Dependent variable"),
26	!	multiple = FALSE
27		),
28	!	checkbox_ui(
29	!	id = ns("explanatory"),
30	!	label = tr_("Independent variables")
31		)
32	!	), # sidebar
33	!	navset_card_pill(
34	!	nav_panel(
35	!	title = tr_("Summary"),
36	!	verbatimTextOutput(outputId = ns("summary"))
37		),
38	!	nav_panel(
39	!	title = tr_("Diagnostic"),
40	!	layout_columns(
41	!	col_widths = breakpoints(xs = 12, sm = c(6, 6), md = c(4, 4, 4)),
42	!	output_plot(id = ns("plot_hist"), title = tr_("Residuals histogram")),
43	!	output_plot(id = ns("plot_qq"), title = tr_("Residual Q-Q plot")),
44	!	output_plot(id = ns("plot_fitted"), title = tr_("Residuals-Fitted")),
45	!	output_plot(id = ns("plot_scale"), title = tr_("Scale-Location")),
46	!	output_plot(id = ns("plot_cook"), title = tr_("Cook's distance")),
47	!	output_plot(id = ns("plot_lev"), title = tr_("Residuals-Leverage"))
48		)
49		),
50	!	nav_panel(
51	!	title = tr_("Prediction"),
52	!	layout_sidebar(
53	!	sidebar = sidebar(
54		## Input: prediction
55	!	radioButtons(
56	!	inputId = ns("interval"),
57	!	label = tr_("Interval"),
58	!	choiceNames = c(tr_("Confidence interval")), # tr_("Prediction interval")
59	!	choiceValues = c("confidence") # "prediction"
60		),
61	!	radioButtons(
62	!	inputId = ns("level"),
63	!	label = tr_("Level"),
64	!	selected = "0.95",
65	!	choiceNames = c("68%", "95%", "99%"),
66	!	choiceValues = c("0.68", "0.95", "0.99")
67		)
68		),
69	!	gt::gt_output(outputId = ns("prediction"))
70		)
71		)
72	!	) # navset_card_pill
73	!	) # layout_sidebar
74	!	) # nav_panel
75		}
76
77		# Server =======================================================================
78		#' Linear Model Server
79		#'
80		#' @param id An ID string that corresponds with the ID used to call the module's
81		#' UI function.
82		#' @param x A reactive [`data.frame`].
83		#' @return A reactive [`lm`] object.
84		#' @seealso [lm_ui()]
85		#' @family modeling modules
86		#' @keywords internal
87		#' @export
88		lm_server <- function(id, x) {
89	!	stopifnot(is.reactive(x))
90
91	!	moduleServer(id, function(input, output, session) {
92		## Update UI -----
93	!	quanti <- subset_quantitative(x)
94	!	resp <- update_selectize_colnames("response", x = quanti)
95	!	expl <- update_checkbox_colnames("explanatory", x = quanti, exclude = resp)
96
97		## Linear regression -----
98	!	vars <- reactive({
99	!	req(resp(), expl())
100	!	stats::as.formula(paste0(resp(), " ~ ", paste0(expl(), collapse = " + ")))
101		}) \|>
102	!	bindEvent(expl()) \|>
103	!	debounce(500)
104
105	!	model <- reactive({
106	!	stats::lm(vars(), data = x(), na.action = stats::na.omit, y = TRUE)
107		}) \|>
108	!	bindEvent(vars())
109
110	!	prediction <- reactive({
111	!	data.frame(
112	!	y = model()$y,
113	!	stats::predict(
114	!	object = model(),
115	!	se.fit = FALSE,
116	!	interval = input$interval,
117	!	level = as.numeric(input$level)
118		)
119		)
120		})
121
122		## Diagnostic tests -----
123		# TODO?
124
125		## Diagnostic plots -----
126	!	plot_hist <- reactive({
127	!	function() {
128	!	graphics::hist(stats::residuals(model()), main = NULL, xlab = "Residuals")
129		}
130		})
131	!	plot_fitted <- reactive({
132	!	function() {
133	!	plot(model(), which = 1, caption = "", sub.caption = "")
134		}
135		})
136	!	plot_qq <- reactive({
137	!	function() {
138	!	plot(model(), which = 2, caption = "", sub.caption = "")
139		}
140		})
141	!	plot_scale <- reactive({
142	!	function() {
143	!	plot(model(), which = 3, caption = "", sub.caption = "")
144		}
145		})
146	!	plot_cook <- reactive({
147	!	function() {
148	!	plot(model(), which = 4, caption = "", sub.caption = "")
149		}
150		})
151	!	plot_lev <- reactive({
152	!	function() {
153	!	plot(model(), which = 5, caption = "", sub.caption = "")
154		}
155		})
156
157		## Render plot -----
158	!	render_plot("plot_hist", plot_hist)
159	!	render_plot("plot_fitted", plot_fitted)
160	!	render_plot("plot_qq", plot_qq)
161	!	render_plot("plot_scale", plot_scale)
162	!	render_plot("plot_cook", plot_cook)
163	!	render_plot("plot_lev", plot_lev)
164
165		## Render table -----
166	!	output$prediction <- gt::render_gt({
167	!	lvl <- as.numeric(input$level)
168	!	int <- switch(
169	!	input$interval,
170	!	confidence = tr_("Confidence interval"),
171	!	prediction = tr_("Prediction interval")
172		)
173	!	gt::gt(prediction(), rownames_to_stub = TRUE) \|>
174	!	gt::tab_spanner(
175	!	label = sprintf("%s (%1.0f%%)", int, lvl * 100),
176	!	columns = c("lwr", "upr")
177		) \|>
178	!	gt::cols_label(
179	!	y = tr_("Response"),
180	!	fit = tr_("Fitted"),
181	!	lwr = tr_("Lower bound"),
182	!	upr = tr_("Upper bound")
183		)
184		})
185
186		## Render prints -----
187	!	output$summary <- renderPrint({ summary(model()) })
188
189	!	model
190		})
191		}

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

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

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

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

1		# UI ===========================================================================
2		#' 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		## Graphical parameters -----
86	!	param <- graphics_server("par")
87
88		## Plot -----
89	!	plot_permute <- reactive({
90	!	req(x())
91
92	!	threshold <- switch(
93	!	input$threshold,
94	!	mean = mean,
95	!	median = stats::median,
96	!	none = NULL
97		)
98
99	!	switch(
100	!	input$type,
101	!	ford = function()
102	!	tabula::plot_ford(x(), weights = input$weights, EPPM = input$eppm),
103	!	barplot = function()
104	!	tabula::plot_bertin(x(), threshold = threshold),
105	!	scalogram = function()
106	!	tabula::plot_spot(x(), color = "black", legend = FALSE),
107	!	heatmap = function()
108	!	tabula::plot_heatmap(x(), color = param$pal_quant, fixed_ratio = FALSE)
109		)
110		})
111
112		## Render plot -----
113	!	render_plot("plot", x = plot_permute)
114		})
115		}

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	!	quanti <- subset_quantitative(x)
68	!	quali <- subset_qualitative(x)
69
70	!	sup_row <- update_selectize_rownames("sup_row", x = x)
71	!	sup_col <- update_selectize_colnames("sup_col", x = quanti)
72	!	sup_quali <- update_selectize_colnames("sup_quali", x = quali, select = TRUE)
73
74		## Check data -----
75	!	old <- reactive({ x() }) \|> bindEvent(input$go)
76	!	notify_change(session$ns("change"), x, old, title = tr_("CA"))
77
78		## Compute CA -----
79	!	compute_ca <- ExtendedTask$new(
80	!	function(x, rank, sup_row, sup_col, sup_quali) {
81	!	mirai::mirai({
82	!	param <- list(object = x, rank = rank,
83	!	sup_row = arkhe::seek_rows(x, names = sup_row),
84	!	sup_col = sup_col)
85	!	if (is.data.frame(x)) param$sup_quali <- sup_quali
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		#' 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	!	quanti <- subset_quantitative(x)
83	!	quali <- subset_qualitative(x)
84
85	!	sup_row <- update_selectize_rownames("sup_row", x = x)
86	!	sup_col <- update_selectize_colnames("sup_col", x = quanti)
87	!	sup_quali <- update_selectize_colnames("sup_quali", x = quali, select = TRUE)
88
89		## Check data -----
90	!	old <- reactive({ x() }) \|> bindEvent(input$go)
91	!	notify_change(session$ns("change"), x, old, title = tr_("PCA"))
92	!	output$help <- renderText({
93	!	if (inherits(x(), "LogRatio")) {
94	!	txt <- tr_("PCA is computed on centered log-ratio (CLR), you should check the data transformation first.")
95	!	return(txt)
96		}
97		})
98
99		## Compute PCA -----
100	!	compute_pca <- ExtendedTask$new(
101	!	function(x, center, scale, rank, sup_row, sup_col, sup_quali) {
102	!	mirai::mirai({
103	!	param <- list(object = x, center = center, scale = scale, rank = rank,
104	!	sup_row = arkhe::seek_rows(x, names = sup_row),
105	!	sup_col = sup_col)
106	!	if (is.data.frame(x)) {
107	!	param$sup_quali <- sup_quali
108		}
109	!	do.call(dimensio::pca, param)
110	!	}, environment())
111		}
112		) \|>
113	!	bslib::bind_task_button("go")
114
115	!	observe({
116	!	compute_pca$invoke(x = x(), center = input$center, scale = input$scale,
117	!	rank = input$rank, sup_row = sup_row(),
118	!	sup_col = sup_col(), sup_quali = sup_quali())
119		}) \|>
120	!	bindEvent(input$go)
121
122	!	results <- reactive({
123	!	notify(compute_pca$result(), title = tr_("Principal Components Analysis"))
124		})
125
126	!	multivariate_server("pca", x = results, y = x)
127
128		## Export -----
129	!	output$download <- downloadHandler(
130	!	filename = function() { make_file_name("pca", "zip") },
131	!	content = function(file) {
132	!	dimensio::export(results(), file = file, flags = "-r9Xj")
133		},
134	!	contentType = "application/zip"
135		)
136
137	!	results
138		})
139		}

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

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

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

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

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