R/cql.R

In joeroe/stratigraphr: Archaeological Stratigraphy and Chronological Sequences

# API for OxCal's Chronological Query Language (CQL2)
# See https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html

# TODO:
# * Indenting
# * More sophisticated type checking:
#   * Expressions in e.g. Boundary() can only take a limited number of other
#     commands

#' Chronological Query Language (CQL)
#'
#' Provides an R interface for the Chronological Query Language (CQL), primarily
#' used to input commands and describe models to OxCal.
#'
#' @param ... `cql` objects to be assembled into a script.
#' @param x   Object to be coerced to a `cql` object.
#'
#' @details
#' CQL scripts are represented by the S3 class `cql`. `cql()` takes the output
#' of individual `cql_` functions and assembles them into a single script. See
#' `vignette("cql")` for a tutorial.
#'
#' List arguments to `cql()` are collapsed to produce a single script. If you
#' want to coerce an object to `cql` and preserve its structure, use `as_cql()`
#' instead.
#'
#' @return A CQL script.
#'
#' @family CQL functions
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html>
#'
#' @export
cql <- function(...) {
  cql <- paste(..., sep = "\n", collapse = "\n")
  cql <- as_cql(cql)
  return(cql)
}


# cql class methods -----------------------------------------------------------

#' @rdname cql
#' @export
as_cql <- function(x) UseMethod("as_cql", x)

#' @rdname cql
#' @export
as_cql.list <- function(x) {
  x <- purrr::map(x, as_cql)
  class(x) <- c("cql", "list")
  return(x)
}

#' @rdname cql
#' @export
as_cql.default <- function(x) {
  x <- as.character(x)
  class(x) <- c("cql", "character")
  return(x)
}

#' @export
print.cql <- function(x, ...) {
  cql <- paste0("// CQL2 generated by stratigraphr v",
                utils::packageVersion("stratigraphr"),
                "\n",
                x)
  cql <- cql_in(cql)
  cql <- as.character(cql)
  writeLines(cql)
  invisible(x)
}


# CQL options -------------------------------------------------------------
# https://c14.arch.ox.ac.uk/oxcalhelp/hlp_analysis_detail.html#opt

#' Set OxCal options in CQL
#'
#' This function generates a CQL command that sets OxCal's global options.
#'
#' @param bcad               Logical. Whether BC/AD are used in the log file output.
#' @param convergence_data   Logical. Whether sample convergence data is included in the output data file.
#' @param curve              Character. The default calibration curve.
#' @param cubic              Logical. Whether cubic (as opposed to linear) interpolation is used for calibration curves.
#' @param ensembles          Integer. The number of age-depth ensembles stored during the analysis.
#' @param floruit            Logical. Whether quantile ranges are calculated instead of the default highest posterior density (hpd).
#' @param intercept          Logical. Whether the intercept method is used for radiocarbon calibration ranges.
#' @param k_iterations       Integer. The default number of MCMC passes.
#' @param plus_minus         Logical. Whether + and - are used in place of BC and AD in log files.
#' @param raw_data           Logical. Whether raw calibration curve data is included in the output data file.
#' @param resolution         Integer. The default bin size for probability distributions of Date and Interval type.
#' @param round              Logical. Whether ranges are rounded off.
#' @param round_by           Integer. Resolution of rounding (0 for automatic).
#' @param sd1                Logical. Whether 68.2% (1 σ) ranges are given in the log and tab delimited files.
#' @param sd2                Logical. Whether 95.4% (2 σ) ranges are given in the log and tab delimited files.
#' @param sd3                Logical. Whether 99.7% (3 σ) ranges are given in the log and tab delimited files.
#' @param uniform_span_prior Logical. Whether the two extra prior factors suggested by Nicholls and Jones 2001 are used.
#' @param use_f14c           Logical. Whether all calibrations take place in F14C space (rather than BP space).
#' @param year               Numeric. The datum point for ages - the default is mid AD 1950.
#' @param ...                Additional named arguments converted to OxCal options. See details.
#'
#' @details
#' Parameter descriptions and defaults are taken from the OxCal v4.4
#' documentation (see references).
#'
#' Options not explicitly included here can be specified as additional named
#' arguments to this function. The name must exactly match the name of the
#' option expected by OxCal; unknown or misspelled options are silently ignored.
#'
#' @return
#' A `cql` object.
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_analysis_detail.html#opt>
#'
#' @family CQL functions
#'
#' @export
cql_options <- function(bcad = TRUE,
                        convergence_data = FALSE,
                        curve = "intcal20.14c",
                        cubic = TRUE,
                        ensembles = 30,
                        floruit = FALSE,
                        intercept = FALSE,
                        k_iterations = 30,
                        plus_minus = FALSE,
                        raw_data = FALSE,
                        resolution = 5,
                        round = FALSE,
                        round_by = 0,
                        sd1 = TRUE,
                        sd2 = TRUE,
                        sd3 = FALSE,
                        uniform_span_prior = TRUE,
                        use_f14c = TRUE,
                        year = 1950.5,
                        ...) {
  options <- as.list(match.call())

  if (length(options) > 1) {
    options <- options[2:length(options)]

    strings <- sapply(options, is.character)
    options[strings] <- paste0("\"", options[strings], "\"")

    names(options) <- dplyr::recode(
      names(options),
      bcad = "BCAD",
      convergence_data = "ConvergenceData",
      curve = "Curve",
      cubic = "Cubic",
      ensembles = "Ensembles",
      floruit = "Floruit",
      intercept = "Intercept",
      k_iterations = "kInterations",
      plus_minus = "PlusMinus",
      raw_data = "RawData",
      resolution = "Resolution",
      round = "Round",
      round_by = "RoundBy",
      sd1 = "SD1",
      sd2 = "SD2",
      sd3 = "SD3",
      uniform_span_prior = "UniformSpanPrior",
      use_f14c = "UseF14C",
      year = "Year"
    )

    cql <- paste(names(options), options, sep = " = ")
    cql <- paste(cql, collapse = ";\n")
    cql <- paste0("Options()\n",
                  "{\n",
                  cql, ";",
                  "\n};")
  }
  else {
    cql <- "Options();"
  }

  cql <- as_cql(cql)
  return(cql)
}

