Nothing
#' Check
#'
#' Check that the output from [assertthat::see_if()] is valid.
#'
#' @param x `character` or `object`
#'
#' @details This object will return an error if the argument to `x`
#' is `FALSE`, and for the error message, will show the error
#' message attached to the object.
#'
#' @return invisible `TRUE`.
#'
#' @noRd
check_that <- function(x) {
if (!isTRUE(x))
stop(attr(x, "msg")[1])
invisible(TRUE)
}
#' Convert sparse matrix to triplet data.frame
#'
#' Convert a sparse matrix to a triplet `data.frame`.
#'
#' @param x `Matrix` object.
#'
#' @noRd
matrix_to_triplet_dataframe <- function(x) {
if (inherits(x, c("dsCMatrix")))
x <- methods::as(x, "dsTMatrix")
if (inherits(x, c("dgCMatrix", "matrix")))
x <- methods::as(x, "dgTMatrix")
data.frame(i = x@i + 1, j = x@j + 1, x = x@x)
}
#' Convert a triplet data.frame to a matrix
#'
#' Convert a triplet data.framr object to a sparse matrix.
#'
#' @param x `data.frame` object. The first column contains the row
#' numbers, the second column contains the column numbers, and the
#' third column contains the cell values.
#
#' @return [Matrix::dgCMatrix-class] object.
#'
#' @noRd
triplet_dataframe_to_matrix <- function(x, forceSymmetric=FALSE, ...) {
assertthat::assert_that(inherits(x, "data.frame"), isTRUE(ncol(x) == 3),
isTRUE(all(x[[1]] == round(x[[1]]))), isTRUE(all(x[[2]] == round(x[[2]]))))
# create sparse amtrix
m <- Matrix::sparseMatrix(i = x[[1]], j = x[[2]], x = x[[3]],
giveCsparse = FALSE, ...)
if (forceSymmetric) {
# force the matrix to be symmetric
# we cannot gurantee that the cells that are filled in belong to either
# the upper or the lower diagonal
m2 <- matrix(c(m@j + 1, m@i + 1, m@x), ncol = 3)
m2 <- m2[m2[, 1] != m2[, 2], ]
m[m2[, 1:2]] <- m2[, 3]
return(Matrix::forceSymmetric(m))
} else {
# return matrix in compressed format
return(methods::as(m, "dgCMatrix"))
}
}
#' Align text
#'
#' Format text by adding a certain number of spaces after new line characters.
#'
#' @param x `character` text.
#'
#' @param n `integer` number of spaces.
#'
#' @return `character`.
#'
#' @examples
#' # make some text
#' original_text <- "animals: horse\npig\nbear"
#'
#' # print text
#' message(original_text)
#'
#' # this look really ugly so we will align it
#' aligned_text <- align_text(original_text, 9)
#'
#' # print aligned text
#' message(aligned_text)
#'
#' @noRd
align_text <- function(x, n) {
assertthat::assert_that(assertthat::is.string(x), assertthat::is.count(n))
if (!grepl("\n", x))
return(x)
return(gsub("\n", paste0("\n", paste(rep(" ", n), collapse = "")), x,
fixed = TRUE))
}
#' Atomic representation
#'
#' Return a pretty character representation of an object with elements and
# names.
#'
#' @param x `object`.
#'
#' @return `character` object.
#'
#' @examples
#' repr_atomic(letters)
#' repr_atomic(letters, "characters")
#' @noRd
repr_atomic <- function(x, description = "") {
n <- length(x)
if (nchar(description) > 0)
description <- paste0(" ", description)
if (length(x) <= 4) {
x <- x[seq_len(min(length(x), 4))]
} else {
x <- c(x[seq_len(min(length(x), 3))], "...")
}
paste0(paste(x, collapse = ", "), " (", n, description, ")")
}
#' No extra arguments
#'
#' Check that no additional unused arguments have been supplied to a function
#' through the `...`.
#'
#' @param ... arguments that are not used.
#'
#' @return `logical` indicating success.
#'
#' @noRd
no_extra_arguments <- function(...) {
return(length(list(...)) == 0)
}
assertthat::on_failure(no_extra_arguments) <- function(call, env) {
call_list <- as.list(call)[-1]
format_args <- function(i) {
if (names(call_list)[i] == "")
return(deparse(call_list[[i]]))
paste0(names(call_list)[i], "=", deparse(call_list[[i]]))
}
msg <- paste(vapply(seq_along(call_list), format_args, character(1)),
collapse = ", ")
if (length(call_list) > 1) {
msg <- paste0("unused arguments (", msg, ")")
} else {
msg <- paste0("unused argument (", msg, ")")
}
msg
}
#' Verify if assertion is met
#'
#' Verify if an assertion is tmet and throw a [warning()] if it
#' is not. This function is equivalent to [assertthat::assert_that()]
#' except that it throws warnings and not errors.
#'
#' @param x `logical` condition.
#'
#' @return `logical` if assertion is met and a `warning` if it is not.
#'
#' @noRd
verify_that <- function(..., env = parent.frame()) {
res <- assertthat::validate_that(..., env = env)
if (isTRUE(res))
return(TRUE)
warning(res)
FALSE
}
#' Any solvers installed?
#'
#' Test if any solvers are installed.
#'
#' @details This function tests if any of the following packages are installed:
#' \pkg{Rsymphony}, \pkg{lpsymphony}, \pkg{gurobi}.
#'
#' @return `logical` value indicating if any solvers are installed.
#'
#' @noRd
any_solvers_installed <- function() {
!is.null(default_solver_name())
}
#' Default solver name
#'
#' This function returns the name of the default solver. If no solvers are
#' detected on the system, then a `NULL` object is returned.
#'
#' @details This function tests if any of the following packages are installed:
#' \pkg{Rsymphony}, \pkg{lpsymphony}, \pkg{gurobi}.
#'
#' @return `character` indicating the name of the default solver.
#'
#' @noRd
default_solver_name <- function() {
if (requireNamespace("gurobi", quietly = TRUE)) {
return("gurobi")
} else if (requireNamespace("Rsymphony", quietly = TRUE)) {
return("Rsymphony")
} else if (requireNamespace("lpsymphony", quietly = TRUE)) {
return("lpsymphony")
} else if (requireNamespace("lpSolveAPI", quietly = TRUE)) {
return("lpSolveAPI")
} else {
return(NULL)
}
}
#' Is valid phylogeny?
#'
#' Check that a phylogeny is valid.
#'
#' @param x object.
#'
#' @return `logical` indicating success.
#'
#' @noRd
is_valid_phylo <- function(x) {
msg <- utils::capture.output(ape::checkValidPhylo(x))
!((any(grepl("FATAL", msg)) || any(grepl("MODERATE", msg))))
}
assertthat::on_failure(is_valid_phylo) <- function(call, env) {
x <- eval(as.list(call)$x, env)
msg <- utils::capture.output(ape::checkValidPhylo(x))
paste(msg, collapse = "\n")
}
#' SYMPHONY status
#'
#' Find a description of the solver status returned from SYMPHONY.
#'
#' @param x `numeric` status code.
#'
#' @return `character` status description.
#'
#' @noRd
symphony_status <- function(x) {
assertthat::assert_that(is.numeric(x))
codes <- c(
"0" = "TM_OPTIMAL_SOLUTION_FOUND",
"225" = "TM_NO_PROBLEM",
"226" = "TM_NO_SOLUTION",
"227" = "TM_OPTIMAL_SOLUTION_FOUND",
"228" = "TM_TIME_LIMIT_EXCEEDED",
"229" = "TM_NODE_LIMIT_EXCEEDED",
"230" = "TM_ITERATION_LIMIT_EXCEEDED",
"231" = "TM_TARGET_GAP_ACHIEVED",
"232" = "TM_FOUND_FIRST_FEASIBLE",
"233" = "TM_FINISHED",
"234" = "TM_UNFINISHED",
"235" = "TM_FEASIBLE_SOLUTION_FOUND",
"236" = "TM_SIGNAL_CAUGHT",
"237" = "TM_UNBOUNDED",
"238" = "PREP_OPTIMAL_SOLUTION_FOUND",
"239" = "PREP_NO_SOLUTION",
"-250" = "TM_ERROR__NO_BRANCHING_CANDIDATE",
"-251" = "TM_ERROR__ILLEGAL_RETURN_CODE",
"-252" = "TM_ERROR__NUMERICAL_INSTABILITY",
"-253" = "TM_ERROR__COMM_ERROR",
"-275" = "TM_ERROR__USER",
"-276" = "PREP_ERROR")
x <- codes[as.character(x)]
if (is.na(x))
warning("solver returned unrecognized code")
as.character(x)
}
#' lp_solve status
#'
#' Find a description of the solver status returned from lp_solve.
#'
#' @param x `numeric` status code.
#'
#' @return `character` status description.
#'
#' @noRd
lp_solve_status <- function(x) {
assertthat::assert_that(is.numeric(x))
codes <- c(
"0" = "optimal solution found",
"1" ="the model is sub-optimal",
"3" ="the model is unbounded",
"2" ="the model is infeasible",
"4" ="the model is degenerate",
"5" ="numerical failure encountered",
"6" ="process aborted",
"7" ="timeout",
"9" ="the model was solved by presolve",
"10" ="the branch and bound routine failed",
"11" ="the branch and bound was stopped because of a break-at-first or break-at-value",
"12" = "a feasible branch and bound solution was found",
"13" = "no feasible branch and bound solution was found")
x <- codes[as.character(x)]
if (is.na(x))
warning("solver returned unrecognized code")
as.character(x)
}
#' Convert to Matrix
#'
#' Convert an object to a matrix class provided by the \pkg{Matrix} package.
#'
#' @param object object.
#'
#' @param class `character` name of new classes.
#'
#' @details
#' This function is a wrapper that is designed to provide
#' compatibility with older and newer versions of the \pkg{Matrix} package.
#'
#' @return `Matrix` object.
#'
#' @noRd
as_Matrix <- function(object, class) {
# assert valid argument
assertthat::assert_that(
assertthat::is.string(class),
assertthat::noNA(class)
)
# if we just want to convert to generic Matrix class then do that...
if (identical(class, "Matrix")) {
return(methods::as(object, class))
}
# convert matrix
if (utils::packageVersion("Matrix") >= as.package_version("1.4-2")) {
if (identical(class, "dgCMatrix")) {
c1 <- "dMatrix"
c2 <- "generalMatrix"
c3 <- "CsparseMatrix"
} else if (identical(class, "dgTMatrix")) {
c1 <- "dMatrix"
c2 <- "generalMatrix"
c3 <- "TsparseMatrix"
} else if (identical(class, "dsCMatrix")) {
c1 <- "dMatrix"
c2 <- "symmetricMatrix"
c3 <- "CsparseMatrix"
} else if (identical(class, "dsTMatrix")) {
c1 <- "dMatrix"
c2 <- "symmetricMatrix"
c3 <- "TsparseMatrix"
} else if (identical(class, "lgCMatrix")) {
c1 <- "lMatrix"
c2 <- "generalMatrix"
c3 <- "CsparseMatrix"
} else {
stop("argument to \"class\" not recognized")
}
out <- methods::as(methods::as(methods::as(object, c1), c2), c3)
} else {
out <- methods::as(object, class)
}
# return result
out
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.