R/entity_accessors.R

Defines functions setEvents getEvents setParameters getParameterReferences getParameters set_rparam_mapping set_react_mapping setReactionMappings getReactionMappings setReactionFunction getValidReactionFunctions setReactions getReactionReferences getReactions setCompartments getCompartmentReferences getCompartments setGlobalQuantities getGlobalQuantityReferences getGlobalQuantities setSpecies getSpeciesReferences getSpecies

#' Get species
#'
#' \code{getSpecies} returns species information as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which species to get.
#' @param raw_expressions Whether expressions should be raw (not converted to readable format), as flag.
#' @param model A model object.
#' @return Species and associated information, as data frame.
#' @seealso \code{\link{getSpeciesReferences}} \code{\link{setSpecies}}
#' @family species functions
#' @export
getSpecies <- function(key = NULL, raw_expressions = FALSE, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(is.flag(raw_expressions), !is.na(raw_expressions))
  
  c_model <- c_datamodel$getModel()
  
  if (is_empty(key))
    cl_metabs <- get_cdv(c_model$getMetabolites())
  else
    cl_metabs <- species_obj(key, c_datamodel)
  
  cl_comps <- map_swig(cl_metabs, "getCompartment")
  
  types <- map_swig_chr(cl_metabs, "getStatus")
  dimensionality <- map_swig_int(cl_comps, "getDimensionality")
  has_init_expression <- types != "ASSIGNMENT"
  has_expression <- !has_init_expression | (types == "ODE")
  
  initial_expressions <- rep_along(cl_metabs, "")
  initial_expressions[has_init_expression] <-
    map_chr(cl_metabs[has_init_expression], iexpr_to_str, c_datamodel = c_datamodel, raw = raw_expressions)
  
  expressions <- rep_along(cl_metabs, "")
  expressions[has_expression] <-
    map_chr(cl_metabs[has_expression], expr_to_str, c_datamodel = c_datamodel, raw = raw_expressions)
  
  # assemble output dataframe
  tibble::tibble(
    key                     = get_key(cl_metabs, is_species = TRUE),
    "Name"                  = map_swig_chr(cl_metabs, "getObjectName"),
    "Compartment"           = map_swig_chr(cl_comps, "getObjectName"),
    "Type"                  = tolower(types),
    "Unit"                  = paste0(c_model$getQuantityUnit(), "/", get_dimension_units(c_model)[dimensionality + 1L]),
    "Initial Concentration" = map_swig_dbl(cl_metabs, "getInitialConcentration"),
    "Initial Number"        = map_swig_dbl(cl_metabs, "getInitialValue"),
    "Concentration"         = map_swig_dbl(cl_metabs, "getConcentration"),
    "Number"                = map_swig_dbl(cl_metabs, "getValue"),
    "Rate"                  = map_swig_dbl(cl_metabs, "getConcentrationRate"),
    "Number Rate"           = map_swig_dbl(cl_metabs, "getRate"),
    "Initial Expression"    = initial_expressions,
    "Expression"            = expressions,
    .rows = length(cl_metabs),
    .name_repair = transform_names_worker
  )
}

#' Get species references
#'
#' \code{getSpeciesReferences} returns species attribute references as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which species to get.
#' @param model A model object.
#' @return Species and associated references, as data frame.
#' @seealso \code{\link{getSpecies}} \code{\link{setSpecies}}
#' @family species functions
#' @export
getSpeciesReferences <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  
  c_model <- c_datamodel$getModel()
  
  if (is_empty(key))
    cl_metabs <- get_cdv(c_model$getMetabolites())
  else
    cl_metabs <- species_obj(key, c_datamodel)
  
  cl_comps <- map_swig(cl_metabs, "getCompartment")
  
  types <- map_swig_chr(cl_metabs, "getStatus")
  dimensionality <- map_swig_int(cl_comps, "getDimensionality")
  has_init_expression <- types != "ASSIGNMENT"
  has_expression <- !has_init_expression | (types == "ODE")
  
  initial_expressions <- rep_along(cl_metabs, NA_character_)
  initial_expressions[has_init_expression] <-
    map_chr(cl_metabs[has_init_expression], iexpr_to_ref_str, c_datamodel = c_datamodel)
  
  expressions <- rep_along(cl_metabs, NA_character_)
  expressions[has_expression] <-
    map_chr(cl_metabs[has_expression], expr_to_ref_str, c_datamodel = c_datamodel)
  
  # assemble output dataframe
  tibble::tibble(
    key                     = get_key(cl_metabs, is_species = TRUE),
    "Name"                  = map_swig_chr(cl_metabs, "getObjectName"),
    "Compartment"           = map_swig_chr(cl_comps, "getObjectName"),
    "Type"                  = tolower(types),
    "Unit"                  = paste0(c_model$getQuantityUnit(), "/", get_dimension_units(c_model)[dimensionality + 1L]),
    "Initial Concentration" = cl_metabs %>% map_swig("getInitialConcentrationReference") %>% as_ref(c_datamodel),
    "Initial Number"        = cl_metabs %>% map_swig("getInitialValueReference") %>% as_ref(c_datamodel),
    "Concentration"         = cl_metabs %>% map_swig("getConcentrationReference") %>% as_ref(c_datamodel),
    "Number"                = cl_metabs %>% map_swig("getValueReference") %>% as_ref(c_datamodel),
    "Rate"                  = cl_metabs %>% map_swig("getConcentrationRateReference") %>% as_ref(c_datamodel),
    "Number Rate"           = cl_metabs %>% map_swig("getRateReference") %>% as_ref(c_datamodel),
    "Initial Expression"    = initial_expressions,
    "Expression"            = expressions,
    .rows = length(cl_metabs),
    .name_repair = transform_names_worker
  )
}