# CQL date functions ------------------------------------------------------
# (Vectorised)

#' Describe dates in CQL
#'
#' The CQL commands `R_Date`, `F14C_Date`, `C_Date` and `Date` are used to
#' describe individual dated events in a model. `R_Date` and `F14C_Date`
#' represent radiocarbon dates expressed in radiocarbon years (the conventional
#' radiocarbon age, CRA) or *fraction modern* (F14C) respectively.
#' `C_Date` represents a calendar date. `Date` directly specifies a date in
#' OxCal's internal format.
#'
#' @param name  Character. Date label(s), usually a lab code.
#' @param date  Numeric. Date or dates expressed in radiocarbon years (`cql_r_date()`),
#'              F14C (`cql_f14c_date()`), calendar years (`cql_c_date()`), or
#'              OxCal's internal format (`cql_date()`) See details.
#' @param error Integer. Uncertainty associated with the date(s).
#'
#' @details
#' The era expected for calendar dates (BP or BC/AD) depends on a global option
#' in OxCal, which defaults to BC/AD. BC dates are specified as negative values.
#'
#' F14C measurements are recommended for modern, "post-bomb" radiocarbon dates
#' \insertCite{Reimer2004-yl}{stratigraphr}.
#'
#' OxCal's internal date format, used with `Date()`, is a decimal Gregorian
#' year, for details see: <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_analysis_calend.html>
#'
#' @return
#' A `cql` object, or a list of `cql` objects if the arguments are vectors.
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_analysis_inform.html#date>
#'
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html>
#'
#' \insertAllCited{}
#'
#' @family CQL functions
#'
#' @export
cql_r_date <- function(name, date, error) {
  name <- as.character(name)
  checkmate::assert_integerish(date)
  checkmate::assert_integerish(error)

  if(length(name) != length(date) |
     length(date) != length(error) |
     length(error) != length(name)) {
    stop("Vector arguments to name, date, error must all be the same length.")
  }

  cql <- glue::glue('R_Date("{name}", {date}, {error});')

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_r_date
#' @export
cql_c_date <- function(name, date, error) {
  name <- as.character(name)
  checkmate::assert_integerish(date)
  checkmate::assert_integerish(error)

  if(length(name) != length(date) |
     length(date) != length(error) |
     length(error) != length(name)) {
    stop("Vector arguments to name, date, error must all be the same length.")
  }

  cql <- glue::glue('C_date("{name}", {date}, {error});')

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_r_date
#' @export
cql_r_f14c <- function(name, date, error) {
  name <- as.character(name)
  checkmate::assert_integerish(date)
  checkmate::assert_integerish(error)

  if(length(name) != length(date) |
     length(date) != length(error) |
     length(error) != length(name)) {
    stop("Vector arguments to name, date, error must all be the same length.")
  }

  cql <- glue::glue('F14C_date("{name}", {date}, {error});')

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_r_date
#' @export
cql_date <- function(name, date) {
  name <- as.character(name)

  cql <- glue::glue('Date("{name}", {date});')

  cql <- as_cql(cql)
  return(cql)
}


# CQL phase functions -----------------------------------------------------
# (Summary)

#' Describe an unordered group in CQL
#'
#' The CQL command `Phase` is used to describe an unordered group of events in
#' a model.
#'
#' @param name  Character. Label for the phase.
#' @param cql   Vector of `cql` objects contained in the phase.
#'
#' @return
#' A `cql` object.
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html>
#'
#' @family CQL functions
#'
#' @export
#'
#' @examples
#' cql(
#'   cql_phase("Phase A", c(
#'     cql_r_date("ABC-001", 10100, 50),
#'     cql_r_date("ABC-002", 10200, 50),
#'     cql_r_date("ABC-003", 10300, 50)
#'   ))
#' )
cql_phase <- function(name, cql) {
  name <- assert_cql_name(name, "cql_phase")

  if(length(name) > 1) {
    if(length(unique(name)) != 1) {
      warning("Vector arguments to name after the first are ignored.")
    }
    name <- name[[1]]
  }

  cql <- paste0("Phase(\"", name, "\")\n",
                "{\n",
                paste(cql, collapse = "\n"),
                "\n};")

  cql <- as_cql(cql)
  return(cql)
}


# CQL sequence functions --------------------------------------------------
# (Summary)

#' Describe an ordered group in CQL
#'
#' The CQL command `Sequence` is used to describe an *ordered* group of events
#' in a model. Specific types of sequence, i.e. `D_Sequence`, `P_Sequence`,
#' `U_Sequence`, and `V_Sequence`, are not yet implemented in stratigraphr.
#'
#' @param name           Character. Label for the sequence.
#' @param cql            Vector of `cql` objects contained in the sequence.
#' @param boundaries     Logical. If `TRUE`, adds `Boundary` constraints between
#'                       each item in the sequence.
#'
#' @details
#' OxCal expects events within sequences to be in chronological order (oldest to
#' youngest) not stratigraphic order (youngest to oldest).
#'
#' @return
#' A `cql` object.
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html>
#'
#' @family CQL functions
#'
#' @export
#'
#' @examples
#' cql(
#'   cql_sequence("Sequence A", c(
#'     cql_r_date("ABC-001", 10100, 50),
#'     cql_r_date("ABC-002", 10200, 50),
#'     cql_r_date("ABC-003", 10300, 50)
#'   ))
#' )
cql_sequence <- function(name, cql, boundaries = FALSE) {
  name <- assert_cql_name(name, "cql_sequence")
  checkmate::assert_logical(boundaries)

  if(length(name) > 1) {
    if(length(unique(name)) != 1) {
      warning("Vector arguments to name after the first are ignored.")
    }
    name <- name[[1]]
  }


  # TODO: Different types of boundaries, parameters, etc.
  if(boundaries) {
    cql <- as.vector(rbind(cql, rep(cql_boundary(""), length(cql))))
    cql <- c(cql_boundary(""), cql)
  }

  cql <- paste0(cql, collapse = "\n")

  cql <- paste(paste0("Sequence(\"", name, "\")"),
               "{",
               cql,
               "};",
               sep = "\n")

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_sequence
#' @export
cql_d_sequence <- function() { warning("CQL command D_Sequence is not yet implemented in stratigraphr") }

#' @rdname cql_sequence
#' @export
cql_p_sequence <- function() { warning("CQL command P_Sequence is not yet implemented in stratigraphr") }

#' @rdname cql_sequence
#' @export
cql_u_sequence <- function() { warning("CQL command U_Sequence is not yet implemented in stratigraphr") }

#' @rdname cql_sequence
#' @export
cql_v_sequence <- function() { warning("CQL command V_Sequence is not yet implemented in stratigraphr") }

# CQL boundary functions --------------------------------------------------

#' Describe a boundary constraint in CQL
#'
#' @description
#' The CQL command `Boundary` describes constraints within an ordered sequence
#' (see [cql_sequence()]). Groups of events between two boundaries are assumed
#' to be sampled from the same prior distribution. `Boundary` alone models a
#' uniform prior. Other types of boundary, i.e. `Sigma_Boundary`, `Tau_Boundary`,
#' and `Zero_Boundary` are not yet implemented in stratigraphr.
#'
#' Boundaries can contain a `Transition` command, in which case they describe
#' a non-instantaneous transition or 'trapezium' prior.
#'
#' @param name        Character. Label for a boundary or transition.
#' @param ...         `cql` objects contained within a boundary.
#' @param prior       `cql` object. Expression describing the prior likelihood of
#'                    a boundary or transition.
#'
#' @return
#' A `cql` object.
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_analysis_oper.html#group>
#'
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html>
#'
#' @family CQL functions
#'
#' @export
#'
#' @examples
#' # Uniform model with unknown boundaries
#' cql(
#'   cql_boundary("P1 start"),
#'   cql_phase("P1", list(
#'     cql_r_date("A", 5050, 30),
#'     cql_r_date("B", 5000, 30),
#'     cql_r_date("C", 4950, 30)
#'   )),
#'   cql_boundary("P1 end")
#' )
#'
#' # Uniform model with boundaries with a prior likelihood
#' cql(
#'   cql_boundary("P1 start",
#'                prior = cql_date("P1S-Prior", cql_u("", 5200, 5100))),
#'   cql_phase("P1", list(
#'     cql_r_date("A", 5050, 30),
#'     cql_r_date("B", 5000, 30),
#'     cql_r_date("C", 4950, 30)
#'   )),
#'   cql_boundary("P1 end",
#'                prior = cql_date("P1E-Prior", cql_u("", 4800, 4900)))
#' )
#'
#' # 'Trapezium' model
#' cql(
#'   cql_boundary("P1 start",
#'     cql_transition("")
#'   ),
#'   cql_phase("P1", list(
#'     cql_r_date("A", 5050, 30),
#'     cql_r_date("B", 5000, 30),
#'     cql_r_date("C", 4950, 30)
#'   )),
#'   cql_boundary("P1 end",
#'     cql_transition("")
#'   )
#' )
cql_boundary <- function(name, ..., prior = NULL) {
  name <- assert_cql_name(name, "cql_boundary")
  checkmate::assert_class(prior, "cql", null.ok = TRUE)
  assert_cql_dots(...)

  if(is.null(prior)) {
    cql <- glue::glue('Boundary("{name}")')
  }
  else {
    prior <- stringr::str_remove(prior, stringr::coll(";"))
    cql <- glue::glue('Boundary("{name}", {prior})')
  }

  if(!missing(...)) {
    innercql <- paste(..., sep = "\n")
    cql <- paste0(
      cql, "\n",
      "{\n",
      innercql, "\n",
      "};"
    )
  }
  else {
    cql <- paste0(cql, ";")
  }

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_boundary
#' @export
cql_sigma_boundary <- function() { warning("CQL command Sigma_Boundary is not yet implemented in stratigraphr") }

#' @rdname cql_boundary
#' @export
cql_tau_boundary <- function() { warning("CQL command Tau_Boundary is not yet implemented in stratigraphr") }

#' @rdname cql_boundary
#' @export
cql_zero_boundary <- function() { warning("CQL command Zero_Boundary is not yet implemented in stratigraphr") }

#' @rdname cql_boundary
#' @export
cql_transition <- function(name, prior = NULL) {
  name <- as.character(name)
  checkmate::assert_class(prior, "cql", null.ok = TRUE)

  if(is.null(prior)) {
    cql <- glue::glue('Transition("{name}");')
  }
  else {
    prior <- stringr::str_remove(prior, stringr::coll(";"))
    cql <- glue::glue('Transition("{name}", {prior});')
  }

  cql <- as_cql(cql)
  return(cql)
}


# CQL distribution functions ----------------------------------------------

#' Describe distributions in CQL
#'
#' The CQL commands `N`, `LnN`, `T`, `U` and `Top_Hat` describe various types
#' of probability distribution functions. `cql_n()` defines a normal distribution
#' by its mean and standard deviation; `cql_lnn()` a log–normal distribution by
#' its mean and standard deviation; `cql_t()` a Student's t distribution by
#' degrees of freedom; `cql_u()` a uniform distribution by its start and end;
#' `cql_top_hat()` a uniform distribution by its central point and width.
#'
#' @param name        Character. Label for the distribution.
#' @param mu          Integer. Mean of a normal or log–normal distribution.
#' @param sigma       Integer. Standard deviation of a normal or log–normal distribution.
#' @param freedom     Integer. Degrees of freedom of a Student's t distribution.
#' @param scale       Numeric. Optional scaling parameter for a Student's t distribution.
#' @param mid         Integer. Centre point of a uniform distribution.
#' @param half_width  Integer. Half-width of a uniform distribution.
#' @param from        Integer. Start point of a uniform distribution.
#' @param to          Integer. End point of a uniform distribution.
#' @param resolution  Integer. Resolution of the PDF. Leave `NULL` (the default) to use the OxCal default.
#'
#' @return
#' A `cql` object.
#'
#' @references
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_analysis_inform.html#param>
#'
#' <https://c14.arch.ox.ac.uk/oxcalhelp/hlp_commands.html>
#'
#' @family CQL functions
#'
#' @export
#'
#' @examples
#' # Describe a date as a uniform distribution
#' cql_date("U-Date", cql_u("U", -5000, -4000))
cql_n <- function(name, mu, sigma, resolution = NULL) {
  name <- as.character(name)
  checkmate::assert_integerish(mu)
  checkmate::assert_integerish(sigma)
  checkmate::assert_integerish(resolution, null.ok = TRUE)

  if(is.null(resolution)) {
    cql <- glue::glue('N("{name}", {mu}, {sigma});')
  }
  else {
    cql <- glue::glue('N("{name}", {mu}, {sigma}, {resolution});')
  }

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_n
#' @export
cql_lnn <- function(name, mu, sigma, resolution = NULL) {
  name <- as.character(name)
  checkmate::assert_integerish(mu)
  checkmate::assert_integerish(sigma)
  checkmate::assert_integerish(resolution, null.ok = TRUE)

  if(is.null(resolution)) {
    cql <- glue::glue('LnN("{name}", {mu}, {sigma});')
  }
  else {
    cql <- glue::glue('LnN("{name}", {mu}, {sigma}, {resolution});')
  }

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_n
#' @export
cql_t <- function(name, freedom, scale = 1, resolution = NULL) {
  name <- as.character(name)
  checkmate::assert_integerish(freedom)
  checkmate::assert_integerish(scale)
  checkmate::assert_integerish(resolution, null.ok = TRUE)

  if(is.null(resolution)) {
    cql <- glue::glue('T("{name}", {freedom}, {scale});')
  }
  else {
    cql <- glue::glue('T("{name}", {freedom}, {scale}, {resolution});')
  }

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_n
#' @export
cql_top_hat <- function(name, mid, half_width) {
  name <- as.character(name)
  checkmate::assert_integerish(mid)
  checkmate::assert_integerish(half_width)

  cql <- glue::glue('Top_Hat("{name}", {mid}, {half_width});')

  cql <- as_cql(cql)
  return(cql)
}

#' @rdname cql_n
#' @export
cql_u <- function(name, from, to, resolution = NULL) {
  name <- as.character(name)
  checkmate::assert_integerish(from)
  checkmate::assert_integerish(to)
  checkmate::assert_integerish(resolution, null.ok = TRUE)

  if(is.null(resolution)) {
    cql <- glue::glue('U("{name}", {from}, {to});')
  }
  else {
    cql <- glue::glue('U("{name}", {from}, {to}, {resolution});')
  }

  cql <- as_cql(cql)
  return(cql)
}

# Other CQL functions ------------------------------------------------------------

#' Other CQL functions (unimplemented)
#'
#' These CQL commands are not yet implemented in stratigraphr and only included
#' here for reference. Unimplemented commands can be included manually using
#' [cql()] (see examples), but if you need one for an analysis please file a bug
#' report!
#'
#' @name cql_other
#'
#' @param ... Ignored.
#'
#' @return
#' A warning not to use these functions!
#'
#' @family CQL functions
#'
#' @examples
#' # Use cql() to manually write commands that are not yet implemented, e.g.:
#' cql("After(\"A\");")
NULL

#' @rdname cql_other
#' @export
cql_age <- function(...) { warning("CQL command Age is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_axis <- function(...) { warning("CQL command Axis is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_c_combine <- function(...) { warning("CQL command C_Combine is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_c_simulate <- function(...) { warning("CQL command C_Simulate is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_correl_matrix <- function(...) { warning("CQL command Correl_Matrix is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_correlation <- function(...) { warning("CQL command Correlation is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_covar_matrix <- function(...) { warning("CQL command Covar_Matrix is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_curve <- function(...) { warning("CQL command Curve is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_delta_r <- function(...) { warning("CQL command Delta_R is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_difference <- function(...) { warning("CQL command Difference is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_end <- function(...) { warning("CQL command End is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_exp <- function(...) { warning("CQL command Exp is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_gap <- function(...) { warning("CQL command Gap is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_interval <- function(...) { warning("CQL command Interval is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_kde_model <- function(...) { warning("CQL command KDE_Model is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_kde_plot <- function(...) { warning("CQL command KDE_Plot is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_label <- function(...) { warning("CQL command Label is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_line <- function(...) { warning("CQL command Line is not yet implemented in stratigraphr") }


#' @rdname cql_other
#' @export
cql_mcmc_sample <- function(...) { warning("CQL command MCMC_Sample is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_mix_curves <- function(...) { warning("CQL command Mix_Curves is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_number <- function(...) { warning("CQL command Number is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_offset <- function(...) { warning("CQL command Offset is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_outlier <- function(...) { warning("CQL command Outlier is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_outlier_model <- function(...) { warning("CQL command Outlier_Model is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_p <- function(...) { warning("CQL command P is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_pois <- function(...) { warning("CQL command Pois is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_prior <- function(...) { warning("CQL command Prior is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_probability <- function(...) { warning("CQL command Probability is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_r_combine <- function(...) { warning("CQL command R_Combine is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_r_simulate <- function(...) { warning("CQL command R_Simulate is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_reservoir <- function(...) { warning("CQL command Reservoir is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_sample <- function(...) { warning("CQL command Sample is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_sapwood <- function(...) { warning("CQL command Sapwood is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_sapwood_model <- function(...) { warning("CQL command Sapwood_Model is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_shift <- function(...) { warning("CQL command Shift is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_start <- function(...) { warning("CQL command Start is not yet implemented in stratigraphr") }


# CQL group functions -----------------------------------------------------

#' @rdname cql_other
#' @export
cql_after <- function() { warning("CQL command After is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_before <- function() { warning("CQL command Before is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_combine <- function() { warning("CQL command Combine is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_first <- function() { warning("CQL command First is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_last <- function() { warning("CQL command Last is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_order <- function() { warning("CQL command Order is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_span <- function() { warning("CQL command Span is not yet implemented in stratigraphr") }

#' @rdname cql_other
#' @export
cql_sum <- function() { warning("CQL command Sum is not yet implemented in stratigraphr") }


# CQL utility functions (not exported) ----------------------------------------

cql_in <- function(x) {
  x <- stringr::str_split(x, stringr::coll("\n"))
  x <- purrr::map(x, function(x) {
    idd <- 1
    for(i in 1:length(x)) {
      if(stringr::str_starts(stringr::str_trim(x[i]), stringr::coll("}"))) idd <- idd - 1
      indent <- paste0(rep(" ", idd), collapse = "")
      x[i] <- paste0(indent, x[i])
      if(stringr::str_starts(stringr::str_trim(x[i]), stringr::coll("{"))) idd <- idd + 1
    }

    x <- paste0(x, collapse = "\n")
    return(x)
  })

  if(length(x) == 1) {
    x <- unlist(x)
  }

  x <- as_cql(x)
  return(x)
}

assert_cql_dots <- function(...) {
  purrr::map(list(...),
             checkmate::assert_class,
             classes= "cql",
             .var.name = "...")
}

# The Name parameter of most OxCal commands is optional, but since we rely on
# R's dots syntax for nested commands, there's no robust way to determine
# whether the user intentionally omitted it. This function is used
# in CQL functions that expect Name as a first argument to do some soft checks.
# If it's passed a cql object, we assume the user omitted Name and throw an
# error. If it's passed something other than a character, we warn that the user
# might have omitted it but try to continue, e.g. if the name was specified as
# an integer representing just the numeric part of a lab code.
#
# Exceptions are the date functions (e.g. R_Date()), which currently insist on
# all three arguments.
assert_cql_name <- function(name, function_name = "CQL function") {
  # TODO: Could be simplified if not is added to checkmate:
  # https://github.com/mllg/checkmate/issues/193
  if(checkmate::test_class(name, "cql")) {
    stop("First argument to ", function_name, " is a cql object. ",
         "Did you forget to include a name?")
  }
  else if (!checkmate::test_character(name)) {
    warning("First argument to ", function_name, " is not a string. ",
            "Did you forget to include a name?")
  }

  return(as.character(name))
}