Nothing
#' Stretch matrix 'm' with a timestep resolution of 'dt'.
#'
#' @inheritParams default_params_doc
#' @param m A matrix of 2 columns and at least 2 rows
#' @param dt The resulution, a value e [0.0001, 1].
#' If 'dt' is set to a very small value, this function will stop
#' @return The stretched matrix
#' @examples
#' m <- matrix( c(c(0.0, 1.0), c(0.5, 1.0)), ncol = 2, nrow = 2)
#' expected <- matrix(
#' c(
#' c(0.0, 0.5, 1.0), # Timepoints
#' c(0.5, 0.5, 1.0) # Values
#' ),
#' ncol = 2, nrow = 3
#' )
#' result <- stretch_nltt_matrix(m = m, dt = 0.5, step_type = "lower")
#' all.equal(result, expected)
#'
#' @author Richèl J.C. Bilderbeek
#' @export
stretch_nltt_matrix <- function(
m,
dt,
step_type
) {
if (!is.matrix(m)) {
stop("stretch_nltt_matrix: m must be a matrix, ",
"m is of class '", class(m), "' instead")
}
if (ncol(m) != 2) {
stop("stretch_nltt_matrix: m must have two columns, ",
"m has ", ncol(m), " columns instead")
}
nLTT::check_step_type(step_type)
# Remove rows with same t's, take the first
rows_to_delete <- NULL
for (i in seq(1, nrow(m) - 1)) { # -1 because in the body i+1 will be used # nolint
if (m[i, 1] == m[i + 1, 1]) {
rows_to_delete <- c(rows_to_delete, i + 1)
}
}
if (!is.null(rows_to_delete)) {
m <- m[-rows_to_delete, ]
}
# Prepare a new matrix called n
n_nrow <- 1 + (1.0 / dt)
testit::assert(all.equal(1.0 / (n_nrow - 1), dt))
n_ts <- seq(0.0, 1.0, length.out = n_nrow)
# I am unsure why seq cannot fulfill its promise to create
# an output of length.out.
# Stop when this happens
if (length(n_ts) != n_nrow) {
stop("dt too small")
}
testit::assert(length(n_ts) == n_nrow)
n_ns <- rep(NA, times = n_nrow)
testit::assert(length(n_ns) == n_nrow)
n <- matrix(c(n_ts, n_ns), ncol = 2, nrow = n_nrow)
testit::assert(nrow(n) == n_nrow)
# Add endtime at the bottom
m <- rbind(m, c(1e99, 1.0))
# Fill in the nLTT values (the second column) in n
# (n already has the time values in its first column):
# - go through the values of m until desired timepoint is exceded
# - copy that nLTT value to n
#
# m n
#
# |
# | +-* |
# | +-* | +----*
# | +-* -> | |
# | +-* +----*
# |+-* |
# |* *
# +----------- +----------------
# ^ ^ ^ ^ ^ ^
#
m_row_index <- 1
for (n_row_index in 1:n_nrow) {
# Find the value in m that has a time later than the time value in n
while (n[n_row_index, 1] >= m[m_row_index + 1, 1]) {
# Work further through m
m_row_index <- m_row_index + 1
}
# Copy the nLTT value from m
n[n_row_index, 2] <- m[m_row_index + ifelse(step_type == "lower", 0, 1), 2] # nolint
}
n
}
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.