#' Set species
#'
#' \code{setSpecies} applies given values to species of the model depending on the \code{key} argument.
#' 
#' Use the \code{key} argument to specify which species to modify and any of the other arguments to specify the value to set.
#' The function is fully vectorized.
#' If a \code{NA} value is supplied, the model value is kept unchanged.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which species to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one species.
#' @param name Name to set, as string.
#' @param compartment Key of new compartment to set, as string.
#' @param type Type ("fixed", "assignment", "reactions", "ode") to set, as string.
#' @param initial_concentration Initial concentration to set, as numeric.
#' @param initial_number Initial particle number to set, as numeric.
#' @param initial_expression Initial expression to set, as string, finite numeric, or logical.
#' @param expression Expression to set, as string, finite numeric, or logical.
#' @param data A data frame as given by \code{\link{getSpecies}} which will be applied before the other arguments.
#' @param model A model object.
#' @seealso \code{\link{getSpecies}} \code{\link{getSpeciesReferences}}
#' @family species functions
#' @export
setSpecies <- function(key = NULL, name = NULL, compartment = NULL, type = NULL, initial_concentration = NULL, initial_number = NULL, initial_expression = NULL, expression = NULL, data = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.null(name)                  || is.character(name)                 && length(name) == length(key),
    is.null(type)                  || is.character(type)                 && length(type) == length(key),
    is.null(compartment)           || is.character(compartment)          && length(compartment)  == length(key),
    is.null(initial_concentration) || is.numeric(initial_concentration)  && length(initial_concentration) == length(key),
    is.null(initial_number)        || is.numeric(initial_number)         && length(initial_number) == length(key),
    is.null(initial_expression)    || is.cexpression(initial_expression) && length(initial_expression) == length(key),
    is.null(expression)            || is.cexpression(expression)         && length(expression) == length(key),
    is.null(data)                  || is.data.frame(data)
  )
  
  # Do this as assertion before we start changing values
  cl_metabs <- species_obj(key %||% character(), c_datamodel)
  
  # gather vectors of what to actually do work on
  false_vec <- rep_along(cl_metabs, FALSE)
  do_name                     <- if (is.null(name))                  false_vec else !is.na(name)
  do_type                     <- if (is.null(type))                  false_vec else !is.na(type)
  do_compartment              <- if (is.null(compartment))           false_vec else !is.na(compartment)
  do_initial_concentration    <- if (is.null(initial_concentration)) false_vec else !is_pure_na(initial_concentration)
  do_initial_number           <- if (is.null(initial_number))        false_vec else !is_pure_na(initial_number)
  do_clear_initial_expression <- if (is.null(initial_expression))    false_vec else initial_expression == ""
  do_initial_expression       <- if (is.null(initial_expression))    false_vec else !is.na(initial_expression) & !do_clear_initial_expression
  do_expression               <- if (is.null(expression))            false_vec else !is.na(expression)

  # cut pointless actions
  do_initial_concentration    <- do_initial_concentration    & !do_initial_number       & !do_initial_expression
  do_initial_number           <- do_initial_number                                      & !do_initial_expression
  do_clear_initial_expression <- do_clear_initial_expression | do_initial_concentration | do_initial_number
  
  # assemble compartments
  if (any(do_compartment)) {
    cl_comps_new <- list_along(cl_metabs)
    cl_comps_new[do_compartment] <- compartment_obj(compartment[do_compartment], c_datamodel)
  }
  
  if (any(do_type))
    type <- toupper(args_match(type, c(NA_character_, "fixed", "assignment", "reactions", "ode")))
  
  if (any(do_initial_expression)) {
    initial_expression[do_initial_expression] <-
      initial_expression[do_initial_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  if (any(do_expression)) {
    expression[do_expression] <-
      expression[do_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  # if data is provided with the data arg, run a recursive call
  # needs to be kept up to date with the function args
  if (!is.null(data))
    do.call(setSpecies, data[names(data) %in% c("key", "name", "type", "initial_concentration", "initial_number", "initial_expression", "expression")])
  
  if (is_empty(cl_metabs))
    return(invisible())
  
  c_model <- c_datamodel$getModel()
  
  # apply names
  for (i in which(do_name))
    cl_metabs[[i]]$setObjectName(name[i])
  
  # apply compartments
  if (any(do_compartment)) {
    comp_old_key <-
      cl_metabs[do_compartment] %>%
      map_swig("getCompartment") %>%
      map_swig_chr("getKey")
    
    comp_new_key <-
      cl_comps_new[do_compartment] %>%
      map_swig_chr("getKey")
    
    comp_changed <- rep_along(cl_metabs, FALSE)
    comp_changed[do_compartment] <- comp_old_key != comp_new_key
    
    if (any(comp_changed)) {
      for (i in which(comp_changed))
        assert_that(
          grab_msg(cl_comps_new[[i]]$addMetabolite(cl_metabs[[i]])),
          msg = "Failed to move species."
        )
        # remove from old compartment by name (by pointer is not exported by swig.)
        # looks like there is some method that will remove the metab when adding it to another comp.
        # cl_comps_old[[i]]$getMetabolites()$removeByName(cl_metabs[[i]]$getObjectName())
      
      c_model$initializeMetabolites()
      c_model$setCompileFlag()
    }
  }
  
  # apply types
  if (any(do_type)) {
    for (i in which(do_type))
      cl_metabs[[i]]$setStatus(type[i])
    
    # this is added to prevent a possible following setInitialConcentration + updateInitialValues("Concentration")
    # from somehow always defaulting to 0 initial concentration.
    compile_and_check(c_model)
  }
  
  if (any(do_clear_initial_expression))
    walk_swig(cl_metabs[do_clear_initial_expression], "setInitialExpression", "")
  
  # apply initial concentrations
  if (any(do_initial_concentration)) {
    for (i in which(do_initial_concentration))
      cl_metabs[[i]]$setInitialConcentration(initial_concentration[i])
    
    c_model$updateInitialValues("Concentration")
  }
  
  # apply initial particlenum
  if (any(do_initial_number)) {
    for (i in which(do_initial_number))
      cl_metabs[[i]]$setInitialValue(initial_number[i])
    
    c_model$updateInitialValues("ParticleNumbers")
  }
  
  # apply initial expressions
  for (i in which(do_initial_expression))
    assert_that(
      grab_msg(cl_metabs[[i]]$setInitialExpression(initial_expression[i])$isSuccess()),
      msg = "Failed when applying an initial expression."
    )
  
  # apply expressions
  for (i in which(do_expression)) {
    c_metab <- cl_metabs[[i]]
    expr <- expression[i]
    
    success <- grab_msg(c_metab$setExpression(expr)$isSuccess())
    
    # if fixed, expression will be "" but setting to "" will not succeed
    assert_that(
      success || (expr == "" && c_metab$getExpression() == ""),
      msg = "Failed when applying an expression."
    )
  }
  
  compile_and_check(c_model)
  
  invisible()
}

#' Get global quantities
#'
#' \code{getGlobalQuantities} returns global quantities as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which global quantities to get.
#' @param raw_expressions Whether expressions should be raw (not converted to readable format), as flag.
#' @param model A model object.
#' @return Global quantities and associated information, as data frame.
#' @seealso \code{\link{getGlobalQuantityReferences}} \code{\link{setGlobalQuantities}}
#' @family global quantity functions
#' @export
getGlobalQuantities <- function(key = NULL, raw_expressions = FALSE, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(is.flag(raw_expressions), !is.na(raw_expressions))
  
  if (is_empty(key))
    cl_quants <- get_cdv(c_datamodel$getModel()$getModelValues())
  else
    cl_quants <- quantity_obj(key, c_datamodel)
  
  types <- map_swig_chr(cl_quants, "getStatus")
  has_init_expression <- types != "ASSIGNMENT"
  has_expression <- !has_init_expression | (types == "ODE")
  
  initial_expressions <- rep_along(cl_quants, "")
  initial_expressions[has_init_expression] <-
    map_chr(cl_quants[has_init_expression], iexpr_to_str, c_datamodel = c_datamodel, raw = raw_expressions)
  
  expressions <- rep_along(cl_quants, "")
  expressions[has_expression] <-
    map_chr(cl_quants[has_expression], expr_to_str, c_datamodel = c_datamodel, raw = raw_expressions)
  
  # assemble output dataframe
  tibble::tibble(
    key                  = get_key(cl_quants),
    "Name"               = map_swig_chr(cl_quants, "getObjectName"),
    "Type"               = tolower(types),
    "Unit"               = map_swig_chr(cl_quants, "getUnitExpression"),
    "Initial Value"      = map_swig_dbl(cl_quants, "getInitialValue"),
    "Value"              = map_swig_dbl(cl_quants, "getValue"),
    "Rate"               = map_swig_dbl(cl_quants, "getRate"),
    "Initial Expression" = initial_expressions,
    "Expression"         = expressions,
    .rows = length(cl_quants),
    .name_repair = transform_names_worker
  )
}

#' Get global quantity references
#'
#' \code{getGlobalQuantityReferences} returns global quantity attribute references as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which global quantities to get.
#' @param model A model object.
#' @return Global quantities and associated references, as data frame.
#' @seealso \code{\link{getGlobalQuantities}} \code{\link{setGlobalQuantities}}
#' @family global quantity functions
#' @export
getGlobalQuantityReferences <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  
  if (is_empty(key))
    cl_quants <- get_cdv(c_datamodel$getModel()$getModelValues())
  else
    cl_quants <- quantity_obj(key, c_datamodel)
  
  types <- map_swig_chr(cl_quants, "getStatus")
  has_init_expression <- types != "ASSIGNMENT"
  has_expression <- !has_init_expression | (types == "ODE")
  
  initial_expressions <- rep_along(cl_quants, NA_character_)
  initial_expressions[has_init_expression] <-
    map_chr(cl_quants[has_init_expression], iexpr_to_ref_str, c_datamodel = c_datamodel)
  
  expressions <- rep_along(cl_quants, NA_character_)
  expressions[has_expression] <-
    map_chr(cl_quants[has_expression], expr_to_ref_str, c_datamodel = c_datamodel)
  
  # assemble output dataframe
  tibble::tibble(
    key                  = get_key(cl_quants),
    "Name"               = map_swig_chr(cl_quants, "getObjectName"),
    "Type"               = tolower(types),
    "Unit"               = map_swig_chr(cl_quants, "getUnitExpression"),
    "Initial Value"      = cl_quants %>% map_swig("getInitialValueReference") %>% as_ref(c_datamodel),
    "Value"              = cl_quants %>% map_swig("getValueReference") %>% as_ref(c_datamodel),
    "Rate"               = cl_quants %>% map_swig("getRateReference") %>% as_ref(c_datamodel),
    "Initial Expression" = initial_expressions,
    "Expression"         = expressions,
    .rows = length(cl_quants),
    .name_repair = transform_names_worker
  )
}

#' Set global quantities
#'
#' \code{setGlobalQuantities} applies given values to global quantities of the model depending on the \code{key} argument.
#'
#' Use the \code{key} argument to specify which global quantity to modify and any of the other arguments to specify the value to set.
#' The function is fully vectorized.
#' If a \code{NA} value is supplied, the model value is kept unchanged.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which global quantity to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one global quantity.
#' @param name Name to set, as string.
#' @param type Type ("fixed", "assignment", "ode") to set, as string.
#' @param unit Unit to set, as string.
#' @param initial_value Initial value to set, as numeric.
#' @param initial_expression Initial expression to set, as string, finite numeric, or logical.
#' @param expression Expression to set, as string, finite numeric, or logical.
#' @param data A data frame as given by \code{\link{getGlobalQuantities}} which will be applied before the other arguments.
#' @param model A model object.
#' @seealso \code{\link{getGlobalQuantities}} \code{\link{getGlobalQuantityReferences}}
#' @family global quantity functions
#' @export
setGlobalQuantities <- function(key = NULL, name = NULL, type = NULL, unit = NULL, initial_value = NULL, initial_expression = NULL, expression = NULL, data = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.null(name)               || is.character(name)                 && length(name) == length(key),
    is.null(type)               || is.character(type)                 && length(type) == length(key),
    is.null(unit)               || is.character(unit)                 && length(unit) == length(key),
    is.null(initial_value)      || is.numeric(initial_value)          && length(initial_value) == length(key),
    is.null(initial_expression) || is.cexpression(initial_expression) && length(initial_expression) == length(key),
    is.null(expression)         || is.cexpression(expression)         && length(expression) == length(key),
    is.null(data)               || is.data.frame(data)
  )
  
  # Do this as assertion before we start changing values
  cl_quants <- quantity_obj(key %||% character(), c_datamodel)
  
  # gather vectors of what to actually do work on
  false_vec <- rep_along(cl_quants, FALSE)
  do_name                     <- if (is.null(name))               false_vec else !is.na(name)
  do_type                     <- if (is.null(type))               false_vec else !is.na(type)
  do_unit                     <- if (is.null(unit))               false_vec else !is.na(unit)
  do_initial_value            <- if (is.null(initial_value))      false_vec else !is_pure_na(initial_value)
  do_clear_initial_expression <- if (is.null(initial_expression)) false_vec else initial_expression == ""
  do_initial_expression       <- if (is.null(initial_expression)) false_vec else !is.na(initial_expression) & !do_clear_initial_expression
  do_expression               <- if (is.null(expression))         false_vec else !is.na(expression)
  
  # cut pointless actions
  do_initial_value            <- do_initial_value            & !do_initial_expression
  do_clear_initial_expression <- do_clear_initial_expression | do_initial_value
  
  if (any(do_type))
    type <- toupper(args_match(type, c(NA_character_, "fixed", "assignment", "ode")))
  
  if (any(do_unit)) {
    unit_pretty <- unit
    do_unit_not_empty <- do_unit & unit != ""
    
    # Use prettyprint as check for valid units. Returns "?" for invalid.
    unit_pretty[do_unit_not_empty] <- grab_msg(map_chr(unit[do_unit_not_empty], unclass(CUnit_prettyPrint)))
    
    invalid_units <- unit_pretty == "?"
    
    assert_that(
      !any(invalid_units),
      msg = paste0('`unit` value(s) "', paste0(unit[invalid_units], collapse = '", "'), '" could not be interpreted.')
    )
  }
  
  if (any(do_initial_expression)) {
    initial_expression[do_initial_expression] <-
      initial_expression[do_initial_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  if (any(do_expression)) {
    expression[do_expression] <-
      expression[do_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  # if data is provided with the data arg, run a recursive call
  # needs to be kept up to date with the function args
  if (!is.null(data))
    do.call(setGlobalQuantities, data[names(data) %in% c("key", "name", "type", "unit", "initial_value", "initial_expression", "expression")])
  
  if (is_empty(cl_quants))
    return(invisible())
  
  c_model <- c_datamodel$getModel()
  
  # apply names
  for (i in which(do_name))
    cl_quants[[i]]$setObjectName(name[i])
  
  # apply types
  for (i in which(do_type))
    cl_quants[[i]]$setStatus(type[i])
  
  # apply units
  for (i in which(do_unit))
    cl_quants[[i]]$setUnitExpression(unit[i])
  
  if (any(do_clear_initial_expression))
    walk_swig(cl_quants[do_clear_initial_expression], "setInitialExpression", "")
  
  # apply initial value
  if (any(do_initial_value)) {
    for (i in which(do_initial_value))
      cl_quants[[i]]$setInitialValue(initial_value[i])
    
    c_model$updateInitialValues("ParticleNumbers")
  }
  
  # apply initial expressions
  for (i in which(do_initial_expression))
    assert_that(
      grab_msg(cl_quants[[i]]$setInitialExpression(initial_expression[i])$isSuccess()),
      msg = "Failed when applying an initial expression."
    )
  
  # apply expressions
  for (i in which(do_expression)) {
    c_quant <- cl_quants[[i]]
    expr <- expression[i]
    
    success <- grab_msg(c_quant$setExpression(expr)$isSuccess())
    
    # if fixed, expression will be "" but setting to "" will not succeed
    assert_that(
      success || (expr == "" && c_quant$getExpression() == ""),
      msg = "Failed when applying an expression."
    )
  }
  
  compile_and_check(c_model)
  
  invisible()
}

#' Get compartments
#'
#' \code{getCompartments} returns compartments as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which compartments to get.
#' @param raw_expressions Whether expressions should be raw (not converted to readable format), as flag.
#' @param model A model object.
#' @return Compartments and associated information, as data frame.
#' @seealso \code{\link{getCompartmentReferences}} \code{\link{setCompartments}}
#' @family compartment functions
#' @export
getCompartments <- function(key = NULL, raw_expressions = FALSE, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(is.flag(raw_expressions), !is.na(raw_expressions))
  
  c_model <- c_datamodel$getModel()
  
  if (is_empty(key))
    cl_comps <- get_cdv(c_model$getCompartments())
  else
    cl_comps <- compartment_obj(key, c_datamodel)
  
  types <- map_swig_chr(cl_comps, "getStatus")
  dimensionality <- map_swig_int(cl_comps, "getDimensionality")
  has_init_expression <- types != "ASSIGNMENT"
  has_expression <- !has_init_expression | (types == "ODE")
  
  initial_expressions <- rep_along(cl_comps, "")
  initial_expressions[has_init_expression] <-
    map_chr(cl_comps[has_init_expression], iexpr_to_str, c_datamodel = c_datamodel, raw = raw_expressions)
  
  expressions <- rep_along(cl_comps, "")
  expressions[has_expression] <-
    map_chr(cl_comps[has_expression], expr_to_str, c_datamodel = c_datamodel, raw = raw_expressions)
  
  # assemble output dataframe
  tibble::tibble(
    key                  = get_key(cl_comps),
    "Name"               = map_swig_chr(cl_comps, "getObjectName"),
    "Type"               = tolower(types),
    "Dimensionality"     = dimensionality,
    "Unit"               = get_dimension_units(c_model)[dimensionality + 1L],
    "Initial Size"       = map_swig_dbl(cl_comps, "getInitialValue"),
    "Size"               = map_swig_dbl(cl_comps, "getValue"),
    "Rate"               = map_swig_dbl(cl_comps, "getRate"),
    "Initial Expression" = initial_expressions,
    "Expression"         = expressions,
    .rows = length(cl_comps),
    .name_repair = transform_names_worker
  )
}

#' Get compartment references
#'
#' \code{getCompartmentReferences} returns compartment attribute references as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which compartments to get.
#' @param model A model object.
#' @return Compartments and associated references, as data frame.
#' @seealso \code{\link{getCompartments}} \code{\link{setCompartments}}
#' @family compartment functions
#' @export
getCompartmentReferences <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  
  c_model <- c_datamodel$getModel()
  
  if (is_empty(key))
    cl_comps <- get_cdv(c_model$getCompartments())
  else
    cl_comps <- compartment_obj(key, c_datamodel)
  
  types <- map_swig_chr(cl_comps, "getStatus")
  dimensionality <- map_swig_int(cl_comps, "getDimensionality")
  has_init_expression <- types != "ASSIGNMENT"
  has_expression <- !has_init_expression | (types == "ODE")
  
  initial_expressions <- rep_along(cl_comps, NA_character_)
  initial_expressions[has_init_expression] <-
    map_chr(cl_comps[has_init_expression], iexpr_to_ref_str, c_datamodel = c_datamodel)
  
  expressions <- rep_along(cl_comps, NA_character_)
  expressions[has_expression] <-
    map_chr(cl_comps[has_expression], expr_to_ref_str, c_datamodel = c_datamodel)
  
  # assemble output dataframe
  tibble::tibble(
    key                  = get_key(cl_comps),
    "Name"               = map_swig_chr(cl_comps, "getObjectName"),
    "Type"               = tolower(types),
    "Dimensionality"     = dimensionality,
    "Unit"               = get_dimension_units(c_model)[dimensionality + 1L],
    "Initial Size"       = cl_comps %>% map_swig("getInitialValueReference") %>% as_ref(c_datamodel),
    "Size"               = cl_comps %>% map_swig("getValueReference") %>% as_ref(c_datamodel),
    "Rate"               = cl_comps %>% map_swig("getRateReference") %>% as_ref(c_datamodel),
    "Initial Expression" = initial_expressions,
    "Expression"         = expressions,
    .rows = length(cl_comps),
    .name_repair = transform_names_worker
  )
}

#' Set compartments
#'
#' \code{setCompartments} applies given values to compartments of the model depending on the \code{key} argument.
#'
#' Use the \code{key} argument to specify which compartment to modify and any of the other arguments to specify the value to set.
#' The function is fully vectorized.
#' If a \code{NA} value is supplied, the model value is kept unchanged.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which compartment to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one compartment.
#' @param name Name to set, as string.
#' @param type Type ("fixed", "assignment", "ode") to set, as string.
#' @param dimensionality Dimensionality to set (0D, 1D, 2D, 3D), as number.
#' @param initial_size Initial size to set, as string.
#' @param initial_expression Initial expression to set, as string, finite numeric, or logical.
#' @param expression Expression to set, as string, finite numeric, or logical.
#' @param data A data frame as given by \code{\link{getCompartments}} which will be applied before the other arguments.
#' @param preserve_concentrations Whether changes in compartment size should keep species concentrations fixed, as flag.
#' If set to \code{TRUE}, size changes will in turn affect species particle numbers. Has no effect on expressions.
#' @param model A model object.
#' @seealso \code{\link{getCompartments}} \code{\link{getCompartmentReferences}}
#' @family compartment functions
#' @export
setCompartments <- function(key = NULL, name = NULL, type = NULL, dimensionality = NULL, initial_size = NULL, initial_expression = NULL, expression = NULL, data = NULL, preserve_concentrations = FALSE, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.null(name)                    || is.character(name)                 && length(name) == length(key),
    is.null(type)                    || is.character(type)                 && length(type) == length(key),
    is.null(dimensionality)          || is.numeric(dimensionality)         && length(dimensionality) == length(key),
    is.null(initial_size)            || is.numeric(initial_size)           && length(initial_size) == length(key),
    is.null(initial_expression)      || is.cexpression(initial_expression) && length(initial_expression) == length(key),
    is.null(expression)              || is.cexpression(expression)         && length(expression) == length(key),
    is.null(data)                    || is.data.frame(data),
    is.flag(preserve_concentrations) && noNA(preserve_concentrations)
  )
  
  # Do this as assertion before we start changing values
  cl_comps <- compartment_obj(key %||% character(), c_datamodel)
  
  # gather vectors of what to actually do work on
  false_vec <- rep_along(cl_comps, FALSE)
  do_name                     <- if (is.null(name))               false_vec else !is.na(name)
  do_type                     <- if (is.null(type))               false_vec else !is.na(type)
  do_dimensionality           <- if (is.null(dimensionality))     false_vec else !is_pure_na(dimensionality)
  do_initial_size             <- if (is.null(initial_size))       false_vec else !is_pure_na(initial_size)
  do_clear_initial_expression <- if (is.null(initial_expression)) false_vec else initial_expression == ""
  do_initial_expression       <- if (is.null(initial_expression)) false_vec else !is.na(initial_expression) & !do_clear_initial_expression
  do_expression               <- if (is.null(expression))         false_vec else !is.na(expression)
  
  # cut pointless actions
  do_initial_size             <- do_initial_size             & !do_initial_expression
  do_clear_initial_expression <- do_clear_initial_expression | do_initial_size
  
  if (any(do_type))
    type <- toupper(args_match(type, c(NA_character_, "fixed", "assignment", "ode")))
  
  if (any(do_dimensionality)) {
    dimensionality <- as.integer(dimensionality)
    assert_that(
      all(dimensionality[do_dimensionality] %in% c(0L:3L)),
      msg = '`dimensionality` should be one of: `NA`, 0, 1, 2, 3'
    )
  }

  if (any(do_initial_expression)) {
    initial_expression[do_initial_expression] <-
      initial_expression[do_initial_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  if (any(do_expression)) {
    expression[do_expression] <-
      expression[do_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  # if data is provided with the data arg, run a recursive call
  # needs to be kept up to date with the function args
  if (!is.null(data))
    do.call(setCompartments, c(data[names(data) %in% c("key", "name", "type", "dimensionality", "initial_size", "initial_expression", "expression")], preserve_concentrations = preserve_concentrations))
  
  if (is_empty(cl_comps))
    return(invisible())
  
  c_model <- c_datamodel$getModel()
  
  # apply names
  for (i in which(do_name))
    cl_comps[[i]]$setObjectName(name[i])
  
  # apply types
  for (i in which(do_type))
    cl_comps[[i]]$setStatus(type[i])
  
  # apply dimensionality
  for (i in which(do_dimensionality))
    cl_comps[[i]]$setDimensionality(dimensionality[i])
  
  if (any(do_clear_initial_expression))
    walk_swig(cl_comps[do_clear_initial_expression], "setInitialExpression", "")
  
  # apply initial size
  if (any(do_initial_size)) {
    for (i in which(do_initial_size))
      cl_comps[[i]]$setInitialValue(initial_size[i])
    
    if (preserve_concentrations)
      c_model$updateInitialValues("Concentration")
    else
      c_model$updateInitialValues("ParticleNumbers")
  }
  
  # apply initial expressions
  for (i in which(do_initial_expression))
    assert_that(
      grab_msg(cl_comps[[i]]$setInitialExpression(initial_expression[i])$isSuccess()),
      msg = "Failed when applying an initial expression."
    )
  
  # apply expressions
  for (i in which(do_expression)) {
    c_comp <- cl_comps[[i]]
    expr <- expression[i]
    
    success <- grab_msg(c_comp$setExpression(expr)$isSuccess())
    
    # if fixed, expression will be "" but setting to "" will not succeed
    assert_that(
      success || (expr == "" && c_comp$getExpression() == ""),
      msg = "Failed when applying an expression."
    )
  }
  
  compile_and_check(c_model)
  
  invisible()
}

#' Get reactions
#'
#' \code{getReactions} returns reactions as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which reactions to get.
#' @param model A model object.
#' @return Reactions and associated information, as data frame.
#' @seealso \code{\link{getReactionReferences}} \code{\link{setReactions}}
#' @family reaction functions
#' @export
getReactions <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  
  if (is_empty(key))
    cl_reacts <- get_cdv(c_datamodel$getModel()$getReactions())
  else
    cl_reacts <- reaction_obj(key, c_datamodel)
  
  # assemble output dataframe
  tibble::tibble(
    key           = get_key(cl_reacts),
    "Name"        = map_swig_chr(cl_reacts, "getObjectName"),
    "Reaction"    = map_swig_chr(cl_reacts, "getReactionScheme"),
    "Rate Law"    = cl_reacts %>% map_swig("getFunction") %>% get_key(),
    "Flux"        = map_swig_dbl(cl_reacts, "getFlux"),
    "Number Flux" = map_swig_dbl(cl_reacts, "getParticleFlux"),
    .rows = length(cl_reacts),
    .name_repair = transform_names_worker
  )
}

#' Get reaction references
#'
#' \code{getReactions} returns reactions attribute references as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which reactions to get.
#' @param model A model object.
#' @return Reactions and associated references, as data frame.
#' @seealso \code{\link{getReactions}} \code{\link{setReactions}}
#' @family reaction functions
#' @export
getReactionReferences <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  
  if (is_empty(key))
    cl_reacts <- get_cdv(c_datamodel$getModel()$getReactions())
  else
    cl_reacts <- reaction_obj(key, c_datamodel)
  
  # assemble output dataframe
  tibble::tibble(
    key           = get_key(cl_reacts),
    "Name"        = map_swig_chr(cl_reacts, "getObjectName"),
    "Reaction"    = map_swig_chr(cl_reacts, "getReactionScheme"),
    "Rate Law"    = cl_reacts %>% map_swig("getFunction") %>% get_key(),
    "Flux"        = cl_reacts %>% map_swig("getFluxReference") %>% as_ref(c_datamodel),
    "Number Flux" = cl_reacts %>% map_swig("getParticleFluxReference") %>% as_ref(c_datamodel),
    .rows = length(cl_reacts),
    .name_repair = transform_names_worker
  )
}

#' Set reactions
#'
#' \code{setReactions} applies given values to reactions of the model depending on the \code{key} argument.
#'
#' Use the \code{key} argument to specify which reaction to modify and any of the other arguments to specify the value to set.
#' The function is fully vectorized.
#' If a \code{NA} value is supplied, the model value is kept unchanged.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which reaction to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one reaction.
#' @param name Name to set, as string.
#' @param data A data frame as given by \code{\link{getReactions}} which will be applied before the other arguments.
#' @param model A model object.
#' @seealso \code{\link{getReactions}} \code{\link{getReactionReferences}}
#' @family reaction functions
#' @export
setReactions <- function(key = NULL, name = NULL, data = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.null(name)      || is.character(name) && length(name) == length(key),
    is.null(data)      || is.data.frame(data)
  )
  
  # Do this as assertion before we start changing values
  cl_reacts <- reaction_obj(key %||% character(), c_datamodel)
  
  # gather vectors of what to actually do work on
  false_vec <- rep_along(cl_reacts, FALSE)
  do_name <- if (is.null(name)) false_vec else !is.na(name)

  # if data is provided with the data arg, run a recursive call
  # needs to be kept up to date with the function args
  if (!is.null(data))
    do.call(setReactions, data[names(data) %in% c("key", "name")])
  
  if (is_empty(cl_reacts))
    return(invisible())
  
  # apply names
  for (i in which(do_name))
    cl_reacts[[i]]$setObjectName(name[i])
  
  invisible()
}

#' Get valid function names for reaction
#' 
#' \code{getValidReactionFunctions} returns valid function names for a reaction.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which reaction to read by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one reaction.
#' @param model A model object.
#' @return Function names, as character vector.
#' @seealso \code{\link{setReactionFunction}}
#' @family reaction functions
#' @export
getValidReactionFunctions <- function(key, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.scalar(key)
  )
  
  c_react <- reaction_obj(key, c_datamodel)[[1]]
  
  c_model <- c_datamodel$getModel()
  c_reacti <- CReactionInterface()
  c_reacti$init(c_react)
  
  # Workaround because the function vector is somehow only given as bare pointer
  # Coerce it to a string vector object
  c_fun_vector <- new(
    "_p_std__vectorT_std__string_std__allocatorT_std__string_t_t",
    ref = c_reacti$getListOfPossibleFunctions()
  )
  
  c_fun_vector %>%
    get_sv() %>%
    kinfunction_strict()
}

#' Set a reaction function
#' 
#' \code{setReactionFunction} sets the reaction function for a reaction.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which reaction to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one reaction.
#' @param fun Key of new kinetic function to set, as string.
#' Also supports fragments of keys, if uniquely matching one kinetic function.
#' @param mappings Parameter mappings, as named list.
#' Names are the parameters of the kinetic function.
#' Values are either entity keys valid for the specific type of parameter or a numeric value in case of a local parameter.
#' @param model A model object.
#' @seealso \code{\link{getValidReactionFunctions}}
#' @family reaction functions
#' @export
setReactionFunction <- function(key, fun, mappings = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.scalar(key),
    is.scalar(fun)
  )
  
  c_react <- reaction_obj(key, c_datamodel)[[1]]
  c_fun <- kinfunction_obj(fun)[[1]]
  fun <- c_fun$getObjectName()
  
  c_model <- c_datamodel$getModel()
  c_reacti <- CReactionInterface()
  c_reacti$init(c_react)
  
  valid_funs <-
    get_sv(
      new(
        "_p_std__vectorT_std__string_std__allocatorT_std__string_t_t",
        ref = c_reacti$getListOfPossibleFunctions()
      )
    )
  
  fun <- rlang::arg_match(fun, valid_funs)
  
  c_reacti$setFunctionAndDoMapping(fun)
  
  if (!is.null(mappings))
    set_react_mapping(c_datamodel, c_reacti, mappings)
  
  c_reacti$writeBackToReaction(c_react)
  
  compile_and_check(c_model)
  
  invisible()
}

#' Get reaction parameter mappings
#' 
#' \code{getReactionMappings} returns reaction parameter mappings for a reaction.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which reaction to read by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one reaction.
#' @param model A model object.
#' @return Reaction parameter mappings, as list.
#' @seealso \code{\link{setReactionMappings}}
#' @family reaction functions
#' @export
getReactionMappings <- function(key, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(is.scalar(key))
  
  c_react <- reaction_obj(key, c_datamodel)[[1]]
  
  c_model <- c_datamodel$getModel()
  c_reacti <- CReactionInterface()
  c_reacti$init(c_react)
  
  params <- seq_along_v(c_reacti)
  names(params) <- map_chr(params, ~ c_reacti$getParameterName(.x))
  
  params_is_local <- map_lgl(params, ~ c_reacti$isLocalValue(.x))
  
  params %>%
    map_if(
      params_is_local,
      ~ c_reacti$getLocalValue(.x)
    ) %>%
    map_if(
      !params_is_local,
      ~ get_sv(c_reacti$getMappings(.x))
    )
}

#' Set reaction parameter mappings
#' 
#' \code{setReactionMappings} sets reaction parameter mappings for a reaction.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which reaction to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one reaction.
#' @param mappings Parameter mappings, as named list.
#' Names are the parameters of the kinetic function.
#' Values are either entity keys valid for the specific type of parameter or a numeric value in case of a local parameter.
#' @param model A model object.
#' @seealso \code{\link{getReactionMappings}}
#' @family reaction functions
#' @export
setReactionMappings <- function(key, mappings, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(is.scalar(key))
  
  c_react <- reaction_obj(key, c_datamodel)[[1]]
  
  c_model <- c_datamodel$getModel()
  
  c_reacti <- CReactionInterface()
  c_reacti$init(c_react)
  
  set_react_mapping(c_datamodel, c_reacti, mappings)
  
  c_reacti$writeBackToReaction(c_react)
  
  compile_and_check(c_model)
  
  invisible()
}

set_react_mapping <- function(c_datamodel, c_reacti, mappings) {
  assert_that(is.list(mappings), !is.null(names(mappings)), noNA(names(mappings)))
  
  params <- seq_along_v(c_reacti)
  names(params) <- map_chr(params, ~ c_reacti$getParameterName(.x))
  
  names(mappings) <- args_match(names(mappings), name = "parameter", names(params))
  
  iwalk(mappings, ~ {
    set_rparam_mapping(c_datamodel, c_reacti, i = params[[.y]], value = .x)
  })
  
  assert_that(c_reacti$isValid(), msg = "Result of mapping is invalid.")
}

set_rparam_mapping <- function(c_datamodel, c_reacti, i, value) {
  type <- c_reacti$getUsage(i)
  
  assert_that(is.scalar(value), msg = paste0("Parameter `", c_reacti$getParameterName(i), '` must be scalar.'))
  
  valid_vals <- NULL
  if (type %in% c("SUBSTRATE", "PRODUCT", "MODIFIER")) {
    key <- species_strict(value, model = c_datamodel)
    
    valid_vals <-
      c_reacti$getListOfMetabs(type) %>%
      get_sv() %>%
      species_strict(model = c_datamodel)
    
    assert_that(
      key %in% valid_vals,
      msg = paste0("Parameter `", c_reacti$getParameterName(i), '` should be one of: "', paste0(valid_vals, collapse = '", '), '".')
    )
    
    c_reacti$setMapping(i, key)
  } else if (type == "VOLUME") {
    # CReactionInterface allows mapping by ObjectName but CoRC uses ObjectDisplayName so do a bit of translation.
    c_comp <- compartment_obj(value, c_datamodel)[[1]]
    valid_vals <- compartment(model = c_datamodel)
    
    assert_that(
      get_key(c_comp) %in% valid_vals,
      msg = paste0("Parameter `", c_reacti$getParameterName(i), '` should be one of: "', paste0(valid_vals, collapse = '", '), '".')
    )
    
    c_reacti$setMapping(i, c_comp$getObjectName())
  } else if (type == "PARAMETER") {
    if (is.number(value)) {
      c_reacti$setLocalValue(i, value)
    } else {
      # CReactionInterface allows mapping by ObjectName but CoRC uses ObjectDisplayName so do a bit of translation.
      c_quant <- quantity_obj(value, c_datamodel)[[1]]
      valid_vals <- quantity(model = c_datamodel)
      
      assert_that(
        get_key(c_quant) %in% valid_vals,
        msg = paste0("Parameter `", c_reacti$getParameterName(i), '` should be one of: "', paste0(valid_vals, collapse = '", '), '" or a number.')
      )
      
      c_reacti$setMapping(i, c_quant$getObjectName())
    }
  } else {
    warning("Parameter `", c_reacti$getParameterName(i), "` is of type `", tolower(type), "` and cannot be mapped through ", getPackageName(),". It has been skipped.")
  }
}

#' Get reaction parameters
#'
#' \code{getParameters} returns reaction parameters as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which reaction parameters to get.
#' @param model A model object.
#' @return Reaction parameters and associated information, as data frame.
#' @seealso \code{\link{getParameterReferences}} \code{\link{setParameters}}
#' @family reaction functions
#' @export
getParameters <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  c_keyfactory <- CRootContainer_getKeyFactory()
  
  if (is_empty(key))
    cl_params <-
      get_cdv(c_datamodel$getModel()$getReactions()) %>%
      map_swig("getParameters") %>%
      map(function(paramgrp) {
        seq_along_v(paramgrp) %>% map(~ paramgrp$getParameter(.x))
      }) %>%
      flatten()
  else
    cl_params <- parameter_obj(key, c_datamodel)
  
  cl_reacts <- map_swig(cl_params, "getObjectAncestor", "Reaction") %>% map(as, "_p_CReaction")
  
  names <- map_swig_chr(cl_params, "getObjectName")
  
  are_local <- map2_lgl(names, cl_reacts, ~ .y$isLocalParameter(.x))
  
  values <- rep_along(cl_params, NA_real_)
  values[are_local] <-
    cl_params[are_local] %>%
    map_swig_dbl("getDblValue")
  
  mappings <- rep_along(cl_params, NA_character_)
  mappings[!are_local] <-
    map2_chr(names[!are_local], cl_reacts[!are_local],
      function(name, c_react) {
        val <- get_sv(c_react$getParameterCNs(name))
        
        # For now don't support multiple mappings
        if (length(val) > 1)
          return("<MULTIPLE>")
  
        get_key(cn_to_object(val[[1]], c_datamodel))
      }
    )
  
  # assemble output dataframe
  tibble::tibble(
    key        = get_key(cl_params),
    "Name"     = names,
    "Reaction" = cl_reacts %>% map_swig_chr("getObjectName"),
    "Value"    = values,
    "Mapping"  = mappings,
    .rows = length(cl_params),
    .name_repair = transform_names_worker
  )
}

#' Get reaction parameter references
#'
#' \code{getParameterReferences} returns reaction parameters as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which reaction parameters to get.
#' @param model A model object.
#' @return Reaction parameters and associated references, as data frame.
#' @seealso \code{\link{getParameters}} \code{\link{setParameters}}
#' @family reaction functions
#' @export
getParameterReferences <- function(key = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  c_keyfactory <- CRootContainer_getKeyFactory()
  
  if (is_empty(key))
    cl_params <-
    get_cdv(c_datamodel$getModel()$getReactions()) %>%
    map_swig("getParameters") %>%
    map(function(paramgrp) {
      seq_along_v(paramgrp) %>% map(~ paramgrp$getParameter(.x))
    }) %>%
    flatten()
  else
    cl_params <- parameter_obj(key, c_datamodel)
  
  cl_reacts <- map_swig(cl_params, "getObjectAncestor", "Reaction") %>% map(as, "_p_CReaction")
  
  names <- map_swig_chr(cl_params, "getObjectName")
  
  are_local <- map2_lgl(names, cl_reacts, ~ .y$isLocalParameter(.x))
  
  value_refs <- rep_along(cl_params, NA_character_)
  value_refs[!are_local] <-
    cl_params[!are_local] %>%
    map_swig("getValueReference") %>%
    as_ref(c_datamodel)

  mappings <- rep_along(cl_params, NA_character_)
  mappings[!are_local] <-
    map2_chr(names[!are_local], cl_reacts[!are_local],
      function(name, c_react) {
        val <- get_sv(c_react$getParameterCNs(name))

        # For now don't support multiple mappings
        if (length(val) > 1)
          return("<MULTIPLE>")

        get_key(cn_to_object(val[[1]], c_datamodel))
      }
    )
  
  # assemble output dataframe
  tibble::tibble(
    key        = get_key(cl_params),
    "Name"     = names,
    "Reaction" = cl_reacts %>% map_swig_chr("getObjectName"),
    "Value"    = value_refs,
    "Mapping"  = mappings,
    .rows = length(cl_params),
    .name_repair = transform_names_worker
  )
}

#' Set reaction parameters
#'
#' \code{setParameters} applies given values to reaction parameters of the model depending on the \code{key} argument.
#'
#' Use the \code{key} argument to specify which reaction parameter to modify and any of the other arguments to specify the value to set.
#' The function is fully vectorized.
#' If a \code{NA} value is supplied, the model value is kept unchanged.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which reaction parameter to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one reaction parameter.
#' @param name Parameter is deprecated.
#' @param value Value to set, as numeric.
#' @param mapping Key of global quantity to map to, as string.
#' Also supports fragments of keys, if uniquely matching one global quantity.
#' @param data A data frame as given by \code{\link{getParameters}} which will be applied before the other arguments.
#' @param model A model object.
#' @seealso \code{\link{getParameters}} \code{\link{getParameterReferences}}
#' @family reaction functions
#' @export
setParameters <- function(key = NULL, name = NULL, value = NULL, mapping = NULL, data = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.null(name)     || is.character(name)    && length(name) == length(key),
    is.null(value)    || is.numeric(value)     && length(value) == length(key),
    is.null(mapping)  || is.character(mapping) && length(mapping) == length(key),
    is.null(data)     || is.data.frame(data)
  )
  
  if (!is.null(name))
    warning("Parameter `name` is deprecated, as parameter names are not modifiable on the reaction level. The parameter is ignored.")
  
  # Do this as assertion before we start changing values
  cl_params <- parameter_obj(key %||% character(), c_datamodel)
  
  # gather vectors of what to actually do work on
  false_vec <- rep_along(cl_params, FALSE)
  do_value   <- if (is.null(value))   false_vec else !is.na(value)
  do_mapping <- if (is.null(mapping)) false_vec else !is.na(mapping)
  
  # cut pointless actions
  do_value <- do_value & !do_mapping
  do_param <- do_value | do_mapping

  # Do this as assertion before we start changing values
  # Makes sure mapping is either NA or a quantity object
  if (any(do_mapping))
    mapping[do_mapping] <-
      mapping[do_mapping] %>%
      quantity_obj(c_datamodel)
  
  # if data is provided with the data arg, run a recursive call
  # needs to be kept up to date with the function args
  if (!is.null(data))
    do.call(setParameters, data[names(data) %in% c("key", "value", "mapping")])
  
  if (is_empty(cl_params))
    return(invisible())
  
  c_model <- c_datamodel$getModel()
  
  # Parameters are only those of type PARAMETER I think.
  # So I can safely set a value and make them local or set a mapping
  # as long as that mapping is a global quantity.
  # Changing the parameters directly seems to be unsafe.
  # The safe method seems to be to go back to the reaction and do manipulations from there.
  
  # apply values
  if (any(do_param)) {
    cl_reacts <- list_along(cl_params)
    cl_reacts[do_param] <-
      cl_params[do_param] %>%
      map_swig("getObjectAncestor", "Reaction") %>%
      map(as, "_p_CReaction")
    
    names <- rep_along(cl_params, NA_character_)
    names[do_param] <- map_swig_chr(cl_params[do_param], "getObjectName")
    
    for (i in which(do_value))
      cl_reacts[[i]]$setParameterValue(names[i], value[i])
    
    for (i in which(do_mapping))
      cl_reacts[[i]]$setParameterObject(names[i], mapping[[i]])
    
    cl_reacts[do_param] %>%
      unique() %>%
      walk_swig("compile")
    
    c_model$setCompileFlag()
  }
  
  compile_and_check(c_model)
  
  invisible()
}

#' Get events
#'
#' \code{getEvents} returns events as a data frame.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Optionally, a character vector specifying which events to get.
#' @param raw_expressions Whether expressions should be raw (not converted to readable format), as flag.
#' @param model A model object.
#' @return Events and associated information, as data frame.
#' \itemize{
#'   \item \code{$assignment_target} is a list column containing possibly several targets per event.
#'   \item \code{$assignment_expression} is a list column containing possibly several expressions per event.
#' }
#' @seealso \code{\link{setEvents}}
#' @family event functions
#' @export
getEvents <- function(key = NULL, raw_expressions = FALSE, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(is.flag(raw_expressions), !anyNA(raw_expressions))
  
  if (is_empty(key))
    cl_events <- get_cdv(c_datamodel$getModel()$getEvents())
  else
    cl_events <- event_obj(key, c_datamodel)
  
  cl_assignments <-
    cl_events %>%
    map_swig("getAssignments") %>%
    map(get_cdv)

  trigger_expressions    <- map_swig_chr(cl_events, "getTriggerExpression")
  priority_expressions   <- map_swig_chr(cl_events, "getPriorityExpression")
  delay_expressions      <- map_swig_chr(cl_events, "getDelayExpression")
  assignment_expressions <- map(cl_assignments, ~ map_swig_chr(.x, "getExpression"))
  
  if (!raw_expressions) {
    trigger_expressions    <- read_expr(trigger_expressions, c_datamodel)
    priority_expressions   <- read_expr(priority_expressions, c_datamodel)
    delay_expressions      <- read_expr(delay_expressions, c_datamodel)
    assignment_expressions <- map(assignment_expressions, read_expr, c_datamodel)
  }
  
  # trigger_expressions    <- emptychr_to_na(trigger_expressions)
  # # priority_expressions   <- emptychr_to_na(priority_expressions)
  # delay_expressions      <- emptychr_to_na(delay_expressions)
  # assignment_expressions <- map(assignment_expressions, map_chr, emptychr_to_na)

  has_delay <- delay_expressions != ""
  has_delay_calc <- map_swig_int(cl_events, "getDelayAssignment")
  delayed <- rep_along(cl_events, "no")
  delayed[has_delay & !has_delay_calc] <- "assignment"
  delayed[has_delay & has_delay_calc] <- "calculation"
  
  targets <-
    cl_assignments %>%
    map(~
      .x %>%
      map_swig_chr("getTargetCN") %>%
      map(cn_to_object, c_datamodel) %>%
      get_key()
    )
  
  # assemble output dataframe
  tibble::tibble(
    key                        = get_key(cl_events),
    "Name"                     = map_swig_chr(cl_events, "getObjectName"),
    "Trigger Expression"       = trigger_expressions,
    "Fire at initial time"     = as.logical(map_swig_int(cl_events, "getFireAtInitialTime")),
    "Trigger must remain true" = !as.logical(map_swig_int(cl_events, "getPersistentTrigger")),
    "Priority Expression"      = priority_expressions,
    "Delayed"                  = delayed,
    "Delay Expression"         = delay_expressions,
    "Assignment Target"        = targets,
    "Assignment Expression"    = assignment_expressions,
    .rows = length(cl_events),
    .name_repair = transform_names_worker
  )
}

#' Set events
#'
#' \code{setEvents} applies given values to events of the model depending on the \code{key} argument.
#'
#' Use the \code{key} argument to specify which event to modify and any of the other arguments to specify the value to set.
#' The function is fully vectorized.
#' If a \code{NA} value is supplied, the model value is kept unchanged.
#' 
#' The \href{https://jpahle.github.io/CoRC/articles/entity_management.html}{online article on managing model entities} provides some further context.
#'
#' @param key Identify which event to edit by specifying it's key, as string.
#' Also supports fragments of keys, if uniquely matching one event.
#' @param name Name to set, as string.
#' @param trigger_expression Trigger expression to set, as string, finite numeric, or logical.
#' @param fire_at_initial_time Whether to fire at initial time if true, as logical.
#' @param trigger_must_remain_true Whether the trigger must remain true, as logical.
#' @param priority_expression Priority expression to set, as string, finite numeric, or logical.
#' @param delayed Whether the event assignment and / or calculation is to be delayed ("no", "assignment", "calculation"), as string.
#' @param delay_expression Delay expression to set, as string, finite numeric, or logical.
#' @param assignment_target List of assignment target entities (species, compartments, global quantities) per event to set, as list containing strings.
#' @param assignment_expression List of assignment expressions per event to set, as list containing string, finite numeric, or logical.
#' @param data A data frame as given by \code{\link{getEvents}} which will be applied before the other arguments.
#' @param model A model object.
#' @seealso \code{\link{getEvents}}
#' @family event functions
#' @export
setEvents <- function(key = NULL, name = NULL, trigger_expression = NULL, fire_at_initial_time = NULL, trigger_must_remain_true = NULL, priority_expression = NULL, delayed = NULL, delay_expression = NULL, assignment_target = NULL, assignment_expression = NULL, data = NULL, model = getCurrentModel()) {
  c_datamodel <- assert_datamodel(model)
  assert_that(
    is.null(name)                     || is.character(name)                   && length(name) == length(key),
    is.null(trigger_expression)       || is.cexpression(trigger_expression)   && length(trigger_expression) == length(key),
    is.null(fire_at_initial_time)     || is.logical(fire_at_initial_time)     && length(fire_at_initial_time) == length(key),
    is.null(trigger_must_remain_true) || is.logical(trigger_must_remain_true) && length(trigger_must_remain_true) == length(key),
    is.null(priority_expression)      || is.cexpression(priority_expression)  && length(priority_expression) == length(key),
    is.null(delayed)                  || is.character(delayed)                && length(delayed) == length(key),
    is.null(delay_expression)         || is.cexpression(delay_expression)     && length(delay_expression) == length(key),
    is.null(assignment_target)        || is.list(assignment_target)           && length(assignment_target) == length(key),
    is.null(assignment_expression)    || is.list(assignment_expression)       && length(assignment_expression) == length(key),
    is.null(data)                     || is.data.frame(data)
  )

  # Do this as assertion before we start changing values
  cl_events <- event_obj(key %||% character(), c_datamodel)

  # gather vectors of what to actually do work on
  false_vec <- rep_along(cl_events, FALSE)
  do_name                     <- if (is.null(name))                     false_vec else !is.na(name)
  do_trigger_expression       <- if (is.null(trigger_expression))       false_vec else !is.na(trigger_expression)
  do_fire_at_initial_time     <- if (is.null(fire_at_initial_time))     false_vec else !is.na(fire_at_initial_time)
  do_trigger_must_remain_true <- if (is.null(trigger_must_remain_true)) false_vec else !is.na(trigger_must_remain_true)
  do_priority_expression      <- if (is.null(priority_expression))      false_vec else !is.na(priority_expression)
  do_delayed                  <- if (is.null(delayed))                  false_vec else !is.na(delayed)
  
  if (any(do_delayed)) {
    delayed <- args_match(delayed, c(NA_character_, "no", "assignment", "calculation"))
    
    # if delayed is set to no we overwrite the expression and set delayed to default (assignment)
    nodelay <- delayed == "no"
    if (any(nodelay)) {
      if (is.null(delay_expression))
        delay_expression <- rep_along(cl_events, NA_character_)
      delay_expression[nodelay] <- ""
      delayed[nodelay] <- "assignment"
    }
  }
  
  do_delay_expression      <- if (is.null(delay_expression))     false_vec else !is.na(delay_expression)
  do_assignment_target     <- if (is.null(assignment_target))    false_vec else !is.na(assignment_target)
  do_assignment_expression <- if (is.null(assignment_expression)) false_vec else !is.na(assignment_expression)
  
  # the way you can set event assignments with this function
  # is a bit unwieldy but lets at least allow it if the data is perfectly structured.
  assert_that(
    identical(do_assignment_target, do_assignment_expression),
    msg = "Assignment targets and assignment expressions must always be set in pairs."
  )
  assert_that(
    identical(lengths(assignment_target[do_assignment_target]), lengths(assignment_expression[do_assignment_expression])),
    msg = "Argument `assignment_target` and `assignment_expression` must have identical structure."
  )
  assert_that(
    every(assignment_target[do_assignment_target], is.character),
    msg = "Argument `assignment_target` must be a list containing character vectors only."
  )
  assert_that(
    every(assignment_target[do_assignment_target], is.cexpression),
    msg = "Argument `assignment_expression` must be a list containing COPASI expressions only."
  )
  assert_that(
    every(assignment_target[do_assignment_target], noNA),
    every(assignment_expression[do_assignment_expression], noNA),
    msg = "Assignment targets and assignment expressions must not contain <NA> in value pairs."
  )

  if (any(do_trigger_expression)) {
    trigger_expression[do_trigger_expression] <-
      trigger_expression[do_trigger_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  if (any(do_priority_expression)) {
    priority_expression[do_priority_expression] <-
      priority_expression[do_priority_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  if (any(do_delay_expression)) {
    delay_expression[do_delay_expression] <-
      delay_expression[do_delay_expression] %>%
      to_cexpr() %>%
      write_expr(c_datamodel)
  }
  
  if (any(do_assignment_target)) {
    assignment_target[do_assignment_target] <-
      assignment_target[do_assignment_target] %>%
      map(~ {
        cl_obj <- map(.x, dn_to_object, c_datamodel, accepted_types = c("_p_CMetab", "_p_CCompartment", "_p_CModelValue", "_p_CModel"))
        assert_that(!some(cl_obj, is.null), msg = "Invalid assignment target given.")
        map_swig_chr(cl_obj, "getKey")
      })
    assert_that(
      assignment_target[do_assignment_target] %>% map_lgl(~ anyDuplicated(.x) == 0) %>% all(),
      msg = "Assignment targets must be unique per event."
    )
    
    assignment_expression[do_assignment_target] <-
      assignment_expression[do_assignment_target] %>%
      map(to_cexpr) %>%
      map(write_expr, c_datamodel)
  }
  
  # if data is provided with the data arg, run a recursive call
  # needs to be kept up to date with the function args
  if (!is.null(data))
    do.call(setEvents, data[names(data) %in% c("key", "name", "trigger_expression", "fire_at_initial_time", "trigger_must_remain_true", "priority_expression", "delayed", "delay_expression", "assignment_target", "assignment_expression")])

  if (is_empty(cl_events))
    return(invisible())

  c_model <- c_datamodel$getModel()
  
  # apply names
  for (i in which(do_name))
    cl_events[[i]]$setObjectName(name[i])

  # apply trigger expressions
  for (i in which(do_trigger_expression))
    assert_that(
      grab_msg(cl_events[[i]]$setTriggerExpression(trigger_expression[i])),
      msg = "Failed when applying a trigger expression."
    )
  
  # apply fire_at_initial_time
  for (i in which(do_fire_at_initial_time))
    cl_events[[i]]$setFireAtInitialTime(fire_at_initial_time[i])
  
  # apply trigger_must_remain_true
  for (i in which(do_trigger_must_remain_true))
    cl_events[[i]]$setPersistentTrigger(!trigger_must_remain_true[i])
  
  # apply priority expression
  for (i in which(do_priority_expression))
    assert_that(
      grab_msg(cl_events[[i]]$setPriorityExpression(priority_expression[i])),
      msg = "Failed when applying a priority expression."
    )
  
  # apply delayed
  if (any(do_delayed)) {
    val <- rep_along(delayed, NA)
    val[delayed == "assignment"] <- FALSE
    val[delayed == "calculation"] <- TRUE
    for (i in which(do_delayed))
      cl_events[[i]]$setDelayAssignment(val[i])
  }
  
  # apply delay expression
  for (i in which(do_delay_expression))
    assert_that(
      grab_msg(cl_events[[i]]$setDelayExpression(delay_expression[i])),
      msg = "Failed when applying a delay expression."
    )
  
  # apply assignment_target
  for (i in which(do_assignment_target)) {
    c_event <- cl_events[[i]]
    c_assignments <- c_event$getAssignments()
    
    # create all new assignments
    cl_assignments_new <- map(assignment_target[[i]], ~ avert_gc(CEventAssignment(.x)))
    # if setting an an expression fails, terminate all recently created objects
    tryCatch({
      walk2(cl_assignments_new, assignment_expression[[i]],
        ~ assert_that(grab_msg(.x$setExpression(.y)), msg = "Failed when applying an assignment expression.")
      )
    },
    error = function(e) {
      walk(cl_assignments_new, delete)
      base::stop(e)
    })
    
    # delete old assignments, add new ones
    c_assignments$clear()
    # the add method should have argument adopt = TRUE
    # argument is missing
    # it seems like it does adopt by default though
    walk(cl_assignments_new, c_assignments$add)
  }
  
  compile_and_check(c_model)
  
  invisible()
}
jpahle/CoRC documentation built on March 23, 2024, 5:40 p.m.