isotracer coverage - 70.76%

Files
Source

### * None of the functions in this file is exported

### * bezierCurve()

#' Calculate the coordinates of a Bezier curve from control points
#'
#' @param x,y Coordinates of the control points
#' @param n Integer, number of steps to use (larger is smoother)
#'
#' @return A two-column matrix with the coordinates of the Bezier curve
#'
#' @examples
#' bezierCurve <- isotracer:::bezierCurve
#' set.seed(9)
#' x = runif(6)
#' y = runif(6)
#' plot(x, y, type = "l", col = "grey")
#' lines(bezierCurve(x, y, 2), col = "cornflowerblue", lwd = 1)
#' lines(bezierCurve(x, y, 4), col = "cornflowerblue", lwd = 1)
#' lines(bezierCurve(x, y, 8), col = "purple", lwd = 1.5)
#' lines(bezierCurve(x, y, 64), col = "indianred", lwd = 4)
#'
#' @keywords internal
#' @noRd

bezierCurve = function(x, y, n) {
    stopifnot(length(x) == length(y))
    stopifnot(length(x) > 1)
    n = as.integer(n)
    stopifnot(n > 0)
    xOut = rep(NA, n + 2)
    yOut = rep(NA, n + 2)
    weights = seq(0, 1, length.out = n + 2)
    # Calculate coordinates
    for (i in seq_along(weights)) {
        xControl = x
        yControl = y
        nControl = length(xControl)
        weight = weights[i]
        while(nControl > 1) {
            xControl = (1 - weight) * xControl[1:(nControl - 1)] + weight * xControl[2:nControl]
            yControl = (1 - weight) * yControl[1:(nControl - 1)] + weight * yControl[2:nControl]
            nControl = length(xControl)
        }
        stopifnot(nControl == 1)
        xOut[i] = xControl
        yOut[i] = yControl
    }
    # Return
    return(as.matrix(cbind(xOut, yOut)))
}

### * ribbonFromTrajectory()

#' Calculate a ribbon polygon spanning a trajectory
#'
#' @param x Two-column object giving the coordinates defining the indicating
#'     trajectory.
#' @param width Numeric, width of the returned segment on the x scale.
#' @param constantWidth.y Boolean, if TRUE the ribbon coordinates are corrected
#'     for the aspect ratio of the plot so that the ribbon has a constant y
#'     width.
#'
#' @return A two-columnm matrix containing the coordinates of the ribbon, ready
#'     to be used with \code{\link{polygon}}
#'
#' @examples
#' bezierCurve <- isotracer:::bezierCurve
#' ribbonFromTrajectory <- isotracer:::ribbonFromTrajectory
#' 
#' set.seed(8)
#' x = runif(4)
#' y = runif(4)
#' b = bezierCurve(x, y, 64)
#' 
#' plot(x, y, type = "l", col = "grey", asp = 1, main = "Plot asp = 1")
#' lines(b, col = "indianred", lwd = 2)
#' bvp <- gridBase::baseViewports()
#' do.call(grid::pushViewport, bvp)
#' polygon(ribbonFromTrajectory(b, width = 0.05),
#'         col = adjustcolor("cornflowerblue", alpha.f = 0.5))
#' points(ribbonFromTrajectory(b, width = 0.05), pch = 19, cex = 0.5)
#' points(ribbonFromTrajectory(b, width = 0.10), pch = 19, cex = 0.5, col = "red")
#' 
#' plot(x, y, type = "l", col = "grey", asp = 3, main = "Plot asp = 3, constant y width")
#' lines(b, col = "indianred", lwd = 2)
#' polygon(ribbonFromTrajectory(b, width = 0.05),
#'         col = adjustcolor("cornflowerblue", alpha.f = 0.5))
#' 
#' plot(x, y, type = "l", col = "grey", asp = 3, main = "Plot asp = 3, no constant y width")
#' lines(b, col = "indianred", lwd = 2)
#' polygon(ribbonFromTrajectory(b, width = 0.05, constantWidth.y = FALSE),
#'         col = adjustcolor("cornflowerblue", alpha.f = 0.5))
#'
#' @keywords internal
#' @noRd

ribbonFromTrajectory = function(x, width, constantWidth.y = TRUE) {
    xIn = x
    x = xIn[,1]
    y = xIn[,2]
    n = length(x)
    # Get the plot aspect ratio (this will probably fail if no plot exists yet)
    if (constantWidth.y) {
        ## # https://stat.ethz.ch/pipermail/r-help/2005-October/080598.html
        ## wRes = par("pin")[1] / diff(par("usr")[c(1, 2)])
        ## hRes = par("pin")[2] / diff(par("usr")[c(3, 4)])
        ## aspectRatio = hRes / wRes
        aspectRatio <- grid_get_asp()
    } else {
        # Use default value of one
        aspectRatio = 1
    }
    # Convert x values to asp=1 space
    xCenter = mean(x)
    x = (x - xCenter) / aspectRatio
    # Calculate one way
    x0 = x
    y0 = y
    xNormal = diff(x0)
    yNormal = diff(y0)
    xyNorm = sqrt(xNormal^2 + yNormal^2)
    thetas = acos(xNormal / xyNorm)
    thetas[yNormal < 0] = - thetas[yNormal < 0]
    out = matrix(ncol = 4, nrow = n) # Columns: xleft, yleft, xright, yright
    for (i in 1:(n-1)) {
        initLeft = c(-width/2, 0)
        initRight = c(width/2, 0)
        # Rotation
        myAngle = thetas[i] + pi/2
        rotationMatrix = matrix(c(cos(myAngle), - sin(myAngle),
                                  sin(myAngle), cos(myAngle)),
                                ncol = 2, byrow = T)
        rotLeft = rotationMatrix %*% initLeft
        rotRight = rotationMatrix %*% initRight
        left = rotLeft + c(x0[i], y0[i])
        right = rotRight + c(x0[i], y0[i])
        out[i, ] = c(left, right)
    }
    # Add the last segment
    out[n, ] = c(rotLeft + c(x0[n], y0[n]), rotRight + c(x0[n], y0[n]))
    # Calculate the other way
    x0 = rev(x)
    y0 = rev(y)
    xNormal = diff(x0)
    yNormal = diff(y0)
    xyNorm = sqrt(xNormal^2 + yNormal^2)
    thetas = acos(xNormal / xyNorm)
    thetas[yNormal < 0] = - thetas[yNormal < 0]
    out2 = matrix(ncol = 4, nrow = n) # Columns: xleft, yleft, xright, yright
    for (i in 1:(n-1)) {
        initLeft = c(-width/2, 0)
        initRight = c(width/2, 0)
        # Rotation
        myAngle = thetas[i] + pi/2
        rotationMatrix = matrix(c(cos(myAngle), - sin(myAngle),
                                  sin(myAngle), cos(myAngle)),
                                ncol = 2, byrow = T)
        rotLeft = rotationMatrix %*% initLeft
        rotRight = rotationMatrix %*% initRight
        left = rotLeft + c(x0[i], y0[i])
        right = rotRight + c(x0[i], y0[i])
        out2[i, ] = c(left, right)
    }
    # Add the last segment
    out2[n, ] = c(rotLeft + c(x0[n], y0[n]), rotRight + c(x0[n], y0[n]))
    # Average both out matrices
    out2 = out2[nrow(out2):1, ]
    outTmp = out2
    out2[, 1:2] = out2[, 3:4]
    out2[, 3:4] = outTmp[, 1:2]
    for (i in 1:nrow(out)) {
        for (j in 1:ncol(out)) {
            out2[i, j] = (out[i, j] + out2[i, j]) / 2
        }
    }
    # Arrange format
    out = rbind(out2[, 1:2], out2[nrow(out2):1, 3:4])
    # Back-convert to plot aspect ratio space
    out[,1] = out[,1]*aspectRatio + xCenter
    # Return
    return(out)
}

### * grid_get_asp()

#' Get the aspect ratio of the current grid viewport
#'
#' @examples
#' grid_get_asp <- isotracer:::grid_get_asp
#' 
#' library(grid)
#' grid.newpage()
#' x <- mtcars$wt
#' y <- mtcars$drat
#' vp <- dataViewport(xData = x, yData = y)
#' pushViewport(vp)
#' grid.points(x, y)
#'
#' # Run this snippet several times, and resize the plot window in-between
#' # The newly drawn rectangle should always be exactly square.
#' width <- 1
#' asp <- grid_get_asp()
#' height <- width / asp
#' col <- sample(colors(), 1)
#' grid.rect(width = unit(width, "native"), height = unit(height, "native"))
#' 
#' @keywords internal
#' @noRd

grid_get_asp <- function() {
    # Get x and y ranges
    vp <- grid::current.viewport()
    xrange <- diff(vp$xscale)
    yrange <- diff(vp$yscale)
    span <- min(xrange, yrange) / 2.5
    xmid <- mean(vp$xscale)
    ymid <- mean(vp$yscale)
    loc_mid <- grid::deviceLoc(grid::unit(xmid, "native"),
                               grid::unit(ymid, "native"))
    loc_right <- grid::deviceLoc(grid::unit(xmid + span, "native"),
                               grid::unit(ymid, "native"))
    loc_top <- grid::deviceLoc(grid::unit(xmid, "native"),
                               grid::unit(ymid + span, "native"))
    height <- as.numeric(loc_top$y) - as.numeric(loc_mid$y)
    width <- as.numeric(loc_right$x) - as.numeric(loc_mid$x)
    return(height/width)
}

### * topo_has_loop()

#' Test if a topology has a loop
#'
#' @param x A topology matrix or a network model (the topology of the first row
#'     is used in this case).
#'
#' @return Boolean
#'
#' @examples
#' topo_has_loop <- isotracer:::topo_has_loop
#' 
#' topo_has_loop(aquarium_mod)
#' topo_has_loop(trini_mod)
#'
#' @keywords internal
#' @noRd

topo_has_loop <- function(x) {
    if (is(x, "networkModel")) {
        x <- unique(topo(x, simplify = FALSE))
        stopifnot(length(x) == 1)
        x <- x[[1]]
    }
    x <- unclass(x) # Remove the "topo" class to treat it as a matrix
    n_comps <- ncol(x)
    # Calculate powers of the transition matrix
    iters <- list()
    iters[[1]] <- x
    if (n_comps == 1) {
        stop("Only one compartment present in the network topology.")
    }
    for (i in 2:n_comps) {
        iters[[i]] <- iters[[i-1]] %*% x
    }
    # Look for loops
    loops <- lapply(iters, diag)
    any_loop <- sapply(loops, function(l) any(l!=0))
    # Return
    return(any(any_loop))
}

is_dag <- function(x) {
    !topo_has_loop(x)
}

### * not_implemented_for_topology_with_loop()

#' Check and throw an error if appropriate
#'
#' @param x A topology matrix or a network model (the topology of the first row
#'     is used in this case).
#'
#' @keywords internal
#' @noRd

not_implemented_for_topology_with_loop <- function(x) {
    if (topo_has_loop(x)) {
        stop("Function not implemented for topologies containing loop(s).")
    }
}

### * sankey_get_layout()

#' Process layout option for a given topology 
#' 
#' @param x A topology.
#' @param layout String or NULL, node-placing algorithm to use from the ggraph
#'     package (e.g. "stress" or "sugiyama"). If NULL, a default layout is
#'     returned, which depends on the topology. The ggraph package itself uses
#'     some algoritms from the igraph package. See the Details in the help of
#'     \code{\link[ggraph]{layout_tbl_graph_igraph}} for available
#'     algorithms. The ggraph package must be installed for this argument to be
#'     taken into account.
#'
#' @return A string
#' 
#' @keywords internal
#' @noRd

sankey_get_layout <- function(x, layout) {
    if (is.null(layout)) {
        if (is_dag(x)) {
            layout <- "left2right"
        } else {
            layout <- "stress"
        }
    }
    return(layout)
}


### * sankey_calc_nodes_locations()

#' Calculate nodes locations for a topology
#'
#' @param x A topology.
#' @param layout String, one of "in-house" or the layout options accepted by
#'     \code{\link[ggraph]{create_layout}}.
#' @param minimize_simple (For in-house algorithm.) Boolean, apply simple
#'     energy minimization by adjusting consumers location based on their
#'     sources y location?
#' @param minimize_E Boolean, use \code{\link{sankey_minimize_energy_sim}} to
#'     adjust node locations using an energy minimization algorithm?
#' @param k1 Numeric, stiffness for springs between nodes on the same x
#'     position (used if minimize_E = TRUE).
#' @param k2 Numeric, sitffness for springs between connected nodes (used if
#'     minimize_E = TRUE).
#' @param l1 Numeric, rest length for springs with k1 stiffness (used if
#'     minimize_E = TRUE).
#' @param l2 Numeric, rest length for springs with k2 stiffness (used if
#'     minimize_E = TRUE).
#'
#' @return A tibble with the nodes and ordered x and y values. The columns are
#'     "comp", "x", and "y".
#'
#' @examples
#' sankey_calc_nodes_locations <- isotracer:::sankey_calc_nodes_locations
#' 
#' sankey_calc_nodes_locations(topo(trini_mod), "left2right")
#' sankey_calc_nodes_locations(topo(aquarium_mod), "stress")
#'
#' @keywords internal
#' @noRd

sankey_calc_nodes_locations <- function(x, layout, 
                                        minimize_simple = TRUE,
                                        minimize_E = FALSE, k1 = 1, k2 = 1, l1 = 1, l2 = 1) {
    if (layout %in% c("left2right", "left-to-right")) {
        # In-house algorithm for topologies without loops
        not_implemented_for_topology_with_loop(x)
        nodes <- sankey_calc_nodes_locations_inhouse(x, minimize_simple = minimize_simple)
        if (minimize_E) {
            nodes <- sankey_minimize_energy_sim(x, nodes, k1 = k1, k2 = k2, l1 = l1,
                                                l2 = l2)
        }
    } else {
        if (!requireNamespace("ggraph", quietly = TRUE)) {
            stop("Package \"ggraph\" needed when specifying a layout argument. Please install it.",
                 call. = FALSE)
        }
        # Check that the random seed  is not reset by graphlayouts functions
        if (exists(".Random.seed", .GlobalEnv)) {
            prev_seed <- .GlobalEnv[[".Random.seed"]]
        } else { prev_seed <- NULL }
        x <- as_tbl_graph(x)
        nodes <- ggraph::create_layout(graph = x, layout = layout)
        if (exists(".Random.seed", .GlobalEnv)) {
            new_seed <- .GlobalEnv[[".Random.seed"]]
        }  else { new_seed <- NULL }
        if (!identical(prev_seed, new_seed)) {
            stop("Random seed was reset when calling ggraph::create_layout() in sankey_calc_nodes_locations().\n",
                 "This is unwanted behaviour, please report it as a bug to the isotracer authors.")
        }
        nodes <- tibble::as_tibble(nodes[, c("name", "x", "y")])
        names(nodes) <- c("comp", "x", "y")
    }
    attr(nodes, "layout") <- layout
    return(nodes)
}

### * sankey_calc_nodes_locations_inhouse()

#' Calculate roughly optimized nodes locations for a topology (in-house algorithm)
#'
#' @param x A topology matrix or a network model (the topology of the first row
#'     is used in this case).
#' @param minimize_simple Boolean, apply simple energy minimization by
#'     adjusting consumers location based on their sources y location.
#'
#' @return A tibble with the nodes and ordered x and y values.
#'
#' @keywords internal
#' @noRd

sankey_calc_nodes_locations_inhouse <- function(x, minimize_simple) {
    if (is(x, "networkModel")) {
        x <- unique(topo(x, simplify = FALSE))
        stopifnot(length(x) == 1)
        x <- x[[1]]
    }
    x <- unclass(x) # Remove the "topo" class to treat it as a matrix
    not_implemented_for_topology_with_loop(x)
    z <- topo_x_ordering(x)
    comps <- names(z)
    d <- tibble::tibble(comp = comps, x = z)
    nodes <- topo_y_ordering(x, d)
    # Center y locations
    x_ranks <- unique(nodes$x)
    for (xi in x_ranks) {
        y_shift <- mean(nodes$y[nodes$x == xi])
        nodes$y[nodes$x == xi] <- nodes$y[nodes$x == xi] - y_shift
    }
    # Adjust y locations
    if (minimize_simple) {
        for (xi in x_ranks) {
            comps <- nodes$comp[nodes$x == xi]
            sources <- colnames(x)[apply(x[comps, , drop = FALSE], 2, sum) > 0]
            if (length(sources) > 0) {
                mean_y_sources <- mean(nodes$y[nodes$comp %in% sources])
                nodes$y[nodes$x == xi] <- nodes$y[nodes$x == xi] + mean_y_sources
            }
        }
    }
    return(nodes)
}

### * topo_x_ordering()

#' Order compartments from left to right
#'
#' @param x A topology matrix or a network model (the topology of the first row
#'     is used in this case).
#'
#' @examples
#' topo_x_ordering <- isotracer:::topo_x_ordering
#' 
#' sort(topo_x_ordering(trini_mod))
#' 
#' @keywords internal
#' @noRd

topo_x_ordering <- function(x) {
    if (is(x, "networkModel")) {
        x <- unique(topo(x, simplify = FALSE))
        stopifnot(length(x) == 1)
        x <- x[[1]]
    }
    x <- unclass(x) # Remove the "topo" class to treat it as a matrix
    n_comps <- ncol(x)
    max_iters <- 2 * n_comps
    links <- which(x > 0)
    from <- links %/% n_comps + 1
    to <- links %% n_comps
    links <- tibble::tibble(from = from, to = to)
    for (i in seq_len(nrow(links))) {
        if (links$to[i] == 0) {
            links$from[i] <- links$from[i] - 1
            links$to[i] <- n_comps
        }
        stopifnot(x[links$to[i], links$from[i]] > 0)
    }
    ranks <- rep(0, n_comps)
    stable <- FALSE
    iter <- 0
    while (!stable & iter <= max_iters) {
        prev_ranks <- ranks
        for (i in seq_len(nrow(links))) {
            if (ranks[links$from[i]] >= ranks[links$to[i]]) {
                ranks[links$to[i]] <- ranks[links$to[i]] + 1
            }
        }
        stable <- all(prev_ranks == ranks)
        iter <- iter + 1
    }
    if (iter == (max_iters + 1)) {
        stop("Maximum number of iterations reached.")
    }
    out <- setNames(ranks, colnames(x))
    return(out)
}

### * topo_y_ordering()

#' Order compartment vertically
#'
#' This function tries to minimize the number of edges crossings for graphical
#' display of the topology.
#'
#' This function assumes that the x locations given in \code{nodes} have been
#' established using \code{\link{topo_x_ordering}}.
#' 
#' @param x A topology matrix or a network model (the topology of the first row
#'     is used in this case).
#' @param nodes A tibble giving the x locations for each node. It must contain
#'     columns "comp" and "x".
#' @param n_iters Number of iterations used to try to optimize the compartment
#'     ordering.
#'
#' @return An updated tibble similar to the \code{nodes} argument.
#'
#' @examples
#' topo_x_ordering <- isotracer:::topo_x_ordering
#' topo_y_ordering <- isotracer:::topo_y_ordering
#' 
#' z <- topo(trini_mod)
#' x <- topo_x_ordering(z)
#' comps <- names(x)
#' d <- tibble::tibble(comp = comps, x = x)
#' nodes <- topo_y_ordering(z, d)
#' 
#' @keywords internal
#' @noRd

topo_y_ordering <- function(x, nodes, n_iters = 2) {
    if (is(x, "networkModel")) {
        x <- unique(topo(x, simplify = FALSE))
        stopifnot(length(x) == 1)
        x <- x[[1]]
    }
    x <- unclass(x) # Remove the "topo" class to treat it as a matrix
    nodes$y <- seq_len(nrow(nodes))
    nodes <- nodes[order(nodes$x, nodes$y), ]
    nodes$id <- seq_len(nrow(nodes))
    comp_id <- setNames(nodes$id, nm = nodes$comp)
    counts <- setNames(topo_count_crossings(x, nodes),
                       paste0(nodes$id, collapse = "-"))
    x_ranks <- unique(nodes$x)
    stopifnot(length(x_ranks) > 1)
    attempts <- 0
    for (iter in seq_len(n_iters)) {
        # Forward walk
        for (i in 1:length(x_ranks)) {
            focal_comps <- nodes$comp[nodes$x == x_ranks[i]]
            focal_y <- nodes$y[nodes$x == x_ranks[i]]
            this_rank_counts <- vector()
            for (ci in focal_comps) {
                swaps <- insert_in_between(ci, focal_comps[focal_comps != ci])
                for (k in seq_along(swaps)) {
                    new_focal_comps <- swaps[[k]]
                    nodes$y[match(new_focal_comps, nodes$comp)] <- focal_y
                    count_name <- paste0(nodes$id[order(nodes$x, nodes$y)],
                                         collapse = "-")
                    counts[count_name] <- topo_count_crossings(x, nodes)
                    this_rank_counts[count_name] <- counts[count_name]
                }
            }
            this_rank_best <- names(this_rank_counts)[which.min(this_rank_counts)]
            this_rank_best_order <- as.numeric(strsplit(this_rank_best, "-")[[1]])
            nodes <- nodes[match(this_rank_best_order, nodes$id), ]
            nodes$y <- seq_len(nrow(nodes))
        }
        # Backward walk
        for (i in length(x_ranks):1) {
            focal_comps <- nodes$comp[nodes$x == x_ranks[i]]
            focal_y <- nodes$y[nodes$x == x_ranks[i]]
            this_rank_counts <- vector()
            for (ci in focal_comps) {
                swaps <- insert_in_between(ci, focal_comps[focal_comps != ci])
                for (k in seq_along(swaps)) {
                    new_focal_comps <- swaps[[k]]
                    nodes$y[match(new_focal_comps, nodes$comp)] <- focal_y
                    count_name <- paste0(nodes$id[order(nodes$x, nodes$y)],
                                         collapse = "-")
                    counts[count_name] <- topo_count_crossings(x, nodes)
                    this_rank_counts[count_name] <- counts[count_name]
                }
            }
            this_rank_best <- names(this_rank_counts)[which.min(this_rank_counts)]
            this_rank_best_order <- as.numeric(strsplit(this_rank_best, "-")[[1]])
            nodes <- nodes[match(this_rank_best_order, nodes$id), ]
            nodes$y <- seq_len(nrow(nodes))
        }
    }
    # Return
    return(nodes[, c("comp", "x", "y")])
}

### * insert_in_between()

#' Insert an element in all possible positions of another vector
#'
#' @param x Element to insert
#' @param into Target vector
#'
#' @return A list of vectors with the x element inserted in all posssible
#'     positions of the target.
#'
#' @examples
#' isotracer:::insert_in_between("a", 1:5)
#'
#' @keywords internal
#' @noRd

insert_in_between <- function(x, into) {
    l <- length(into)
    out <- list()
    for (i in 0:l) {
        z <- c(into[0:i], x)
        if (i+1 <= l) {
            z <- c(z, into[(i+1):l])
        }
        out[[i+1]] <- z
    }
    return(out)
}

### * topo_count_crossings()

#' Count edges crossings given a topology and a proposed node arrangement
#'
#' This function assumes that the x locations given in \code{nodes} have been
#' established using \code{\link{topo_x_ordering}}.
#' 
#' @param x A topology matrix or a network model (the topology of the first row
#'     is used in this case).
#' @param nodes A tibble giving the x and y locations for each node. It must
#'     contain columns "comp", "x" and "y".
#'
#' @return Integer, the number of crossing edges when drawing the nodes
#'     and the connecting edges.
#'
#' @examples
#' topo_x_ordering <- isotracer:::topo_x_ordering
#' topo_count_crossings <- isotracer:::topo_count_crossings
#' 
#' z <- topo(trini_mod)
#' x <- topo_x_ordering(z)
#' comps <- names(x)
#' y <- 1:length(comps)
#' d <- tibble::tibble(comp = comps, x = x, y = y)
#' topo_count_crossings(z, d)
#' 
#' @keywords internal
#' @noRd

topo_count_crossings <- function(x, nodes) {
    if (is(x, "networkModel")) {
        x <- unique(topo(x, simplify = FALSE))
        stopifnot(length(x) == 1)
        x <- x[[1]]
    }
    x <- unclass(x) # Remove the "topo" class to treat it as a matrix
    crossings <- 0
    nodes <- nodes[order(nodes$x, nodes$y), ]
    x_ranks <- unique(nodes$x)
    stopifnot(length(x_ranks) > 1)
    for (i in 2:length(x_ranks)) {
        # Get the edges for gap i
        n <- nodes[nodes$x %in% x_ranks[c(i-1, i)], ]
        e <- x[n$comp[n$x == x_ranks[i]], n$comp[n$x == x_ranks[i-1]], drop = FALSE]
        if (ncol(e)>1) {
            for (j in 2:ncol(e)) {
                k <- which(e[, j] > 0)
                for (w in 1:(j-1)) {
                    for (ki in k) {
                        if (ki < nrow(e)) {
                            crossings <- crossings + sum(e[, w][(ki+1):nrow(e)])
                        }
                    }
                }
            }
        }
    }
    return(crossings)
}

### * sankey_minimize_energy()

#' Adjust nodes y positions using a spring/energy minimization model
#'
#' WIP: This function does not seem to working properly at the moment.
#'
#' @param x A topology.
#' @param nodes The output of \code{\link{sankey_calc_nodes_locations}} run on
#'     \code{x}.
#' @param k1 Numeric, stiffness for springs between nodes on the same x position.
#' @param k2 Numeric, sitffness for springs between connected nodes.
#' @param l1 Numeric, rest length for springs with k1 stiffness.
#' @param l2 Numeric, rest length for springs with k2 stiffness.
#'
#' @return An updated \code{nodes} tibble.
#'
#' @importFrom stats optim
#' 
#' @examples
#' sankey_calc_nodes_locations <- isotracer:::sankey_calc_nodes_locations
#' sankey_minimize_energy <- isotracer:::sankey_minimize_energy
#' 
#' nodes <- sankey_calc_nodes_locations(trini_mod, layout = "left2right")
#' sankey_minimize_energy(topo(trini_mod), nodes)
#' 
#' @keywords internal
#' @noRd

sankey_minimize_energy <- function(x, nodes, k1 = 100, k2 = 10, l1 = 1, l2 = 1) {
    n_comps <- ncol(x)
    links <- which(unclass(x) > 0)
    from <- links %/% n_comps + 1
    to <- links %% n_comps
    links <- tibble::tibble(from = from, to = to)
    for (i in seq_len(nrow(links))) {
        if (links$to[i] == 0) {
            links$from[i] <- links$from[i] - 1
            links$to[i] <- n_comps
        }
        stopifnot(x[links$to[i], links$from[i]] > 0)
    }
    links$from <- colnames(x)[links$from]
    links$to <- colnames(x)[links$to]
    # The y location of the first node is fixed.
    stopifnot(nrow(nodes) > 1)
    nodes <- nodes[order(nodes$x, nodes$y), ]
    links$from <- match(links$from, nodes$comp)
    links$to <- match(links$to, nodes$comp)
    energy <- function(...) {
        nodes$y <- c(nodes$y[1], unlist(list(...)))
        energy <- 0
        # Energy due to springs between nodes on same x_rank
        x_ranks <- unique(nodes$x)
        for (xi in x_ranks) {
            ni <- nodes[nodes$x == xi, ]
            if (nrow(ni) > 1) {
                for (i in 2:nrow(ni)) {
                    delta_l <- ni$y[i] - ni$y[i-1] - l1
                    energy <- energy + 1/2 * k1 * delta_l^2
                }
            }
        }
        # Energy due to springs along connections between nodes of different x_rank
        for (i in 1:nrow(links)) {
            delta_l <- abs(nodes$y[links$to[i]] - nodes$y[links$from[i]]) - l2
            energy <- energy + 1/2 * k2 * delta_l^2
        }
        return(energy)
    }
    start_values <- nodes$y[2:nrow(nodes)]
    y_locs <- optim(start_values, energy, method = "BFGS")$par
    nodes$y <- c(nodes$y[1], y_locs)
    return(nodes)
}

### * sankey_minimize_energy_sim()

#' Adjust nodes y positions using a spring/energy minimization model
#'
#' @param x A topology.
#' @param nodes The output of \code{\link{sankey_calc_nodes_locations}} run on
#'     \code{x}.
#' @param k1 Numeric, stiffness for springs between nodes on the same x
#'     position.
#' @param k2 Numeric, sitffness for springs between connected nodes.
#' @param l1 Numeric, rest length for springs with k1 stiffness.
#' @param l2 Numeric, rest length for springs with k2 stiffness.
#' @param cd Numeric, dampening constant.
#' @param debug Boolean, if TRUE return trajectories instead of the node
#'     tibble.
#' @param return_acc Boolean, if TRUE also return velocity and acceleration
#'     values in the node tibble (useful for debugging).
#' @param n_iters Number of iterations in the simulation loop.
#' @param dt Time step used in the simulation loop.
#'
#' @return An updated \code{nodes} tibble.
#'
#' @examples
#' sankey_calc_nodes_locations <- isotracer:::sankey_calc_nodes_locations
#' sankey_minimize_energy_sim <- isotracer:::sankey_minimize_energy_sim
#' 
#' nodes <- sankey_calc_nodes_locations(trini_mod, layout = "left2right")
#' nodes <- nodes[nodes$x < 2, ]
#' z <- sankey_minimize_energy_sim(topo(trini_mod)[nodes$comp, nodes$comp], nodes,
#'        n_iters = 200, cd = 0.8, dt = 0.1, debug = TRUE)
#' z <- do.call(rbind, z)
#' lattice::xyplot(ts(z))
#'
#' (z <- sankey_minimize_energy_sim(topo(trini_mod)[nodes$comp, nodes$comp], nodes,
#'         n_iters = 200, cd = 0.8, dt = 0.1, return_acc = TRUE))
#' plot(z$x, z$y)
#' text(z$x, z$y, z$comp)
#' 
#' @keywords internal
#' @noRd

sankey_minimize_energy_sim <- function(x, nodes, k1 = 1, k2 = 1, l1 = 1, l2 = 1,
                                       cd = 0.8, n_iters = 25, dt = 0.5, debug = FALSE,
                                       return_acc = FALSE) {
    n_comps <- ncol(x)
    links <- which(x > 0)
    from <- links %/% n_comps + 1
    to <- links %% n_comps
    links <- tibble::tibble(from = from, to = to)
    for (i in seq_len(nrow(links))) {
        if (links$to[i] == 0) {
            links$from[i] <- links$from[i] - 1
            links$to[i] <- n_comps
        }
        stopifnot(x[links$to[i], links$from[i]] > 0)
    }
    links$from <- colnames(x)[links$from]
    links$to <- colnames(x)[links$to]
    stopifnot(nrow(nodes) > 1)
    nodes <- nodes[order(nodes$x, nodes$y), ]
    nodes$v <- 0
    links$from <- match(links$from, nodes$comp)
    links$to <- match(links$to, nodes$comp)
    traj <- list()
    x_ranks <- unique(nodes$x)
    # Dynamic simulation
    for (i in seq_len(n_iters)) {
        nodes$a <- 0
        traj[[i]] <- nodes$y
        # Add forces due to springs between nodes on same x_rank
        for (xi in x_ranks) {
            ni <- nodes[nodes$x == xi, ]
            if (nrow(ni) > 1) {
                for (i in 2:nrow(ni)) {
                    delta_l <- ni$y[i] - ni$y[i-1] - l1
                    force <- k1 * delta_l
                    ni$a[i] <- ni$a[i] - force
                    ni$a[i-1] <- ni$a[i-1] + force
                }
            }
            nodes[nodes$x == xi, ] <- ni
        }
        # Add forces due to springs along connections between nodes of different x_rank
        for (i in 1:nrow(links)) {
            delta_l <- abs(nodes$y[links$to[i]] - nodes$y[links$from[i]]) - l2
            force <- k2 * delta_l
            if (nodes$y[links$to[i]] > nodes$y[links$from[i]]) {
                nodes$a[links$to[i]] <- nodes$a[links$to[i]] - force
                nodes$a[links$from[i]] <- nodes$a[links$from[i]] + force
            } else {
                nodes$a[links$to[i]] <- nodes$a[links$to[i]] + force
                nodes$a[links$from[i]] <- nodes$a[links$from[i]] - force
            }
        }
        # Dampening
        for (i in seq_len(nrow(nodes))) {
            nodes$a[i] <- nodes$a[i] - cd * nodes$v[i]
        }
        # Integration
        for (i in seq_len(nrow(nodes))) {
            nodes$y[i] <- nodes$y[i] + dt * nodes$v[i]
            nodes$v[i] <- nodes$v[i] + dt * nodes$a[i]
        }
    }
    if (debug) {
        return(traj)
    }
    if (return_acc) {
        return(nodes)
    }
    return(nodes[, c("comp", "x", "y")])
}

### * sankey_draw_node()

#' Draw a rounded rectangle with a label
#'
#' @param x,y Locations of the center of the rectangle.
#' @param label String, label added inside the rectangle.
#' @param fill Fill color.
#' @param col Border color.
#' @param text_col Text color.
#' @param style One of "roundrect", "square".
#' @param padding Padding value.
#' @param padding_factor Adjustment factor for padding.
#' @param r_factor Adjustment factor for rounded corner.
#' @param side Vector of length 1 or 2 giving node width and height values
#'     (used for style = "square").
#' @param factor Adjustment factor for node dimensions (used for style =
#'     "square").
#'
#' @keywords internal
#' @noRd

sankey_draw_node <- function(x, y, label,
                             fill = NULL, col = "black", text_col = NULL,
                             style = "roundrect",
                             padding = NULL, padding_factor = 1, r_factor = 1, # For roundrect
                             side = NULL, factor = 1) {
    # Convert x and y coordinates
    x <- grid::unit(x, "native")
    y <- grid::unit(y, "native")
    # Draw box
    if (is.null(fill)) {
        gp <- grid::gpar(col = col)
    } else {
        gp <- grid::gpar(col = col, fill = fill)
    }
    if (style == "roundrect") {
        r <- grid::unit(0.1, "snpc") * r_factor
        if (is.null(padding)) {
            padding <- grid::unit(1, "strwidth", "o")
        }
        width <- grid::unit(1, "strwidth", label) + 2 * padding * padding_factor
        height <- grid::unit(1, "strheight", label) + 2 * padding * padding_factor
        grid::grid.roundrect(x = x, y = y, width = width, height = height,
                             gp = gp, r = r)
    } else if (style == "square") {
        if (is.null(side)) {
            side <- grid::unit(1, "strwidth", "toto")
        }
        if (length(side) == 1) {
            side <- grid::unit.c(side, side)
        }
        grid::grid.rect(x = x, y = y, width = side[1] * factor,
                        height = side[2] * factor, gp = gp)
    }
    # Draw label
    if (is.null(text_col)) {
        text_col <- col
    }
    gp <- grid::gpar(col = text_col)
    grid::grid.text(label = label, x = x, y = y, gp = gp)
}

### * sankey_draw_edge()

#' Draw a constant-width ribbon between nodes
#'
#' @param backbone Two-column table containing the x and y coordinates of the
#'     points making the mid-line of the edge ribbon.
#' @param width Width of the edge ribbon.
#' @param fill Color for ribbon fill.
#' @param col Color for ribbon border.
#' @param factor Adjustment factor for ribbon width.
#' 
#' @keywords internal
#' @noRd

sankey_draw_edge <- function(backbone, width = 0.1, fill = NULL, col = "black",
                             factor = 1) {
    rb <- ribbonFromTrajectory(backbone, width * factor)
    if (is.null(fill)) {
        gp <- grid::gpar(col = col)
    } else {
        gp <- grid::gpar(col = col, fill = fill)
    }
    grid::grid.polygon(x = rb[, 1], y = rb[, 2], default.units = "native", gp = gp)
}

### * make_and_push_ortho_vp()

#' Make an orthonormal data viewport
#'
#' This function must be run when a parent viewport already exists. It adds a
#' container viewport, centered, with specified width and height, and fills
#' this container viewport with an orthonormal data viewport (based on the
#' physical dimensions of the container viewport).
#'
#' Note that this function creates and push two viewports on the stack (a
#' container filling the parent viewport completely and a data viewport filling
#' the container, with an orthonormal cartesian coordinate system), so that two
#' viewports must be popped in order to come back to the parent viewport in use
#' before the function call.
#'
#' @param width,height Numeric between 0 and 1, fraction of the parent viewport
#'     width and height filled by the new viewport.
#' @param debug Boolean.
#' 
#' @return An orthonormal data viewport which bounds (0, 1) on one axis.
#'
#' @examples
#' library(grid)
#' grid.newpage()
#' pushViewport(viewport())
#' ortho_vp <- isotracer:::make_and_push_ortho_vp(width = 0.9, height = 0.9,
#'               debug = TRUE)
#'
#' @keywords internal
#' @noRd

make_and_push_ortho_vp <- function(width = 1, height = 1, debug = FALSE) {
    debug_bg_col <- "#095ba7"
    debug_line_col <- "#9fccfa" # "#baecfa"
    parent_vp <- grid::current.viewport()
    if (debug) {
        grid::grid.rect(gp = grid::gpar(col = debug_line_col,
                                        fill = debug_bg_col))
    }
    container_vp <- grid::viewport(width = width, height = height,
                                   name = "ortho_container")
    grid::pushViewport(container_vp)
    if (debug) {
        grid::grid.rect(gp = grid::gpar(col = debug_line_col,
                                        fill = debug_bg_col))
    }
    container_dims <- grid::deviceDim(container_vp$width,
                                      container_vp$height,
                                      valueOnly = TRUE)
    canvas_dims <- container_dims
    if (canvas_dims$w >= canvas_dims$h) {
        y_scale <- c(0, 1)
        x_scale <- y_scale * canvas_dims$w / canvas_dims$h
        x_scale <- x_scale - (x_scale[2] - 1) / 2
    } else {
        x_scale <- c(0, 1)
        y_scale <- x_scale * canvas_dims$h / canvas_dims$w
        y_scale <- y_scale - (y_scale[2] - 1) / 2
    }
    canvas_vp <- grid::dataViewport(xscale = x_scale, yscale = y_scale,
                                    name = "ortho_canvas")
    grid::pushViewport(canvas_vp)
    if (debug) {
        shift <- 0.05
        arrow_style <- grid::arrow(length = grid::unit(0.01, "native"))
        grid::grid.rect(width = 1, height = 1,
                        default.units = "native",
                        gp = grid::gpar(col = debug_line_col, lty = 2))
        grid::grid.lines(x = c(0, 0.1) + shift, y = shift, default.units = "native",
                         gp = grid::gpar(col = debug_line_col),
                         arrow = arrow_style)
        grid::grid.lines(x = shift, y = c(0, 0.1) + shift, default.units = "native",
                         gp = grid::gpar(col = debug_line_col),
                         arrow = arrow_style)
        grid::grid.points(x = 0.5, y = 0.5, default.units = "native",
                          pch = 3, gp = grid::gpar(col = debug_line_col))
        grid::grid.text("0.1 x", x = grid::unit(0.05 + shift, "native"),
                        y = grid::unit(shift, "native") + grid::unit(0.7, "strheight", "x"),
                        gp = grid::gpar(cex = 1, col = debug_line_col))
        grid::grid.text("0.1 y", x = grid::unit(shift, "native") + grid::unit(0.7, "strheight", "x"),
                        y = grid::unit(0.05 + shift, "native"),
                        gp = grid::gpar(cex = 1, col = debug_line_col),
                        rot = -90)
        grid::grid.text("(0, 0)",
                        x = grid::unit(0, "native") + grid::unit(0.1, "strwidth", "x"),
                        y = grid::unit(0, "native") + grid::unit(0.4, "strheight", "x"),
                        hjust = 0, vjust = 0,
                        gp = grid::gpar(cex = 1, col = debug_line_col))
        grid::grid.text("(1, 1)",
                        x = grid::unit(1, "native") - grid::unit(1, "strwidth", "(1, 1)"),
                        y = grid::unit(1, "native") - grid::unit(0.4, "strheight", "x"),
                        hjust = 0, vjust = 1,
                        gp = grid::gpar(cex = 1, col = debug_line_col))
        topleft <- signif(c(canvas_vp$xscale[1], canvas_vp$yscale[2]), 3)
        topleft_char <- paste0("(", topleft[1], ", ", topleft[2], ")")
        grid::grid.text(topleft_char,
                        x = grid::unit(topleft[1], "native") + grid::unit(0.1, "strwidth", "x"),
                        y = grid::unit(topleft[2], "native") - grid::unit(0.4, "strheight", "x"),
                        hjust = 0, vjust = 1,
                        gp = grid::gpar(cex = 1, col = debug_line_col))
        bottomright <- signif(c(canvas_vp$xscale[2], canvas_vp$yscale[1]), 3)
        bottomright_char <- paste0("(", bottomright[1], ", ", bottomright[2], ")")
        grid::grid.text(bottomright_char,
                        x = grid::unit(bottomright[1], "native") - grid::unit(1, "strwidth", bottomright_char),
                        y = grid::unit(bottomright[2], "native") + grid::unit(0.4, "strheight", "x"),
                        hjust = 0, vjust = 0,
                        gp = grid::gpar(cex = 1, col = debug_line_col))
        grid::grid.text("(0.5, 0.5)",
                        x = grid::unit(0.5, "native") + grid::unit(0.1, "strwidth", "x"),
                        y = grid::unit(0.5, "native") + grid::unit(0.4, "strheight", "x"),
                        hjust = 0, vjust = 0,
                        gp = grid::gpar(cex = 1, col = debug_line_col))
    }
    return(canvas_vp)
}

### * sankey_draw_edges()

#' @keywords internal
#' @noRd

sankey_draw_edges <- function(edges, defaults = list(col = adjustcolor("black", alpha.f = 0.5),
                                                     fill = adjustcolor("grey", alpha.f = 0.5),
                                                     lwd = 1, lty = 1),
                              debug = FALSE) {
    debug_bg_col <- "#095ba7"
    debug_line_col <- "#9fccfa" # "#baecfa"
    if (is.null(edges) || nrow(edges) == 0) {
        return(NULL)
    }
    for (property in names(defaults)) {
        if (! property %in% colnames(edges)) {
            edges[[property]] <- defaults[[property]]
        }
    }
    for (i in seq_len(nrow(edges))) {
        rb <- ribbonFromTrajectory(edges[["backbone"]][[i]],
                                   width = edges[["width"]][i])
        gp <- grid::gpar(col = edges[["col"]][i],
                         fill = edges[["fill"]][i],
                         lwd = edges[["lwd"]][i],
                         lty = edges[["lty"]][i])
        grid::grid.polygon(x = rb[, 1], y = rb[, 2], default.units = "native",
                           gp = gp)
        if (debug) {
            grid::grid.lines(x = edges[["control_points"]][[i]][, 1],
                             y = edges[["control_points"]][[i]][, 2],
                             default.units = "native",
                             gp = grid::gpar(col = debug_line_col,
                                             lty = 2))
            grid::grid.lines(x = edges[["backbone"]][[i]][, 1],
                             y = edges[["backbone"]][[i]][, 2],
                             default.units = "native",
                             gp = grid::gpar(col = debug_line_col))
            grid::grid.points(x = edges[["control_points"]][[i]][, 1],
                              y = edges[["control_points"]][[i]][, 2],
                              default.units = "native",
                              pch = 1,
                              gp = grid::gpar(col = debug_line_col,
                                              cex = 0.75))
            grid::grid.points(x = edges[["backbone"]][[i]][, 1],
                              y = edges[["backbone"]][[i]][, 2],
                              default.units = "native",
                              pch = 21,
                              gp = grid::gpar(col = debug_line_col,
                                              fill = debug_line_col,
                                              cex = 0.5))
        }
    }
    return(NULL)
}

### * sankey_draw_nodes()

#' @keywords internal
#' @noRd

sankey_draw_nodes <- function(nodes, defaults = list(label = "",
                                                     col = adjustcolor("black", alpha.f = 0.5),
                                                     fill = adjustcolor("grey", alpha.f = 0.5),
                                                     lwd = 1, lty = 1),
                              debug = FALSE, node_s = "default") {
    debug_bg_col <- "#095ba7"
    debug_line_col <- "#9fccfa" # "#baecfa"
    if (is.null(nodes) || nrow(nodes) == 0) {
        return(NULL)
    }
    for (property in names(defaults)) {
        if (! property %in% colnames(nodes)) {
            nodes[[property]] <- defaults[[property]]
        }
    }
    for (i in seq_len(nrow(nodes))) {
        gp <- grid::gpar(col = nodes$col[i],
                         fill = nodes$fill[i],
                         lwd = nodes$lwd[i],
                         lty = nodes$lty[i])
        if (node_s == "roundsquare") {
            grid::grid.roundrect(x = nodes$x[i], y = nodes$y[i],
                            width = nodes$width[[i]],
                            height = nodes$height[[i]],
                            default.units = "native",
                            gp = gp)
        } else {
            grid::grid.rect(x = nodes$x[i], y = nodes$y[i],
                            width = nodes$width[[i]],
                            height = nodes$height[[i]],
                            default.units = "native",
                            gp = gp)
        }
        if (debug) {
            gp <- grid::gpar(col = debug_line_col,
                             lty = 5)
            if (node_s == "roundrect") {
                grid::grid.roundrect(x = nodes$x[i], y = nodes$y[i],
                                width = nodes$width[[i]],
                                height = nodes$height[[i]],
                                default.units = "native",
                                gp = gp)
            } else {
                grid::grid.rect(x = nodes$x[i], y = nodes$y[i],
                                width = nodes$width[[i]],
                                height = nodes$height[[i]],
                                default.units = "native",
                                gp = gp)
            }
            left <- nodes$x[i] - grid::convertWidth(nodes$width[[i]], unitTo = "native",
                                                    valueOnly = TRUE) / 2
            right <- nodes$x[i] + grid::convertWidth(nodes$width[[i]], unitTo = "native",
                                                     valueOnly = TRUE) / 2
            bottom <- nodes$y[i] - grid::convertHeight(nodes$height[[i]], unitTo = "native",
                                                       valueOnly = TRUE) / 2
            top <- nodes$y[i] + grid::convertHeight(nodes$height[[i]], unitTo = "native",
                                                    valueOnly = TRUE) / 2
            gp <- grid::gpar(col = debug_line_col,
                             lty = "26")
            grid::grid.lines(x = c(left, right), y = c(top, bottom),
                             default.units = "native", gp = gp)
            grid::grid.lines(x = c(left, right), y = c(bottom, top),
                             default.units = "native", gp = gp)
            gp <- grid::gpar(col = debug_line_col,
                             fill = debug_bg_col)
            grid::grid.points(x = nodes[["x"]][i], y = nodes[["y"]][i],
                              pch = 5, size = grid::unit(0.8, "char"),
                              default.units = "native", gp = gp)
            grid::grid.text(x = nodes[["x"]][i],
                            y = grid::unit(nodes[["y"]][i], "native") +
                                grid::unit(1.4, "strheight", "x"),
                            default.units = "native", gp = gp,
                            label = nodes[["comp"]][i])
        }
    }
    return(NULL)
}

### * sankey_draw_labels()

#' @keywords internal
#' @noRd

sankey_draw_labels <- function(labels, defaults = list(label = "",
                                                       cex = 1,
                                                       col = adjustcolor("black", alpha.f = 0.5),
                                                       fill = adjustcolor("grey", alpha.f = 0.5),
                                                       lwd = 1, lty = 1),
                               debug = FALSE) {
    debug_bg_col <- "#095ba7"
    debug_line_col <- "#9fccfa" # "#baecfa"
    if (is.null(labels) || nrow(labels) == 0) {
        return(NULL)
    }
    for (property in names(defaults)) {
        if (! property %in% colnames(labels)) {
            labels[[property]] <- defaults[[property]]
        }
    }
    for (i in seq_len(nrow(labels))) {
        if (debug) {
            gp <- grid::gpar(col = debug_line_col,
                             lwd = 0.5)
            grid::grid.points(x = labels$label_x[i],
                              y = labels$label_y[[i]],
                              default.units = "native",
                              pch = 3, gp = gp)
            half_height <- grid::convertHeight(grid::unit(1/2 * labels$cex[i], "strheight", labels$label[[i]]),
                                               unitTo = "native", valueOnly = TRUE)
            top <- labels$label_y[i] + half_height
            bottom <- labels$label_y[i] - half_height
            left <- grid::convertWidth(grid::unit(labels$label_x[i], "native") -
                                        grid::unit(0.525 * labels$cex[i], "strwidth", labels$label[[i]]),
                                        unitTo = "native", valueOnly = TRUE)
            right <- grid::convertWidth(grid::unit(labels$label_x[i], "native") +
                                         grid::unit(0.525 * labels$cex[i], "strwidth", labels$label[[i]]),
                                         unitTo = "native", valueOnly = TRUE)
            grid::grid.lines(c(left, right), c(top, top),
                             default.units = "native", gp = gp)
            grid::grid.lines(c(left, right), c(bottom, bottom),
                             default.units = "native", gp = gp)
        }
        gp <- grid::gpar(col = labels$col[i],
                         cex = labels$cex[i])
        grid::grid.text(label = labels$label[[i]],
                        x = labels$label_x[i],
                        y = labels$label_y[[i]],
                        default.units = "native", gp = gp)
    }
    return(NULL)
}

### * (1) sankey_place_nodes()

#' Perform initial placement of the nodes
#'
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' @param xlim,ylim Limits of the x and y scales.
#' 
#' @examples
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' 
#' topo <- topo(trini_mod)
#' nodes <- tibble::tibble(comp = colnames(topo), size = 1, col = "red")
#' nodes$label <- letters[1:nrow(nodes)]
#' sankey_place_nodes(topo, nodes, layout = "left2right")
#' sankey_place_nodes(topo, nodes, layout = "stress")
#' 
#' @keywords internal
#' @noRd

sankey_place_nodes <- function(topo, nodes = NULL, flows, layout, xlim = c(0, 1),
                               ylim = c(0, 1)) {
    nodes_arg <- nodes
    # Calculate node locations
    nodes <- sankey_calc_nodes_locations(topo, layout)
    # Adjust node locations to fill the canvas
    nodes$x <- (nodes$x - min(nodes$x)) / (max(nodes$x) - min(nodes$x)) * diff(xlim) + xlim[1]
    nodes$y <- (nodes$y - min(nodes$y)) / (max(nodes$y) - min(nodes$y)) * diff(ylim) + ylim[1]
    nodes$label <- nodes$comp
    # Return
    if (!is.null(nodes_arg)) {
        if (any(colnames(nodes_arg) %in% c("x", "y"))) {
            stop("Provided `nodes` tibble cannot have `x` or `y` column.")
        }
        if (! setequal(nodes$comp, nodes_arg$comp)) {
            stop("Provided `nodes` tibble must have a `comp` column with exactly the same entries as the topology compartments.")
        }
        if ("label" %in% colnames(nodes_arg)) {
            nodes$label <- NULL
        }
        nodes <- dplyr::left_join(nodes, nodes_arg, by = "comp")
    }
    out <- list(nodes = nodes, edges = NULL)
    attr(out, "layout") <- layout
    return(out)
}

### * (2) sankey_place_edge_sockets_on_nodes()

#' Determine relative location of edge sockets on nodes
#'
#' @param scene A list with a "nodes" tibble.
#' @param topo A topology.
#' @param nodes A node tibble.
#' @param flows A tibble giving the flow rates between connected nodes.
#' @param layout String specifying the plot layout.
#'
#' @examples
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' sankey_place_edge_sockets_on_nodes <- isotracer:::sankey_place_edge_sockets_on_nodes
#' 
#' topo <- topo(trini_mod)
#' flows <- flows_from_topo(topo)
#' flows$width <- 1
#' layout <- "stress"
#' scene <- sankey_place_nodes(topo, flows = flows, layout = layout)
#' z <- sankey_place_edge_sockets_on_nodes(scene, topo, flows = flows, layout = layout)
#' 
#' @keywords internal
#' @noRd

sankey_place_edge_sockets_on_nodes <- function(scene, topo, nodes = NULL, flows, layout) {
    nodes <- scene$nodes
    edges <- flows
    stopifnot(is.null(scene[["edges"]]))
    edges$from_x <- nodes$x[match(edges$from, nodes$comp)]
    edges$to_x <- nodes$x[match(edges$to, nodes$comp)]
    edges$from_y <- nodes$y[match(edges$from, nodes$comp)]
    edges$to_y <- nodes$y[match(edges$to, nodes$comp)]
    sockets <- list()
    # Layout left2right
    if (layout == "left2right") {
        edges <- edges[order(edges$from_x, edges$from_y), ]
        nodes$left_accumulator <- 0
        nodes$right_accumulator <- 0
        for (i in seq_len(nrow(edges))) {
            from <- edges$from[i]
            to <- edges$to[i]
            edge_id <- c(from = from, to = to)
            # Socket from
            socket_from <- list()
            socket_from[["node_id"]] <- from
            socket_from[["node_side"]] <- "right"
            socket_from[["edge_id"]] <- list(edge_id)
            socket_from[["edge_end"]] <- "from"
            socket_from[["rel_loc"]] <- (nodes$right_accumulator[nodes$comp == from] +
                                         edges$width[i]/2)
            nodes$right_accumulator[nodes$comp == from] <- (nodes$right_accumulator[nodes$comp == from] +
                                                            edges$width[i])
            socket_from[["width"]] <- edges$width[i]
            # Socket to
            socket_to <- list()
            socket_to[["node_id"]] <- to
            socket_to[["node_side"]] <- "left"
            socket_to[["edge_id"]] <- list(edge_id)
            socket_to[["edge_end"]] <- "to"
            socket_to[["rel_loc"]] <- (nodes$left_accumulator[nodes$comp == to] +
                                       edges$width[i]/2)
            nodes$left_accumulator[nodes$comp == to] <- (nodes$left_accumulator[nodes$comp == to] +
                                                         edges$width[i])
            socket_to[["width"]] <- edges$width[i]
            # Store sockets
            sockets[[2*i-1]] <- socket_from
            sockets[[2*i]] <- socket_to
        }
    } else if (layout %in% c("stress", "kk", "lgl", "fr", "dh", "mds")) {
        # Layout stress or kk or ...
        edges <- edges[order(edges$from_x, edges$from_y), ]
        sides <- c("right", "top", "left", "bottom")
        # Place sockets (node side and angular location)
        for (i in seq_len(nrow(edges))) {
            from <- edges$from[i]
            to <- edges$to[i]
            edge_id <- c(from = from, to = to)
            edge_id_char <- paste(from, to, sep = "->")
            recip_edge_id <- paste(to, from, sep = "->")
            # Socket from
            quadrant <- sankey_stress_quadrant(y = edges$to_y[i] - edges$from_y[i],
                                               x = edges$to_x[i] - edges$from_x[i])
            socket_from <- list()
            socket_from[["node_id"]] <- from
            socket_from[["node_side"]] <- sides[quadrant["q"]]
            socket_from[["edge_id"]] <- list(edge_id)
            socket_from[["edge_id_char"]] <- edge_id_char
            socket_from[["recip_edge_id"]] <- recip_edge_id
            socket_from[["edge_end"]] <- "from"
            socket_from[["rel_quadrant_angle"]] <- quadrant["a"]
            socket_from[["width"]] <- edges$width[i]
            # Socket to
            quadrant <- sankey_stress_quadrant(y = -(edges$to_y[i] - edges$from_y[i]),
                                               x = -(edges$to_x[i] - edges$from_x[i]))
            socket_to <- list()
            socket_to[["node_id"]] <- to
            socket_to[["node_side"]] <- sides[quadrant["q"]]
            socket_to[["edge_id"]] <- list(edge_id)
            socket_to[["edge_id_char"]] <- edge_id_char
            socket_to[["recip_edge_id"]] <- recip_edge_id
            socket_to[["edge_end"]] <- "to"
            socket_to[["rel_quadrant_angle"]] <- quadrant["a"]
            socket_to[["width"]] <- edges$width[i]
            # Give a little nudge if a reciprocal edge exists
            if (recip_edge_id %in% sapply(sockets, "[[", "edge_id_char")) {
                socket_to[["rel_quadrant_angle"]] <- socket_to[["rel_quadrant_angle"]] - 1e-8
            }
            # Store sockets
            sockets[[2*i-1]] <- socket_from
            sockets[[2*i]] <- socket_to
        }
        sockets <- dplyr::bind_rows(sockets)
        sockets <- sockets[order(sockets$node_id, sockets$node_side,
                                 sockets$rel_quadrant_angle), ]

        # Update the node side accumulators and sockets relative locations
        nodes$left_accumulator <- 0
        nodes$right_accumulator <- 0
        nodes$top_accumulator <- 0
        nodes$bottom_accumulator <- 0
        sockets[["rel_loc"]] <- 0
        for (i in seq_len(nrow(sockets))) {
            ni <- which(nodes$comp == sockets$node_id[i])
            side <- sockets$node_side[i]
            if (side == "left") {
                sockets$rel_loc[i] <- nodes$left_accumulator[ni] - sockets$width[i]/2
                nodes$left_accumulator[ni] <- nodes$left_accumulator[ni] - sockets$width[i]
            }
            if (side == "bottom") {
                sockets$rel_loc[i] <- nodes$bottom_accumulator[ni] + sockets$width[i]/2
                nodes$bottom_accumulator[ni] <- nodes$bottom_accumulator[ni] + sockets$width[i]
            }
            if (side == "right") {
                sockets$rel_loc[i] <- nodes$right_accumulator[ni] + sockets$width[i]/2
                nodes$right_accumulator[ni] <- nodes$right_accumulator[ni] + sockets$width[i]
            }
            if (side == "top") {
                sockets$rel_loc[i] <- nodes$top_accumulator[ni] - sockets$width[i]/2
                nodes$top_accumulator[ni] <- nodes$top_accumulator[ni] - sockets$width[i]
            }
        }

        # Optimize sockets distribution around a given node
        for (n in nodes$comp) {
            node_sockets <- sockets[sockets$node_id == n, ]
            current_imbalance <- sankey_stress_socket_imbalance(node_sockets)
            possible_moves <- sankey_stress_socket_moves(node_sockets)
            if (length(possible_moves) > 0) {
                possible_imbalances <- sapply(possible_moves,
                                              sankey_stress_socket_imbalance)
                possible_moves <- possible_moves[order(possible_imbalances)]
                possible_imbalances <- sort(possible_imbalances)
                if (possible_imbalances[1] < current_imbalance) {
                    # Do the move
                    sockets[sockets$node_id == n, ] <- possible_moves[[1]]
                }
            }
        }

        # Update nodes accumulators and sockets rel_loc
        sockets <- sockets[order(sockets$node_id, sockets$node_side,
                                 sockets$rel_quadrant_angle), ]
        nodes$left_accumulator <- 0
        nodes$right_accumulator <- 0
        nodes$top_accumulator <- 0
        nodes$bottom_accumulator <- 0
        sockets[["rel_loc"]] <- 0
        for (i in seq_len(nrow(sockets))) {
            ni <- which(nodes$comp == sockets$node_id[i])
            side <- sockets$node_side[i]
            if (side == "left") {
                sockets$rel_loc[i] <- nodes$left_accumulator[ni] - sockets$width[i]/2
                nodes$left_accumulator[ni] <- nodes$left_accumulator[ni] - sockets$width[i]
            }
            if (side == "bottom") {
                sockets$rel_loc[i] <- nodes$bottom_accumulator[ni] + sockets$width[i]/2
                nodes$bottom_accumulator[ni] <- nodes$bottom_accumulator[ni] + sockets$width[i]
            }
            if (side == "right") {
                sockets$rel_loc[i] <- nodes$right_accumulator[ni] + sockets$width[i]/2
                nodes$right_accumulator[ni] <- nodes$right_accumulator[ni] + sockets$width[i]
            }
            if (side == "top") {
                sockets$rel_loc[i] <- nodes$top_accumulator[ni] - sockets$width[i]/2
                nodes$top_accumulator[ni] <- nodes$top_accumulator[ni] - sockets$width[i]
            }
        }
    } else {
        # Default sockets
        for (i in seq_len(nrow(edges))) {
            from <- edges$from[i]
            to <- edges$to[i]
            edge_id <- c(from = from, to = to)
            # Socket from
            socket_from <- list()
            socket_from[["node_id"]] <- from
            socket_from[["node_side"]] <- "center"
            socket_from[["edge_id"]] <- list(edge_id)
            socket_from[["edge_end"]] <- "from"
            socket_from[["rel_loc"]] <- 0
            socket_from[["width"]] <- edges$width[i]
            # Socket to
            socket_to <- list()
            socket_to[["node_id"]] <- to
            socket_to[["node_side"]] <- "center"
            socket_to[["edge_id"]] <- list(edge_id)
            socket_to[["edge_end"]] <- "to"
            socket_to[["rel_loc"]] <- 0
            socket_to[["width"]] <- edges$width[i]
            # Store sockets
            sockets[[2*i-1]] <- socket_from
            sockets[[2*i]] <- socket_to
        }
    }
    # Return
    sockets <- dplyr::bind_rows(sockets)
    out <- scene
    out[["nodes"]] <- nodes
    out[["edges"]] <- edges
    out[["edge_sockets"]] <- sockets
    return(out)
}

### * (3) sankey_calc_node_shape()

#' Determine node shape
#'
#' @importFrom stats aggregate
#' 
#' @param scene Scene list.
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' @param node_f Multiplicative factor used to adjust node size.
#' @param xlim Limits of the x scale.
#' @param node_s String defining how node size is calculated. The effect of the
#'     string also depends on the chosen layout.
#' 
#' @examples
#' library(magrittr)
#' 
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' sankey_place_edge_sockets_on_nodes <- isotracer:::sankey_place_edge_sockets_on_nodes
#' sankey_calc_node_shape <- isotracer:::sankey_calc_node_shape
#' 
#' topo <- topo(trini_mod)
#' flows <- flows_from_topo(topo)
#' flows$width <- 1
#' layout <- "left2right"
#' scene <- sankey_place_nodes(topo, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, topo, flows = flows, layout = layout)
#' z <- sankey_calc_node_shape(scene, topo, flows = flows, layout = layout)
#'
#' topo <- topo(trini_mod)
#' flows <- flows_from_topo(topo)
#' flows$width <- 1
#' layout <- "stress"
#' scene <- sankey_place_nodes(topo, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, topo, flows = flows, layout = layout)
#' z <- sankey_calc_node_shape(scene, topo, flows = flows, layout = layout)
#'
#' y <- new_networkModel() %>%
#'          set_topo(c("subs -> NH3 -> subs",
#'                     "NH3 -> Q, E", "E -> Q -> E",
#'                     "E -> D, M")) %>%
#'          set_steady("subs") %>%
#'              set_prop_family("normal_sd")
#' y <- topo(y)
#' nodes <- nodes_from_topo(y)
#' nodes$size <- runif(nrow(nodes), 1, 2)
#' flows <- flows_from_topo(y)
#' flows$width <- runif(nrow(flows), 0.2, 5)
#' layout <- "stress"
#' scene <- sankey_place_nodes(y, nodes = nodes, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, y, flows = flows, layout = layout)
#' z <- sankey_calc_node_shape(scene, y, flows = flows, layout = layout)
#'  
#' @keywords internal
#' @noRd

sankey_calc_node_shape <- function(scene, topo, nodes = NULL, flows, layout,
                                   node_f = 1, xlim = c(0, 1), node_s = "auto") {
    nodes <- scene$nodes
    sockets <- scene$edge_sockets
    nodes$shape <- NA
    nodes$width <- NA
    nodes$height <- NA
    if (!"size" %in% colnames(nodes)) {
        nodes[["size"]] <- 1
    }
    # Layout left2right
    if (layout == "left2right") {
        for (i in seq_len(nrow(nodes))) {
            nodes$shape[i] <- "rect"
            nodes$height[i] <- list(grid::unit(max(nodes$left_accumulator[i],
                                              nodes$right_accumulator[i]),
                                              "native"))
            nodes$width[i] <- nodes$size[i] / as.numeric(nodes$height[[i]])
        }
        # Adjust nodes width
        max_width_per_x <- aggregate(width ~ x, data = nodes, FUN = max)
        total_width <- sum(max_width_per_x$width)
        max_allowed_width <- diff(xlim) * 0.5
        adj_factor <- max_allowed_width / total_width
        nodes$width <- lapply(nodes$width * adj_factor * node_f,
                              function(x) grid::unit(x, "native") )
    } else if (layout %in% c("stress", "kk", "lgl", "fr", "dh", "mds")) {
        # Layout stress or kk or ...
        min_width <- grid::convertWidth(grid::unit(1, "strwidth", "x"), unitTo = "native",
                                        valueOnly = TRUE)
        min_height <- abs(grid::convertHeight(grid::unit(1, "strheight", "x"), unitTo = "native",
                                              valueOnly = TRUE))
        for (i in seq_len(nrow(nodes))) {
            node_sockets <- sockets[sockets$node_id == nodes$comp[i], ]
            side_sockets <- lapply(c("top", "left", "right", "bottom"), function(s) {
                z <- node_sockets[node_sockets$node_side == s, ]
                if (nrow(z) == 0) return(0)
                return(sum(z$width))
            })
            names(side_sockets) <- c("top", "left", "right", "bottom")
            nodes$shape[i] <- "rect"
            nodes$width[i] <- list(grid::unit(max(min_width, side_sockets[["top"]],
                                                  side_sockets[["bottom"]]),
                                              units = "native"))
            nodes$height[i] <- list(grid::unit(max(min_height, side_sockets[["left"]],
                                                   side_sockets[["right"]]),
                                               units = "native"))
        }
        if (node_s == "constant") {
            max_width <- do.call(max, nodes$width)
            max_height <- do.call(max, nodes$height)
            nodes$width <- rep(list(max_width), nrow(nodes))
            nodes$height <- rep(list(max_height), nrow(nodes))
        }
        if (node_s == "square" | node_s == "roundsquare") {
            ext_factor <- ifelse(node_s == "roundsquare", 1.10, 1.05)
            max_width <- do.call(max, nodes$width)
            max_height <- do.call(max, nodes$height)
            side_dim <- max(max_width, max_height) * ext_factor
            nodes$width <- rep(list(side_dim), nrow(nodes))
            nodes$height <- rep(list(side_dim), nrow(nodes))
        }
        if (node_s == "prop") {
            nodes$min_area <- as.numeric(nodes$width) * as.numeric(nodes$height)
            nodes$dim_adj <- nodes$size / nodes$min_area
            nodes$dim_adj <- nodes$dim_adj / min(nodes$dim_adj)
            for (i in seq_len(nrow(nodes))) {
                a <- max(as.numeric(nodes$width[[i]]), as.numeric(nodes$height[[i]]))
                b <- min(as.numeric(nodes$width[[i]]), as.numeric(nodes$height[[i]]))
                adj <- nodes$dim_adj[i]
                if (adj <= a/b) {
                    beta <- adj
                    alpha <- 1
                } else {
                    beta <- sqrt(adj * a/b)
                    alpha <- sqrt(adj * b/a)
                }
                if (as.numeric(nodes$width[[i]]) >= as.numeric(nodes$height[[i]])) {
                    nodes$width[[i]] <- grid::unit(alpha * as.numeric(nodes$width[[i]]), "native")
                    nodes$height[[i]] <- grid::unit(beta * as.numeric(nodes$height[[i]]), "native")
                } else {
                    nodes$width[[i]] <- grid::unit(beta * as.numeric(nodes$width[[i]]), "native")
                    nodes$height[[i]] <- grid::unit(alpha * as.numeric(nodes$height[[i]]), "native")
                }
            }
        }
    } else {
        # Default node shape
        width <- list(grid::unit(1, "strwidth", "toto"))
        height <- list(grid::unit(1, "strheight", "toto"))
        for (i in seq_len(nrow(nodes))) {
            nodes$shape[i] <- "rect"
            nodes$width[i] <- width
            nodes$height[i] <- height
        }
    }
    # Return
    out <- scene
    out$nodes <- nodes
    return(out)
}

### * (4) sankey_adjust_node_locations()

#' Adjust node location
#' 
#' @param scene Scene list.
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' 
#' @examples
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' sankey_place_edge_sockets_on_nodes <- isotracer:::sankey_place_edge_sockets_on_nodes
#' sankey_calc_node_shape <- isotracer:::sankey_calc_node_shape
#' sankey_adjust_node_locations <- isotracer:::sankey_adjust_node_locations
#' 
#' topo <- topo(trini_mod)
#' flows <- flows_from_topo(topo)
#' flows$width <- 1
#' layout <- "left2right"
#' scene <- sankey_place_nodes(topo, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, topo, flows = flows, layout = layout)
#' scene <- sankey_calc_node_shape(scene, topo, flows = flows, layout = layout)
#' z <- sankey_adjust_node_locations(scene, topo, flows = flows, layout = layout)
#' 
#' @keywords internal
#' @noRd

sankey_adjust_node_locations <- function(scene, topo, nodes = NULL, flows, layout) {
    # Layout left2right
    if (layout == "left2right") {
        nodes <- scene$nodes
        nodes <- nodes[order(nodes$x, nodes$y), ]
        ylim <- range(nodes$y)
        x_locs <- sort(unique(nodes$x))
        # Fix collision
        for (xi in x_locs) {
            ni <- nodes[nodes$x == xi, ]
            previous_mean_y <- mean(ni$y)
            total_height <- sum(as.numeric(unlist(ni$height)))
            available_height <- diff(ylim) - total_height
            min_spacer <- min(0.08, 0.1 * total_height, available_height / (nrow(ni) + 1))
            if (nrow(ni) > 1) {
                for (i in 2:nrow(ni)) {
                    top_a <- ni$y[i-1] + as.numeric(ni$height[i-1]) / 2
                    bottom_b <- ni$y[i] - as.numeric(ni$height[i]) / 2
                    if (bottom_b - top_a < min_spacer) {
                        # Collision or too close, shift all remaining nodes upwards
                        shift <- top_a - bottom_b + min_spacer
                        ni$y[i] <- ni$y[i] + shift
                    }
                }
            }
            new_mean_y <- mean(nodes$y)
            ni$y <- ni$y - new_mean_y + previous_mean_y
            nodes[nodes$x == xi, ] <- ni
        }
        # Quick minimization
        for (xi in x_locs) {
            comps <- nodes$comp[nodes$x == xi]
            sources <- colnames(topo)[apply(topo[comps,, drop = FALSE], 2, sum) > 0]
            if (length(sources) > 0) {
                mean_y_self <- mean(nodes$y[nodes$x == xi])
                mean_y_sources <- mean(nodes$y[nodes$comp %in% sources])
                nodes$y[nodes$x == xi] <- nodes$y[nodes$x == xi] - mean_y_self + mean_y_sources
            }
        }
        # Adjust node location so that none is outside the canvas
        for (xi in x_locs) {
            ni <- nodes[nodes$x == xi, ]
            if (nrow(ni) > 1) {
                previous_mean_y <- mean(ni$y)
                total_height <- sum(as.numeric(unlist(ni$height)))
                available_height <- diff(ylim) - total_height
                min_spacer <- min(0.08, 0.1 * total_height, available_height / (nrow(ni) + 1))
                lowest <- ni$y[1] - as.numeric(ni$height[1]) / 2
                if (lowest < ylim[1]) {
                    extra <- ylim[1] - lowest
                    total_spacing <- (ni$y[nrow(ni)] - as.numeric(ni$height[nrow(ni)]) / 2) - lowest
                    if (total_spacing > extra) {
                        # The extra height can be accommodated in the spacing
                        spacing_adj_factor <- 1 - extra / total_spacing
                        # Apply this factor on the nodes from top to bottom
                        for (i in (nrow(ni)-1):1) {
                            current_spacing <- (ni$y[i+1] - as.numeric(ni$height[i+1]) / 2 -
                                                ni$y[i] + as.numeric(ni$height[i]) / 2)
                            shift <- current_spacing * (1 - spacing_adj_factor)
                            for (j in i:1) {
                                ni$y[j] <- ni$y[j] + shift
                            }
                        }
                    }
                }
                highest <- ni$y[nrow(ni)] + as.numeric(ni$height[nrow(ni)]) / 2
                if (highest > ylim[2]) {
                    extra <- highest - ylim[2]
                    total_spacing <- highest - ni$y[1] - as.numeric(ni$height[1]) / 2
                    if (total_spacing > extra) {
                        # The extra height can be accommodated in the spacing
                        spacing_adj_factor <- 1 - extra / total_spacing
                        # Apply this factor on the nodes from bottom to top
                        for (i in 2:nrow(ni)) {
                            current_spacing <- (ni$y[i] - as.numeric(ni$height[i]) / 2 -
                                                ni$y[i-1] + as.numeric(ni$height[i-1]) / 2)
                            shift <- current_spacing * (1 - spacing_adj_factor)
                            for (j in i:nrow(ni)) {
                                ni$y[j] <- ni$y[j] - shift
                            }
                        }
                    }
                }
            }
            nodes[nodes$x == xi, ] <- ni
        }
        out <- scene
        out$nodes <- nodes
    } else {
        # Default is to do nothing
        out <- scene
    }
    return(out)
}

### * (5) sankey_adjust_edge_sockets()

#' Adjust edge sockets relative location on nodes
#'
#' @param scene Scene list.
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' 
#' @keywords internal
#' @noRd

sankey_adjust_edge_sockets <- function(scene, topo, nodes = NULL, flows, layout) {
    nodes <- scene$nodes
    edges <- scene$edges
    edge_sockets <- scene$edge_sockets
    # Layout left2right
    if (layout == "left2right") {
        for (i in seq_len(nrow(edge_sockets))) {
            # Slide sockets so that each node face has its group of sockets centered
            node_i <- which(nodes$comp == edge_sockets$node_id[i])
            if (edge_sockets$edge_end[i] == "from") {
                shift <- nodes$right_accumulator[node_i] / 2
            } else {
                shift <- nodes$left_accumulator[node_i] / 2
            }
            edge_sockets$rel_loc[i] <- edge_sockets$rel_loc[i] - shift
        }
        out <- scene
        out[["edge_sockets"]] <- edge_sockets
    } else if (layout %in% c("stress", "kk", "lgl", "fr", "dh", "mds")) {
        for (i in seq_len(nrow(edge_sockets))) {
            # Slide sockets so that each node face has its group of sockets centered
            node_i <- which(nodes$comp == edge_sockets$node_id[i])
            side <- edge_sockets$node_side[i]
            if (side == "left") {
                shift <- nodes$left_accumulator[node_i] / 2
            } else if (side == "top") {
                shift <- nodes$top_accumulator[node_i] / 2
            } else if (side == "right") {
                shift <- nodes$right_accumulator[node_i] / 2
            } else {
                shift <- nodes$bottom_accumulator[node_i] / 2
            }
            edge_sockets$rel_loc[i] <- edge_sockets$rel_loc[i] - shift
        }
        out <- scene
        out[["edge_sockets"]] <- edge_sockets
    } else {
        # Default is to do nothing
        out <- scene
    }
    # Return
    return(out)
}

### * (6) sankey_calc_edge_socket_coordinates()

#' Calculate absolute coordinates of edge sockets
#'
#' This function calculates the absolute (x, y) coordinates of the center of
#' each edge socket, as well as the normal vector of each socket (which is
#' actually the normal vector of the receiving node face).
#' 
#' @param scene Scene list.
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' 
#' @examples
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' sankey_place_edge_sockets_on_nodes <- isotracer:::sankey_place_edge_sockets_on_nodes
#' sankey_calc_node_shape <- isotracer:::sankey_calc_node_shape
#' sankey_adjust_edge_sockets <- isotracer:::sankey_adjust_edge_sockets
#' sankey_calc_edge_socket_coordinates <- isotracer:::sankey_calc_edge_socket_coordinates
#'
#' topo <- topo(trini_mod)
#' nodes <- nodes_from_topo(topo)
#' nodes$size <- 1
#' flows <- flows_from_topo(topo)
#' flows$width <- 1
#' layout <- "left2right"
#' scene <- sankey_place_nodes(topo, nodes = nodes, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, topo, flows = flows, layout = layout)
#' scene <- sankey_calc_node_shape(scene, topo, flows = flows, layout = layout)
#' scene <- sankey_adjust_edge_sockets(scene, topo, flows = flows, layout = layout)
#' z <- sankey_calc_edge_socket_coordinates(scene, topo, flows = flows, layout = layout)
#'
#' @keywords internal
#' @noRd

sankey_calc_edge_socket_coordinates <- function(scene, topo, nodes = NULL, flows, layout) {
    nodes <- scene$nodes
    sockets <- scene$edge_sockets
    sockets$center_x <- NA
    sockets$center_y <- NA
    sockets$normal <- rep(list(NA), nrow(sockets))
    # Process the sockets
    for (i in seq_len(nrow(sockets))) {
        side <- sockets$node_side[i]
        ni <- which(nodes$comp == sockets$node_id[i])
        nw <- as.numeric(grid::convertWidth(nodes$width[[ni]], unitTo = "native"))
        nh <- as.numeric(grid::convertHeight(nodes$height[[ni]], unitTo = "native"))
        stopifnot(side %in% c("center", "left", "right", "top", "bottom"))
        if (side == "center") {
            sockets$center_x[i] <- nodes$x[ni]
            sockets$center_y[i] <- nodes$y[ni]
            sockets$normal[[i]] <- c(0, 0)
        } else if (side %in% c("left", "right")) {
            sockets$center_x[i] <- nodes$x[ni]
            sockets$center_y[i] <- (nodes$y[ni] +
                                    sockets$rel_loc[i])
            if (side == "left") {
                sockets$normal[[i]] <- c(-1, 0)
                sockets$center_x[i] <- sockets$center_x[i] - nw / 2
            } else {
                sockets$normal[[i]] <- c(1, 0)
                sockets$center_x[i] <- sockets$center_x[i] + nw / 2
            }
        } else if (side %in% c("top", "bottom")) {
            sockets$center_x[i] <- (nodes$x[ni] +
                                    sockets$rel_loc[i])
            sockets$center_y[i] <- nodes$y[ni]
            if (side == "top") {
                sockets$normal[[i]] <- c(0, 1)
                sockets$center_y[i] <- sockets$center_y[i] + nh / 2
            } else {
                sockets$normal[[i]] <- c(0, -1)
                sockets$center_y[i] <- sockets$center_y[i] - nh / 2
            }
        }
    }
    # Return
    out <- scene
    out[["edge_sockets"]] <- sockets
    return(out)
}

### * (7) sankey_place_edge_backbones()

#' Calculate absolute coordinates of edge backbones
#' 
#' @param scene Scene list.
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' @param n Integer, number of steps used for Bézier curve interpolation.
#' 
#' @examples
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' sankey_place_edge_sockets_on_nodes <- isotracer:::sankey_place_edge_sockets_on_nodes
#' sankey_calc_node_shape <- isotracer:::sankey_calc_node_shape
#' sankey_calc_edge_socket_coordinates <- isotracer:::sankey_calc_edge_socket_coordinates
#' sankey_place_edge_backbones <- isotracer:::sankey_place_edge_backbones
#'
#' t <- topo(trini_mod)
#' nodes <- tibble::tibble(comp = colnames(t), size = 1, col = "red")
#' flows <- flows_from_topo(t)
#' flows$width <- 1
#' layout <- "left2right"
#' scene <- sankey_place_nodes(t, nodes = nodes, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, t, flows = flows, layout = layout)
#' scene <- sankey_calc_node_shape(scene, t, flows = flows, layout = layout)
#' scene <- sankey_calc_edge_socket_coordinates(scene, t, flows = flows, layout = layout)
#' z <- sankey_place_edge_backbones(scene, t, flows = flows, layout = layout)
#' 
#' @keywords internal
#' @noRd

sankey_place_edge_backbones <- function(scene, topo, nodes = NULL, flows, layout,
                                        n = 32) {
    nodes <- scene$nodes
    edges <- scene$edges
    edges$backbone <- rep(list(NA), nrow(edges))
    edges$control_points <- rep(list(NA), nrow(edges))
    edge_sockets <- scene$edge_sockets
    # Default
    for (i in seq_len(nrow(edges))) {
        edge_id <- c(from = edges$from[i], to = edges$to[i])
        sockets <- edge_sockets[sapply(edge_sockets$edge_id, function(x) identical(edge_id, x)), ]
        s_from <- as.list(sockets[sockets$edge_end == "from", ])
        s_to <- as.list(sockets[sockets$edge_end == "to", ])
        xy_start <- c(s_from$center_x, s_from$center_y)
        xy_end <- c(s_to$center_x, s_to$center_y)
        if (identical(s_from$normal[[1]], c(0, 0))) {
            v <- xy_end - xy_start
            v <- v / sqrt(sum(v^2))
            s_from$normal[[1]] <- v
        }
        if (identical(s_to$normal[[1]], c(0, 0))) {
            v <- xy_start - xy_end
            v <- v / sqrt(sum(v^2))
            s_to$normal[[1]] <- v
        }
        if (layout %in% c("left2right")) {
            len_straight <- sqrt(sum((xy_end[1] - xy_start[1])^2))
            xy_start2 <- xy_start + c(s_from$normal[[1]][1], 0) * len_straight * 0.15
            xy_end2 <- xy_end + c(s_to$normal[[1]][1], 0) * len_straight * 0.15
            xy_start3 <- xy_start + c(s_from$normal[[1]][1], 0) * len_straight * 0.3
            xy_end3 <- xy_end + c(s_to$normal[[1]][1], 0) * len_straight * 0.3
            bb <- cbind(xy_start, xy_start2, xy_start3,
                        xy_end3, xy_end2, xy_end)
        } else if (layout %in% c("stress", "kk", "lgl", "fr", "dh", "mds")) {
            len_straight <- sqrt(sum((xy_end - xy_start)^2))
            xy_start2 <- xy_start + s_from$normal[[1]] * len_straight * 0.15
            xy_end2 <- xy_end + s_to$normal[[1]] * len_straight * 0.15
            xy_start3 <- xy_start + s_from$normal[[1]] * len_straight * 0.3
            xy_end3 <- xy_end + s_to$normal[[1]] * len_straight * 0.3
            bb <- cbind(xy_start, xy_start2, xy_start3,
                        xy_end3, xy_end2, xy_end)
        } else {
            len_straight <- sqrt(sum((xy_end - xy_start)^2))
            xy_start2 <- xy_start + s_from$normal[[1]] * len_straight * 0.2
            xy_end2 <- xy_end + s_to$normal[[1]] * len_straight * 0.2
            bb <- cbind(xy_start, xy_start2, xy_end2, xy_end)
        }
        edges$control_points[[i]] <- t(bb)
        edges$backbone[[i]] <- bezierCurve(x = bb[1, ], y = bb[2, ], n = n)
    }
    # Return
    out <- scene
    out[["edges"]] <- edges
    return(out)
}

### * (8) sankey_place_labels()

#' Place node labels
#'
#' @param scene Scene list.
#' @param topo Topology.
#' @param nodes Node tibble.
#' @param flows Flows tibble.
#' @param layout Layout string.
#' @param cex_lab Expansion factor for label size.
#' 
#' @examples
#' sankey_place_nodes <- isotracer:::sankey_place_nodes
#' sankey_place_edge_sockets_on_nodes <- isotracer:::sankey_place_edge_sockets_on_nodes
#' sankey_calc_node_shape <- isotracer:::sankey_calc_node_shape
#' sankey_calc_edge_socket_coordinates <- isotracer:::sankey_calc_edge_socket_coordinates
#' sankey_place_edge_backbones <- isotracer:::sankey_place_edge_backbones
#' sankey_place_labels <- isotracer:::sankey_place_labels
#'
#' t <- topo(trini_mod)
#' nodes <- tibble::tibble(comp = colnames(t), size = 1, col = "red")
#' flows <- flows_from_topo(t)
#' flows$width <- 1
#' layout <- "left2right"
#' scene <- sankey_place_nodes(t, nodes = nodes, flows = flows, layout = layout)
#' scene <- sankey_place_edge_sockets_on_nodes(scene, t, flows = flows, layout = layout)
#' scene <- sankey_calc_node_shape(scene, t, flows = flows, layout = layout)
#' scene <- sankey_calc_edge_socket_coordinates(scene, t, flows = flows, layout = layout)
#' scene <- sankey_place_edge_backbones(scene, t, flows = flows, layout = layout)
#' z <- sankey_place_labels(scene, t, flows = flows, layout = layout)
#' 
#' @keywords internal
#' @noRd

sankey_place_labels <- function(scene, topo, nodes, flows, layout, cex_lab = 1) {
    nodes <- scene$nodes
    labels <- nodes[, c("comp", "label", "x", "y", "width", "height")]
    names(labels) <- c("comp", "label", "node_x", "node_y", "node_width", "node_height")
    # Convert node dimensions to native units
    labels$node_width <- sapply(labels$node_width, function(x) {
        grid::convertWidth(x, unitTo = "native", valueOnly = TRUE)
    })
    labels$node_height <- sapply(labels$node_height, function(x) {
        grid::convertHeight(x, unitTo = "native", valueOnly = TRUE)
    })
    # Calculate label coordinates
    labels <- tibble::add_column(labels, cex = cex_lab, label_x = NA, label_y = NA)
    for (i in seq_len(nrow(labels))) {
        node_bottom <- labels$node_y[i] - labels$node_height[i]/2
        labels$label_x[i] <- labels$node_x[i]
        labels$label_y[i] <- (node_bottom -
                              grid::convertHeight(grid::unit(0.5, "strheight", "X"),
                                                  unitTo = "native", valueOnly = TRUE) -
                              grid::convertHeight(grid::unit(cex_lab, "strheight", "X"),
                                                  unitTo = "native", valueOnly = TRUE) / 2)
    }
    # Return
    out <- scene
    out[["labels"]] <- labels
    return(out)
}

### * sankey_stress_quadrant()

#' From an absolute angle, calculate the quadrant and relative angle in this quadrant
#'
#' In the "stress" layout, each node has four quadrants defined from its (x, y)
#' centre: 1 = east (-pi/4, pi/4), 2 = north (pi/4, 3pi/4), 3 = west (3pi/4,
#' 5pi/4), and 4 = south (-3pi/4, -pi/4).
#'
#' This function takes (y, x) in the same way as \code{\link{atan2}}.
#'
#' @param y,x Same as for \code{\link{atan2}}. From atan2 help: "The arc-tangent
#'     of two arguments atan2(y, x) returns the angle between the x-axis and
#'     the vector from the origin to (x, y), i.e., for positive arguments
#'     atan2(y, x) == atan(y/x)."
#'
#' @return A vector with two elements: the quadrant and the relative
#'     anti-clockwise angle from this quadrant origin.
#'
#' @examples
#' sankey_stress_quadrant <- isotracer:::sankey_stress_quadrant
#' 
#' theta <- seq(- pi, pi, length.out = 128)
#' x <- cos(theta)
#' y <- sin(theta)
#' q <- sapply(seq_along(x), function(i) sankey_stress_quadrant(y[i], x[i]))
#' plot(theta, q[2,], col = c("blue", "green", "purple", "red")[q[1,]],
#'      pch = 19)
#' 
#' @keywords internal
#' @noRd

sankey_stress_quadrant <- function(y, x) {
    angle <- as.vector(atan2(y, x))
    stopifnot(angle <= pi & angle >= -pi)
    if (angle >= -pi/4 & angle <= pi/4) {
        # east
        q <- 1
        a <- angle + pi/4
    } else if (angle >= pi/4 & angle <= 3*pi/4) {
        # north
        q <- 2
        a <- angle - pi/4
    } else if (angle >= 3*pi/4 | angle <= -3*pi/4 ) {
        # west
        q <- 3
        if (angle >= 3*pi/4) {
            a <- angle - 3*pi/4
        } else {
            angle <- angle + 2 * pi
            a <- angle - 3*pi/4
        }
    } else {
        # south
        q <- 4
        a <- angle + 3*pi/4
    }
    return(c(q = q, a = a))
}

### * sankey_stress_socket_imbalance()

#' Calculate an imbalance score for socket distribution around a node
#'
#' @param node_sockets A tibble containing the (at most 4) rows describing the
#'     sockets related to one given node.
#'
#' @return The variance of the total socket width per node side (or NA if the
#'     input has zero row). This can be used as an imbalance score to minimize
#'     when optimizing the distribution of sockets around a node.
#'
#' @importFrom stats aggregate
#' @importFrom stats var
#' 
#' @examples
#' sankey_stress_socket_imbalance <- isotracer:::sankey_stress_socket_imbalance
#' 
#' z <- structure(list(node_id = c("arg", "arg"), node_side = c("bottom", "top"),
#'        edge_id = list(c(from = "petro", to = "arg"), c(from = "tricor", to = "arg")),
#'        edge_id_char = c("petro->arg", "tricor->arg"),
#'        recip_edge_id = c("arg->petro", "arg->tricor"), edge_end = c("to", "to"),
#'        rel_quadrant_angle = c(0.00537724841543286, 1.26282578153344), width = c(1, 1),
#'        rel_loc = c(0.5, -0.5)), row.names = c(NA, -2L),
#'        class = c("tbl_df", "tbl", "data.frame"))
#' sankey_stress_socket_imbalance(z)
#' 
#' @keywords internal
#' @noRd

sankey_stress_socket_imbalance <- function(node_sockets) {
    if (nrow(node_sockets) > 0) {
        width_per_side <- tibble::deframe(aggregate(width ~ node_side,
                                                    data = node_sockets,
                                                    FUN = sum))
        width_per_side <- c(width_per_side, rep(0, 4 - length(width_per_side)))
        imbalance <- var(width_per_side)
    } else {
        imbalance <- NA
    }
    return(imbalance)
}

### * sankey_stress_socket_moves()

#' Determine all the possible socket arrangements one move away from input
#'
#' @param node_sockets A tibble containing the (at most 4) rows describing the
#'     sockets related to one given node.
#'
#' @keywords internal
#' @noRd

sankey_stress_socket_moves <- function(node_sockets) {
    if (nrow(node_sockets) == 1) {
        return(list())
    }
    moves <- list()
    moves_i <- 1
    ref <- node_sockets
    cclock_move <- c("top" = "left", "left" = "bottom", "bottom" = "right",
                     "right" = "top")
    clock_move <- c("bottom" = "left", "left" = "top", "top" = "right",
                    "right" = "bottom")
    for (side in unique(ref$node_side)) {
        side_sockets <- ref[ref$node_side == side, ]
        side_sockets <- side_sockets[order(side_sockets$rel_quadrant_angle), ]
        if (nrow(side_sockets) > 1) {
            if (side_sockets$rel_quadrant_angle[1] <= pi/4) {
                # Clockwise move
                new_side <- clock_move[side]
                if (!any(side_sockets$node_side == new_side)) {
                    new_angle <- pi/2 - 0.01
                } else {
                    new_angle <- pi/2 - (pi/2 - max(side_sockets$rel_quadrant_angle[side_sockets$node_side == new_side])) / 2
                }
                # Update
                side_sockets$node_side[1] <- new_side
                side_sockets$rel_quadrant_angle[1] <- new_angle
                z <- ref
                z[z$node_side == side, ] <- side_sockets
                moves[[moves_i]] <- z
                moves_i <- moves_i + 1
            }
            side_sockets <- ref[ref$node_side == side, ]
            side_sockets <- side_sockets[order(side_sockets$rel_quadrant_angle), ]
            if (side_sockets$rel_quadrant_angle[nrow(side_sockets)] > pi/4) {
                # Counter-clockwise move
                new_side <- cclock_move[side]
                if (!any(side_sockets$node_side == new_side)) {
                    new_angle <- 0.01
                } else {
                    new_angle <- min(side_sockets$rel_quadrant_angle[side_sockets$node_side == new_side]) / 2
                }
                # Update
                side_sockets$node_side[nrow(side_sockets)] <- new_side
                side_sockets$rel_quadrant_angle[nrow(side_sockets)] <- new_angle
                z <- ref
                z[z$node_side == side, ] <- side_sockets
                moves[[moves_i]] <- z
                moves_i <- moves_i + 1
            }
        }
    }
    return(moves)
}

### * sankey_get_elements_lims()

#' Return the xlim and ylim to contain all the graphical elements
#'
#' @param scene Scene list.
#'
#' @return A list with "xlim" and "ylim" elements.
#'
#' @keywords internal
#' @noRd

sankey_get_elements_lims <- function(scene) {
    nodes <- scene[["nodes"]]
    nodes_min_x <- min(nodes$x - as.numeric(nodes$width)/2)
    nodes_max_x <- max(nodes$x + as.numeric(nodes$width)/2)
    nodes_min_y <- min(nodes$y - as.numeric(nodes$height)/2)
    nodes_max_y <- max(nodes$y + as.numeric(nodes$height)/2)
    edges <- scene[["edges"]]
    edges$ribbon <- lapply(seq_len(nrow(edges)), function(i) {
        ribbonFromTrajectory(edges[["backbone"]][[i]],
                             width = edges[["width"]][i])
    })
    ribbons <- do.call(rbind, edges$ribbon)
    edges_min_x <- min(ribbons[, 1])
    edges_max_x <- max(ribbons[, 1])
    edges_min_y <- min(ribbons[, 2])
    edges_max_y <- max(ribbons[, 2])
    xlim <- c(min(nodes_min_x, edges_min_x),
              max(nodes_max_x, edges_max_x))
    ylim <- c(min(nodes_min_y, edges_min_y),
              max(nodes_max_y, edges_max_y))
    return(list(xlim = xlim, ylim = ylim))
}

### * None of the functions in this file is exported

### * describe_z_eta()

#' Print a message describing the role of eta or zeta in a distribution family
#'
#' @param param_name Name of the parameter (e.g. "eta" or "zeta").
#' @param family Family string.
#' @param prefix,suffix Strings appended to the message.
#'
#' @keywords internal
#' @noRd

describe_z_eta <- function(param_name, family, prefix = "  (", suffix = ")") {
    msg <- list(
        "gamma_cv" = " is the coefficient of variation of gamma distributions.",
        "normal_cv" = " is the coefficient of variation of normal distributions.",
        "normal_sd" = " is the standard deviation of normal distributions.",
        "beta_phi" = " is the precision (phi) of beta distributions.")
    if (!family %in% names(msg)) {
        stop("The provided value for the family argument is not allowed.")
    }
    message(prefix, param_name, msg[[family]], suffix, sep = "")
}

### * valid_prior_tbl()

#' Test if the input is a valid prior tibble
#'
#' @param x Some input to test.
#'
#' @return Boolean.
#'
#' @examples
#' valid_prior_tbl(priors(aquarium_mod))
#' valid_prior_tbl(mtcars)
#'
#' @keywords internal
#' @noRd

valid_prior_tbl <- function(x) {
    # Is tibble?
    if (!is(x, "tbl_df")) return(FALSE)
    # Has at least columns "in_model" and "prior"?
    if (!all(c("in_model", "prior") %in% colnames(x))) return(FALSE)
    # "in_model" is a character vector?
    if (!is(x[["in_model"]], "character")) return(FALSE)
    # "prior" is a list?
    if (!is(x[["prior"]], "list")) return(FALSE)
    # Are all the entries in the "prior" column NULL or priors?
    non_null <- x[["prior"]][!is.null(x[["prior"]])]
    if (!all(sapply(non_null, is, "prior"))) return(FALSE)
    # End of tests
    return(TRUE)
}

### * All functions in this file are exported

### * new_networkModel()

#' Create an empty network model
#'
#' The first step in building a network model is to create a new, empty
#' \code{networkModel} object. This model can then be completed using functions
#' such as \code{set_topo()}, \code{set_init()}, etc...
#'
#' @param quiet Boolean, if \code{FALSE} print a message indicating which
#'     distribution family is used for proportions.
#'
#' @return An empty \code{networkModel} object. It is basically a zero-row
#'     tibble with the appropriate columns.
#' 
#' @examples
#' m <- new_networkModel()
#' m
#' class(m)
#'
#' @export

new_networkModel <- function(quiet = FALSE) {
    verbose <- !quiet
    x <- tibble::tibble(topology = list(),
                        initial = list(),
                        observations = list())
    attr(x, "prop_family") <- "gamma_cv"
    if (verbose) {
        message("Using default distribution family for proportions (\"gamma_cv\").")
        describe_z_eta("eta", attr(x, "prop_family"))
    }
    attr(x, "size_family") <- "normal_cv"
    if (verbose) {
        message("Using default distribution family for sizes (\"normal_cv\").")
        describe_z_eta("zeta", attr(x, "size_family"))
    }
    attr(x, "size_zeta_per_compartment") <- FALSE
    x <- structure(x, class = c("networkModel", class(x)))
    return(x)
}

### * set_prop_family()

#' Set the distribution family for observed proportions
#'
#' @param nm A \code{networkModel} object (output from
#'     \code{\link{new_networkModel}}).
#' @param family Allowed values are "gamma_cv", "beta_phi", "normal_cv", and
#'     "normal_sd".
#' @param quiet Boolean, if \code{FALSE} print a message indicating which
#'     distribution family is used for proportions.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' library(magrittr)
#' 
#' m <- new_networkModel() %>%
#'   set_topo(links = "NH4, NO3 -> epi -> pseph, tricor")
#' m <- m %>% set_prop_family("beta_phi")
#' m
#' attr(m, "prop_family")
#'
#' @export

set_prop_family <- function(nm, family, quiet = FALSE) {
    verbose <- !quiet
    known_families <- c("gamma_cv" = 1, "normal_cv" = 2, "normal_sd" = 3,
                        "beta_phi" = 4)
    if (!family %in% names(known_families)) {
        stop("Unknown distribution family for proportions. Got value: \"",
             family, "\"\n",
             "Allowed values are: ", paste0(sapply(names(known_families), function(x) paste0("\"", x, "\"")),
                                            collapse = ", "))
    }
    attr(nm, "prop_family") <- family
    if (verbose) {
        message("Using distribution family for proportions: \"", family, "\".",
                sep = "")
        describe_z_eta("eta", family)
    }
    return(nm)
}

### * set_size_family()

#' Set the distribution family for observed sizes
#'
#' @param nm A \code{networkModel} object (output from
#'     \code{\link{new_networkModel}}).
#' @param family Allowed values are "normal_cv" and "normal_sd".
#' @param by_compartment Boolean, if TRUE then zeta is compartment-specific.
#' @param quiet Boolean, if \code{FALSE} print a message indicating which
#'     distribution family is used for proportions.
#' @param quiet_reset Boolean, write a message when model parameters (and
#'     covariates and priors) are reset?
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' library(magrittr)
#' 
#' m <- new_networkModel() %>%
#'   set_topo(links = "NH4, NO3 -> epi -> pseph, tricor")
#' m <- m %>% set_size_family("normal_sd")
#' m
#' attr(m, "size_family")
#'
#' m <- m %>% set_size_family(by_compartment = TRUE)
#' attr(m, "size_zeta_per_compartment")
#' 
#' @export

set_size_family <- function(nm, family, by_compartment, quiet = FALSE,
                            quiet_reset = FALSE) {
    verbose <- !quiet
    verbose_reset <- !quiet_reset
    if (!missing(family)) {
        known_families <- c("normal_cv" = 1, "normal_sd" = 2)
        if (!family %in% names(known_families)) {
            stop("Unknown distribution family for proportions. Got value: \"",
                 family, "\"\n",
                 "Allowed values are: ", paste0(sapply(names(known_families), function(x) paste0("\"", x, "\"")),
                                                collapse = ", "))
        }
        attr(nm, "size_family") <- family
        if (verbose) {
            message("Using distribution family for sizes: \"", family, "\".",
                    sep = "")
            describe_z_eta("zeta", family)
        }
    }
    if (!missing(by_compartment)) {
        stopifnot(by_compartment %in% c(FALSE, TRUE))
        attr(nm, "size_zeta_per_compartment") <- by_compartment
        if(verbose) {
            message("Compartment-specific zeta set to ", by_compartment, ".",
                    sep = "")
        }
        if (!is.null(nm[["parameters"]])) {
            # nm already had parameters
            # Reset to update the zeta parameters
            nm <- add_param_mapping(nm)
            if (verbose_reset) {
                message("Parameters priors and covariates were reset because `by_compartment` was specified.")
                message("(This means that no priors are set and no covariates are used in the returned networkModel.)")
            }
        }
    }
    return(nm)
}

### * set_topo()

### ** Doc

#' Set the topology in a network model.
#'
#' @param nm A \code{networkModel} object (output from
#'     \code{\link{new_networkModel}}).
#' @param ... One or more strings describing the links defining the network
#'     topology. Optionally, links can be given as a data frame. See the
#'     examples for more details about acceptable input formats.
#' @param from Optional, string containing the column name for sources if
#'     links are provided as a data frame.
#' @param to Optional, string containing the column name for destinations if
#'     links are provided as a data frame.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' # A single string can describe several links in one go.
#' m <- new_networkModel() %>%
#'   set_topo("NH4, NO3 -> epi -> pseph, tricor")
#' m
#' topo(m)
#'
#' # Several strings can be given as distinct arguments.
#' m2 <- new_networkModel() %>%
#'   set_topo("NH4, NO3 -> epi -> pseph, tricor",
#'            "NH4 -> FBOM, CBOM", "CBOM <- NO3")
#' m2
#' topo(m2)
#'
#' # Multiple strings can be also be combined into a single argument with `c()`.
#' links <- c("NH4, NO3 -> epi -> pseph, tricor", "NH4 -> FBOM, CBOM",
#'            "CBOM <- NO3")
#' m3 <- new_networkModel() %>%
#'   set_topo(links)
#' m3
#' topo(m3)
#'
#' # A data frame can be used to specify the links.
#' links <- data.frame(source = c("NH4", "NO3", "epi"),
#'                     consumer = c("epi", "epi", "petro"))
#' links
#' m4 <- new_networkModel() %>%
#'   set_topo(links, from = "source", to = "consumer")
#' m4
#' m4$topology[[1]]
#' 
#' @export

### ** Code

set_topo <- function(nm, ..., from = NULL, to = NULL) {
    # Parse the ... argument
    args <- list(...)
    if (length(args) > 1) {
        if (!all(sapply(args, is.character))) {
            stop("Only strings can be used when providing multiple link arguments.\n",
                 "(Maybe you provided both string(s) and data frame(s)?)")
        }
        links <- unlist(args)
    } else {
        links <- args[[1]]
    }
    # Build the topology object
    topology <- make_topology(links = links, from = from, to = to)
    # If the network model is empty, create a row of NULLs
    message_reset <- TRUE
    if (nrow(nm) == 0) {
        nm[1, 1] <- NA
        message_reset <- FALSE
    }
    # Assign all the cells in the "topology" column
    for (i in seq_len(nrow(nm))) {
        nm$topology[[i]] <- topology
    }
    # Add parameter mapping
    nm <- add_param_mapping(nm)
    if (message_reset) {
        msg <- c("`set_topo()` was called on a non-empty networkModel object.",
                 "As a result, the parameter mapping and the priors of the model were reset.")
        message(paste0(msg, collapse = " "))
    }
    return(nm)
}

### * set_steady()

#' Flag some network compartments as being in a steady state
#'
#' @param nm A \code{networkModel} object.
#' @param comps Vector of strings, names of the compartments to set steady.
#' @param which Vector of integers giving the nm rows to update. Default is to
#'     update all rows.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' library(magrittr)
#' x <- new_networkModel() %>%
#'    set_topo("NH4 -> algae -> daphnia") %>%
#'    set_steady("NH4")
#' topo(x)
#'
#' @export

set_steady <- function(nm, comps = NULL, which = NULL) {
    if (is.null(which)) {
        which <- seq_len(nrow(nm))
    }
    stopifnot(all(which %in% seq_len(nrow(nm))))
    # Update row by row
    for (i in which) {
        topo <- nm[["topology"]][[i]]
        steady <- attr(topo, "steadyState")
        for (comp in comps) {
            stopifnot(comp %in% colnames(topo))
            steady <- c(steady, comp)
        }
        attr(nm[["topology"]][[i]], "steadyState") <- steady
    }
    # Return
    return(nm)
}

### * set_split()

#' Flag some network compartments as being split compartments
#'
#' This function automatically adds a default prior (uniform on [0,1]) for the
#' active portion of split compartments.
#' 
#' @param nm A \code{networkModel} object.
#' @param comps Vector of strings, the names of the compartments to set split.
#' @param which Vector of integers giving the nm rows to update. Default is to
#'     update all rows.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' library(magrittr)
#' x <- new_networkModel() %>%
#'    set_topo("NH4 -> algae -> daphnia") %>%
#'    set_split("algae")
#' topo(x)
#'
#' @export

set_split <- function(nm, comps = NULL, which = NULL) {
    if (is.null(which)) {
        which <- seq_len(nrow(nm))
    }
    stopifnot(all(which %in% seq_len(nrow(nm))))
    # Update row by row
    for (i in which) {
        topo <- nm[["topology"]][[i]]
        split <- attr(topo, "split")
        for (comp in comps) {
            stopifnot(comp %in% colnames(topo))
            split <- c(split, comp)
        }
        attr(nm[["topology"]][[i]], "split") <- split
        # Add the corresponding parameters
        params <- nm[["parameters"]][[i]]
        for (comp in comps) {
            paramName <- paste0("portion.act_", comp)
            params <- tibble::add_row(params, in_replicate = paramName,
                                      in_model = paramName)
        }
        nm[["parameters"]][[i]] <- params
    }
    # Update priors
    for (comp in comps) {
        paramName <- paste0("portion.act_", comp)
        attr(nm, "priors") <- tibble::add_row(attr(nm, "priors"),
                                              in_model = paramName,
                                              prior = list(uniform_p(0, 1)))
    }
    return(nm)
}

### * set_half_life()

#' Set the half-life for radioactive tracers
#'
#' Indicating a non-zero value for half-life will add a decay to the marked
#' portion of the tracer element. The decay constant is calculated from the
#' half-life value as:
#'
#' lambda_decay = log(2) / half_life
#'
#' Note that for correct calculations the half-life value should be given in
#' the same time unit (e.g. hour, day) that the time unit used for
#' observations.
#' 
#' @param nm A \code{networkModel} object.
#' @param hl Half-life value, in the same time unit as the observations are (or
#'     will be) given. Setting half-life to zero is equivalent to using a
#'     stable isotope (no decay used in the model).
#' @param quiet Boolean for verbosity.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' library(magrittr)
#' x <- new_networkModel() %>%
#'     set_topo("32P -> root -> leaf") %>%
#'     set_half_life(hl = 14.268)
#' x
#'
#' @export

set_half_life <- function(nm, hl, quiet = FALSE) {
    verbose <- !quiet
    if (hl == 0) {
        if (verbose) {
            message("Half-life set to zero; the model will assume stable isotopes.")
        }
        attr(nm, "lambda_hl") <- NULL
    } else {
        lambda_hl <- log(2) / hl
        if (verbose) {
            message("Half-life set to ", hl, " time units.\n",
                    "(equivalent to a decay rate of ", signif(lambda_hl, 3), " per time unit).")
        }
        attr(nm, "lambda_hl") <- lambda_hl
    }
    return(nm)
}

### * add_pulse_event()

#' Register a pulse event on one of the compartment of a topology
#'
#' When applied to a steady-state compartment, this is equivalent to changing
#' the steady state. Negative values are allowed, so one can add a "pulse" to a
#' steady-state compartment and then later add a similar but negative "pulse"
#' to simulate a drip in a stream for example.
#'
#' @param nm A \code{networkModel} object.
#' @param time Numeric, time at which the pulse is happening.
#' @param comp One compartment name only.
#' @param unmarked Numeric, quantity of unmarked marker added.
#' @param marked Numeric, quantity of marked marker added.
#' @param which Vector of integers giving the nm rows to update. Default is to
#'     update all rows.
#' @param pulses Optionally, a tibble containing the pulse information in
#'     columns. If provided, `comp`, `time`, `unmarked` and `marked` must be
#'     strings giving the corresponding column names.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' m <- trini_mod
#' m$events <- NULL
#' pulses <- tibble::tribble(
#'    ~ stream,    ~ transect, ~ comp, ~ time, ~ qty_14N, ~ qty_15N,
#'        "UL",  "transect.1",  "NH4",     11,         0,  -0.00569,
#'        "UL",  "transect.2",  "NH4",     11,         0,  -0.00264,
#'        "UL",  "transect.3",  "NH4",     11,         0, -0.000726,
#'        "UL",  "transect.1",  "NO3",     11,         0,  -0.00851,
#'        "UL",  "transect.2",  "NO3",     11,         0,  -0.01118,
#'        "UL",  "transect.3",  "NO3",     11,         0,  -0.01244,
#'    )
#' m <- add_pulse_event(m, pulses = pulses, comp = "comp", time = "time",
#'                      unmarked = "qty_14N", marked = "qty_15N")
#' m
#'  
#' 
#' @export

add_pulse_event <- function(nm, time, comp = NULL, unmarked, marked,
                            which = NULL, pulses) {
    if (!missing(pulses)) {
        # Table syntax
        if (is.null(groups(nm))) {
            # No groups
            for (i in seq_len(nrow(pulses))) {
                args <- list(nm = nm,
                             time = pulses[[time]][i],
                             comp = pulses[[comp]][i],
                             unmarked = pulses[[unmarked]][i],
                             marked = pulses[[marked]][i])
                nm <- do.call(add_pulse_event, args)
            }
            return(nm)
        } else {
            # Groups
            grps <- groups(nm)
            gp_vars <- colnames(grps)
            if (!all(gp_vars %in% colnames(pulses))) {
                gp_vars_str <- paste0("\"", gp_vars, "\"")
                stop("The `pulses` argument must have columns specifying the group variables of the network model.\n",
                     "  (Model grouped by: ", paste(gp_vars_str, collapse = ", "), ")\n",
                     "  (Missing column(s) in `pulses` table: ", paste(gp_vars_str[!gp_vars %in% colnames(pulses)], collapse = ", "), ")\n")
            }
            pulses_labels <- apply(as.matrix(pulses[, gp_vars]), 1, paste, collapse = " ")
            for (i in seq_len(nrow(pulses))) {
                grps <- groups(nm)
                grps_labels <- apply(as.matrix(grps), 1, paste, collapse = " ")
                row_i <- which(grps_labels == pulses_labels[i])
                stopifnot(length(row_i) == 1)
                args <- list(nm = nm,
                             time = pulses[[time]][i],
                             comp = pulses[[comp]][i],
                             unmarked = pulses[[unmarked]][i],
                             marked = pulses[[marked]][i],
                             which = row_i)
                nm <- do.call(add_pulse_event, args)
            }
            return(nm)
        }
    }
    # Single pulse
    if (is.null(which)) {
        which <- seq_len(nrow(nm))
    }
    stopifnot(all(which %in% seq_len(nrow(nm))))
    # Create an empty "events" column if needed
    if (!"events" %in% colnames(nm)) {
        nm[["events"]] <- rep(list(NULL), nrow(nm))
    }
    # Update row by row
    for (i in which) {
        topo <- nm[["topology"]][[i]]
        stopifnot(comp %in% colnames(topo))
        this_event <- tibble::tibble(event = "pulse",
                         time = time,
                         compartment = comp,
                         characteristics = list(list(unmarked = unmarked,
                                                marked = marked)))
        nm[["events"]][[i]] <- dplyr::bind_rows(nm[["events"]][[i]],
                                                this_event)
        nm[["events"]][[i]] <- nm[["events"]][[i]][order(nm[["events"]][[i]][["time"]],
                                                         nm[["events"]][[i]][["compartment"]]), ]
    }
    # Return
    return(nm)
}

### * set_init()

#' Set initial conditions in a network model
#'
#' @param nm A \code{networkModel} object (e.g. output from
#'     \code{\link{new_networkModel}})
#' @param data A tibble containing the initial conditions
#' @param comp String, name of the \code{data} column with the compartment names
#' @param size String, name of the \code{data} column with the compartment sizes
#' @param prop String, name of the \code{data} column with the compartment
#'     proportions of marked tracer
#' @param group_by Optional vector of string giving the names of the columns to
#'     use for grouping the data into replicates
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' # Using the topology from the Trinidad case study
#' m <- new_networkModel() %>%
#'   set_topo("NH4, NO3 -> epi, FBOM", "epi -> petro, pseph",
#'            "FBOM -> tricor", "petro, tricor -> arg")
#'
#' # Taking initial condtions from the 'lalaja' dataset at t=0
#' inits <- lalaja[lalaja[["time.days"]] == 0, ]
#' inits
#' m <- set_init(m, inits, comp = "compartment", size = "mgN.per.m2",
#'               prop = "prop15N", group_by = "transect")
#' m
#' 
#' @export

set_init <- function(nm, data, comp, size, prop, group_by = NULL) {
    # Trim extra compartments
    topo_comps <- unique(unlist(comps(nm)))
    init_comps <- unique(data[[comp]])
    extra_comps <- init_comps[!init_comps %in% topo_comps]
    if (length(extra_comps) > 0) {
        message(paste0(strwrap("Some compartments are not present in the network topology and are removed from the initial data:"),
                       collapse = "\n"), "\n",
                "  - ", paste0(extra_comps, collapse = "\n  - "), "\n")
        data <- data[data[[comp]] %in% topo_comps, ]
    }
    # Build init
    grouped_init <- make_init(data = data, comp = comp,
                              size = size, prop = prop,
                              group_by = group_by)
    out <- merge_nm_by_group(nm = nm, tib = grouped_init,
                             destination = "initial",
                             tib_name = "initial conditions")
    attr(out, "prop_family") <- attr(nm, "prop_family")
    attr(out, "default_columns") <- list(comp = comp,
                                         size = size,
                                         prop = prop,
                                         group_by = group_by)
    # Check that each compartment gets exactly one initial condition
    for (i in seq_len(nrow(out))) {
        z <- out$initial[[i]]
        if (nrow(z) != nrow(na.omit(z))) {
            stop("Some NAs are present in the initial conditions.")
        }
        if (!all(table(z$compartment) == 1)) {
            stop("Some compartments are present twice in the initial conditions data.")
        }
        if (!all(topo_comps %in% z[["compartment"]])) {
            stop("Some compartments are present in the topology but do not have initial conditions.")
        }
    }
    return(out)
}

### * set_obs()

#' Set observations in a network model
#'
#' @param nm A \code{networkModel} object (e.g. output from
#'     \code{\link{new_networkModel}})
#' @param data A tibble containing the observations. If NULL, remove
#'     observations from the model.
#' @param comp String, name of the \code{data} column with the compartment
#'     names
#' @param size String, name of the \code{data} column with the compartment
#'     sizes
#' @param prop String, name of the \code{data} column with the compartment
#'     proportions of heavy tracer
#' @param time String, name of the \code{data} column with the sampling times
#' @param group_by Optional vector of string giving the names of the columns to
#'     use for grouping the data into replicates
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' # Using the topology from the Trinidad case study
#' m <- new_networkModel() %>%
#'   set_topo("NH4, NO3 -> epi, FBOM", "epi -> petro, pseph",
#'            "FBOM -> tricor", "petro, tricor -> arg")
#'
#' # Taking initial condtions from the 'lalaja' dataset at t=0
#' inits <- lalaja[lalaja[["time.days"]] == 0, ]
#' inits
#' m <- set_init(m, inits, comp = "compartment", size = "mgN.per.m2",
#'               prop = "prop15N", group_by = "transect")
#' m
#'
#' # Taking observations from 'lalaja'
#' m <- set_obs(m, lalaja[lalaja[["time.days"]] > 0, ], time = "time.days")
#' m
#' plot(m)
#' 
#' @export

set_obs <- function(nm, data, comp, size, prop, time, group_by) {
    if (is.null(data)) {
        nm[["observations"]] <- rep(list(NULL), nrow(nm))
        return(nm)
    }
    # Get default columns
    default_columns <- attr(nm, "default_columns")
    columns_from_attr <- c()
    if (missing(comp)) {
        comp <- default_columns[["comp"]]
        if (!is.null(comp)) {
            columns_from_attr <- c(columns_from_attr, "comp")
        }
    }
    if (missing(size)) {
        size <- default_columns[["size"]]
        if (!is.null(size)) {
            columns_from_attr <- c(columns_from_attr, "size")
        }
    }
    if (missing(prop)) {
        prop <- default_columns[["prop"]]
        if (!is.null(prop)) {
            columns_from_attr <- c(columns_from_attr, "prop")
        }
    }
    if (missing(group_by)) {
        group_by <- default_columns[["group_by"]]
        if (!is.null(group_by)) {
            columns_from_attr <- c(columns_from_attr, "group_by")
        }
    }
    if (length(columns_from_attr) > 0) {
        msg <- "Using the same columns by default as the ones used with `set_init()`:\n"
        for (i in columns_from_attr) {
            msg <- c(msg, paste0("  ", i, " = \"", default_columns[[i]], "\"\n"))
        }
        msg <- paste0(msg, collapse = "")
        message(msg)
    }
    # Trim extra compartments
    topo_comps <- unique(unlist(comps(nm)))
    obs_comps <- unique(data[[comp]])
    extra_comps <- obs_comps[!obs_comps %in% topo_comps]
    if (length(extra_comps) > 0) {
        message(paste0(strwrap("Some compartments are not present in the network topology and are removed from the observed data:"),
                       collapse = "\n"), "\n",
                "  - ", paste0(extra_comps, collapse = "\n  - "), "\n")
        data <- data[data[[comp]] %in% topo_comps, ]
    }
    # Build observations
    grouped_obs <- make_obs(data = data, comp = comp, size = size, prop = prop,
                            time = time, group_by = group_by)
    out <- merge_nm_by_group(nm = nm, tib = grouped_obs,
                             destination = "observations",
                             tib_name = "observations")
    default_columns[["time"]] <- time
    attr(out, "default_columns") <- default_columns
    attr(out, "prop_family") <- attr(nm, "prop_family")
    return(out)
}

### * set_params()

#' Set the parameters in a network model
#'
#' @param nm A \code{networkModel} object.
#' @param params A named vector or a tibble with columns c("parameter",
#'     "value") containing the (global) parameter values.
#' @param force Boolean, if FALSE will not overwrite already set parameters.
#' @param quick Boolean, if TRUE take some shortcuts for faster parameter
#'     settings when called by another function. This should usually be left to
#'     the default (FALSE) by a regular package user.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' m <- aquarium_mod
#' p <- sample_params(m)
#' m2 <- set_params(m, p)
#' m2$parameters
#' 
#' @export

set_params <- function(nm, params, force = TRUE, quick = FALSE) {
    if (is.vector(params)) {
        params <- data.frame(value = params, parameter = names(params),
                             stringsAsFactors = FALSE)
    }
    prev_params <- attr(nm, "parameterValues")
    if (!is.null(prev_params) & !force) {
        kept_indices <- !(prev_params$parameter %in% params$parameter)
        kept_params <- prev_params[kept_indices, ]
        new_params <- dplyr::bind_rows(kept_params, params)
    } else {
        new_params <- params
    }
    if (!quick) {
        new_params <- new_params[order(new_params[["parameter"]]), ]
        attr(nm, "parameterValues") <- tibble::as_tibble(new_params)
    } else {
        attr(nm, "parameterValues") <- new_params
    }
    for (i in seq_len(nrow(nm))) {
        nm[["parameters"]][[i]]$value <- new_params[["value"]][match(nm[["parameters"]][[i]]$in_model,
                                                                     new_params[["parameter"]])]
    }
    return(nm)
}

### * set_prior() | set_priors()

#' Set prior(s) for a network model
#'
#' @param x A \code{networkModel} object.
#' @param prior A prior built with e.g. uniform_p() or hcauchy_p(). Call
#'     \code{available_priors()} to see a table of implemented
#'     priors. Alternatively, if \code{prior} is a tibble, the function will
#'     try to use it to set parameter priors. The format of such an argument is
#'     the same as the format of the output of the getter function
#'     \code{priors()} (see examples). Note that if `prior` is given as a
#'     tibble, all other arguments (except `x`) are disregarded.
#' @param param String, target parameter or regexp to target several
#'     parameters. Default is the empty string \code{""}, which will match all
#'     parameters.
#' @param use_regexp Boolean, if \code{TRUE} (the default) then \code{param} is
#'     used as a regular expression to match one or several parameter names.
#' @param quiet Boolean, if \code{FALSE} print a message indicating which
#'     parameters had their prior modified.
#'
#' @return A \code{networkModel} object.
#'
#' @examples
#' # Copy `aquarium_mod`
#' m <- aquarium_mod
#' priors(m)
#'
#' # Modify the priors of `m`
#' m <- set_priors(m, exponential_p(0.5), "lambda")
#' priors(m)
#'
#' # Re-apply priors from the original `aquarium_mod`
#' prev_priors <- priors(aquarium_mod)
#' prev_priors
#' m <- set_priors(m, prev_priors)
#' priors(m)
#' 
#' @export

set_prior <- function(x, prior, param = "", use_regexp = TRUE, quiet = FALSE) {
    verbose <- !quiet
    params <- params(x, simplify = TRUE)
    priors <- priors(x)
    stopifnot(setequal(params, priors[["in_model"]]))
    params <- priors[["in_model"]]
    # If `prior` is a tibble
    if (is(prior, "tbl_df")) {
        if (!valid_prior_tbl(prior)) {
            stop("`prior` is not a valid prior tibble.")
        }
        prior <- prior[, c("in_model", "prior")]
        extra_params <- which(!prior[["in_model"]] %in% params)
        if (length(extra_params) > 0) {
            message("Some parameter names in `prior` are not used in the network model and will be ignored.\n",
                    paste0(paste0("\"", prior[["in_model"]][extra_params], "\""), collapse = ", "))
        }
        prior <- prior[which(prior[["in_model"]] %in% params), ]
        param_indices <- match(prior[["in_model"]], params)
        for (i in seq_along(param_indices)) {
            priors[["prior"]][[param_indices[i]]] <- prior[["prior"]][[i]]
        }
        if (verbose) {
            message("Prior modified for parameter(s): \n  - ",
                    paste0(prior[["in_model"]], collapse = "\n  - "))
        }
        attr(x, "priors") <- priors
        return(x)
    }
    # If `prior` is not a tibble
    if (!is(prior, "prior")) {
        stop("`prior` must be a valid prior. See `available_priors()`.")
    }
    if (use_regexp) {
        param_indices <- which(grepl(pattern = param, x = params))
    } else {
        param_indices <- which(params == param)
    }
    if (length(param_indices) == 0) {
        stop("No matching parameter found for: ", param, ".\n",
             "Available parameters are: \n- ",
             paste0(params, collapse = "\n- "))
    }
    for (i in param_indices) {
        priors[["prior"]][[i]] <- prior
    }
    if (verbose) {
        message("Prior modified for parameter(s): \n  - ",
                paste0(params[param_indices], collapse = "\n  - "))
    }
    attr(x, "priors") <- priors
    return(x)
}

#' @rdname set_prior
#' @export

set_priors <- set_prior
    
### * add_covariates()

#' Add fixed effects of one or several covariates to some parameters.
#'
#' Note that new global parameters are not given any default prior.
#'
#' @param nm A \code{networkModel} object.
#' @param ... One or several formulas defining the covariates.
#' @param use_regexpr Boolean, use regular expression to match the parameters
#'     affected by the formulas?
#' 
#' @return A \code{networkModel} object.
#'
#' @examples
#' # Using a subset of the topology from the Trinidad case study
#' m <- new_networkModel() %>%
#'   set_topo("NH4, NO3 -> epi, FBOM", "epi -> petro, pseph")
#'
#' # Taking initial condtions from the 'lalaja' dataset at t=0
#' # Grouping by transect id
#' inits <- lalaja[lalaja[["time.days"]] == 0, ]
#' inits
#' m <- set_init(m, inits, comp = "compartment", size = "mgN.per.m2",
#'               prop = "prop15N", group_by = "transect")
#' m
#'
#' # Default model
#' params(m, simplify = TRUE)
#'
#' # Adding an effect of the "transect" covariate on some parameters
#' m <- add_covariates(m, upsilon_epi_to_pseph ~ transect)
#' params(m, simplify = TRUE)
#'
#' @export

add_covariates <- function(nm, ..., use_regexpr = TRUE) {
    formula <- list(...)
    # Apply formula
    for (eachFormula in formula) {
        nm <- refresh_param_mapping(nm, eachFormula, use_regexpr = use_regexpr)
    }
    # Refresh priors
    current_priors <- priors(nm)
    global_params <- params(nm, simplify = TRUE)
    default_priors <- tibble::tibble(in_model = global_params)
    default_priors$prior <- rep(list(NULL), nrow(default_priors))
    kept_priors <- current_priors[current_priors$in_model %in% global_params, ]
    new_priors <- default_priors[!default_priors$in_model %in%
                                 current_priors$in_model, ]
    priors <- dplyr::bind_rows(kept_priors, new_priors)
    priors <- priors[order(priors$in_model), ]
    # Return
    attr(nm, "priors") <- priors
    return(nm)
}

### * print.networkModel()

#' Print method for \code{networkModel} objects
#'
#' @param x A \code{networkModel} object.
#' @param ... Passsed to the next method.
#'
#' @return Called for the side effect of printing a network model object.
#' 
#' @method print networkModel
#'
#' @export
#' 

print.networkModel <- function(x, ...) {
    NextMethod()
    lambda_hl <- attr(x, "lambda_hl")
    if (!is.null(lambda_hl)) {
        hl <- signif(log(2) / lambda_hl, 5)
        cat("# Half-life of marked tracer:", hl, "time units.\n")
    }
}

### * TODO

# Clean-up this file

### * None of the functions in this file is exported

### * plot_nm()

#' Plot a network model object
#'
#' Reminder: A network model object is basically a tibble. Each row is one
#' experimental replicate (also called "group"). The tibble might have the
#' columns "observations", "prediction" and "trajectory". Those columns contain
#' the data that can be plotted.
#'
#' @param x A network model object. Alternatively, it can also be the output
#'     from \code{split_to_unit_plot()} that the user has filtered themselves.
#' @param facet_row,facet_column Optional, either can be "group" or
#'     "compartment". Define how facetting is performed.
#' @param scale Define how y-scaling is performed within each panel (or
#'     cell). Can be one of "auto" (scaling on a per-panel basis), "all"
#'     (scaling shared by all panels) and "row" (scaling per row). Note that
#'     the x-scaling is always done for "all" (i.e. shared across all panels).
#' @param type Either "prop", "size" or "both"
#' @param newpage If FALSE, add the plot to the current page.
#' @param xlab,ylab Labels for x and y axes.
#' @param margins Figure margins.
#' @param grid Boolean, draw a grid?
#' @param ylab.size Y-axis label for size data.
#' @param ylab.prop Y-axis label for proportion data.
#' @param legend Boolean, draw legend?
#' @param log Boolean, apply log transform to y axis?
#' @param .colComps Colors for compartments.
#' @param comps Optional, vector of compartment names giving the order in which
#'     they should be shown in the plot.
#' @param keep Optional, vector of names of compartments to keep.
#' @param drop Optional, vector of names of compartments to drop.
#'
#' @importFrom grDevices dev.hold
#' @importFrom grDevices dev.flush
#' 
#' @return NULL
#'
#' @keywords internal
#' @noRd

plot_nm <- function(x, facet_row = NULL, facet_column = NULL, scale = "auto",
                    type = "both", newpage = TRUE, xlab = NULL, ylab = NULL,
                    margins = c(0.5, 0.5, 1, 1), grid = TRUE,
                    ylab.size = NULL, ylab.prop = NULL, legend = TRUE,
                    log = FALSE, .colComps = NULL, comps, keep, drop) {
    if (!"group" %in% colnames(x)) {
        x[["group"]] <- rep(list(NULL), nrow(x))
    }
    # Default geometries for each type of data to plot
    geometries <- c("observations" = "points",
                    "initial" = "points",
                    "prediction" = "envelope",
                    "trajectory" = "line")
    colors <- c("#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", "#A6D854", "#FFD92F", 
                "#E5C494", "#B3B3B3")
    # Colors are taken from RColorBrewer::brewer.pal(8, "Set2")
    facet_variables <- c("group", "compartment", "type")
    nature <- type
    if (nature == "both") nature <- c("size", "prop")
    if (length(facet_row) == 0) facet_row <- NULL
    if (length(facet_column) == 0) facet_column <- NULL
    stopifnot(is.null(facet_row) | all(facet_row %in% facet_variables))
    stopifnot(is.null(facet_column) | all(facet_column %in% facet_variables))
    stopifnot(all(nature %in% c("prop", "size", "both")))
    # Prepare the data
    if (!"ready_for_unit_plot" %in% class(x)) {
        if (log) {
            transform <- log10
        } else {
            transform <- NULL
        }
        z <- split_to_unit_plot(x, transform)
    } else {
        z <- x
    }
    # Determine what to draw
    if (!missing(comps)) {
        z <- z[z[["compartment"]] %in% comps, ]
    }
    if (!missing(keep)) {
        z <- z[z[["compartment"]] %in% keep, ]
    }
    if (!missing(drop)) {
        z <- z[!z[["compartment"]] %in% drop, ]
    }
    if ("observations" %in% colnames(x) && !is.null(x$observations[[1]])) {
        draw_obs <- TRUE
    } else {
        draw_obs <- FALSE
    }
    if ("prediction" %in% colnames(x) && !is.null(x$prediction[[1]])) {
        draw_pred <- TRUE
    } else {
        draw_pred <- FALSE
    }
    # Process the data
    if (!draw_pred) {
        z <- dplyr::filter(z, type != "prediction")
    }
    if (!draw_obs) {
        z <- dplyr::filter(z, type != "observations")
    }
    if (nrow(z) == 0) {
        stop("Nothing to plot")
    }
    z <- z[z$nature %in% nature, ]
    z$geometry <- geometries[z$type]
    z$groupLabel <- purrr::map_chr(z$group, function(x) {
        paste0(x, collapse = ", ")
    })
    groupLabels <- sort(unique(z$groupLabel))
    compLabels <- sort(unique(z$compartment))
    if (!missing(comps)) {
        compLabels <- compLabels[order(match(compLabels, comps))]
    }
    colComps <- rep(colors, length(compLabels))
    colComps <- colComps[1:length(compLabels)]
    colComps <- setNames(colComps, nm = compLabels)
    if (!is.null(.colComps)) {
        .colComps <- sort(.colComps)
        .colComps <- .colComps[names(sort(colComps))]
        stopifnot(all(.colComps == sort(colComps)))
    }
    if (newpage) grid::grid.newpage()
    dev.hold()
    on.exit(dev.flush())
    if (legend) {
        labels <- c("compartment", names(x))
        longest <- labels[which.max(nchar(labels))]
        longest <- paste0(longest, "aaaaaaaa", collapse = " ")
        lo <- grid::grid.layout(ncol = 2,
                                widths = grid::unit(c(1, 1), c("null", "strwidth"), list(NULL, longest)))
        vp_top_with_legend <- grid::viewport(layout = lo)
        grid::pushViewport(vp_top_with_legend)
        vp_legend <- grid::viewport(layout.pos.col = 2)
        grid::pushViewport(vp_legend)
        draw_legend(colComps)
        grid::upViewport(1)
        vp_plot <- grid::viewport(layout.pos.col = 1)
        grid::pushViewport(vp_plot)
    }
    # Plot both size and proportion
    if (type == "both") {
        # Plot size and prop
        # Facetting for type
        facet_type <- "column"
        if ("type" %in% facet_row) {
            facet_row <- facet_row[facet_row != "type"]
            facet_type <- "row"
        }
        if ("type" %in% facet_column) {
            facet_column <- facet_column[facet_column != "type"]
            facet_type <- "column"
        }
        # Top vp
        if (facet_type == "column") {
            top_vp <- grid::viewport(layout = grid::grid.layout(ncol = 2))
        } else {
            top_vp <- grid::viewport(layout = grid::grid.layout(nrow = 2))
        }
        grid::pushViewport(top_vp)
        if (facet_type == "column") {
            size_vp <- grid::viewport(layout.pos.col = 1)
        } else {
            size_vp <- grid::viewport(layout.pos.row = 1)
        }
        grid::pushViewport(size_vp)
        plot_nm(x = x, facet_row = facet_row, facet_column = facet_column,
                scale = scale, type = "size", newpage = FALSE,
                xlab = xlab, ylab = ylab.size, margins = margins, grid = grid,
                .colComps = colComps, legend = FALSE, log = log,
                comps = comps, keep = keep, drop = drop)
        grid::upViewport(1)
        if (facet_type == "column") {
            prop_vp <- grid::viewport(layout.pos.col = 2)
        } else {
            prop_vp <- grid::viewport(layout.pos.row = 2)
        }
        grid::pushViewport(prop_vp)
        plot_nm(x = x, facet_row = facet_row, facet_column = facet_column,
                scale = scale, type = "prop", newpage = FALSE,
                xlab = xlab, ylab = ylab.prop, margins = margins, grid = grid,
                .colComps = colComps, legend = FALSE, log = log,
                comps = comps, keep = keep, drop = drop)
        grid::upViewport(1)
        grid::upViewport(1)
        if (legend) {
            grid::upViewport(2)
        }
        return(invisible(NULL))
    }
    stopifnot(scale %in% c("auto", "all", "row"))
    if (is.null(xlab)) xlab <- "Time"
    if (is.null(ylab)) {
        ylab <- ifelse(nature == "size", "Size", "Proportion")
    }
    # Facetting
    if (is.null(facet_row)) {
        z$row_id <- 1
    } else {
        if (facet_row == "group") { z$row_id <- match(z$groupLabel, groupLabels) }
        if (facet_row == "compartment") { z$row_id <- match(z$compartment, compLabels) }
    }
    if (is.null(facet_column)) {
        z$col_id <- 1
    } else {
        if (facet_column == "group") { z$col_id <- match(z$groupLabel, groupLabels) }
        if (facet_column == "compartment") { z$col_id <- match(z$compartment, compLabels) }
    }
    # Functions to get the scales
    xscaling <- function(z) {
        x <- unlist(lapply(z$data, function(x) x[["time"]]))
        return(extendrange(range(x, na.rm = TRUE)))
    }
    yscaling <- function(z) {
        x <- unlist(lapply(z$data, function(x) {
            d <- colnames(x)[startsWith(colnames(x), "quantity")]
            unlist(x[, d])
        }))
        range_x <- range(x, na.rm = TRUE)
        if (range_x[1] == range_x[2]) {
            delta <- 0.01 * range_x[1]
            range_x <- range_x + c(-delta, delta)
        }
        return(extendrange(range_x))
    }
    xscale <- xscaling(z)
    yscale_all <- yscaling(z)
    # Plot layout
    grid::pushViewport(grid::viewport(x = grid::unit(margins[2], "lines"),
                                      y = grid::unit(margins[1], "lines"),
                                      width = grid::unit(1, "npc") - grid::unit(sum(margins[c(2, 4)]), "lines"),
                                      height = grid::unit(1, "npc") - grid::unit(sum(margins[c(1, 3)]), "lines"),
                                      just =c("left", "bottom")))
    # Top container
    vp_top <- grid::viewport(layout = grid::grid.layout(nrow = 2, ncol = 2,
                                                           width = grid::unit(c(1.3, 1), c("lines", "null")),
                                                           height = grid::unit(c(1, 1.3), c("null", "lines"))))
    grid::pushViewport(vp_top)
    vp_xlab <- grid::viewport(layout.pos.row = 2, layout.pos.col = 2)
    grid::pushViewport(vp_xlab)
    grid::grid.text(xlab, gp = grid::gpar(cex = 1))
    grid::upViewport(1)
    vp_ylab <- grid::viewport(layout.pos.row = 1, layout.pos.col = 1)
    grid::pushViewport(vp_ylab)
    grid::grid.text(ylab, gp = grid::gpar(cex = 1), rot = 90)
    grid::upViewport(1)
    ## Widths
    if (scale %in% c("all", "row")) {
        # One y-axis per row
        widths <- rep((grid::unit(1, "npc") - grid::unit(3, "lines"))*(1/max(z$col_id)), max(z$col_id))
        widths[1] <- widths[1] + grid::unit(3, "lines")
    } else {
        # One y-axis per panel
        widths <- rep(grid::unit(1, "npc")*(1/max(z$col_id)), max(z$col_id))
    }
    ## Heights
    heights <- rep((grid::unit(1, "npc") - grid::unit(3, "lines"))*(1/max(z$row_id)), max(z$row_id))
    heights[length(heights)] <- heights[length(heights)] + grid::unit(3, "lines")
    layout <- grid::grid.layout(nrow = max(z$row_id), ncol = max(z$col_id),
                                width = widths, height = heights)
    vp_master <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2,
                                layout = layout)
    grid::pushViewport(vp_master)
    # Draw each panel
    for (i in 1:max(z$row_id)) {
        z_row <- z[z$row_id == i, ]
        yscale_row <- yscaling(z_row)
        for (j in 1:max(z$col_id)) {
            z_ij <- z[z$row_id == i & z$col_id == j, ]
            margins <- rep(0, 4)
            if (i == max(z$row_id)) margins[1] <- 3
            if (j == 1 | scale == "auto") margins[2] <- 3
            layout <- grid::grid.layout(nrow = 3, ncol = 2,
                                        widths = grid::unit(c(margins[2], 1),
                                                       units = c("lines", "null")),
                                        heights = grid::unit(c(1.5, 1, margins[1]),
                                                       units = c("lines", "null", "lines")))
            vp_panel <- grid::viewport(layout.pos.row = i,
                                       layout.pos.col = j,
                                       layout = layout)
            grid::pushViewport(vp_panel)
            # Title
            vp_title <- grid::viewport(layout.pos.row = 1,
                                       layout.pos.col = 2)
            grid::pushViewport(vp_title)
            grid::grid.rect(gp = grid::gpar(fill = grey(0.95)))
            label <- sapply(seq_len(nrow(z_ij)), function(i) {
                if (z_ij$groupLabel[i] != "") {
                    paste(z_ij$groupLabel[i])
                } else {
                    z_ij$compartment[i]
                }
            })
            label <- paste(unique(label), collapse = " + ")
            grid::grid.text(label)
            grid::upViewport(1)
            # Plot
            vp_plot <- grid::viewport(layout.pos.row = 2,
                                       layout.pos.col = 2)
            grid::pushViewport(vp_plot)
            yscale <- yscaling(z_ij)
            if (scale == "all") yscale <- yscale_all
            if (scale == "row") yscale <- yscale_row
            draw_nm_panel(z_ij, colors = colComps[z_ij$compartment],
                          xscale = xscale, yscale = yscale,
                          x.axis = i == max(z$row_id),
                          y.axis = j == 1 | scale == "auto",
                          grid = grid, log = log)
            grid::grid.rect(gp = grid::gpar(fill = NA))
            grid::upViewport(1)
            # Out vp_panel
            grid::upViewport(1)
        }
    }
    # Up viewports
    grid::upViewport(1)
    grid::upViewport(1)
    grid::upViewport(1)
    if (legend) {
        grid::upViewport(2)
    }
    # Return
    return(invisible(NULL))
}

### * split_to_unit_plot()

#' Separate network model object into plot chunks
#' 
#' Function to split enriched network model object (i.e. network model that can
#' have a trajectory or a prediction columns) into unit plot data.
#'
#' @param x A network model object, with obs/traj/prediction data.
#' @param transform Optional, function to apply to all "quantities" columns
#'     (e.g. log).
#'
#' @return A tibble which can be e.g. filtered and used for plotting.
#'
#' @keywords internal
#' @noRd

split_to_unit_plot <- function(x, transform = NULL) {
    `!!` <- rlang::`!!`
    # Convert trajectory column to a light, tidy version
    if ("trajectory" %in% colnames(x)) {
        x$trajectory <- lapply(x$trajectory, function(z) {
            stopifnot(nrow(z) == 1)
            sizes <- tibble::as_tibble(as.data.frame(z$sizes))
            sizes$time <- z$timepoints[[1]]
            sizes <- tidyr::pivot_longer(sizes, cols = -"time",
                                         names_to = "compartment", values_to = "size")
            props <- tibble::as_tibble(as.data.frame(z$proportions))
            props$time <- z$timepoints[[1]]
            props <- tidyr::pivot_longer(props, cols = -"time",
                                         names_to = "compartment", values_to = "prop")
            out <- dplyr::left_join(sizes, props, by = c("time", "compartment"))
            return(out)
        })
    }
    # For now implemented for a network model with prediction column
    if (!"prediction" %in% colnames(x)) {
        x$prediction <- rep(list(NULL), nrow(x))
    }
    target_cols <- c("observations", "prediction", "trajectory")
    target_cols <- target_cols[target_cols %in% colnames(x)]
    if (length(target_cols) < 1) {
        stop("x should have at least one of \"observations\", \"prediction\", or \"trajectory\" columns.")
    }
    y <- x[, c("initial", "group", target_cols)]
    y <- tidyr::pivot_longer(y, cols = tidyselect::all_of(target_cols),
                             names_to = "type",
                             values_to = "data")
    # Drop rows with NULL data
    y <- y[!sapply(y[["data"]], is.null), ]
    # Split by compartment
    z <- y
    z[["data"]] <- lapply(z[["data"]], function(x) {
        tidyr::nest(dplyr::group_by(x, `!!`(rlang::sym("compartment"))))
    })
    z$row_id <- 1:nrow(z)
    for (i in seq_len(nrow(z))) {
        z$data[[i]]$row_id <- i
        z$data[[i]]$data <- as.list(z$data[[i]]$data)
    }
    y <- dplyr::select(z, - "data")
    # Note: in the call, I add `multiple = "all"` because of a new warning
    # in dplyr 1.1.0 (and because in this case rows in `y` can match multiple
    # rows in `dplyr::bind_rows(z$data)`).
    y <- dplyr::full_join(y, dplyr::bind_rows(z$data), by = "row_id",
                          multiple = "all")
    y <- dplyr::select(y, - "row_id")
    # Separate size and proportion data
    y$size <- as.list(rep(NA, nrow(y)))
    y$prop <- as.list(rep(NA, nrow(y)))
    for (i in seq_len(nrow(y))) {
        d <- y$data[[i]]
        ds <- dplyr::select(d, tidyselect::starts_with("size"), "time")
        n <- names(ds)
        n <- gsub("size", "quantity", n)
        names(ds) <- n
        dp <- dplyr::select(d, tidyselect::starts_with("prop"), "time")
        n <- names(dp)
        n <- gsub("proportion", "quantity", n)
        n <- gsub("prop", "quantity", n)
        names(dp) <- n
        y$size[[i]] <- na.omit(ds)
        y$prop[[i]] <- na.omit(dp)
    }
    y <- dplyr::select(y, - "data")
    z <- tidyr::pivot_longer(y, cols = c("size", "prop"),
                             names_to = "nature",
                             values_to = "data")
    z <- dplyr::select(z, "group", "compartment", "nature", "type", "data", "initial")
    # Separate initial values
    init <- dplyr::select(z, "group", "compartment", "initial")
    init$size <- rep(list(NA), nrow(init))
    init$prop <- rep(list(NA), nrow(init))
    for (i in seq_len(nrow(init))) {
        comp_i <- init$compartment[i]
        init$initial[[i]] <- init$initial[[i]][init$initial[[i]][["compartment"]] == comp_i, ]
        stopifnot(nrow(init$initial[[i]]) == 1)
        init$size[[i]] <- tibble::tibble(quantity = init$initial[[i]]$size[1],
                                         time = 0)
        init$prop[[i]] <- tibble::tibble(quantity = init$initial[[i]]$proportion[1],
                                         time = 0)
    }
    init$initial <- NULL
    init$type <- "initial"
    init <- tidyr::pivot_longer(init, cols = c("size", "prop"),
                             names_to = "nature",
                             values_to = "data")
    init <- unique(init)
    # Merge
    z$initial <- NULL
    z <- dplyr::bind_rows(z, init)
    # Apply transform
    if (!is.null(transform)) {
        for (i in seq_len(nrow(z))) {
            d <- z$data[[i]]
            cols <- colnames(d)[grepl("quantity", colnames(d))]
            for (col in cols) {
                d[[col]] <- transform(d[[col]])
            }
            z$data[[i]] <- d
        }
    }
    # Return
    return(structure(z, class = c("ready_for_unit_plot", class(z))))
}

### * draw_nm_panel()

#' Draw a panel of the data (obs/traj/pred) from a network model
#'
#' @param x Output from \code{split_to_unit_plot}.
#' @param colors Passed to \code{draw_nm_layer}.
#' @param xscale,yscale X and y scales.
#' @param x.axis,y.axis Booleans, draw the axes?
#' @param grid Boolean, draw a grid?
#' @param log Boolean, log-transform the y axis?
#' 
#' @keywords internal
#' @noRd

draw_nm_panel <- function(x, colors = "grey", xscale = NULL, yscale = NULL,
                          x.axis = FALSE, y.axis = FALSE, grid = FALSE,
                          log = FALSE) {
    # Get lims
    x_range <- range(unlist(lapply(x$data, function(i) i[["time"]])),
                     na.rm = TRUE)
    y_range <- range(unlist(lapply(x$data, function(i) {
        unlist(i[, grepl("quantity", colnames(i))])
    })), na.rm = TRUE)
    # Create viewport
    if (is.null(xscale)) xscale <- x_range
    if (is.null(yscale)) yscale <- y_range
    vp <- grid::dataViewport(xscale = xscale,
                             yscale = yscale)
    grid::pushViewport(vp)
    # Draw grid
    xat <- pretty(xscale)
    xat <- xat[xat >= xscale[1] & xat <= xscale[2]]
    yat <- pretty(yscale)
    if (log) {
        yat <- log10(prettyLog(yscale))
    }
    yat <- yat[yat >= yscale[1] & yat <= yscale[2]]
    ylabel <- yat
    if (log) {
        ylabel <- prettyLogLabels(yscale)
        ylabel <- ylabel[log10(prettyLog(yscale)) >= yscale[1] & log10(prettyLog(yscale)) <= yscale[2]]
    }
    if (grid) {
        grid.col <- grey(0.95)
        for (xi in xat) {
            grid::grid.lines(x = grid::unit(c(xi, xi), "native"),
                             y = grid::unit(yscale, "native"),
                             gp =grid::gpar(col = grid.col))
        }
        for (yi in yat) {
            grid::grid.lines(x = grid::unit(xscale, "native"),
                             y = grid::unit(c(yi, yi), "native"),
                             gp =grid::gpar(col = grid.col))
        }
    }
    # Draw layers
    colors <- rep(colors, nrow(x))
    for (i in seq_len(nrow(x))) {
        draw_nm_layer(x[i, ], color = colors[i])
    }
    if (x.axis) grid::grid.xaxis()
    if (y.axis) grid::grid.yaxis(at = yat,
                                 label = ylabel)
    # Up viewports
    grid::upViewport(1)
}

### * draw_nm_layer()

#' @importFrom grDevices adjustcolor
#' 
#' @keywords internal
#' @noRd

draw_nm_layer <- function(x, color = "grey") {
    stopifnot(nrow(x) == 1)
    geometry <- x$geometry[[1]]
    stopifnot(geometry %in% c("points", "envelope", "line"))
    if (geometry == "points") {
        if (nrow(x$data[[1]]) > 0) {
            grid::grid.points(x = x$data[[1]]$time,
                              y = x$data[[1]]$quantity,
                              default.unit = "native",
                              pch = 21,
                              gp = grid::gpar(col = "black",
                                              fill = color))
        }
    }
    if (geometry == "envelope") {
        if (nrow(x$data[[1]]) > 0) {
            grid::grid.polygon(x = c(x$data[[1]]$time, rev(x$data[[1]]$time)),
                               y = c(x$data[[1]]$quantity_low, rev(x$data[[1]]$quantity_high)),
                               default.unit = "native",
                               gp = grid::gpar(col = color,
                                               fill = adjustcolor(color, alpha.f = 0.25)))
        }
    }
    if (geometry == "line") {
        if (nrow(x$data[[1]]) > 0) {
            grid::grid.lines(x = x$data[[1]]$time,
                             y = x$data[[1]]$quantity,
                             default.unit = "native",
                             gp = grid::gpar(col = color))
        }
    }
}

### * draw_legend()

#' Draw a legend for plot_nm()
#'
#' @importFrom grDevices adjustcolor
#'
#' @param x A named vector of colors
#' 
#' @keywords internal
#' @noRd

draw_legend <- function(x) {
    lo <- grid::grid.layout(nrow = 2,
                            heights = grid::unit(c(2, 1.5 * length(x)),
                                                 c("lines", "lines")))
    vp_legend <- grid::viewport(layout = lo)
    grid::pushViewport(vp_legend)
    # Title
    vp_title <- grid::viewport(layout.pos.row = 1)
    grid::pushViewport(vp_title)
    grid::grid.text("Compartments", x = grid::unit(2, "strwidth", list("a")),
                    just = "left",
                    gp = grid::gpar(fontface = 2))
    grid::upViewport(1)
    # Label stack
    lo <- grid::grid.layout(nrow = length(x),
                            heights = grid::unit(rep(1.5, length(x)),
                                                 rep("lines", length(x))))
    vp_label_stack_top <- grid::viewport(layout.pos.row = 2)
    grid::pushViewport(vp_label_stack_top)
    vp_label_stack <- grid::viewport(x = grid::unit(3, "strwidth", list("a")),
                                     just = "left",
                                     layout = lo)
    grid::pushViewport(vp_label_stack)
    # Individual labels
    for (i in seq_along(x)) {
        # Colored square + label
        lo <- grid::grid.layout(ncol = 2,
                                widths = grid::unit(c(0.9, 1), c("lines", "null")))
        vp_compartment <- grid::viewport(layout.pos.row = i,
                                         layout = lo)
        grid::pushViewport(vp_compartment)
        vp_square_top <- grid::viewport(layout.pos.col = 1)
        grid::pushViewport(vp_square_top)
        vp_square <- grid::viewport(width = grid::unit(1.1, "lines"),
                                    height = grid::unit(1.1, "lines"))
        grid::pushViewport(vp_square)
        grid::grid.rect(gp = grid::gpar(col = x[i],
                                        fill = adjustcolor(x[i], alpha.f = 0.5)))
        grid::upViewport(2)
        vp_label <- grid::viewport(layout.pos.col = 2)
        grid::pushViewport(vp_label)
        grid::grid.text(names(x)[i], x = grid::unit(2, "strwidth", list("a")),
                        just = "left")
        grid::upViewport(2)
    }
    grid::upViewport(3)
}

### * prettyLog

#' Find pretty ticks for log scale
#'
#' @param range Range of the axis, in log10-transformed scale
#'
#' @return A vector containing the tick values in natural scale
#' 
#' @keywords internal
#' @noRd

prettyLog <- function(range) {
    x <- range
    min_x <- 10^min(x)
    max_x <- 10^max(x)
    z <- list(c(1), c(1, 5), c(1, 2, 5))
    o <- lapply(seq_along(z), function(j) {
        k <- c()
        for (i in -10:10) {
            k <- c(k, z[[j]] * 10^i)
        }
        k <- k[k >= min_x & k <= max_x]
        return(k)
    })
    if (length(o[[1]]) >= 3) {
        return(o[[1]])
    } else if (length(o[[2]]) >= 3) {
        return(o[[2]])
    } else {
        return(o[[3]])
    }
}

### * prettyLogLabels

#' Same as prettyLog but return expression for labels
#'
#' TODO For now the function just returns its input.
#' 
#' @param range Range of the axis, in log10-transformed scale
#'
#' @return A vector containing the tick values in natural scale
#' 
#' @keywords internal
#' @noRd

prettyLogLabels <- function(range) {
    ticks <- prettyLog(range)
    labels <- ticks
    return(labels)
}

### * plot_traces()

#' Plot nice traces from a mcmc list
#'
#' @param x A \code{coda::mcmc.list} object
#' @param variables Optional, a vector specifying the ordered variables to plot
#' @param regexp If TRUE (the default), strings in \code{variables} are used to
#'     select traces to draw by pattern matching with the variables names.
#' @param loglik Boolean, if \code{TRUE} additionally plot the loglik trace.
#' @param ratio Aspect ratio for the overall plot that the function thrives to
#'     respect (this will have an effect on the balance between numbers of rows
#'     and colums)
#' @param transform Function to use to transform the values before plotting
#'     (e.g. log). The function is applied directly to \code{x}, so it should
#'     be able to handle \code{mcmc.list} object (and return a similar object).
#' @param lty Line type for the density plots
#' @param hist Boolean, if TRUE draw histograms instead of density profiles
#' @param nbins Number of histogram bins, used only if \code{drawHist} is TRUE.
#' @param pdf Filename to save the plot as a pdf. If \code{NULL}, the plot is
#'     displayed.
#' @param png Filename to save the plot as a png. If \code{NULL}, the plot is
#'     displayed.
#' @param width,height Width and height of the pdf file in inches. Also used
#'     for the size of the png file, using a RES value of 150.
#'
#' @importFrom grDevices dev.hold
#' @importFrom grDevices dev.flush
#' @importFrom grDevices dev.off
#'
#' @keywords internal
#' @noRd

plot_traces <- function(x, variables = NULL, regexp = TRUE, loglik = FALSE,
                       ratio = 4/3, transform = NULL, lty = 1,
                       hist = TRUE, nbins = 32,
                       pdf = NULL, png = NULL, width = 12, height = 10) {
    x_original <- x
    if (is.null(transform)) {
        x <- x
    } else {
        x <- transform(x)
    }
    drawHist <- hist
    nBars <- nbins
    # Parse pdf/png arguments
    stopifnot(is.null(pdf) | is.null(png))
    if (!is.null(pdf)) {
        pdf(file = pdf, width = width, height = height)
    }
    if (!is.null(png)) {
        RES = 150
        png(file = png, width = width * RES, height = height * RES, res = RES,
            type = "cairo-png")
    }
    dev.hold()
    on.exit(dev.flush())
    # Prepare data
    if (loglik) {
        prev_varnames <- coda::varnames(x)
        # Add loglik trace to each mcmc object
        mcmcList <- lapply(seq_along(x), function(i) {
            y <- cbind(x[[i]], attr(x, "loglik")[[i]])
            colnames(y) <- c(prev_varnames, "loglik")
            chainI <- coda::mcmc(y)
            return(chainI)
        })
        x <- coda::as.mcmc.list(mcmcList)
        for (i in seq_along(x)) {
            attr(x[[i]], "mcpar") <- coda::mcpar(x_original)
        }
    }
    if (regexp & !is.null(variables)) {
        vars <- coda::varnames(x)
        selectedVars <- vars[unlist(sapply(variables, grep, x = vars))]
        selectedVars <- unique(selectedVars)
        if (length(selectedVars) == 0) {
            stop("No variables found matching: ", variables)
        }
        variables <- selectedVars
    }
    drawTraces(mcmc.list = x, variables = variables,
               ratio = ratio, lty = lty,
               drawHist = drawHist, nBars = nBars)
    if (!is.null(pdf) | !is.null(png)) {
        invisible(dev.off())
    }
    return(invisible(x_original))
}

### * drawTraces

#' Draw the traces for a mcmc.list object
#'
#' @param mcmc.list A coda mcmc.list object
#' @param drawXAxis Boolean
#' @param variables A vector containing the names of the variables to include
#'     in the plot. If NULL, all variables are used.
#' @param ratio Aspect ratio for the overall plot that the function thrives to
#'     respect (this will have an effect on the balance between numbers of rows
#'     and colums)
#' @param drawHist Boolean, if TRUE draw histograms instead of density profiles
#' @param nBars Number of histogram bars, used only if \code{drawHist} is TRUE.
#' @param newpage Boolean, run grid.newpage() before drawing?
#' @param ... Arguments passed to \code{\link{drawTraceOneVar}}
#'
#' @keywords internal
#' @noRd

drawTraces = function(mcmc.list, drawXAxis = FALSE, variables = NULL,
                      ratio = 4/3, drawHist = FALSE, nBars = 64,
                      newpage = TRUE, ...) {
    nchains = coda::nchain(mcmc.list)
    nvars = coda::nvar(mcmc.list)
    varsToPlot = 1:nvars
    if (!is.null(variables)) {
        nvars = length(variables)
        varsToPlot = variables
    }
    colors = c("deeppink", "green3", "darkmagenta", "dodgerblue")
    colors = rep(colors, nchains)
    mfrow = n2mfrowByRatio(nvars, ratio = ratio)
    # New page
    if (newpage) grid::grid.newpage()
    # Viewport for traces
    if (drawXAxis) {
        vpTraces = grid::viewport(layout = grid::grid.layout(nrow = mfrow[1] + 1, ncol = mfrow[2],
                                                             heights = grid::unit(c(rep(1, mfrow[1]), 4), c(rep("null", mfrow[1]), "lines"))),
                                  name = "vpTraces", clip = "on")
    } else {
        vpTraces = grid::viewport(layout = grid::grid.layout(nrow = mfrow[1], ncol = mfrow[2]),
                                  name = "vpTraces", clip = "on")
    }
    grid::pushViewport(vpTraces)
    # Draw panel for each parameter
    lapply(seq_len(nvars), function(v) {
        row = 1 + (v-1) %/% mfrow[2]
        column = 1 + (v-1) %% mfrow[2]
        vpCell = grid::viewport(layout.pos.row = row,
                                layout.pos.col = column,
                                name = paste("vpCell", row, column, sep = "."))
        grid::pushViewport(vpCell)
        grid::grid.rect(gp = grid::gpar(col = grey(0.5)))
        if (drawHist) {
            drawTraceOneVarHist(mcmc.list = mcmc.list, varname = varsToPlot[v], colors = colors,
                            drawXAxis = ifelse(drawXAxis,
                            (row == mfrow[1] | (row == (mfrow[1] - 1) & column == mfrow[2])),
                            FALSE), nBars = nBars, ...)
        } else {
            drawTraceOneVar(mcmc.list = mcmc.list, varname = varsToPlot[v], colors = colors,
                            drawXAxis = ifelse(drawXAxis,
                            (row == mfrow[1] | (row == (mfrow[1] - 1) & column == mfrow[2])),
                            FALSE), ...)
        }
        grid::upViewport(1)
    })
    # Back to parent viewport
    grid::upViewport(1)
}

### * drawTraceOneVar

#' Draw the chain traces for one variable, using a density profile for the density panel
#'
#' This function is mostly useful when it is called by other functions as a
#' buildign block to draw the traces of several variables.
#'
#' @param mcmc.list A coda mcmc.list object
#' @param varname Name of the variable of which the trace is to be drawn
#' @param colors Vector of colors for the chain traces
#' @param drawXAxis Boolean
#' @param lty Line type for the density plot
#'
#' @importFrom stats density
#' @importFrom grDevices grey
#' @importFrom grDevices extendrange
#' @importFrom grDevices adjustcolor
#'
#' @keywords internal
#' @noRd

drawTraceOneVar = function(mcmc.list, varname, colors, drawXAxis = FALSE, lty = 1) {
    EXTENSION = c(0.025, 0.1)
    ALPHA_FILL = 0.2
    ALPHA_TRACES = 0.6
    DENSITY_MAX_RELATIVE_SHIFT = 0 # Can be set to e.g. 0.25 for slight shift in density plots
    MODE_COL = "white"
    CI_LWD = c(0.25, 0.15) # Unit: char
    # Process the data
    varnameOriginal <- varname
    if (is.numeric(varname)) {
        varname = coda::varnames(mcmc.list)[varname]
        if (is.null(varname)) {
            varname <- "unnamed_variable"
        }
    }
    mcpars = coda::mcpar(mcmc.list[[1]])
    nchains = coda::nchain(mcmc.list)
    if (!is.null(dim(mcmc.list[[1]]))) {
        varData = lapply(mcmc.list, function(mcmc) mcmc[, varnameOriginal])
    } else {
        # There is only one variable
        varData = lapply(mcmc.list, function(mcmc) as.vector(mcmc))
    }
    xData = seq(from = mcpars[1], to = mcpars[2], by = mcpars[3])
    yData = unlist(varData)
    densities = lapply(varData, density)
    densitiesData = unlist(lapply(densities, "[[", "y"))
    densitiesRange = range(densitiesData)
    if (nchains > 1) {
        stepDensity = diff(densitiesRange) * DENSITY_MAX_RELATIVE_SHIFT / (nchains - 1)
    } else {
        stepDensity = 0
    }
    densitiesRange[2] = densitiesRange[2] + stepDensity * (nchains - 1) + diff(densitiesRange) * 0.1
    # Viewport for the parameter panel
    vpParamPanel = grid::viewport(layout = grid::grid.layout(nrow = 2, ncol = 1,
                                                             heights = grid::unit(c(1.5, 1), c("lines", "null"))),
                                  name = paste("vpParamPanel", varname, sep = "."))
    grid::pushViewport(vpParamPanel)
    # Viewport for the title
    vpTitle = grid::viewport(name = "vpTitle", layout.pos.row = 1)
    grid::pushViewport(vpTitle)
    grid::grid.rect(gp = grid::gpar(fill = grey(0.95), col = grey(0.5)))
    grid::grid.text(varnameToExp(varname),
                    gp = grid::gpar(col = grey(0.5), cex = 1.2))
    grid::upViewport(1)
    # Viewport for the graph
    vpGraph = grid::viewport(layout = grid::grid.layout(nrow = 1, ncol = 3,
                                                        widths = grid::unit(c(3, 1, 0.25), c("lines", "null", "null"))),
                             name = "vpGraph", layout.pos.row = 2, clip = ifelse(drawXAxis, "off", "on"))
    grid::pushViewport(vpGraph)
    # Viewport for the y axis
    vpYAxis = grid::viewport(name = "vpYAxis", layout.pos.col = 1)
    grid::pushViewport(vpYAxis)
    grid::upViewport(1)
    # Viewport for the trace plot
    vpTracePlot = grid::dataViewport(xData = xData, yData = yData, extension = EXTENSION,
                                     name = "vpTracePlot", layout.pos.col = 2)
    grid::pushViewport(vpTracePlot)
    ## Draw the chains
    lapply(seq_len(nchains), function(i) {
        grid::grid.lines(x = xData, y = varData[[i]], default.units = "native",
                         gp = grid::gpar(col = adjustcolor(colors[i], alpha.f = ALPHA_TRACES),
                                         lwd = 1))
    })
    ## Draw axes
    grid::grid.yaxis(gp = grid::gpar(cex = 0.7))
    if (drawXAxis) {
        # https://stackoverflow.com/questions/8816456/rotate-labels-in-grid-xaxis
        grid::grid.xaxis(edits = grid::gEdit(gPath="labels", rot=90))
    }
    grid::upViewport(1)
    # Viewport for the density plot
    vpDensityPlot = grid::dataViewport(xscale = extendrange(densitiesRange, f = 0.025),
                                       yData = yData, extension = EXTENSION,
                                       name = "vpDensityPlot", layout.pos.col = 3,
                                       clip = "on")
    grid::pushViewport(vpDensityPlot)
    lapply(seq_len(nchains), function(i) {
        grid::grid.polygon(x = c(densities[[i]]$y, densities[[i]]$y[1]) + stepDensity * (i - 1),
                           y = c(densities[[i]]$x, densities[[i]]$x[1]),
                           default.unit = "native",
                           gp = grid::gpar(col = colors[i],
                                           fill = adjustcolor(colors[i], alpha.f = ALPHA_FILL),
                                           lty = lty))
    })
    grid::upViewport(1)
    # Back to vpParamPanel
    grid::upViewport(1)
    # Back to original (parent) viewport
    grid::upViewport(1)
}

### * drawTraceOneVarHist

#' Draw the chain traces for one variable, using a histogram for density panel
#'
#' This function is mostly useful when it is called by other functions as a
#' buildign block to draw the traces of several variables.
#'
#' @param mcmc.list A coda mcmc.list object
#' @param varname Name of the variable of which the trace is to be drawn
#' @param colors Vector of colors for the chain traces
#' @param drawXAxis Boolean
#' @param lty Line type for the density plot
#' @param nBars Number of histogram bars per trace
#'
#' @importFrom stats density
#' @importFrom graphics hist
#' @importFrom grDevices grey
#' @importFrom grDevices extendrange
#' @importFrom grDevices adjustcolor
#'
#' @keywords internal
#' @noRd

drawTraceOneVarHist = function(mcmc.list, varname, colors, drawXAxis = FALSE, lty = 1, nBars = 128) {
    EXTENSION = c(0.025, 0.1)
    ALPHA_FILL = 0.2
    ALPHA_TRACES = 0.6
    DENSITY_MAX_RELATIVE_SHIFT = 0 # Can be set to e.g. 0.25 for slight shift in density plots
    MODE_COL = "white"
    CI_LWD = c(0.25, 0.15) # Unit: char
    # Process the data
    varnameOriginal <- varname
    if (is.numeric(varname)) {
        varname = coda::varnames(mcmc.list)[varname]
        if (is.null(varname)) {
            varname <- "unnamed_variable"
        }
    }
    mcpars = coda::mcpar(mcmc.list[[1]])
    nchains = coda::nchain(mcmc.list)
    if (!is.null(dim(mcmc.list[[1]]))) {
        varData = lapply(mcmc.list, function(mcmc) mcmc[, varnameOriginal])
    } else {
        # There is only one variable
        varData = lapply(mcmc.list, function(mcmc) as.vector(mcmc))
    }
    xData = seq(from = mcpars[1], to = mcpars[2], by = mcpars[3])
    yData = unlist(varData)
    densities = lapply(varData, density)
    densitiesData = unlist(lapply(densities, "[[", "y"))
    densitiesRange = range(densitiesData)
    histRange <- range(unlist(varData))
    histBreaks <- seq(histRange[1], histRange[2], length.out = nBars + 1)
    histograms <- lapply(seq_along(varData), function(i) {
        d <- varData[[i]]
        hist(d, breaks = histBreaks, plot = FALSE)$density
    })
    if (nchains > 1) {
        stepDensity = diff(densitiesRange) * DENSITY_MAX_RELATIVE_SHIFT / (nchains - 1)
    } else {
        stepDensity = 0
    }
    densitiesRange[2] = densitiesRange[2] + stepDensity * (nchains - 1) + diff(densitiesRange) * 0.1
    # Viewport for the parameter panel
    vpParamPanel = grid::viewport(layout = grid::grid.layout(nrow = 2, ncol = 1,
                                                             heights = grid::unit(c(1.5, 1), c("lines", "null"))),
                                  name = paste("vpParamPanel", varname, sep = "."))
    grid::pushViewport(vpParamPanel)
    # Viewport for the title
    vpTitle = grid::viewport(name = "vpTitle", layout.pos.row = 1)
    grid::pushViewport(vpTitle)
    grid::grid.rect(gp = grid::gpar(fill = grey(0.95), col = grey(0.5)))
    grid::grid.text(varnameToExp(varname),
                    gp = grid::gpar(col = grey(0.5), cex = 1.2))
    grid::upViewport(1)
    # Viewport for the graph
    vpGraph = grid::viewport(layout = grid::grid.layout(nrow = 1, ncol = 3,
                                                        widths = grid::unit(c(3, 1, 0.25), c("lines", "null", "null"))),
                             name = "vpGraph", layout.pos.row = 2, clip = ifelse(drawXAxis, "off", "on"))
    grid::pushViewport(vpGraph)
    # Viewport for the y axis
    vpYAxis = grid::viewport(name = "vpYAxis", layout.pos.col = 1)
    grid::pushViewport(vpYAxis)
    grid::upViewport(1)
    # Viewport for the trace plot
    if (length(unique(yData)) == 1) {
        if (yData[1] == 0) {
            adjYdata <- c(-0.1, 0.1)
        } else {
            adjYdata <- c(0.9 * unique(yData), yData, 1.1 * unique(yData))
        }
    } else {
        adjYdata <- yData
    }
    vpTracePlot = grid::dataViewport(xData = xData, yData = adjYdata, extension = EXTENSION,
                                     name = "vpTracePlot", layout.pos.col = 2)
    grid::pushViewport(vpTracePlot)
    ## Draw the chains
    lapply(seq_len(nchains), function(i) {
        grid::grid.lines(x = xData, y = varData[[i]], default.units = "native",
                         gp = grid::gpar(col = adjustcolor(colors[i], alpha.f = ALPHA_TRACES),
                                         lwd = 1))
    })
    ## Draw axes
    grid::grid.yaxis(gp = grid::gpar(cex = 0.7))
    if (drawXAxis) {
        # https://stackoverflow.com/questions/8816456/rotate-labels-in-grid-xaxis
        grid::grid.xaxis(edits = grid::gEdit(gPath="labels", rot=90))
    }
    grid::upViewport(1)
    # Viewport for the density plot
    if (!any(is.na(unlist(histograms)))) {
        if (length(unique(yData)) == 1) {
            adjYdata <- c(0.9 * unique(yData), yData, 1.1 * unique(yData))
        } else {
            adjYdata <- yData
        }
        vpDensityPlot = grid::dataViewport(xscale = extendrange(c(0, max(unlist(histograms))), f = 0.025),
                                           yData = adjYdata, extension = EXTENSION,
                                           name = "vpDensityPlot", layout.pos.col = 3,
                                           clip = "on")
        grid::pushViewport(vpDensityPlot)
        lapply(seq_len(nchains), function(i) {
            grid::grid.polygon(x = c(0, rep(histograms[[i]], each = 2), 0), #c(densities[[i]]$y, densities[[i]]$y[1]) + stepDensity * (i - 1),
                               y = rep(histBreaks, each = 2), #c(densities[[i]]$x, densities[[i]]$x[1]),
                               default.unit = "native",
                               gp = grid::gpar(col = colors[i],
                                               fill = adjustcolor(colors[i], alpha.f = ALPHA_FILL),
                                               lty = lty))
        })
        grid::upViewport(1)
    }
    # Back to vpParamPanel
    grid::upViewport(1)
    # Back to original (parent) viewport
    grid::upViewport(1)
}

### * n2mfrowByRatio

#' Provide a good mfrow argument given a number of cells and a target ratio
#'
#' @param n Number of cells to fit in the plot
#' @param ratio Aspect ratio for the overall plot that the function thrives to
#'     respect (this will have an effect on the balance between numbers of rows
#'     and colums)
#'
#' @importFrom grDevices dev.size
#'
#' @keywords internal
#' @noRd

n2mfrowByRatio = function(n, ratio = 4/3) {
    # Build all the reasonable combinations of nRows x nColumns
    nOne = seq_len(n)
    nTheOther = ceiling(n / nOne)
    nTheOtherKept = unique(nTheOther)
    nOneKept = sapply(nTheOtherKept, function(k) {
        min(nOne[nTheOther == k])
    })
    # Note: one can do nRows = c(nOneKept, nTheOtherKept) and nColumns =
    # c(nTheOtherKept, nOneKept) if it is important to minimize the number of
    # empty cells
    nRows = c(nOne, nTheOther)
    nColumns = c(nTheOther, nOne)
    nRbyC = as.data.frame(unique(cbind(nRows, nColumns)))
    names(nRbyC) = c("nRows", "nColumns")
    # Get device size
    devSize = dev.size()
    # Calculate ratios
    nRbyC$rowHeight = devSize[2] / nRbyC$nRows
    nRbyC$colWidth = devSize[1] / nRbyC$nColumns
    nRbyC$ratio = nRbyC$colWidth / nRbyC$rowHeight
    nRbyC$dist = abs(log(nRbyC$ratio / ratio))
    i = which(nRbyC$dist == min(nRbyC$dist))
    # Return
    return(c(nRbyC$nRows[i], nRbyC$nColumns[i]))
}

### * varnameToExp

#' Convert a variable name to the appropriate mathematical expression
#'
#' @param varname Variable name to be converted
#'
#' @keywords internal
#' @noRd

varnameToExp = function(varname) {
    rm_underscore <- function(x) {
        gsub("_", ".", x)
    }
    # Try to split with "|" to find replication variables
    elements = strsplit(varname, split = "[|]")[[1]]
    varname = elements[1]
    replVar = ""
    if (length(elements) > 1) {
        replVar = paste(elements[2:length(elements)], collapse = ",")
        replVar = paste(" |", rm_underscore(replVar))
    }
    # Uptake rate
    if (grepl("^upsilon_", varname)) {
        tmp = strsplit(varname, "^upsilon_")[[1]][2]
        tmp = strsplit(tmp, "_to_")[[1]]
        from = rm_underscore(tmp[1])
        to = rm_underscore(tmp[2])
        return(latex2exp::TeX(paste0("$\\upsilon_{", from, " \\rightarrow ", to, "}$", replVar)))
    }
    # Loss rate
    if (grepl("^lambda_", varname)) {
        comp = rm_underscore(strsplit(varname, "^lambda_")[[1]][2])
        return(latex2exp::TeX(paste0("$\\lambda_{", comp, "}$", replVar)))
    }
    # Active fraction
    if (grepl("^portion\\.act_", varname)) {
        comp = rm_underscore(strsplit(varname, "^portion\\.act_")[[1]][2])
        if (nchar(comp) > 4) {
            comp = substr(comp, start = 1, stop = nchar(comp) - 4)
        }
        return(latex2exp::TeX(paste0("$\\pi_{", comp, "}$", replVar)))
    }
    # propCv
    if (varname == "eta") {
        if (replVar == "") {
            return(latex2exp::TeX(paste0("$\\eta$")))
        }
        return(latex2exp::TeX(paste0("$\\eta_{", "}$", replVar)))
    }
    # sizeCv
    if (varname == "zeta") {
        if (replVar == "") {
            return(latex2exp::TeX(paste0("$\\zeta$")))
        }
        return(latex2exp::TeX(paste0("$\\zeta_{", "}$", replVar)))
    }
    if (grepl("^zeta_", varname)) {
        comp = rm_underscore(strsplit(varname, "^zeta_")[[1]][2])
        if (replVar == "") {
            return(latex2exp::TeX(paste0("$\\zeta_{", comp, "}$")))
        }
        return(latex2exp::TeX(paste0("$\\zeta_{", comp, "}$", replVar)))
    }
    # Return
    if (replVar == "") {
        return(varname)
    }
    return(paste0(varname, replVar))
}

### * capture_msg()

#' Capture a message generated by running an expression
#'
#' This function is inspired by the code from testthat::capture_message(). Note
#' that an expression such as `m <- new_networkModel()` will not have an effect
#' on the calling environment if a message is caught (i.e. no `m` object is
#' created in the calling environment of `capture_msg()`). In my understanding,
#' this is because the emission of a message interrupts the expression
#' evaluation.
#'
#' @param expr Expression to evaluate.
#'
#' @return NULL if no message was produced, the first message produced otherwise.
#'
#' @examples
#' isotracer:::capture_msg(new_networkModel())
#' 
#' @keywords internal
#' @noRd

capture_msg <- function(expr) {
    captured <- tryCatch({
        expr
        NULL
    }, message = function(msg) {
        return(msg)
    })
    return(captured)
}

### * flows_from_topo()

#' Build a flow tibble from a topology
#'
#' @param x A topology.
#'
#' @return A tibble with columns "from" and "to".
#'
#' @examples
#' flows_from_topo(topo(trini_mod))
#'
#' @keywords internal
#' @noRd

flows_from_topo <- function(x) {
    x <- unclass(x) # Remove the "topo" class to treat it as a matrix
    n_comps <- ncol(x)
    links <- which(x > 0)
    from <- links %/% n_comps + 1
    to <- links %% n_comps
    links <- tibble::tibble(from = from, to = to)
    for (i in seq_len(nrow(links))) {
        if (links$to[i] == 0) {
            links$from[i] <- links$from[i] - 1
            links$to[i] <- n_comps
        }
        stopifnot(x[links$to[i], links$from[i]] > 0)
    }
    flows <- tibble::tibble(from = colnames(x)[links$from],
                            to = rownames(x)[links$to])
    return(flows)
}

### * nodes_from_topo()

#' Build a node tibble from a topology
#'
#' @param x A topology.
#'
#' @return A tibble with columns "comp" and "label".
#'
#' @examples
#' nodes_from_topo(topo(trini_mod))
#'
#' @keywords internal
#' @noRd

nodes_from_topo <- function(x) {
    nodes <- tibble::tibble(comp = colnames(x),
                            label = colnames(x))
    return(nodes)
}

### * None of the functions in this file is exported

### * encode_priors()

#' Prepare the prior encoding for stan data
#'
#' @param params_nm Output from params(nm, simplify = TRUE).
#' @param priors_nm Output from priors(nm) (must have the same parameter order
#'     as params_nm).
#'
#' @keywords internal
#' @noRd

encode_priors <- function(params_nm, priors_nm) {
    if (any(sapply(priors_nm$prior, is.null))) {
        stop("One or several parameters are missing a prior.\n",
             "You can list the current model priors with `priors(...)`.\n",
             "You can list the missing model priors with `missing_priors(...)`.")
    }
    d <- list()
    d[["nPriorConstant_code0"]] <- 0
    d[["nPriorUniform_code1"]] <- 0
    d[["nPriorHcauchy_code2"]] <- 0
    d[["nPriorBeta_code3"]] <- 0
    d[["nPriorTrNormal_code4"]] <- 0
    d[["nPriorExponential_code5"]] <- 0
    d[["nPriorGamma_code6"]] <- 0
    ### Prior types (used to map the correct prior in the stan model)
    priorTypes <- c("constant" = 0, "uniform" = 1, "hcauchy" = 2, "scaled_beta" = 3,
                    "trun_normal" = 4, "exponential" = 5, "gamma" = 6)
    ### Parameter priors
    d[["mappingParamPriorType"]] <- rep(NA, length(params_nm))
    d[["mappingParamPriorID"]] <- rep(NA, length(params_nm))
    prior_i <- c("constant" = 1, "uniform" = 1, "hcauchy" = 1,
                 "scaled_beta" = 1, "trun_normal" = 1, "exponential" = 1,
                 "gamma" = 1) # Counts for each prior type
    # Set some defaults
    for (priorDistParam in c("constantParams", "lowerParams", "upperParams", "hcauchyScaleParams",
                             "rawBetaAlpha", "rawBetaBeta", "betaScaleParams",
                             "trNormMeanParams", "trNormSdParams", "exponentialRateParams",
                             "gammaAlphaParams", "gammaBetaParams")) {
        # Set zero as default for all prior distribution parameters
        d[[priorDistParam]] <- rep(0, length(params_nm))
    }
    # Go through each param prior
    for (i in seq_along(params_nm)) {
        p <- priors_nm[["prior"]][[i]]
        stopifnot(p[["type"]] %in% names(priorTypes))
        d[["mappingParamPriorType"]][i] <- priorTypes[p[["type"]]]
        d[["mappingParamPriorID"]][i] <- prior_i[p[["type"]]]
        prior_i[p[["type"]]] <- prior_i[p[["type"]]] + 1
        if (p[["type"]] == "constant") {
            d[["constantParams"]][i] <- p[["parameters"]][["value"]]
            d[["nPriorConstant_code0"]] <- d[["nPriorConstant_code0"]] + 1
        }
        if (p[["type"]] == "uniform") {
            d[["lowerParams"]][i] <- p[["parameters"]]["min"]
            d[["upperParams"]][i] <- p[["parameters"]]["max"]
            d[["nPriorUniform_code1"]] <- d[["nPriorUniform_code1"]] + 1
        }
        if (p[["type"]] == "hcauchy") {
            d[["hcauchyScaleParams"]][i] <- p[["parameters"]]["scale"]
            d[["nPriorHcauchy_code2"]] <- d[["nPriorHcauchy_code2"]] + 1
        }
        if (p[["type"]] == "scaled_beta") {
            d[["rawBetaAlpha"]][i] <- p[["parameters"]]["alpha"]
            d[["rawBetaBeta"]][i] <- p[["parameters"]]["beta"]
            d[["betaScaleParams"]][i] <- p[["parameters"]]["scale"]
            d[["nPriorBeta_code3"]] <- d[["nPriorBeta_code3"]] + 1
        }
        if (p[["type"]] == "trun_normal") {
            d[["trNormMeanParams"]][i] <- p[["parameters"]][["mean"]]
            d[["trNormSdParams"]][i] <- p[["parameters"]][["sd"]]
            d[["nPriorTrNormal_code4"]] <- d[["nPriorTrNormal_code4"]] + 1
        }
        if (p[["type"]] == "exponential") {
            d[["exponentialRateParams"]][i] <- p[["parameters"]][["lambda"]]
            d[["nPriorExponential_code5"]] <- d[["nPriorExponential_code5"]] + 1
        }
        if (p[["type"]] == "gamma") {
            d[["gammaAlphaParams"]][i] <- p[["parameters"]][["alpha"]]
            d[["gammaBetaParams"]][i] <- p[["parameters"]][["beta"]]
            d[["nPriorGamma_code6"]] <- d[["nPriorGamma_code6"]] + 1
        }
    }
    # Count non-constant priors
    d[["nNonConstantPriors"]] <- length(params_nm) - d[["nPriorConstant_code0"]]
    # Return
    return(d)
}

### * encode_steady()

#' Encode steady compartments for stan data
#'
#' @param nm A \code{networkModel} object.
#' 
#' @keywords internal
#' @noRd

encode_steady <- function(nm) {
    d <- list()
    steady <- lapply(nm[["topology"]], function(x) {
        match(attr(x, "steadyState"), colnames(x))
    })
    d[["maxNsteady"]] <- max(sapply(steady, length))
    d[["nSteady"]] <- setNames(c(sapply(steady, length), 0), # Padded
                               nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
    d[["steadyIndices"]] <- array(0, dim = c(d[["maxNsteady"]], nrow(nm)),
                                  dimnames = list(seq_len(d[["maxNsteady"]]),
                                                  paste0("grp", seq_len(nrow(nm)))))
    for (i in seq_len(nrow(nm))) {
        d[["steadyIndices"]][seq_along(steady[[i]]),i] <- steady[[i]]
    }
    # Return
    return(d)
}

### * encode_split()

#' Encode split compartments for stan data
#'
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#'
#' @keywords internal
#' @noRd

encode_split <- function(nm, allParams) {
    d <- list()
    split <- lapply(nm[["topology"]], function(x) {
        match(attr(x, "split"), colnames(x))
    })
    d[["splitPresent"]] <- as.numeric(max(sapply(split, length)) > 0)
    nGroups <- nrow(nm)
    splitComps <- array(0, dim = c(length(comps(nm)[[1]]), nGroups),
                        dimnames = list(seq_along(comps(nm)[[1]]),
                                        paste0("grp", seq_len(nrow(nm)))))
    for (i in seq_along(split)) {
        splitComps[split[[i]], i] <- 1
    }
    d[["splitComps"]] <- splitComps
    # Parameter mapping
    piMapping <- array(0, dim = c(length(comps(nm)[[1]]), nGroups),
                       dimnames = list(seq_along(comps(nm)[[1]]),
                                       paste0("grp", seq_len(nrow(nm)))))
    for (g in seq_len(nGroups)) {
        compNames <- colnames(nm$topology[[g]])
        stopifnot(length(compNames) == length(comps(nm)[[1]]))
        for (k in seq_along(compNames)) {
            if (splitComps[k, g] > 0) {
                paramName <- paste0("portion.act_", compNames[k])
                paramGlobal <- nm$parameters[[g]]$in_model[nm$parameters[[g]]$in_replicate == paramName]
                stopifnot(length(paramGlobal) == 1)
                piMapping[k, g] <- match(paramGlobal, allParams)
            }
        }
    }
   d[["piMapping"]] <- piMapping
    # Return
    return(d)
}

### * encode_init()

#' Encode initial conditions for a network model
#'
#' For now this function assumes that each row has the same number of
#' compartments.
#'
#' @param nm A \code{networkModel} object.
#'
#' @keywords internal
#' @noRd

encode_init <- function(nm) {
    nComps <- sapply(comps(nm), length)
    stopifnot(all(nComps == nComps[1]))
    nGroups <- nrow(nm)
    d <- array(0, dim = c(nComps[1], 2, nGroups),
               dimnames = list(1:nComps[1], c("unmarked", "marked"),
                               c(paste0("grp", seq_len(nGroups)))))
    for (i in seq_len(nGroups)) {
        comps <- colnames(nm$topology[[i]])
        stopifnot(nrow(nm$initial[[i]]) == length(comps))
        stopifnot(setequal(nm$initial[[i]][["compartment"]], comps))
        comps <- nm$initial[[i]][match(comps, nm$initial[[i]][["compartment"]]), ]
        stopifnot(all(comps$compartment == colnames(nm$topology[[i]])))
        unmarked <- comps$size * (1 - comps$proportion)
        marked <- comps$size * comps$proportion
        d[,,i] <- cbind(unmarked, marked)
    }
    return(list(initialQuantities = d))
}

### * encode_distrib_families()

#' Encode the families for proportions and sizes distributions
#'
#' @param nm A \code{networkModel} object.
#'
#' @keywords internal
#' @noRd

encode_distrib_families <- function(nm) {
    o <- list()
    # Encode distribution family for proportions
    known_families <- c("gamma_cv" = 1, "normal_cv" = 2, "normal_sd" = 3,
                        "beta_phi" = 4)
    prop_family <- attr(nm, "prop_family")
    if (!prop_family %in% names(known_families)) {
        stop("Unknown distribution family for proportions. Got value: ",
             prop_family, "\n",
             "Allowed values are: ", names(known_families))
    }
    o[["propFamily"]] <- known_families[prop_family]
    # Encode distribution family for sizes
    size_known_families <- c("normal_cv" = 1, "normal_sd" = 2)
    size_family <- attr(nm, "size_family")
    if (!size_family %in% names(size_known_families)) {
        stop("Unknown distribution family for sizes. Got value: ",
             size_family, "\n",
             "Allowed values are: ", names(size_known_families))
    }
    o[["sizeFamily"]] <- size_known_families[size_family]
    return(o)
}

### * encode_upsilons()

#' Encode the uptake rates for stan data
#'
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#' 
#' @keywords internal
#' @noRd

encode_upsilons <- function(nm, allParams) {
    nGroups <- nrow(nm)
    upsilons <- nm_get_upsilons(nm, allParams)
    nUpsilons <- setNames(c(upsilons[["nUpsilons"]], 0), # Padding
                          nm = c(paste0("grp", seq_len(nGroups)), "padding"))
    maxNupsilons <- max(nUpsilons)
    upsilonMapping <- array(0, dim = c(maxNupsilons, 3, nGroups),
                            dimnames = list(1:maxNupsilons,
                                            c("from", "to", "param"),
                                            paste0("grp", seq_len(nGroups))))
    for (i in seq_len(nGroups)) {
        upsilonMapping[1:nUpsilons[i], 1:3, i] <- as.matrix(upsilons[["upsilons"]][[i]])
    }
    return(list(nUpsilons = nUpsilons,
                maxNupsilons = maxNupsilons,
                upsilonMapping = upsilonMapping))
}

### ** nm_get_upsilons()

#' Get upsilons for a network model
#' 
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#' 
#' @keywords internal
#' @noRd

nm_get_upsilons <- function(nm, allParams) {
    upsilons <- lapply(seq_len(nrow(nm)), function(i) {
        z <- nm_row_get_upsilons(nm[i, ], allParams = allParams)
        tibble::tibble(upsilons = list(z), nUpsilons = nrow(z))
    })
    return(dplyr::bind_rows(upsilons))
}

### ** nm_row_get_upsilons()

#' Get upsilons for one row of a network model
#' 
#' @param nm_row A row from a \code{networkModel} object.
#' @param allParams Parameters of the network model.
#' 
#' @keywords internal
#' @noRd

nm_row_get_upsilons <- function(nm_row, allParams) {
    nmRow <- nm_row
    stopifnot(nrow(nmRow) == 1)
    # Get data
    topo <- nmRow[["topology"]][[1]]
    mapping <- nmRow[["parameters"]][[1]][, c("in_replicate", "in_model")]
    mapping <- tibble::deframe(mapping)
    # Build output
    from <- vector()
    to <- vector()
    param <- vector()
    compartments <- colnames(topo)
    stopifnot(all(compartments == rownames(topo)))
    for (j in seq_len(ncol(topo))) {
        for (i in seq_len(nrow(topo))) {
            if (topo[i,j] == 1) {
                from <- c(from, j)
                to <- c(to, i)
                paramName <- paste0("upsilon_", compartments[j], "_to_",
                                    compartments[i])
                param <- c(param, match(mapping[paramName], allParams))
            }
        }
    }
    return(tibble::tibble(from = from, to = to, param = param))
}

### * encode_lambdas()

#' Encode the loss rates for stan data
#'
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#'
#' @keywords internal
#' @noRd

encode_lambdas <- function(nm, allParams) {
    nGroups <- nrow(nm)
    lambdas <- nm_get_lambdas(nm, allParams)
    nLambdas <- setNames(c(lambdas[["nLambdas"]], 0), # Padding
                         nm = c(paste0("grp", seq_len(nGroups)), "padding"))
    maxNlambdas <- max(nLambdas)
    lambdaMapping <- array(0, dim = c(maxNlambdas, 2, nGroups),
                           dimnames = list(1:maxNlambdas,
                                           c("from", "param"),
                                           paste0("grp", seq_len(nGroups))))
    for (i in seq_len(nGroups)) {
        lambdaMapping[1:nLambdas[i], 1:2, i] <- as.matrix(lambdas[["lambdas"]][[i]])
    }
    return(list(nLambdas = nLambdas,
                maxNlambdas = maxNlambdas,
                lambdaMapping = lambdaMapping))
}

### ** nm_get_lambdas()

#' Get lambdas for a network model
#' 
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#' 
#' @keywords internal
#' @noRd

nm_get_lambdas <- function(nm, allParams) {
    lambdas <- lapply(seq_len(nrow(nm)), function(i) {
        z <- nm_row_get_lambdas(nm[i, ], allParams = allParams)
        tibble::tibble(lambdas = list(z), nLambdas = nrow(z))
    })
    return(dplyr::bind_rows(lambdas))
}

### ** nm_row_get_lambdas()

#' Get lambdas for one row of a network model
#' 
#' @param nm_row A row from a \code{networkModel} object.
#' @param allParams Parameters of the network model.
#' 
#' @keywords internal
#' @noRd

nm_row_get_lambdas <- function(nm_row, allParams) {
    nmRow <- nm_row
    stopifnot(nrow(nmRow) == 1)
    # Get data
    topo <- nmRow[["topology"]][[1]]
    mapping <- nmRow[["parameters"]][[1]][, c("in_replicate", "in_model")]
    mapping <- tibble::deframe(mapping)
    # Build output
    from <- vector()
    param <- vector()
    compartments <- colnames(topo)
    stopifnot(all(compartments == rownames(topo)))
    for (j in seq_len(ncol(topo))) {
        paramName <- paste0("lambda_", compartments[j])
        if (paramName %in% names(mapping)) {
            from <- c(from, j)
            param <- c(param, match(mapping[paramName], allParams))
        }
    }
    return(tibble::tibble(from = from, param = param))
}

### * All functions in this file are exported

### * run_mcmc()

### ** Doc

#' Run a MCMC sampler on a network model using Stan
#'
#' @param model A \code{networkModel}.
#' @param iter A positive integer specifying the number of iterations for each
#'   chain (including warmup). The default is 2000.
#' @param chains A positive integer specifying the number of Markov chains.
#'   The default is 4.
#' @param method A character string indicating the method to use to solve ODE
#'   in the Stan model; available methods are "matrix_exp" and "euler". The
#'   default is "matrix_exp", which uses matrix exponential and is reasonably
#'   fast for small networks. For large networks, the "euler" method can be
#'   used. It implements a simple forward Euler method to solve the ODE and can
#'   be faster than the matrix exponential approach, but extra caution must be
#'   taken to check for numerical accuracy (e.g. testing different \code{dt}
#'   time step values, ensuring that the product between \code{dt} and the
#'   largest transfer rates expected from the priors is always very small
#'   compared to 1).
#' @param euler_control An optional list containing extra parameters when using
#'   \code{method = "euler"}. Allowed list elements are \code{"dt"} and
#'   \code{"grid_size"}, which are respectively the time step size for
#'   trajectory calculations (\code{"dt"}) or the number of points for the
#'   calculation (\code{"grid_size"}). Only one of "dt" or "grid_size" can be
#'   specified, not both. If none is provided, a default grid size of 256 steps
#'   is used.
#' @param cores Number of cores to use for parallel use. Default is
#'   \code{NULL}, which means to use the value stored in
#'   \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param stanfit If TRUE, returns a `stanfit` object instead of the more
#'   classical `mcmc.list` object. Note that when an `mcmc.list` object is
#'   returned, the original `stanfit` object is still accessible as an
#'   attribute of that object (see Examples).
#' @param vb Boolean, if TRUE will use \code{rstan::vb} for a quick approximate
#'   sampling of the posterior. Important note from \code{?rstan::vb}:
#'   "This is still considered an experimental feature.  We recommend calling
#'   \code{stan} or \code{sampling} for final inferences and only using ‘vb’ to
#'   get a rough idea of the parameter distributions."
#' @param ... Arguments passed to `rstan::sampling` (e.g. iter, chains).
#'
#' @return An object of class `stanfit` returned by `rstan::sampling` if
#'   \code{stanfit = TRUE}, otherwise the result of converting this
#'   \code{stanfit} object with \code{stanfit_to_named_mcmclist} (i.e. an object
#'   of class \code{networkModelStanfit} and \code{mcmc.list}, which still
#'   carries the original `stanfit` object stored as an attribute).
#'
#' @examples
#' aquarium_mod
#' \dontrun{
#'   # The 'aquarium_run' object is shipped with the package, so you don't
#'   # actually need to run the line below to obtain it
#'   aquarium_run <- run_mcmc(aquarium_mod)
#' 
#'   plot(aquarium_run)
#'   summary(aquarium_run)
#'
#'   # The original stanfit object returned by Stan
#'   sfit <- attr(aquarium_run, "stanfit")
#'   sfit
#'
#'   # The stanfit object can be used for diagnostics, LOO cross-validation, etc.
#'   rstan::loo(sfit)
#' }
#' 
#' @export

### ** Code

run_mcmc <- function(model, iter = 2000, chains = 4, method = "matrix_exp",
                     euler_control = list(),
                     cores = NULL, stanfit = FALSE, vb = FALSE, ...) {
    stopifnot(method %in% c("matrix_exp", "euler"))
    if (method != "euler" & length(euler_control) != 0) {
        stop("The `euler_control` parameter is not empty, but `method` is not set to \"euler\".")
    }
    if (method == "euler") {
      if (vb) {
        stop("vb not implemented for euler method")
      }
        fit <- mugen_stan(nm = model, iter = iter, chains = chains,
                          euler_control = euler_control,
                          cores = cores, stanfit = stanfit, ...)
    }
    if (method == "matrix_exp") {
        fit <- matrix_exp_stan(nm = model, iter = iter, chains = chains,
                               cores = cores, stanfit = stanfit,
                               vb = vb, ...)
    }
    return(fit)
}

### * stanfit_to_named_mcmclist()

#' Convert a Stanfit object to a nicely named mcmc.list object
#'
#' When running \code{run_mcmc} with \code{stanfit = FALSE} (typically for
#' debugging purposes), the parameters in the returned \code{stanfit} object
#' are named using a base label and an indexing system. This function provides
#' a way to convert this \code{stanfit} object into a more conventional
#' \code{mcmc.list} object where parameters are named according to their role
#' in the original network model used when running \code{run_mcmc}.
#' 
#' @param stanfit A stanfit object returned by \code{rstan::sampling}.
#' 
#' @return An \code{mcmc.list} object. It also has the original stanfit object
#'   stored as an attribute \code{"stanfit"}.
#'
#' @export

stanfit_to_named_mcmclist <- function(stanfit) {
    stan_data <- attr(stanfit, "isotracer_stan_data")
    fit <- stanfit
    # Get mcpars
    start <- fit@sim[["warmup"]] + 1
    end <- fit@sim[["iter"]]
    thin <- fit@sim[["thin"]]
    n_kept <- fit@sim[["n_save"]] - fit@sim[["warmup2"]]
    mcpars <- c(start, end, thin)
    # Prepare the mcmc.list object
    out <- rstan::As.mcmc.list(fit)
    for (i in seq_along(out)) {
        stopifnot(nrow(out[[i]]) == n_kept)
    }
    attr(out, "mcpar") <- mcpars
    rawNames <- coda::varnames(out)
    nonConstantParamNames <- rawNames[grepl("^nonConstantParams[\\[\\.]",
                                            rawNames)]
    loglikNames <- rawNames[grepl("^log_lik[\\[\\.]", rawNames)]
    ll <- out[, loglikNames]
    out <- out[, nonConstantParamNames]
    coda::varnames(out) <- stan_data[["allParams"]][stan_data[["mappingParamPriorType"]] != 0]
    llTrace <- lapply(ll, function(x) {
        out <- coda::as.mcmc(apply(as.matrix(x), 1, sum))
        attr(out, "mcpar") <- attr(x, "mcpar")
        return(out)
    })
    llTrace <- coda::as.mcmc.list(llTrace)
    attr(out, "loglik") <- llTrace
    attr(out, "mcpar") <- mcpars
    # Add values of constant parameters (if any)
    n_constant_params <- sum(stan_data[["mappingParamPriorType"]] == 0)
    if (n_constant_params > 0) {
        constant_params <- stan_data[["allParams"]][stan_data[["mappingParamPriorType"]] == 0]
        constant_values <- stan_data[["constantParams"]][stan_data[["mappingParamPriorType"]] == 0]
        constant_params <- setNames(constant_values, nm = constant_params)
        attr(out, "constant_params") <- constant_params
    }
    # Return the mcmc.list object
    outClass <- c("networkModelStanfit", class(out))
    attr(out, "stanfit") <- stanfit
    return(structure(out, class = outClass))
}

### * All functions in this file are exported

### * delta2prop()

#' Convert delta notation to proportion of heavy isotope
#'
#' For details and references about quantities used in expressing isotopic
#' ratios, see:
#'
#' - Figure 1 in Coplen, Tyler B. “Guidelines and Recommended Terms for
#' Expression of Stable-Isotope-Ratio and Gas-Ratio Measurement Results.” Rapid
#' Communications in Mass Spectrometry 25, no. 17 (September 15, 2011):
#' 2538–60. https://doi.org/10.1002/rcm.5129.
#'
#' - Table 2.1 in Fry, Brian. Stable Isotope Ecology. New York:
#' Springer-Verlag, 2006. //www.springer.com/gp/book/9780387305134.
#'
#' @section Ratios for reference standards:
#'
#' The ratios for reference standards are taken from the Table 2.1 from Fry
#' 2006. Note that the values used for oxygen isotopes are from the standard
#' mean ocean water (SMOW).
#'
#' Standards recognized by this function are: \code{c("d15N", "d2H", "d13C",
#' "d17O.SMOW", "d18O.SMOW", "d33S", "d34S", "d36S")}
#' 
#' @param x Vector of delta values.
#' @param Rstandard String describing the isotopic measurement, e.g. "d15N",
#'     "d13C" and used to set automatically Rstandards (see the Section
#'     "Ratios for reference standards" for more details). Alternatively, a
#'     numeric value to use for Rstandard, e.g. 0.0036765.
#'
#' @return A vector of same length of x, containing the proportion (numeric
#'     between 0 and 1) of heavy isotope based on the delta values and the
#'     Rstandard provided.
#'
#' @examples
#' deltas <- c(78, 5180, 263, 1065, NA, 153, 345)
#'
#' # Rstandard can be specified with a string for some preset references
#' prop15N <- delta2prop(deltas, "d15N")
#' prop13C <- delta2prop(deltas, "d13C")
#'
#' # Rstandard can also be specified manually for non-preset references
#' prop15N_manual <- delta2prop(deltas, 0.0036765)
#' prop13C_manual <- delta2prop(deltas, 0.011180)
#'
#' # Call delta2prop() to get the detail of available references
#' delta2prop()
#' 
#' @export
#'

delta2prop <- function(x = NULL, Rstandard = NULL) {
    # Known standards
    Rstandards <- list("d15N" = 0.0036765,
                       "d2H" = 0.00015576,
                       "d13C" = 0.011180,
                       "d17O.SMOW" = 0.0003799,
                       "d18O.SMOW" = 0.0020052,
                       "d33S" = 0.0078772,
                       "d34S" = 0.0441626,
                       "d36S" = 0.0001533)
    # Message about available standards
    msg <- paste0("Available standards are:")
    for (i in seq_along(Rstandards)) {
        label <- names(Rstandards)[i]
        string <- paste(label, paste(rep("_", 13 - nchar(label)), collapse = ""))
        value <- Rstandards[[i]]
        msg <- paste(msg, paste(string, value, collapse = ""), sep = "\n    ")
    }
    # Parse argument
    if (is.null(Rstandard)) {
        Rstandard <- "non-specified"
        if (is.null(x)) {
            message(paste(msg, sep = "\n"))
            return(invisible(NULL))
        }
    }
    if (length(Rstandard) > 1) {
      msg <- paste0(
        "The Rstandard argument must be of length 1 but the argument provided was ",
        ifelse(is.numeric(Rstandard), "a numeric vector", "an object"),
        " of length ", length(Rstandard), ".")
      if (is.numeric(Rstandard)) {
        msg <- paste0(
          msg, "\n",
          "If you did not want to pass a numeric vector but rather wanted to ",
          "pass a string defining the standard to use (such as \"d15N\"), maybe ",
          "you forgot the quotes?")
      }
      stop(msg)
    }
    if (is.character(Rstandard)) {
        if (!Rstandard %in% names(Rstandards)) {
            unk_std <- paste0("Rstandard argument (", Rstandard, "): unknown. ",
                              collapse = "")
            msg <- paste0(unk_std, msg, collapse = "")
            stop(msg)
        }
        Rstandard <- Rstandards[[Rstandard]]
    } else if (!is.numeric(Rstandard)) {
        stop("Provided value must the name of a known measurement type or a numeric.")
    }
    # Calculate proportions and return
    R0 <- Rstandard
    props <- R0 * (x/1000 + 1) / (R0 * (x/1000 + 1) + 1)
    return(props)
}

### * prop2delta()

#' Convert isotopic proportions to delta values
#'
#' This function performs the inverse of the operation performed by
#' \code{delta2prop()}.
#'
#' @param x Vector of proportions values.
#' @param Rstandard String describing the isotopic measurement, e.g. "d15N",
#'     "d13C" and used to set automatically Rstandards (see the Section
#'     "Ratios for reference standards" for more details). Alternatively, a
#'     numeric value to use for Rstandard, e.g. 0.0036765.
#'
#' @return A vector of same length of x, containing the delta values based on
#'   the proportions of heavy isotope provided as x and the Rstandard provided.
#'
#' @examples
#' prop15N <- c(0.00395, 0.02222, 0.00462, 0.00753, NA, 0.00422, 0.00492)
#'
#' # Rstandard can be specified with a string for some preset references
#' d15N <- prop2delta(prop15N, "d15N")
#' d15N
#'
#' # Rstandard can also be specified manually for non-preset references
#' d15N_manual <- prop2delta(prop15N, 0.0036765)
#' d15N_manual
#'
#' # Call delta2prop() to get the detail of available references
#' delta2prop()
#'
#' @export

prop2delta <- function(x = NULL, Rstandard = NULL) {
    # Known standards
    Rstandards <- list("d15N" = 0.0036765,
                       "d2H" = 0.00015576,
                       "d13C" = 0.011180,
                       "d17O.SMOW" = 0.0003799,
                       "d18O.SMOW" = 0.0020052,
                       "d33S" = 0.0078772,
                       "d34S" = 0.0441626,
                       "d36S" = 0.0001533)
    # Message about available standards
    msg <- paste0("Available standards are:")
    for (i in seq_along(Rstandards)) {
        label <- names(Rstandards)[i]
        string <- paste(label, paste(rep("_", 13 - nchar(label)), collapse = ""))
        value <- Rstandards[[i]]
        msg <- paste(msg, paste(string, value, collapse = ""), sep = "\n    ")
    }
    # Parse argument
    if (is.null(Rstandard)) {
        Rstandard <- "non-specified"
        if (is.null(x)) {
            message(paste(msg, sep = "\n"))
            return(invisible(NULL))
        }
    }
    if (length(Rstandard) > 1) {
      msg <- paste0(
        "The Rstandard argument must be of length 1 but the argument provided was ",
        ifelse(is.numeric(Rstandard), "a numeric vector", "an object"),
        " of length ", length(Rstandard), ".")
      if (is.numeric(Rstandard)) {
        msg <- paste0(
          msg, "\n",
          "If you did not want to pass a numeric vector but rather wanted to ",
          "pass a string defining the standard to use (such as \"d15N\"), maybe ",
          "you forgot the quotes?")
      }
      stop(msg)
    }
    if (is.character(Rstandard)) {
        if (!Rstandard %in% names(Rstandards)) {
            unk_std <- paste0("Rstandard argument (", Rstandard, "): unknown. ",
                              collapse = "")
            msg <- paste0(unk_std, msg, collapse = "")
            stop(msg)
        }
        Rstandard <- Rstandards[[Rstandard]]
    } else if (!is.numeric(Rstandard)) {
        stop("Provided value must the name of a known measurement type or a numeric.")
    }
    # Calculate deltas and return
    R0 <- Rstandard
    deltas <- (1/R0 * x / (1 - x) - 1) * 1000
    return(deltas)
}

### * filter_by_group

#' Filter a tibble based on the "group" column
#'
#' This function can be used to filter any tibble (e.g. network model object)
#' that has a "group" column. See the Examples for more details and syntax.
#'
#' @param .data A tibble that has a `group` column, such as a `networkModel`
#'     object.
#' @param ... Conditional expressions for filtering (see the Examples).
#'
#' @return A tibble similar to the input object, but with rows filtered based
#'     on \code{...}.
#' 
#' @examples
#' trini_mod
#' trini_mod$group
#' groups(trini_mod)
#' filter_by_group(trini_mod, stream == "LL", transect == "transect.1")
#' filter_by_group(trini_mod, transect == "transect.1")
#' \dontrun{
#' # The code below would raise an error because there is no "color" grouping variable.
#' filter_by_group(trini_mod, color == "red")
#' }
#'
#' @export
#'

filter_by_group <- function(.data, ...) {
    if (dplyr::is_grouped_df(.data)) {
        warning("\"groups\" attribute is not kept in returned object.")
    }
    is_grouped <- TRUE
    if (!"group" %in% colnames(.data)) {
        is_grouped <- FALSE
    }
    if (nrow(.data) == 0 |
        (nrow(.data) == 1 && is.null(.data$group[[1]]))) {
        is_grouped <- FALSE
    }
    if (!is_grouped) {
        stop("Input data does not have a valid \"group\" column.")
    }
    if (!length(unique(lapply(.data$group, names))) == 1) {
        stop("Variable names are not consistent in \"group\" column.")
    }
    grp <- tibble::as_tibble(do.call(rbind, .data$group))
    if (".my_index" %in% names(grp)) {
        stop("\"group\" column already has the reserved \".my_index\" field.")
    }
    grp$.my_index <- seq_len(nrow(grp))
    filtered <- dplyr::filter(grp, ...)
    return(.data[filtered$.my_index, ])
}

### * dic()

#' Calculate DIC from a model output
#'
#' Note that DIC might not be indicated for network models, as the posteriors
#' are often not multinormal distributions.
#'
#' LOO is probably not a good choice either since the data is akin to a time
#' series (so data points are not independent). Maybe WAIC could be an option?
#' (TODO: read about this.)
#'
#' DIC is calculated as:
#'
#' DIC = Dbar + pD
#'
#' where D are deviance values calculated as -2 * loglik for each MCMC
#' iteration, Dbar is the mean deviance value and pD is the effective number of
#' parameters in the model and can be calculated as var(D)/2 (Gelman 2003).
#' 
#' @param ... One or several \code{mcmc.list} objects, output(s) from
#'     \code{\link{run_mcmc}}.
#' @param weight Boolean, if TRUE calculate DIC weights based on Link and
#'     Barker 2010 (Link, W. A., and R. J. Barker. 2010. Bayesian Inference
#'     With Ecological Applications. Amsterdam Boston Heidelberg London:
#'     Elsevier/Academic Press).
#'
#' @return A tibble with one row per \code{mcmc.list} object provided in
#'     \code{...}. This tibble is sorted by DIC, so the row order might be
#'     different from the \code{mcmc.list} objects order.
#'
#' @examples
#' \donttest{
#' # Define two different models
#' m1 <- aquarium_mod
#' m2 <- set_topo(m1, c("NH4 -> algae -> daphnia -> NH4", "algae -> NH4"))
#' m2 <- set_priors(m2, priors(m1))
#' m2 <- set_priors(m2, normal_p(0, 0.5), "upsilon_algae_to_NH4")
#' # Run the models
#' r1 <- run_mcmc(m1, chains = 2)
#' r2 <- run_mcmc(m2, chains = 2)
#' # Model comparison with DIC
#' dic(r1, r2)
#' }
#' 
#' @export
#' 

# TODO add formula for DIC calculation in function doc.

dic <- function(..., weight = TRUE) {
    # Deparse based on https://stackoverflow.com/questions/51259346/how-to-get-names-of-dot-dot-dot-arguments-in-r
    # (but I don't understand how it works)
    names <- sapply(substitute(list(...))[-1], deparse)
    logliks <- lapply(list(...), function(x) attr(x, "loglik"))
    if (any(sapply(logliks, is.null))) {
        stop("No \"loglik\" attribute found for at least one input object.")
    }
    logliks <- lapply(logliks, unlist)
    D <- lapply(logliks, function(x) -2 * x)
    Dbar <- sapply(D, mean)
    pD <- sapply(D, function(x) var(x) / 2)
    out <- tibble::tibble(fit = names,
                          Dbar = Dbar,
                          pD = pD)
    out[["DIC"]] <- out$Dbar + out$pD
    min_DIC <- min(out[["DIC"]])
    out[["delta_DIC"]] <- out[["DIC"]] - min_DIC
    num <- exp(- out[["delta_DIC"]] / 2)
    denom <- sum(num)
    out[["weight"]] <- num / denom
    out <- out[order(out$delta_DIC), ]
    return(out)
}

### * All functions in this file are exported

### * ggtopo (generic)

#' Plot a topology
#'
#' A quick plot using ggraph
#'
#' @param x A network model or a topology matrix.
#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
#' @param edge "fan" (the default) or "line" or "curve".
#' @param ... Passed to the methods.
#'
#' @return A ggplot2 plot.
#' 
#' @examples
#' if (requireNamespace("ggraph")) {
#'   ggtopo(aquarium_mod, edge = "line")
#' }
#'
#' @export

ggtopo <- function(x, layout = "auto", edge = "fan", ...) {
    UseMethod("ggtopo")
}

### * ggtopo.networkModel

#' Plot a network topology
#'
#' A quick plot using ggraph
#'
#' @param x A topology matrix.
#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
#' @param edge "curve" (the default) or "line".
#' @param ... Not used for now.
#'
#' @return A ggplot2 plot.
#' 
#' @examples
#' if (requireNamespace("ggraph")) {
#'   ggtopo(aquarium_mod, edge = "line")
#'   ggtopo(trini_mod)
#' }
#'
#' @export

ggtopo.networkModel <- function(x, layout = "auto", edge = "fan", ...) {
    topos <- topo(x, simplify = FALSE)
    if (length(unique(topos)) > 1) {
        message("Plotting the topology of the first row of the networkModel.")
    }
    topo <- topos[[1]]
    ggtopo(topo, layout = layout, edge = edge)
}

### * ggtopo.topology

#' Plot a topology
#'
#' A quick plot using ggraph
#'
#' @param x A topology matrix.
#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
#' @param edge "curve" (the default), "line" or "fan".
#' @param ... Not used for now.
#'
#' @return A ggplot2 plot.
#' 
#' @examples
#' if (requireNamespace("ggraph")) {
#'   z <- topo(aquarium_mod)
#'   ggtopo(z)
#'   ggtopo(z, edge = "line")
#' 
#'   z <- topo(trini_mod)
#'   ggtopo(z)
#'
#'   # For finer control, one can build a tbl_graph from the topology and
#'   # use ggraph directly
#'   x <- as_tbl_graph(z)
#'   library(ggraph)
#'   ggraph(x) + geom_edge_link()
#' }
#'
#' @export

ggtopo.topology <- function(x, layout = "auto", edge = "fan", ...) {
    `!!` <- rlang::`!!`
    topo <- x
    if (!edge %in% c("curve", "line", "fan")) {
        stop("edge should be either \"curve\", \"fan\", or \"line\".")
    }
    if (!requireNamespace("ggraph", quietly = TRUE)) {
        stop("Package \"ggraph\" needed for this function to work. Please install it.",
             call. = FALSE)
    }
    x <- as_tbl_graph(topo)
    # https://stackoverflow.com/questions/49989158/how-to-have-a-removed-from-a-ggraph-plot-legend
    GeomLabel <- ggplot2::GeomLabel
    GeomLabel$draw_key <- function(data, params, size) {
        ggplot2::draw_key_rect(data)
    }
    # Check that the random seed  is not reset by graphlayouts functions
    if (exists(".Random.seed", .GlobalEnv)) {
        prev_seed <- .GlobalEnv[[".Random.seed"]]
    } else { prev_seed <- NULL }
    msg_ggraph <- capture_msg(ggraph::ggraph(x, layout = layout))
    if (!is.null(msg_ggraph) && msg_ggraph$message == "Multiple parents. Unfolding graph\n") {
        message("\"stress\" layout cannot handle this topology. ",
                "Using \"kk\" layout instead.")
        layout <- "kk"
    }
    g <- ggraph::ggraph(x, layout = layout)
    if (exists(".Random.seed", .GlobalEnv)) {
        new_seed <- .GlobalEnv[[".Random.seed"]]
    }  else { new_seed <- NULL }
    if (!identical(prev_seed, new_seed)) {
        stop("Random seed was reset when calling ggraph::ggraph() in ggtopo().\n",
             "This is unwanted behaviour, please report it as a bug to the isotracer authors.")
    }
    if (edge == "curve") {
        g <- g +
            ggraph::geom_edge_diagonal(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
                                                    end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name")))),
                                       arrow = grid::arrow(length = grid::unit(1, "line")))
    } else if (edge == "fan") {
        g <- g +
            ggraph::geom_edge_fan(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
                                                    end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name")))),
                                       arrow = grid::arrow(length = grid::unit(1, "line")))
    } else {
        g <- g +
            ggraph::geom_edge_link(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
                                                end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name")))),
                                   arrow = grid::arrow(length = grid::unit(1, "line")))
    }
    g <- g +
        ggraph::geom_node_label(ggplot2::aes(label = `!!`(rlang::sym("name")),
                                    fill = `!!`(rlang::sym("steady_state"))),
                                col = "black",
                                fontface = 1,
                                label.padding = grid::unit(0.5, "line"),
                                label.r = grid::unit(0.5, "line")) +
        ggplot2::coord_cartesian(clip = "off") +
        ggraph::theme_graph(base_family = "sans") # https://github.com/thomasp85/ggraph/issues/67
    g <- g + ggplot2::scale_fill_manual(values = c("FALSE" = "#a6cee3",
                                                   "TRUE" = "#b2df8a"),
                                        labels = c("FALSE" = "No",
                                                   "TRUE" = "Yes")) +
        ggplot2::labs(fill = "Steady state")
    if (length(attr(topo, "steadyState")) == 0) {
        g <- g + ggplot2::theme(legend.position = "none")
    }
    return(g)
}

### * ggflows()

#' A quick-and-dirty way of visualizing relative flows in a network
#'
#' @param x A tibble with the flow estimates, with columns "from", "to", and
#'     "flow".
#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
#' @param edge "curve" (the default), "line" or "fan".
#' @param max_width Optional, numeric giving the maximum edge width (minimum
#'     width is always 1).
#' @param legend Boolean, display edge width legend?
#' @param ... Not used.
#'
#' @return A ggplot2 plot.
#' 
#' @examples
#' if (requireNamespace("ggraph")) {
#'   z <- tibble::tribble(
#'                ~from,               ~to,            ~flow,
#'      "leavesAndStem", "rootsAndRhizome", 333.929866077124,
#'         "lowerWater", "rootsAndRhizome", 4425.15780019304,
#'    "rootsAndRhizome",   "leavesAndStem", 525.208837577916,
#'         "upperWater",   "leavesAndStem", 11224.0814971855
#'   )
#'   ggflows(z)
#'   ggflows(z, max_width = 15)
#' }
#'
#' @export
#' 

ggflows <- function(x, layout = "auto", edge = "fan", max_width, legend = TRUE, ...) {
    `!!` <- rlang::`!!`
    if (! all(c("from", "to", "flow") %in% colnames(x))) {
        stop("`x` must have at least columns \"from\", \"to\", and \"flow\".")
    }
    if (!requireNamespace("ggraph", quietly = TRUE)) {
        stop("Package \"ggraph\" needed for this function to work. Please install it.",
             call. = FALSE)
    }
    if (!requireNamespace("tidygraph", quietly = TRUE)) {
        stop("Package \"tidygraph\" needed for this function to work. Please install it.",
             call. = FALSE)
    }
    x <- x[, c("from", "to", "flow")]
    if (!edge %in% c("curve", "line", "fan")) {
        stop("edge should be either \"curve\", \"fan\", or \"line\".")
    }
    # https://stackoverflow.com/questions/49989158/how-to-have-a-removed-from-a-ggraph-plot-legend
    # https://stackoverflow.com/questions/56173310/how-to-adjust-the-width-of-edges-by-weight-in-ggraph-network-in-r
    GeomLabel <- ggplot2::GeomLabel
    GeomLabel$draw_key <- function(data, params, size) {
        ggplot2::draw_key_rect(data)
    }
    g <- ggraph::ggraph(x, layout = layout)
    if (edge == "curve") {
        g <- g +
            ggraph::geom_edge_diagonal(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
                                                    end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name"))),
                                                    width = `!!`(rlang::sym("flow"))),
                                       arrow = grid::arrow(length = grid::unit(1, "line")))
    } else if (edge == "fan") {
        g <- g +
            ggraph::geom_edge_fan(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
                                               end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name"))),
                                               width = `!!`(rlang::sym("flow"))),
                                       arrow = grid::arrow(length = grid::unit(1, "line")))
    } else {
        g <- g +
            ggraph::geom_edge_link(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
                                                end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name"))),
                                                width = `!!`(rlang::sym("flow"))),
                                   arrow = grid::arrow(length = grid::unit(1, "line")))
    }
    g <- g +
        ggraph::geom_node_label(ggplot2::aes(label = `!!`(rlang::sym("name"))),
                                fill = grey(0.9),
                                fontface = 1,
                                label.padding = grid::unit(0.5, "line"),
                                label.r = grid::unit(0.5, "line")) +
        ggplot2::coord_cartesian(clip = "off") +
        ggraph::theme_graph(base_family = "sans") # https://github.com/thomasp85/ggraph/issues/67
    if (!missing(max_width)) {
        if (max_width < 1) {
            stop("`max_width` must be >= 1.")
        }
        g <- g +
            ggraph::scale_edge_width(range = c(1, max_width))
    }
    if (!legend) {
        g <- g + ggplot2::theme(legend.position = "none")
    }
    return(g)
}

### * TODO

# Clean-up this file

### * None of the functions in this file is exported

### * group2string()

#' Convert a group entry to a string
#'
#' @param x A vector describing a group. Can be NULL.
#'
#' @return A string.
#'
#' @keywords internal
#' @noRd

group2string <- function(x) {
    if (is.null(x)) {
        return("NULL")
    }
    n <- names(x)
    s <- paste(paste(n, x, sep = "="), collapse = "; ")
    return(s)
}

### * Alias for tidy_mcmc()

#' @keywords internal
#' @noRd

tidy_mcmc_list <- function(...) {
    tidy_mcmc(...)
}

### * None of the functions in this file is exported

### * mugen_stan()

#' Run a stan model from a network model (temporary name)
#'
#' Incorporate a loglik trace: https://mc-stan.org/loo/reference/extract_log_lik.html
#'
#' @param nm A \code{networkModel} object.
#' @param iter A positive integer specifying the number of iterations for each
#'     chain (including warmup). The default is 2000.
#' @param chains A positive integer specifying the number of Markov chains.
#'     The default is 4.
#' @param euler_control An optional list containing extra parameters for the
#'     Euler method. The list elements can be \code{"dt"} or
#'     \code{"grid_size"}, which are respectively the time step size for
#'     trajectory calculations (\code{"dt"}) or the number of points for the
#'     calculation (\code{"grid_size"}). If none is provided, a default grid
#'     size of 256 steps is used.
#' @param cores Number of cores to use for parallel run. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param stanfit If TRUE, returns a `stanfit` object instead of the more
#'     classical `mcmc.list` object.
#' @param use_fixed_values Boolean, if TRUE any parameter value set with
#'     \code{set_params()} will be taken as fixed during the MCMC run. Default
#'     is FALSE.
#' @param ... Passed to \code{rstan::sampling}.
#'
#' @keywords internal
#' @noRd

mugen_stan <- function(nm, iter = 2000, chains = 4, euler_control = list(),
                       cores = NULL, stanfit = FALSE,
                       use_fixed_values = FALSE, ...) {
    # Detect cores
    cores <- get_n_cores(cores = cores)
    # Convert network model to stan data
    stan.data <- prep_stan_data_euler(nm, dt = euler_control[["dt"]],
                                      grid_size = euler_control[["grid_size"]],
                                      use_fixed_values = use_fixed_values)
    # Fit the model
    stan.data[["ode_method"]] <- 2 # For Euler scheme
    fit <- rstan::sampling(stanmodels[["networkModel"]],
                           data = stan.data,
                           iter = iter,
                           chains = chains,
                           cores = cores,
                           pars = c("nonConstantParams", "log_lik",
                                    "rawUniformParams", "rawHcauchyParams",
                                    "rawBetaParams", "rawTrNormParams",
                                    "rawExponentialParams", "rawGammaParams"), ...)
    stopifnot(!"isotracer_stan_data" %in% names(attributes(fit)))
    attr(fit, "isotracer_stan_data") <- stan.data
    # Return
    if (stanfit) {
        return(fit)
    } else {
        return(stanfit_to_named_mcmclist(stanfit = fit))
    }
}

### * prep_stan_data_euler()

#' Prepare stan data from a network model
#'
#' @param nm A \code{networkModel} object.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param use_fixed_values Boolean, if TRUE any parameter value set with
#'     \code{set_params()} will be taken as fixed during the MCMC run. Default
#'     is FALSE.
#' 
#' @keywords internal
#' @noRd

prep_stan_data_euler <- function(nm, dt = NULL, grid_size = NULL,
                                 use_fixed_values = FALSE) {
    d <- list()
    end <- NULL
    params_nm <- params(nm, simplify = TRUE)
    priors_nm <- priors(nm, fix_set_params = use_fixed_values,
                        quiet = TRUE)
    priors_nm <- priors_nm[match(params_nm, priors_nm[["in_model"]]), ]
    stopifnot(all(params_nm == priors_nm[["in_model"]]))
    # For now the stan model is only implemented for network models with the
    # same number of compartments on each row (a more general case where rows
    # can have different numbers of compartments is easily converted to this
    # case, by adding compartments without connections to fill the topology in
    # each row).
    stopifnot(length(unique(sapply(comps(nm), length))) == 1)
    # Counts
    d[["nComps"]] <- length(comps(nm)[[1]])
    d[["nGroups"]] <- nrow(nm)
    d[["nParams"]] <- length(params_nm)
    # Encode steady state compartments
    dSteady <- encode_steady(nm)
    d <- c(d, dSteady)
    # Encode split compartments
    dSplit <- encode_split(nm, params_nm)
    d <- c(d, dSplit)
    # Encode initial conditions
    dInit <- encode_init(nm)
    d <- c(d, dInit)
    # Encode events
    dEvents <- encode_events(nm, dt = dt, grid_size = grid_size, end = end)
    d <- c(d, dEvents)
    # Encode observations (including eta and zeta parameter indices)
    dObs <- encode_obs(nm, params_nm, dt = dt, grid_size = grid_size, end = end)
    d <- c(d, dObs)
    # Encode parameter priors
    dPriors <- encode_priors(params_nm, priors_nm)
    d <- c(d, dPriors)
    # Encode time schemes
    dTimeSchemes <- encode_time_schemes(nm, dt = dt, grid_size = grid_size,
                                        end = end)
    d <- c(d, dTimeSchemes)
    # Encode uptake rates (upsilons)
    dUpsilons <- encode_upsilons(nm, params_nm)
    d <- c(d, dUpsilons)
    # Encode losses (lambdas)
    dLambdas <- encode_lambdas(nm, params_nm)
    d <- c(d, dLambdas)
    # Encode decay rate for radioactive tracers
    lambda_decay <- attr(nm, "lambda_hl")
    if (is.null(lambda_decay)) {
        lambda_decay <- 0
    }
    d[["lambda_decay"]] <- lambda_decay
    # Encode distribution families (for proportions and sizes)
    d <- c(d, encode_distrib_families(nm))
    # Add encoding for matrix exponential (so that the Stan model does not crash)
    d[["allParams"]] <- params_nm
    matrix_exp <- encode_intervals(nm)
    matrix_exp <- c(matrix_exp, encode_unique_obs_times(nm))
    stopifnot(!any(names(matrix_exp) %in% names(d)))
    d <- c(d, matrix_exp)
    return(d)
}

### * encode_events()

#' Encode events (for Stan model using Euler integration)
#'
#' For now, only pulse events are encoded.
#'
#' @param nm A \code{networkModel} object.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param end Time value for end point. If not provided, the last observation
#'     or event is used.
#'
#' @examples
#' encode_events <- isotracer:::encode_events
#' encode_events(aquarium_mod)
#' encode_events(trini_mod)
#' 
#' @keywords internal
#' @noRd

encode_events <- function(nm, dt = NULL, grid_size = NULL, end = NULL) {
    d <- nm_get_time_schemes(nm, dt = dt, grid_size = grid_size, end = end)
    nGroups <- nrow(nm)
    o <- list()
    events <- nm[["events"]]
    stopifnot(all(dplyr::bind_rows(events)[["event"]] == "pulse"))
    # Encode compartments and timepoints
    for (i in seq_len(nrow(nm))) {
        comps <- colnames(nm$topology[[i]])
        comps <- setNames(seq_along(comps), nm = comps)
        if (!is.null(events[[i]])) {
            events[[i]]$compartment <- comps[events[[i]]$compartment]
            events[[i]]$timepoints <- match(events[[i]]$time, d$timepoints[[i]])
        }
    }
    # Encode the number of events
    if (length(events) == 0) {
        nEvents <- rep(0, nrow(nm))
    } else {
        nEvents <- sapply(events, function(x) {
            if (is.null(x)) return(0)
            return(nrow(x))
        })
    }
    o[["maxNpulseEvents"]] <- max(nEvents)
    o[["nPulseEvents"]] <- setNames(c(nEvents, 0), # Padded
                                    nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
    # Encode pulses
    o[["pulseEventsIndices"]] <- array(0, dim = c(max(nEvents), 2, nGroups),
                                       dimnames = list(seq_len(max(nEvents)),
                                                       c("timepoint", "comp"),
                                                       paste0("grp", seq_len(nGroups))))
    o[["pulseEventsQuantities"]] <- array(0, dim = c(max(nEvents), 2, nGroups),
                                          dimnames = list(seq_len(max(nEvents)),
                                                          c("unmarked", "marked"),
                                                          paste0("grp", seq_len(nGroups))))
    for (i in seq_len(nGroups)) {
        if (!is.null(events[[i]])) {
            o[["pulseEventsIndices"]][1:nEvents[i], 1:2, i] <-
                as.matrix(events[[i]][, c("timepoints", "compartment")])
            chars <- lapply(events[[i]]$characteristics, tibble::as_tibble)
            chars <- dplyr::bind_rows(chars)[, c("unmarked", "marked")]
            o[["pulseEventsQuantities"]][1:nEvents[i], 1:2, i] <-
                as.matrix(chars)
        }
    }
    # Return
    return(o)
}

### ** nm_get_time_schemes()

#' Build the time schemes for numerical solving of the system of differential equations
#'
#' This function processes each row of a networkModel. It always assumes that
#' the starting time point is t=0.
#'
#' @param nm A networkModel
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param end Time value for end point. If not provided, the last observation
#'     or event is used.
#' @param at Optional, vector of time values at which the trajectory must be
#'     evaluated
#'
#' @keywords internal
#' @noRd

nm_get_time_schemes <- function(nm, dt = NULL, grid_size = NULL, end = NULL,
                                at = NULL) {
    # Get the time schemes for each row of nm
    ts <- lapply(seq_len(nrow(nm)), function(i) {
        z <- nm_row_get_time_scheme(nm[i, ], dt = dt, grid_size = grid_size,
                                    end = end, at = at)
        z <- tibble::as_tibble(lapply(z, list))
    })
    ts <- dplyr::bind_rows(ts)
    return(ts)    
}

### ** nm_row_get_time_scheme()

#' Build the time scheme for numerical solving of the system of differential equations
#'
#' This function is applied to one row of a networkModel. It always assumes
#' that the starting time point is t=0.
#'
#' @param nm_row A row from a \code{networkModel} object.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param end Time value for end point. If not provided, the last observation
#'     or event is used.
#' @param at Optional, vector of time values at which the trajectory must be
#'     evaluated
#'
#' @examples
#' isotracer:::nm_row_get_time_scheme(aquarium_mod)
#' 
#' @keywords internal
#' @noRd

nm_row_get_time_scheme <- function(nm_row, dt = NULL, grid_size = NULL, end = NULL,
                                   at = NULL) {
    nmRow <- nm_row
    stopifnot(nrow(nmRow) == 1)
    # Parse dt and gridsize
    if (!(is.null(dt) | is.null(grid_size))) {
        stop("Only \"dt\" or \"grid_size\" can be specified, not both.")
    }
    if (is.null(dt) & is.null(grid_size)) {
        grid_size <- 256
    }
    # Get observation times
    observations <- nmRow[["observations"]][[1]]
    obsTimes <- observations[["time"]]
    obsTimes <- sort(unique(obsTimes))
    # Get events time
    eventTimes <- c()
    if (!is.null(nmRow[["events"]][[1]])) {
        eventTimes <- unique(nmRow[["events"]][[1]]$time)
    }
    # Get "at" times
    atTimes <- c()
    if (!is.null(at)) {
        atTimes <- unique(at)
    }
    # Get end time
    if (is.null(end)) {
        maxTime <- max(c(obsTimes, eventTimes, atTimes))
    } else {
        maxTime <- end
    }
    # Calculate dt
    if (is.null(dt)) {
        dt <- maxTime / grid_size
    }
    # Generate a time scheme
    timepoints <- c(seq(0, maxTime, by = dt), obsTimes, eventTimes, atTimes)
    timepoints <- sort(unique(timepoints))
    timepoints <- timepoints[timepoints <= maxTime]
    # (if end = NULL, timepoints is a timeline with timesteps at most dt wide
    # and containing all the observations sampling times and the event times,
    # even if not a multiple of dt.)
    # (else, timepoints is truncated at end.)
    # Annotate the observations tibble with the timepoints ids
    observations[["timepoint"]] <- match(observations[["time"]], timepoints)
    if (is.null(end)) {
        stopifnot(!any(is.na(observations[["timepoint"]])))
    }
    # Get unique dts
    dts <- timepoints_to_dt(timepoints)
    # Return
    return(list(timepoints = timepoints,
                unique_dt = dts[["unique_dt"]],
                dt_i = dts[["dt_i"]],
                observations = observations))
}

### ** timepoints_to_dt()

#' Prepare the set of unique dt from a vector of timepoints
#'
#' Useful to identify how many different transfer matrices have to be calculated.
#'
#' @param timepoints Numeric vector of timepoints, sorted.
#'
#' @keywords internal
#' @noRd

timepoints_to_dt <- function(timepoints) {
    dts <- diff(timepoints)
    uniqueDts <- sort(unique(dts))
    dt_i <- match(dts, uniqueDts)
    stopifnot(!any(is.na(dt_i)))
    return(list(unique_dt = uniqueDts,
                dt_i = dt_i))
}

### * encode_obs()

#' Encode observations for a network model
#'
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param end Time value for end point. If not provided, the last observation
#'     or event is used.
#' 
#' @return NULL if the observations column only contain NULLs.
#'
#' @importFrom stats na.omit
#' 
#' @keywords internal
#' @noRd

encode_obs <- function(nm, allParams, dt = NULL, grid_size = NULL, end = NULL) {
    d <- nm_get_time_schemes(nm, dt = dt, grid_size = grid_size, end = end)
    nGroups <- nrow(nm)
    zeta_by_comp <- attr(nm, "size_zeta_per_compartment")
    if (is.null(zeta_by_comp)) {
        zeta_by_comp<- FALSE
    }
    # TODO Add filtering to keep only compartments present in topo
    # TODO Handle gracefully the case without observations
    if (all(sapply(nm$observations, is.null))) {
        return(NULL)
    }
    # Get sizes
    sizes <- purrr::map(d$observations, function(x) {
        na.omit(x[, c("compartment", "size", "timepoint")])
    })
    # Get proportions
    props <- purrr::map(d$observations, function(x) {
        na.omit(x[, c("compartment", "proportion", "timepoint")])
    })
    # Encode compartments
    for (i in seq_len(nrow(nm))) {
        comps <- colnames(nm$topology[[i]])
        comps <- setNames(seq_along(comps), nm = comps)
        sizes[[i]]$compartment <- comps[sizes[[i]]$compartment]
        props[[i]]$compartment <- comps[props[[i]]$compartment]
    }
    # Encode sizes and props
    o <- list()
    o[["nSizesObs"]] <- c(purrr::map_dbl(sizes, nrow), 0) # Padded
    names(o[["nSizesObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
    o[["nPropsObs"]] <- c(purrr::map_dbl(props, nrow), 0) # Padded
    names(o[["nPropsObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
    o[["maxNsizesObs"]] <- max(o[["nSizesObs"]])
    o[["maxNpropsObs"]] <- max(o[["nPropsObs"]])
    # Prepare containers
    o[["sizesObsIndices"]] <- array(0, dim = c(o[["maxNsizesObs"]], 3, nGroups),
                                    dimnames = list(seq_len(o[["maxNsizesObs"]]),
                                                    c("comp", "timepoint", "zeta"),
                                                    paste0("grp", seq_len(nGroups))))
    o[["sizesObs"]] <- array(0, dim = c(o[["maxNsizesObs"]], nGroups),
                             dimnames = list(seq_len(o[["maxNsizesObs"]]),
                                             paste0("grp", seq_len(nGroups))))
    o[["propsObsIndices"]] <- array(0, dim = c(o[["maxNpropsObs"]], 3, nGroups),
                                    dimnames = list(seq_len(o[["maxNpropsObs"]]),
                                                    c("comp", "timepoint", "eta"),
                                                    paste0("grp", seq_len(nGroups))))
    o[["propsObs"]] <- array(0, dim = c(o[["maxNpropsObs"]], nGroups),
                             dimnames = list(seq_len(o[["maxNpropsObs"]]),
                                             paste0("grp", seq_len(nGroups))))
    # Fill containers
    for (g in seq_len(nGroups)) {
        if (o[["nSizesObs"]][g] > 0) {
            o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 1:2, g] <- as.matrix(sizes[[g]][, c("compartment", "timepoint")])
            o[["sizesObs"]][1:o[["nSizesObs"]][g], g] <- as.matrix(sizes[[g]][, c("size")])
            if (!zeta_by_comp) {
                zeta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "zeta"]
                zeta_index <- match(zeta_global, allParams)
                o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
            } else {
                comps <- colnames(nm$topology[[g]])
                comps <- setNames(seq_along(comps), nm = comps)
                zeta_replicate <- paste0("zeta_", names(comps)[sizes[[g]][["compartment"]]])
                zeta_global <- nm[["parameters"]][[g]]$in_model[match(zeta_replicate, nm[["parameters"]][[g]]$in_replicate)]
                zeta_index <- match(zeta_global, allParams)
                o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
            }
        }
    }
    for (g in seq_len(nGroups)) {
        if (o[["nPropsObs"]][g] > 0) {
            o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 1:2, g] <- as.matrix(props[[g]][, c("compartment", "timepoint")])
            o[["propsObs"]][1:o[["nPropsObs"]][g], g] <- as.matrix(props[[g]][, c("proportion")])
            eta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "eta"]
            eta_index <- match(eta_global, allParams)
            o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 3, g] <- eta_index
        }
    }
    # Return
    return(o)
}

### * encode_time_schemes()

#' Encode the time schemes for stan data
#'
#' @param nm A \code{networkModel} object.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param end Time value for end point. If not provided, the last observation
#'     or event is used.
#'
#' @keywords internal
#' @noRd

encode_time_schemes <- function(nm, dt = NULL, grid_size = NULL, end = NULL) {
    # (timestep and dt are used interchangeably)
    # Get the time schemes
    ts <- nm_get_time_schemes(nm, dt = dt, grid_size = grid_size, end = end)
    # Build the arrays
    nGroups <- nrow(nm)
    n_unique_dts <- purrr::map_dbl(ts$unique_dt, length)
    maxN_unique_dts <- max(n_unique_dts)
    n_timesteps <- purrr::map_dbl(ts$dt_i, length)
    maxN_timesteps <- max(n_timesteps)
    unique_dts <- array(0, dim = c(maxN_unique_dts, nGroups),
                        dimnames = list(c(1:maxN_unique_dts),
                                        paste0("grp", 1:nGroups)))
    timesteps <- array(0, c(maxN_timesteps, nGroups),
                       dimnames = list(c(1:maxN_timesteps),
                                        paste0("grp", 1:nGroups)))
    # Fill the arrays
    for (i in seq_len(nrow(nm))) {
        unique_dts[1:n_unique_dts[i], i] <- ts[["unique_dt"]][[i]]
        timesteps[1:n_timesteps[i],  i] <- ts[["dt_i"]][[i]]
    }
    # Prepare data
    d <- list()
    d[["nTimesteps"]] <- setNames(c(n_timesteps, 0), # Padded
                                  nm = c(paste0("grp", 1:nGroups), "padding"))
    d[["nUniqueDts"]] <- setNames(c(n_unique_dts, 0), # Padded
                                  nm = c(paste0("grp", 1:nGroups), "padding"))
    d[["timesteps"]] <- timesteps
    d[["unique_dts"]] <- unique_dts
    d[["maxNtimesteps"]] <- max(d[["nTimesteps"]])
    d[["maxNuniqueDts"]] <- max(d[["nUniqueDts"]])
    return(d)
}

### * TODO

# Clean-up this file

### * All functions in this file are exported

### * plot.networkModel()

#' Plot observations/trajectories/predictions from a network model
#'
#' @param x A \code{networkModel} object.
#' @param ... Passed to \code{plot_nm}.
#'
#' @return Called for side effect (plotting).
#' 
#' @method plot networkModel
#' 
#' @export

plot.networkModel <- function(x, ...) {
    plot_nm(x, ...)
}

### * plot.ready_for_unit_plot()

#' Plot output from \code{split_to_unit_plot}
#'
#' @param x A \code{ready_for_unit_plot} object.
#' @param ... Passed to \code{plot_nm}.
#'
#' @return Called for side effect (plotting).
#' 
#' @method plot ready_for_unit_plot
#'
#' @export

plot.ready_for_unit_plot <- function(x, ...) {
    plot_nm(x, ...)
}

### * plot.networkModelStanfit()

#' @method plot networkModelStanfit
#'
#' @export

plot.networkModelStanfit <- function(x, ...) {
    plot_traces(x, ...)
}

### * plot.tidy_flows_mcmc.list()

#' @method plot tidy_flows_mcmc.list
#'
#' @export

plot.tidy_flows_mcmc.list <- function(x, ...) {
    plot_traces(x, ...)
}

### * plot.derived.mcmc.list()

#' @method plot derived.mcmc.list
#'
#' @export

plot.derived.mcmc.list <- function(x, ...) {
    plot_traces(x, ...)
}

### * traceplot()

#' Plot mcmc.list objects
#'
#' @param x A \code{coda::mcmc.list} object.
#' @param ... Passed to \code{plot_traces}.
#'
#' @return Called for side effect (plotting).
#' 
#' @export

traceplot <- function(x, ...) {
    plot_traces(x, ...)
}

### * mcmc_heatmap()

#' Draw a heatmap based on the correlations between parameters
#'
#' Note that the colors represent the strength of the correlations (from 0 to
#' 1), but do not inform about their sign. The method used to calculate
#' correlation coefficients is Spearman's rho.
#'
#' @param x A \code{coda::mcmc.list} object.
#' @param col Optional, vectors of colors defining the color ramp. Default uses
#'     the divergent palette "Blue-Red 2" from the colorspace package.
#' @param ... Passed to \code{\link{heatmap}}.
#'
#' @return Called for side effect (plotting).
#' 
#' @importFrom grDevices heat.colors
#' @importFrom grDevices colorRampPalette
#' @importFrom stats dist
#' @importFrom stats cor
#' @importFrom stats hclust
#' @importFrom stats heatmap
#' 
#' @export

mcmc_heatmap = function(x, col = NULL, ...) {
    chain <- x
    f <- 0.45 # Multiplicative factor to adjust the label margin
    # Prepare color palette (generated with the colorspace Berlin palette)
    if (is.null(col)) {
        col <- rev(c("#4A6FE3", "#7086E1", "#8F9DE1", "#ABB4E2", "#C7CBE3", "#E2E2E2", 
                     "#E6C4C9", "#E5A5B1", "#E28699", "#DB6581", "#D33F6A"))
    }
    cols <- colorRampPalette(col)(1025)
    # Draw heatmap
    data <- cor(do.call(rbind, chain), method = "spearman")
    col_low_index <- 513 + floor(min(data) * 512)
    col_high_index <- 513 + ceiling(max(data) * 512)
    cols <- cols[col_low_index:col_high_index]
    labels <- colnames(data)
    labels <- gsub("^lossRate_", "__", labels)
    labels <- gsub("^portion_", "__", labels)
    labels <- gsub("^uptakeRate_from_", "__", labels)
    maxLabels <- max(sapply(labels, nchar))
    labels <- sapply(colnames(data), varnameToExp)
    margin <- maxLabels * f
    heatmap(data, labCol = labels, labRow = labels,
            distfun = function(x) dist(abs(x)), 
            hclustfun = function(x) hclust(abs(x), method = "ward.D2"),
            scale = "none", col = cols, margins = rep(margin, 2), ...)
}

### * sankey()

#' Draw a Sankey plot for a network and estimated flows
#'
#' @param topo A topology.
#' @param nodes Optional, a tibble containing the properties of the nodes. It
#'     should have a `comp` column with the same entries as the topology. It
#'     cannot have `x` and `y` entries. If it has a `label` entry, it will
#'     replace the `comp` values for node labels.
#' @param flows A tibble containing the values of the flows in the topology. If
#'     NULL (the default), all flows have same width in the plot.
#' @param layout String, node-placing algorithm to use from the ggraph package
#'     (e.g. "stress"). The ggraph package itself uses some algoritms from the
#'     igraph package. See the Details in the help of
#'     \code{\link[ggraph]{layout_tbl_graph_igraph}} for available
#'     algorithms. The ggraph package must be installed for this argument to be
#'     taken into account. Currently, only the "left2right" and "stress" layout
#'     are implemented in detail, and any other layout will use rough defaults
#'     for the aesthetic adjustments. Other layouts which are kind of working
#'     are "kk", "lgl", "fr", "dh", "mds". Some of those produce
#'     non-reproducible node locations (at least I haven't managed to reproduce
#'     them even by setting the RNG seed before calling the function).
#' @param new Boolean, create a new page for the plot?
#' @param debug Boolean, if TRUE then draw a lot of shapes to help with
#'     debugging.
#' @param node_f,edge_f Multiplicative factor to adjust node and edge size.
#' @param node_s String defining how node size is calculated. The effect of the
#'     string also depends on the chosen layout.
#' @param edge_n Integer, number of interpolation points along each edge.
#' @param cex_lab,cex.lab Expansion factor for label size (both arguments are
#'     synonyms).
#' @param fit Boolean, if TRUE try to fit all the graphical elements inside the
#'     canvas.
#'
#' @return Mostly called for its side effect (plotting), but also returns
#'     invisible the scene object describing the Sankey plot. Note that the
#'     structure of this object is experimental and might change in the future!
#' 
#' @examples
#' library(magrittr)
#' 
#' topo <- topo(trini_mod)
#' sankey(topo, debug = TRUE)
#' sankey(topo, layout = "stress")
#' sankey(topo(aquarium_mod), layout = "stress", edge_f = 0.5)
#'
#' m <- new_networkModel() %>%
#'     set_topo(c("subs -> NH3 -> subs",
#'                "NH3 -> Q, E", "E -> Q -> E",
#'                "E -> D, M")) %>%
#'     set_steady("subs") %>%
#'     set_prop_family("normal_sd")
#' ggtopo(m)
#' sankey(topo(m), layout = "stress")
#'
#' # Debug visualization
#'
#' ## Helper functions
#' flows_from_topo <- function(x) {
#'     x <- unclass(x) # Remove the "topo" class to treat it as a matrix
#'     n_comps <- ncol(x)
#'     links <- which(x > 0)
#'     from <- links %/% n_comps + 1
#'     to <- links %% n_comps
#'     links <- tibble::tibble(from = from, to = to)
#'     for (i in seq_len(nrow(links))) {
#'         if (links$to[i] == 0) {
#'             links$from[i] <- links$from[i] - 1
#'             links$to[i] <- n_comps
#'         }
#'         stopifnot(x[links$to[i], links$from[i]] > 0)
#'     }
#'     flows <- tibble::tibble(from = colnames(x)[links$from],
#'                             to = rownames(x)[links$to])
#'     return(flows)
#' }
#' nodes_from_topo <- function(x) {
#'     nodes <- tibble::tibble(comp = colnames(x),
#'                             label = colnames(x))
#'     return(nodes)
#' }
#'
#' t <- topo(trini_mod)
#' nodes <- nodes_from_topo(t)
#' nodes$label <- as.list(nodes$label)
#' nodes$label[[2]] <- latex2exp::TeX("$\\beta$")
#' nodes$size <- runif(nrow(nodes), 1, 2)
#' flows <- flows_from_topo(t)
#' flows$width <- runif(nrow(flows), 0.2, 2)
#' z <- sankey(t, nodes = nodes, flows = flows, layout = "left2right",
#'             debug = TRUE, node_f = 1, edge_f = 0.9, edge_n = 32,
#'             cex_lab = 1.5)
#'
#' # Stress layout
#' y <- new_networkModel() %>%
#'         set_topo(c("subs -> NH3 -> subs",
#'                    "NH3 -> Q, E", "E -> Q -> E",
#'                    "E -> D, M")) %>%
#'         set_steady("subs") %>%
#'             set_prop_family("normal_sd")
#' y <- topo(y)
#' nodes <- nodes_from_topo(y)
#' nodes$size <- runif(nrow(nodes), 1, 10)
#' ggtopo(y, edge = "fan")
#' flows <- flows_from_topo(y)
#' flows$width <- runif(nrow(flows), 0.2, 5)
#' z <- sankey(y, nodes = nodes, flows = flows, debug = FALSE, edge_n = 32,
#'             edge_f = 0.4, node_s = "prop")
#'
#' # Another example
#' r <- new_networkModel() %>%
#'     set_topo("infusion -> plasma -> body -> plasma") %>%
#'     set_steady(c("infusion", "body"))
#' r <- topo(r)
#' ggtopo(r, edge = "fan")
#' sankey(r, debug = TRUE, edge_f = 0.2)
#' 
#' @export
#'

sankey <- function(topo, nodes = NULL, flows = NULL, layout = NULL, new = TRUE,
                   debug = FALSE, node_f = 1, edge_f = 1, node_s = "auto",
                   edge_n = 32, cex_lab = NULL, cex.lab = NULL, fit = TRUE) {
    # Process arguments
    if (!is.null(cex_lab) & !is.null(cex.lab)) {
        message("Both `cex_lab` and `cex.lab` provided. Using `cex_lab`.")
    }
    if (is.null(cex_lab) & !is.null(cex.lab)) {
        cex_lab <- cex.lab
    }
    if (is.null(cex_lab)) {
        cex_lab <- 1
    }
    # Create canvas
    if (new) { grid::grid.newpage() }
    if (!debug) {
        dev.hold()
        on.exit(dev.flush())
    }
    top_vp <- grid::viewport()
    grid::pushViewport(top_vp)
    canvas_vp <- make_and_push_ortho_vp(width = 0.9, height = 0.9,
                                        debug = debug)
    # Get default layout if needed
    layout <- sankey_get_layout(topo, layout)
    # Build node tibble if needed
    if (is.null(nodes)) {
        nodes <- tibble::tibble(comp = colnames(topo))
    }
    if (!"size" %in% colnames(nodes)) {
        nodes <- tibble::add_column(nodes, size = 1)
    }
    # Get unit flows if needed
    if (is.null(flows)) {
        flows <- flows_from_topo(topo)
    }
    if (!"width" %in% colnames(flows)) {
        flows <- tibble::add_column(flows, width = 1)
    }
    # Adjust flow widths
    total_width <- 1
    flows$width <- flows$width / sum(flows$width) * total_width * edge_f
    # 1) place_nodes
    scene <- sankey_place_nodes(topo, nodes, flows, layout,
                                xlim = canvas_vp$xscale,
                                ylim = canvas_vp$yscale)
    # 2) place_edge_sockets_on_nodes
    scene <- sankey_place_edge_sockets_on_nodes(scene, topo, nodes, flows, layout)
    # 3) calc_node_shape
    scene <- sankey_calc_node_shape(scene, topo, nodes, flows, layout, node_f = node_f,
                                    xlim = canvas_vp$xscale, node_s = node_s)
    # 4) adjust_node_locations
    scene <- sankey_adjust_node_locations(scene, topo, nodes, flows, layout)
    # 5) adjust_edge_sockets
    scene <- sankey_adjust_edge_sockets(scene, topo, nodes, flows, layout)
    # 6) calc_edge_socket_coordinates
    scene <- sankey_calc_edge_socket_coordinates(scene, topo, nodes, flows, layout)
    # 7) place_edge_backbones
    scene <- sankey_place_edge_backbones(scene, topo, nodes, flows, layout, n = edge_n)
    # 8) place_labels
    scene <- sankey_place_labels(scene, topo, nodes, flows, layout, cex_lab = cex_lab)
    # Draw elements
    elements_limits <- sankey_get_elements_lims(scene)
    ratio_x <- diff(elements_limits[["xlim"]]) / diff(canvas_vp$xscale)
    ratio_y <- diff(elements_limits[["ylim"]]) / diff(canvas_vp$yscale)
    ratio <- max(ratio_x, ratio_y)
    xscale_fit <- (canvas_vp$xscale - mean(canvas_vp$xscale)) * ratio + mean(elements_limits[["xlim"]])
    yscale_fit <- (canvas_vp$yscale - mean(canvas_vp$yscale)) * ratio + mean(elements_limits[["ylim"]])
    if (fit) {
        # Create a new canvas vp
        canvas_fit_vp <- grid::dataViewport(xscale = xscale_fit,
                                            yscale = yscale_fit,
                                            name = "ortho_canvas_fit")
        grid::pushViewport(canvas_fit_vp)
    }
    sankey_draw_edges(scene[["edges"]], debug = debug)
    sankey_draw_nodes(scene[["nodes"]], debug = debug, node_s = node_s)
    sankey_draw_labels(scene[["labels"]], debug = debug)
    if (fit) {
        # Pop extra canvas viewport
        grid::popViewport(1)
    }
    # Pop viewports
    grid::popViewport(3)
    # Return elements
    return(invisible(scene))
}

### * quick_sankey()

#' Draw a Sankey plot with basic defaults
#' 
#' @param flows A tibble containing flows (output from
#'     \code{\link{tidy_flows}}). For now it should have an "average_flow"
#'     column in the tibbles of the "flows" list column.
#' @param ... Passed to \code{\link{sankey}}.
#'
#' @return Mostly called for its side effect (plotting), but also returns
#'     invisible the scene object describing the Sankey plot. Note that the
#'     structure of this object is experimental and might change in the future!
#' 
#' @export
#' 

quick_sankey <- function(flows, ...) {
    `!!` <- rlang::`!!`
    flows <- dplyr::bind_rows(lapply(flows$flows, as.data.frame))
    stopifnot(all(c("from", "to", "average_flow") %in% colnames(flows)))
    flows <- na.omit(flows[, c("from", "to", "average_flow")])
    flows <- dplyr::group_by(flows, `!!`(rlang::sym("from")),
                             `!!`(rlang::sym("to")))
    flows <- dplyr::summarize(flows, width = mean(`!!`(rlang::sym("average_flow"))),
                              .groups = "drop")
    # Build topo from flows table
    topo <- make_topology(flows, from = "from", to = "to")
    sankey(topo = topo, nodes = nodes_from_topo(topo), flows = flows, ...)
}


### * None of the functions in this file is exported

### * add_param_mapping()

#' Build the (default) parameter mapping in a \code{networkModel} object
#'
#' For now this function just builds the default base mapping. Improvements
#' are: taking into account fixed effect of discrete variables and updating
#' gracefully when grouping or topology is modified. Maybe this is not doable
#' in a clean way, and the best option is just to reset the mapping when
#' grouping or topo is modified and warn the user.
#'
#' This function also sets the default priors
#'
#' @param nm A \code{networkModel} object.
#'
#' @return A \code{networkModel} object.
#'
#' @keywords internal
#' @noRd

add_param_mapping <- function(nm, use_default = FALSE) {
    # Build canonical mapping
    mapping <- lapply(seq_len(nrow(nm)), function(i) {
        params <- nm_base_params(nm[i, ])
        tibble::tibble(in_replicate = params,
                       in_model = params)
    })
    nm$parameters <- mapping
    # Set default priors
    priors <- tibble::tibble(in_model = nm_base_params(nm))
    if (use_default) {
        priors$prior <- lapply(seq_len(nrow(priors)), function(i) {
            hcauchy_p(scale = 0.1)
        })
        for (i in which(grepl("^portion[.]act_", priors$in_model))) {
            priors$prior[[i]] <- uniform_p(0, 1)
        }
    } else {
        priors$prior <- lapply(seq_len(nrow(priors)), function(i) {
            NULL
        })
    }
    attr(nm, "priors") <- priors
    # Return
    return(nm)
}

### * nm_base_params()

#' Get the vector of default parameter names
#'
#' @param nm A \code{networkModel} object
#'
#' @return A vector of strings
#' 
#' @keywords internal
#' @noRd

nm_base_params <- function(nm) {
    params <- c(lapply(nm$topology, topo_get_upsilon_names),
                lapply(nm$topology, topo_get_lambda_names),
                lapply(nm$topology, topo_get_portionAct_names),
                "eta")
    # (eta is a parameter for the variation of observed proportions)
    # Check if zeta should be compartment-specific
    # (zeta is a parameter for the variation of observed sizes)
    z <- attr(nm, "size_zeta_per_compartment")
    if (!is.null(z) && z) {
        comps <- unique(unlist(lapply(nm$topology, colnames)))
        zetas <- paste0("zeta_", comps)
        params <- c(params, zetas)
    } else {
        params <- c(params, "zeta")
    }
    params <- sort(unique(unlist(params)))
    return(params)
}

### * refresh_param_mapping()

#' Apply a formula on param mapping
#'
#' @param nm A \code{networkModel} object.
#' @param formula A list of formulas describing the parameter dependencies on
#'     covariates. Formulas are applied sequentially.
#' @param use_regexpr Boolean. Use regular expression to match the left-hand
#'     terms to replicate parameters?
#'
#' @return An updated \code{networkModel}
#'
#' @importFrom stats update
#' 
#' @keywords internal
#' @noRd

refresh_param_mapping <- function(nm, formula, use_regexpr = TRUE) {
    base_params <- nm_base_params(nm)
    # Parse formula
    leftTerms <- all.vars(update(formula, . ~ 0))
    rightTerms <- all.vars(update(formula, 0 ~ .))
    # Apply regexpr if needed
    if (use_regexpr) {
        for (lt in leftTerms) {
            matches <- any(grepl(lt, base_params))
            leftTerms <- c(leftTerms, base_params[grepl(lt, base_params)])
            if (matches && !lt %in% base_params) {
                # Terms with regexpr match are allowed to be dropped if needed
                leftTerms <- leftTerms[leftTerms != lt]
            }
        }
        leftTerms <- unique(leftTerms)
    }
    # Check that the left terms make sense (they are default parameter names)
    stopifnot(all(leftTerms %in% c(".", base_params)))
    # Get all the parameter names if "." was specified
    if ("." %in% leftTerms) { leftTerms <- base_params }
    # Check that the right terms make sense (they are grouping variables)
    stopifnot(!is.null(nm$group))
    groups <- groups(nm)
    stopifnot(all(rightTerms %in% c(colnames(groups), ".")))
    rightTerms <- rightTerms[rightTerms != "."]
    # Go over the rows of the design data frame
    for (i in seq_len(nrow(nm))) {
        mapping <- nm$parameters[[i]]
        if (length(rightTerms) > 0) {
            covariates <- groups[, rightTerms]
            covariatesString <- apply(covariates, 1, paste, collapse = "|")
            for (lt in leftTerms) {
                g <- paste(lt, covariatesString, sep = "|")
                mapping$in_model[mapping$in_replicate == lt] <- g[i]
            }
        } else {
            for (lt in leftTerms) {
                g <- lt
                mapping$in_model[mapping$in_replicate == lt] <- g
            }
        }
        nm$parameters[[i]] <- mapping
    }
    # Return
    return(nm)
}

### * None of the functions in this file is exported

### * project_row()

### ** Doc

#' Calculate the trajectories for one row
#'
#' This is the workhorse function doing all the hard-work of projecting
#' trajectories through numerical integration. All other functions involving
#' any trajectory projection (except the Stan model itself) should rely on this
#' function.
#' 
#' @param nm_row One row of a \code{networkModel} object.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'     (\code{dt}) or the number of points for the calculation
#'     (\code{grid_size}) can be provided. If none is provided, then a default
#'     grid size of 256 steps is used.
#' @param at Optional, vector of time values at which the trajectory must be
#'     evaluated.
#' @param end Time value for end point. If not provided, the last observation
#'     or event is used.
#' @param flows Boolean, return flows in the output?
#' @param cached_ts,cached_ee Used for optimization by other functions, not for
#'     use by the package user.
#' @param lambda_decay If non-NULL, used as the decay rate for marked tracer
#'     (used to model radioactive tracers).
#'
#' @return A tibble with one row. If flows are calculated, the returned flow
#'     values are flows during each dt intervals, not instantaneous flows. Note
#'     that in the case of a radioactive tracer, the returned flows do not
#'     incorporate the "loss flow" due to radioactive decay (so if one is to do
#'     some material accounting based on the flow values, some material will
#'     "leak" and appear not to be accounted for and actually corresponds to
#'     the tracer lost by radioactive decay).
#' 
#' @examples
#' project_row <- isotracer:::project_row
#' 
#' m <- aquarium_mod
#' m <- set_params(m, sample_params(m))
#' z <- project_row(m[1,])
#' z <- project_row(m[1,], flows = TRUE)
#'
#' # Calculate total flows over the projected time window
#' f <- z$flows[[1]]
#' f <- f[1:(length(f)-1)] # Drop last entry (which is NA)
#' f <- dplyr::bind_rows(f)
#' f <- dplyr::group_by(f, from, to)
#' f <- dplyr::summarize(f, total_flow = sum(flow))
#' duration <- diff(range(z$timepoints[[1]]))
#' f$mean_instantaneous_flow <- f$total_flow / duration
#' 
#' @keywords internal
#' @noRd

### ** Code

project_row <- function(nm_row, dt = NULL, grid_size = NULL, at = NULL, end = NULL,
                        flows = FALSE, cached_ts = NULL, cached_ee = NULL,
                        lambda_decay = NULL, ignore_pulses = FALSE) {
    ### * Preprocessing
    if (is.null(lambda_decay)) {
        lambda_decay <- 0
    }
    get_flows <- flows
    nmRow <- nm_row
    nComps <- ncol(nmRow$topology[[1]])
    comps <- colnames(nmRow$topology[[1]])
    params <- nmRow$parameters[[1]]
    params <- setNames(params$value, nm = params$in_replicate)
    ss <- attr(nmRow$topology[[1]], "steadyState")
    ss <- match(ss, comps)
    sp <- attr(nmRow$topology[[1]], "split")
    sp <- match(sp, comps)
    if (is.null(end)) {
        if (is.null(at)) {
            end <- max(nmRow$observations[[1]][["time"]])
            if (!is.null(nmRow[["events"]][[1]])) {
                end <- max(c(end, nmRow$events[[1]][["time"]]))
            }
        } else {
            end <- max(at)
        }
    }
    if (get_flows) {
        flows <- list()
        flow_template <- data.frame(from = rep(comps, each = nComps),
                                    to = rep(comps, nComps),
                                    flow = NA,
                                    factor = 1,
                                    in_topo = as.vector(nmRow$topology[[1]]),
                                    stringsAsFactors = FALSE)
        flow_template[["in_topo"]][flow_template[["from"]] == flow_template[["to"]]] <- 1
        # factor to adjust sign of comps_to_NA flows
        flow_template[["factor"]][flow_template[["from"]] == flow_template[["to"]]] <- -1
        flow_template[["to"]][flow_template[["from"]] == flow_template[["to"]]] <- NA
        flow_template_keep <- flow_template$in_topo > 0
        flow_template$in_topo <- NULL
        flow_template_to_fill <- flow_template[flow_template_keep, ]
        flow_template_to_fill[["factor"]] <- NULL
        flow_template_adjust <- flow_template[["factor"]][flow_template_keep]
    }
    ### * Get time scheme
    if (is.null(cached_ts)) {
        ts <- nm_row_get_time_scheme(nm_row = nmRow, dt = dt, grid_size = grid_size,
                                     end = end, at = at)
    }  else {
        ts <- cached_ts
    }
    timepoints <- ts$timepoints
    timesteps <- ts$dt_i
    dts <- ts$unique_dt
    ### * Get events
    if (is.null(cached_ee)) {
        events <- encode_events(nmRow, end = end, dt = dt, grid_size = grid_size)
    } else {
        events <- cached_ee
    }
    nPulses <- events[["maxNpulseEvents"]]
    pulseEvents <- rbind(events[["pulseEventsIndices"]][,,1],
                         c(0, 0)) # Padding to keep matrix when one event only
    pulseQuantities <- rbind(events[["pulseEventsQuantities"]][,,1],
                             c(0, 0))
    ### * Build transition matrices
    transitions <- list()
    transitionsDecay <- list() # This one incorporates the effect of lambda_decay
    for (i in seq_along(dts)) {
        transitions[[i]] <- build_transition_matrix(nmRow$topology[[1]],
                                                    nmRow$parameters[[1]],
                                                    dts[i])
        transitionsDecay[[i]] <- (transitions[[i]] -
                                  diag(nComps) * lambda_decay * dts[i])
    }
    if (get_flows) {
        transfer_mat <- list()
        for (i in seq_along(dts)) {
            transfer_mat[[i]] <- build_transfer_matrix(nmRow$topology[[1]],
                                                       nmRow$parameters[[1]],
                                                       dts[i])
        }
    }
    ### * Initialize event index
    pulseIndex <- 1
    ### * Initialize unmarked and marked quantities
    unmarked <- matrix(NA, ncol = nComps, nrow = length(timepoints))
    marked <- matrix(NA, ncol = nComps, nrow = length(timepoints))
    init <- nmRow$initial[[1]]
    init <- init[match(comps, init$compartment), ]
    stopifnot(all(comps == init$compartment))
    ## Update split compartments
    if (length(sp) > 0) {
        initRefr <- list()
        for (j in sp) {
            portion <- as.vector(params[paste0("portion.act_", comps[j])])
            initRefr[[j]] <- c("unmarked" = init[["size"]][j] * (1 - portion) * (1 - init[["proportion"]][j]),
                               "marked" = init[["size"]][j] * (1 - portion) * init[["proportion"]][j])
            init[["size"]][j] <- init[["size"]][j] * portion
        }
    }
    init$unmarked <- init$size * (1 - init$proportion)
    init$marked <- init$size * init$proportion
    unmarked[1, ] <- init$unmarked[match(comps, init$compartment)]
    marked[1, ] <- init$marked[match(comps, init$compartment)]
    ## Apply pulses
    if (nPulses > 0 & (!ignore_pulses)) {
        if (pulseIndex <= nPulses) {
            while(pulseIndex <= nPulses && pulseEvents[pulseIndex, 1] == 1) {
                unmarked[1, pulseEvents[pulseIndex, 2]] <- unmarked[1, pulseEvents[pulseIndex, 2]] + pulseQuantities[pulseIndex, 1]
                marked[1, pulseEvents[pulseIndex, 2]] <- marked[1, pulseEvents[pulseIndex, 2]] + pulseQuantities[pulseIndex, 2]
                pulseIndex <- pulseIndex + 1
            }
        }
    }
    ### * Loop over dt
    for (t in seq_along(timesteps)) {
        # Apply the transfer matrix
        unmarked[t+1, ] <- transitions[[timesteps[t]]] %*% unmarked[t, ]
        marked[t+1, ] <- transitionsDecay[[timesteps[t]]] %*% marked[t, ]
        # Gather flows
        if (get_flows) {
            flows_t <- transfer_mat[[timesteps[t]]]
            sizes_t <- unmarked[t, ] + marked[t, ]
            for (j in seq_along(comps)) {
                flows_t[, j] <- flows_t[, j] * sizes_t[j]
            }
            flows_to_store <- as.vector(flows_t)[flow_template_keep]
            flows[[t]] <- flow_template_to_fill
            flows[[t]]$flow <- flows_to_store * flow_template_adjust # Adjust sign of comp_to_NA flows
        }
        # Reset steady-state compartments
        for (j in ss) {
            unmarked[t+1,j] <- unmarked[t,j]
            marked[t+1,j] <- marked[t,j]
        }
        # Apply pulse events
        if (nPulses > 0 & (!ignore_pulses)) {
            if (pulseIndex <= nPulses) {
                while(pulseIndex <= nPulses && pulseEvents[pulseIndex, 1] == t+1) {
                    unmarked[t+1, pulseEvents[pulseIndex, 2]] <- unmarked[t+1, pulseEvents[pulseIndex, 2]] + pulseQuantities[pulseIndex, 1]
                    marked[t+1, pulseEvents[pulseIndex, 2]] <- marked[t+1, pulseEvents[pulseIndex, 2]] + pulseQuantities[pulseIndex, 2]
                    pulseIndex <- pulseIndex + 1
                }
            }
        }
    } # End of loop

    ### * Clean-up and return
    colnames(unmarked) <- comps
    colnames(marked) <- comps
    if (length(sp) > 0) {
        for (j in sp) {
            unmarked[, j] <- unmarked[, j] + initRefr[[j]]["unmarked"]
            marked[, j] <- marked[, j] + initRefr[[j]]["marked"]
        }
    }
    sizes <- unmarked + marked
    proportions <- marked / sizes
    colnames(proportions) <- comps
    o <- tibble::tibble(timepoints = list(timepoints),
                        unmarked = list(unmarked),
                        marked = list(marked),
                        sizes = list(sizes),
                        proportions = list(proportions))
    if (get_flows) {
        o$dt <- list(c(diff(o[["timepoints"]][[1]]), NA))
        o$flows <- list(c(flows, NA))
    }
    return(o)
}

### * build_transition_matrix()

#' Build the transition matrix for a topology
#'
#' @param topo A network topology.
#' @param params A tibble with "in_replicate" and "value" columns giving the
#'     parameter values.
#' @param dt Numerical, time step value.
#' @param apply_steady_state Boolean, if TRUE set values for steady state
#'     compartments to the appropriate 1.
#'
#' @keywords internal
#' @noRd

build_transition_matrix <- function(topo, params, dt,
                                    apply_steady_state = FALSE) {
    nComps <- ncol(topo)
    comps <- colnames(topo)
    params <- setNames(params$value, nm = params$in_replicate)
    m <- matrix(0, ncol = nComps, nrow= nComps)
    for (i in seq_len(nComps)) {
        # upsilons
        for (j in seq_len(nComps)) {
            if (topo[i,j] == 1) {
                p <- paste("upsilon", comps[j], "to", comps[i], sep = "_")
                m[i,j] <- params[p]
                m[j,j] <- m[j,j] - params[p]
            }
        }
        # lambdas
        p <- paste("lambda", comps[i], sep = "_")
        m[i,i] <- m[i,i] - params[p]
    }
    # Apply dt
    m <- diag(nComps) + m * dt
    colnames(m) <- comps
    rownames(m) <- comps
    # Apply steady states
    if (apply_steady_state) {
        ss_comps <- attr(topo, "steadyState")
        if (length(ss_comps) > 0) {
            for (comp in ss_comps) {
                i <- which(comps == comp)
                m[i, ] <- 0
                m[i, i] <- 1
            }
        }
    }
    return(m)
}

### * build_transfer_matrix()

#' Build the transfer matrix for a topology
#'
#' A transfer matrix is similar to a transition matrix, except that the
#' diagonal doesn't contain the numerical values corresponding to what remains
#' after transfer. The transfer matrix describes the flows rather than the
#' compartment states after transition.
#'
#' Note that this function does not take into account radioactive decay when
#' calculating how much material is lost (lambda rates) from a
#' compartment. This is equivalent to consider that the flows are calculated
#' for a situation where all isotopes are stable.
#'
#' @param topo A network topology.
#' @param params A tibble with "in_replicate" and "value" columns giving the
#'     parameter values.
#' @param dt Numerical, time step value.
#'
#' @keywords internal
#' @noRd

build_transfer_matrix <- function(topo, params, dt) {
    nComps <- ncol(topo)
    comps <- colnames(topo)
    params <- setNames(params$value, nm = params$in_replicate)
    m <- matrix(0, ncol = nComps, nrow= nComps)
    for (i in seq_len(nComps)) {
        # upsilons
        for (j in seq_len(nComps)) {
            if (topo[i,j] == 1) {
                p <- paste("upsilon", comps[j], "to", comps[i], sep = "_")
                m[i,j] <- params[p]
            }
        }
        # lambdas
        p <- paste("lambda", comps[i], sep = "_")
        if (m[i,i] != 0) {
            stop("A compartment has a flow to itself (which is not permitted in the model).")
        }
        m[i,i] <- m[i,i] - params[p]
    }
    # Apply dt
    m <- m * dt
    colnames(m) <- comps
    rownames(m) <- comps
    return(m)
}

### * calc_instantaneous_flow()

#' Calculate instantaneous flow given a topology, sizes and parameter values
#'
#' Note that this function applies portions of active compartments
#' instantaneously, i.e. it assumes that for a split compartment the size and
#' active portion values are correct. This means that this function should not
#' be used to calculate flows in a network which contains split compartments
#' and which is not at equilibrium over than at t0, since in such a network the
#' estimated parameters give the active portion values at t0 (i.e. for the
#' initial conditions).
#' 
#' @param topo Network topology.
#' @param sizes Compartement sizes (tibble).
#' @param parameters Parameter values (tibble). A named vector containing
#'     parameter values is also accepted.
#'
#' @return A tibble with instantaneous flows.
#'
#' @examples
#' calc_instantaneous_flow <- isotracer:::calc_instantaneous_flow
#' 
#' # Small network
#' m <- aquarium_mod
#' p <- sample_params(m)
#' m <- set_params(m, p)
#' flows <- calc_instantaneous_flow(m$topology[[1]], m$initial[[1]],
#'                                  m$parameters[[1]])
#' 
#' # Large network
#' m <- trini_mod
#' p <- sample_params(m)
#' m <- set_params(m, p)
#' flows <- calc_instantaneous_flow(m$topology[[1]], m$initial[[1]],
#'                                  m$parameters[[1]])
#' 
#' @keywords internal
#' @noRd

calc_instantaneous_flow <- function(topo, sizes, parameters) {
    # Convert parameters to a tibble if needed
    if (!is(parameters, "tbl")) {
        if (!(is.vector(parameters) & !is.null(attr(parameters, "names")))) {
            stop("\"parameters\" must be a tibble or a named vector.")
        }
        parameters <- tibble::tibble(value = parameters,
                                     in_replicate = names(parameters))
    }
    # Process input
    n_comps <- ncol(topo)
    comps <- colnames(topo)
    comp_indices <- setNames(seq_len(n_comps), nm = comps)
    params <- parameters
    params <- setNames(params$value, nm = params$in_replicate)
    ss <- attr(topo, "steadyState")
    ss <- match(ss, comps)
    sp <- attr(topo, "split")
    sp <- match(sp, comps)
    # Build transfer matrix
    # (could use the build_transfer_matrix() function for consistency)
    tm <- matrix(0, ncol = n_comps, nrow= n_comps)
    for (i in seq_len(n_comps)) {
        # upsilons
        for (j in seq_len(n_comps)) {
            if (topo[i,j] == 1) {
                p <- paste("upsilon", comps[j], "to", comps[i], sep = "_")
                tm[i,j] <- params[p]
            }
        }
        # lambdas
        p <- paste("lambda", comps[i], sep = "_")
        if (tm[i,i] != 0) {
            stop("A compartment has a flow to itself (which is not permitted in the model).")
        }
        tm[i,i] <- tm[i,i] - params[p]
    }
    # Prepare sizes
    sizes <- sizes[match(comps, sizes$compartment), ]
    stopifnot(all(comps == sizes$compartment))
    ## Update split compartments
    if (length(sp) > 0) {
        sizeRefr <- list()
        for (j in sp) {
            portion <- as.vector(params[paste0("portion.act_", comps[j])])
            sizeRefr[[j]] <- sizes[["size"]][j] * (1 - portion)
            sizes[["size"]][j] <- sizes[["size"]][j] * portion
        }
    }
    # Calculate flows
    flows_mat <- tm
    stopifnot(ncol(flows_mat) == n_comps)
    for (j in seq_len(n_comps)) {
        flows_mat[, j] <- flows_mat[, j] * sizes[["size"]][j]
    }
    # Put flows into a tibble format
    flows <- tibble::tibble(from = rep(comps, each = n_comps),
                            to = rep(comps, n_comps),
                            instantaneous_flow = as.vector(flows_mat))
    ## Check that the matrix major order was correct
    # (maybe we can get rid of this checking step?)
    check_mat <- matrix(flows[["instantaneous_flow"]], ncol = n_comps, byrow = FALSE)
    delta <- max(abs(check_mat - flows_mat))
    if (delta > 1e-15) {
        stop("Issue with matrix major order when formatting flows.")
    }
    # Post-processing
    flows$in_topo <- as.vector(topo)
    flows[["in_topo"]][flows[["from"]] == flows[["to"]]] <- 1
    flows[["to"]][flows[["from"]] == flows[["to"]]] <- NA
    flows <- flows[flows$in_topo > 0, ]
    flows$in_topo <- NULL
    # Return
    return(flows)
}

### * gather_flows()

#' Helper function to calculate flows while calculating trajectories
#'
#' This function does not take into account any refractory portions, and
#' assumes that what is passed to it concerns only active portions.
#'
#' This function assumes that topo, sizes and transfer_mat are all ordered in
#' the same way (i.e. compartments match across arguments, and topo has the
#' same, ordered colnames and rownames).
#' 
#' @param topo A network topology.
#' @param sizes A vector containing compartment sizes.
#' @param transfer_mat A transfer matrix.
#'
#' @return A well-formatted tibble.
#' 
#' @keywords internal
#' @noRd

gather_flows <- function(topo, sizes, transfer_mat) {
    comps <- colnames(topo)
    n_comps <- ncol(topo)
    flows <- transfer_mat
    for (i in seq_len(ncol(topo))) {
        flows[, i] <- flows[, i] * sizes[i]
    }
    flows <- tibble::tibble(from = rep(comps, each = n_comps),
                            to = rep(comps, n_comps),
                            flow = as.vector(flows))
    flows$in_topo <- as.vector(topo)
    flows[["in_topo"]][flows[["from"]] == flows[["to"]]] <- 1
    flows[["to"]][flows[["from"]] == flows[["to"]]] <- NA
    flows <- flows[flows$in_topo > 0, ]
    flows$in_topo <- NULL
    return(flows)
}

### * potential_steady_state()

#' Simple test to check if a network potentially admis a steady state
#'
#' This is an imperfect test, but it will reject the two most obvious cases
#' where no steady state is (probably) possible: (1) if all lambdas are zero
#' but one source is in steady state (material accumulates in the network) and
#' (2) at least one lambda is non-null, but there are no steady state sources
#' (material leaks from the network without being replaced).
#'
#' Note that this is a bit rough, since some exceptions can exists: for example
#' if independent sub-networks exist in the network.
#'
#' @param x A one-row network object.
#'
#' @return Boolean.
#'
#' @examples
#' potential_steady_state <- isotracer:::potential_steady_state
#' 
#' m <- aquarium_mod
#' m <- set_prior(m, constant_p(0), "lambda")
#' m <- set_params(m, sample_params(m))
#' potential_steady_state(m)
#'
#' m <- set_prior(m, normal_p(0, 3), "lambda_NH4")
#' m <- set_params(m, sample_params(m))
#' potential_steady_state(m)
#'
#' m <- trini_mod[1, ]
#' m <- set_params(m, sample_params(m))
#' potential_steady_state(m)
#' 
#' @keywords internal
#' @noRd

potential_steady_state <- function(x) {
    if (nrow(x) != 1) {
        stop("\"x\" must have exactly one row.")
    }
    topo <- topo(x, simplify = TRUE)
    params <- x$parameters[[1]]
    lambdas <- params$value[grepl("^lambda_", params$in_replicate)]
    has_steady_state <- length(attr(topo, "steadyState")) > 0
    has_non_zero_lambda <- any(lambdas != 0)
    if (has_steady_state & ! has_non_zero_lambda) {
        return(FALSE)
    }
    if (! has_steady_state & has_non_zero_lambda) {
        return(FALSE)
    }
    return(TRUE)
}

### * calculate_steady_state_one_row()

#' Calculate steady-state compartment sizes for a one-row network
#'
#' This is an experimental function. It attempts to calculate steady-state
#' compartment sizes using the set parameter values and the initial compartment
#' sizes. Use it with caution!
#'
#' Note about how steady state sizes for split compartments are calculated: the
#' steady size of the active portion is calculated divide it is divided by the
#' active fraction (portion.act parameter) to get the total size including the
#' refractory portion. In this case we get a "steady-state" refractory portion,
#' consistent with steady state size of active fraction and with portion.act
#' parameter.
#' 
#' @param nm_row A one-row network model, with set parameter values.
#'
#' @return A named vector containing the steady state compartment sizes.
#'
#' @examples
#' calculate_steady_state_one_row <- isotracer:::calculate_steady_state_one_row
#' 
#' # Simple model, no split compartments
#' m <- aquarium_mod
#' m <- set_prior(m, constant_p(0), "lambda")
#' set.seed(4)
#' m <- set_params(m, sample_params(m))
#' proj <- project(m, end = 40)
#' plot(proj)
#' calculate_steady_state_one_row(m)
#'
#' # With split compartments
#' m <- trini_mod[1, ]
#' set.seed(4)
#' m <- set_params(m, sample_params(m))
#' proj <- project(m, end = 40)
#' plot(proj)
#' calculate_steady_state_one_row(m)
#' 
#' @keywords internal
#' @noRd

calculate_steady_state_one_row <- function(nm_row) {
    stopifnot(nrow(nm_row) == 1)
    topo <- topo(nm_row, simplify = TRUE)
    if (!potential_steady_state(nm_row)) {
        stop("The network model row seems not to admit a steady state.\n",
             "(i.e. potential_steady_state(...) returned FALSE).")
    }
    # Go on
    has_ss_comps <- length(attr(topo, "steadyState")) != 0
    has_split_comps <- length(attr(topo, "split")) != 0
    params <- nm_row$parameters[[1]]
    transition_mat <- build_transition_matrix(topo = topo, params = params, dt = 1,
                                              apply_steady_state = TRUE)
    decomp <- eigen(transition_mat)
    values <- decomp$values
    vectors <- decomp$vectors
    # Process split compartments
    if (has_split_comps) {
        sp_comps <- attr(topo, "split")
        inits <- nm_row$initial[[1]]
        original_inits <- inits
        original_inits$refr_size <- 0
        original_inits$p_act <- 1
        for (i in seq_len(nrow(inits))) {
            if (inits$compartment[i] %in% sp_comps) {
                p_act <- params$value[params$in_replicate == paste0("portion.act_", inits$compartment[i])]
                original_inits$refr_size[i] <- original_inits$size[i] * (1 - p_act)
                original_inits$p_act[i] <- p_act
                inits$size[i] <- inits$size[i] * p_act
            }
        }
        nm_row$initial[[1]] <- inits
    }
    # Determine eigen elements of interest
    if (!has_ss_comps) {
        accepted <- which(Im(values) == 0)
        if (length(accepted) > 1) {
            accepted <- which(Im(values) == 0 &
                              apply(sign(Re(vectors)), 2, function(x) length(unique(x))) == 1)
        }
        if (length(accepted) == 0) {
            stop("No real eigenvalue for the transition matrix.")
        }
    } else {
        accepted <- which(values == 1)
        if (length(accepted) == 0) {
            stop("1 is not an eigenvalue of the transition matrix.")
        }
        # Check consistency with ss comps
        ss_comps <- attr(topo, "steadyState")
        ss_comps_i <- sapply(ss_comps, function(x) which(colnames(topo) == x))
        for (i in accepted) {
            v <- vectors[, i]
            values_v <- v[ss_comps_i]
            if (!sum(values_v != 0) > 0) {
                stop("Eigenvector incompatible with steady state compartments.")
            }
            if (!sum(values_v != 0) == 1) {
                stop("Steady state compartments incompatible with current implementation.")
            }
        }
    }
    # Calculate steady state sizes
    values <- values[accepted]
    vectors <- vectors[, accepted, drop = FALSE]
    comps <- colnames(topo)
    inits <- nm_row$initial[[1]]
    stopifnot(setequal(comps, inits$compartment))
    if (!has_ss_comps) {
        total_size <- sum(inits$size)
        if (length(accepted) > 1) {
            stop("Unexpected eigenvalue decomposition: more than one real eigen value found.")
        }
        stable_sizes <- vectors[, 1]
        stopifnot(all(stable_sizes == Re(stable_sizes)))
        stable_sizes <- Re(stable_sizes)
        names(stable_sizes) <- colnames(transition_mat)
        adjust <- total_size / sum(stable_sizes)
        stable_sizes <- adjust * stable_sizes
    } else {
        ss_comps <- attr(topo, "steadyState")
        ss_comps_i <- sapply(ss_comps, function(x) which(colnames(topo) == x))
        for (v in seq_len(ncol(vectors))) {
            focal_ss <- which(vectors[, v][ss_comps_i] > 0)
            if (!length(focal_ss) == 1) {
                stop("More than one steady state compartment participating in an eigenvector.")
            }
            focal_init <- inits$size[inits$compartment == colnames(topo)[ss_comps_i[focal_ss]]]
            focal_index <- ss_comps_i[focal_ss]
            adjust_factor <- focal_init / vectors[, v][focal_index]
            vectors[, v] <- vectors[, v] * adjust_factor
        }
        stable_sizes <- apply(vectors, 1, sum)
        names(stable_sizes) <- colnames(transition_mat)
        for (i in ss_comps) {
            if (abs(stable_sizes[i] - inits$size[inits$compartment == i]) > .Machine$double.eps * 1000) {
                stop("Incompatible initial and steady state size for a steady state compartment.\n",
                     "(size difference is ", abs(stable_sizes[i] - inits$size[inits$compartment == i]), ").")
            }
        }
    }
    # Process split compartments
    if (has_split_comps) {
      p_act <- setNames(original_inits$p_act,
                        nm = original_inits$compartment)
      stable_sizes <- stable_sizes / p_act[names(stable_sizes)]
      ## refr_sizes <- setNames(original_inits$refr_size,
      ##                        nm = original_inits$compartment)
      ## stable_sizes <- stable_sizes + refr_sizes[names(stable_sizes)]
    }
    # Return
    return(stable_sizes)
}

### * None of the functions in this file is exported

### * matrix_exp_stan()

#' Run a stan model from a network model, using matrix exponential to solve ODEs.
#'
#' Incorporate a loglik trace: https://mc-stan.org/loo/reference/extract_log_lik.html
#'
#' @param nm A \code{networkModel} object.
#' @param iter A positive integer specifying the number of iterations for each
#'     chain (including warmup). The default is 2000.
#' @param chains A positive integer specifying the number of Markov chains.
#'     The default is 4.
#' @param cores Number of cores to use for parallel run. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param stanfit If TRUE, returns a `stanfit` object instead of the more
#'     classical `mcmc.list` object.
#' @param use_fixed_values Boolean, if TRUE any parameter value set with
#'     \code{set_params()} will be taken as fixed during the MCMC run. Default
#'     is FALSE.
#' @param vb Boolean, if TRUE will use \code{rstan::vb} for a quick approximate
#'   sampling of the posterior. Important note from \code{?rstan::vb}:
#'   "This is still considered an experimental feature.  We recommend calling
#'   \code{stan} or \code{sampling} for final inferences and only using ‘vb’ to
#'   get a rough idea of the parameter distributions."
#' @param ... Passed to \code{rstan::sampling}.
#'
#' @keywords internal
#' @noRd

matrix_exp_stan <- function(nm, iter = 2000, chains = 4, cores = NULL,
                            stanfit = FALSE, use_fixed_values = FALSE,
                            vb = FALSE, ...) {
  # Detect cores
  cores <- get_n_cores(cores = cores)
  # Convert network model to stan data
  stan.data <- prep_stan_data_expm(nm, use_fixed_values = use_fixed_values)
  # Fit the model
  stan.data[["ode_method"]] <- 1 # For matrix exponential
  # Approximate sampling (vb = TRUE)
  if (vb) {
    if (stanfit) {
      stop("vb not implemented for stanfit = TRUE")
    }
    fits <- lapply(seq_len(chains), function(i) {
      fit <- rstan::vb(stanmodels[["networkModel"]],
                       data = stan.data,
                       iter = iter,
                       pars = c("nonConstantParams", "log_lik",
                                "rawUniformParams", "rawHcauchyParams",
                                "rawBetaParams", "rawTrNormParams",
                                "rawExponentialParams", "rawGammaParams"), ...)
      stopifnot(!"isotracer_stan_data" %in% names(attributes(fit)))
      attr(fit, "isotracer_stan_data") <- stan.data
      fit
    })
    fits <- lapply(fits, stanfit_to_named_mcmclist)
    fits <- lapply(fits, function(i) i[[1]])
    return(coda::as.mcmc.list(fits))
  }
  # Accurate sampling (vb = FALSE)
  fit <- rstan::sampling(stanmodels[["networkModel"]],
                         data = stan.data,
                         iter = iter,
                         chains = chains,
                         cores = cores,
                         pars = c("nonConstantParams", "log_lik",
                                  "rawUniformParams", "rawHcauchyParams",
                                  "rawBetaParams", "rawTrNormParams",
                                  "rawExponentialParams", "rawGammaParams"), ...)
  stopifnot(!"isotracer_stan_data" %in% names(attributes(fit)))
  attr(fit, "isotracer_stan_data") <- stan.data
  # Return
  if (stanfit) {
    return(fit)
  } else {
    return(stanfit_to_named_mcmclist(stanfit = fit))
  }
}

### * prep_stan_data_expm()

#' Prepare stan data from a network model
#'
#' @param nm A \code{networkModel} object.
#' @param use_fixed_values Boolean, if TRUE any parameter value set with
#'     \code{set_params()} will be taken as fixed during the MCMC run. Default
#'     is FALSE.
#' 
#' @keywords internal
#' @noRd

prep_stan_data_expm <- function(nm, use_fixed_values = FALSE) {
    d <- list()
    params_nm <- params(nm, simplify = TRUE)
    priors_nm <- priors(nm, fix_set_params = use_fixed_values,
                        quiet = TRUE)
    priors_nm <- priors_nm[match(params_nm, priors_nm[["in_model"]]), ]
    stopifnot(all(params_nm == priors_nm[["in_model"]]))
    # For now the stan model is only implemented for network models with the
    # same number of compartments on each row (a more general case where rows
    # can have different numbers of compartments is easily converted to this
    # case, by adding compartments without connections to fill the topology in
    # each row).
    stopifnot(length(unique(sapply(comps(nm), length))) == 1)
    # Counts
    d[["nComps"]] <- length(comps(nm)[[1]])
    d[["nGroups"]] <- nrow(nm)
    d[["nParams"]] <- length(params_nm)
    # Encode priors
    d <- c(d, encode_priors(params_nm, priors_nm))
    # Encode distribution families (for proportions and sizes)
    d <- c(d, encode_distrib_families(nm))
    # Encode initial conditions
    d <- c(d, encode_init(nm))
    # Encode steady state compartments
    d <- c(d, encode_steady(nm))
    # Encode split compartments
    d <- c(d, encode_split(nm, params_nm))
    # Encode decay rate for radioactive tracers
    lambda_decay <- attr(nm, "lambda_hl")
    if (is.null(lambda_decay)) {
        lambda_decay <- 0
    }
    d[["lambda_decay"]] <- lambda_decay
    # Encode intervals in-between events
    d <- c(d, encode_intervals(nm))
    # Encode pulse events
    d <- c(d, encode_pulse_events(nm))
    # Encode unique obs times
    d <- c(d, encode_unique_obs_times(nm))
    # Encode individual obs
    d <- c(d, encode_individual_obs(nm, params_nm))
    # Encode uptake rates (upsilons)
    d <- c(d, encode_upsilons(nm, params_nm))
    # Encode losses (lambdas)
    d <- c(d, encode_lambdas(nm, params_nm))
    # Add encoding for Euler (so that the Stan model does not crash)
    d[["allParams"]] <- params_nm
    euler <- encode_time_schemes(nm)
    stopifnot(!any(names(euler) %in% names(d)))
    d <- c(d, euler)
    return(d)
}

### * encode_intervals()

#' Encode time intervals between events
#'
#' @param nm A \code{networkModel} object.
#'
#' @keywords internal
#' @noRd

encode_intervals <- function(nm) {
    o <- list()
    nGroups <- nrow(nm)
    timelines <- lapply(seq_len(nrow(nm)), function(i) {
        nm_row_get_timeline(nm[i, ])
    })
    nTimeIntervals <- sapply(timelines, '[[', "nIntervals")
    o[["maxNtimeIntervals"]] <- max(nTimeIntervals)
    o[["nTimeIntervals"]] <- setNames(c(nTimeIntervals, 0), # Padded
                                      nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
    durations <- lapply(timelines, function(x) {
        x[["intervalEnds"]] - x[["intervalStarts"]]
    })
    o[["intervalsLengths"]] <- array(0, dim = c(max(nTimeIntervals), nGroups),
                                     dimnames = list(seq_len(max(nTimeIntervals)),
                                                     paste0("grp", seq_len(nGroups))))
    for (g in seq_len(nGroups)) {
        o[["intervalsLengths"]][1:(o[["nTimeIntervals"]][g]), g] <- durations[[g]]
    }
    o
}

### ** nm_row_get_timeline()

#' @examples
#' nm_row_get_timeline(aquarium_mod[1, ])
#' nm_row_get_timeline(trini_mod[1, ])
#' @keywords internal
#' @noRd
nm_row_get_timeline <- function(nm_row) {
    events <- nm_row_get_events(nm_row)
    obs <- nm_row_get_obs(nm_row)
    o <- c(events, obs)
    o[["maxTime"]] <- max(c(o[["eventTimes"]], o[["obsTimes"]]))
    o[["nIntervals"]] <- o[["nEventTimes"]] + 1
    o[["intervalStarts"]] <- c(0, o[["eventTimes"]])
    o[["intervalEnds"]] <- c(o[["eventTimes"]], o[["maxTime"]])
    o[["intervalStartsWithAnEvent"]] <- o[["intervalStarts"]] %in% o[["eventTimes"]]
    o[["obsIntervalIndex"]] <- sapply(o[["obsTimes"]], function(i) {
        w <- which(o[["intervalStarts"]] <= i)
        if (length(w) > 0) { return(max(w)) }
        return(o[["nIntervals"]])
    })
    o[["elapsedTimeSinceEvent"]] <- o[["obsTimes"]] - o[["intervalStarts"]][o[["obsIntervalIndex"]]]
    return(o)
}

### ** plot_nm_row_timeline()

#' @param nm_row_timeline Output from \code{nm_row_get_timeline}.
#' @return None, called for side-effect of drawing a timeline plot where
#'     boundaries are light gray, events are red, and observation times are
#'     blue.
#' @examples
#' plot_nm_row_timeline(nm_row_get_timeline(aquarium_mod[1, ]))
#' plot_nm_row_timeline(nm_row_get_timeline(trini_mod[1, ]))
#' @keywords internal
#' @noRd
plot_nm_row_timeline <- function(nm_row_timeline) {
    z <- nm_row_timeline
    plot(0, type = "n", xlim = c(0, z[["maxTime"]]), ylim = c(0, 1),
         xlab = "Time", axes = FALSE, ylab = "")
    graphics::axis(1)
    graphics::lines(c(0, 0), c(0, 1), col = "lightgray")
    graphics::lines(rep(z[["maxTime"]], 2), c(0, 1), col = "lightgray")
    for (i in seq_along(z[["eventTimes"]])) {
        graphics::lines(rep(z[["eventTimes"]], 2), c(0, 1), col = "red", lty = 2, lwd = 2)
    }
    graphics::points(z[["obsTimes"]], y = rep(0.5, length(z[["obsTimes"]])),
           pch = 21, col = "blue", bg = "blue")
}

### ** nm_row_get_events()

nm_row_get_events <- function(nm_row) {
    stopifnot(nrow(nm_row) == 1)
    o <- list()
    if (!"events" %in% colnames(nm_row)) {
        o[["eventTimes"]] <- numeric()
    } else {
        o[["eventTimes"]] <- sort(unique(nm_row[["events"]][[1]][["time"]]))
    }
    o[["nEventTimes"]] <- length(o[["eventTimes"]])
    o <- o[c("nEventTimes", "eventTimes")]
    return(o)
}

### ** nm_row_get_obs()

nm_row_get_obs <- function(nm_row) {
    stopifnot(nrow(nm_row) == 1)
    stopifnot("observations" %in% colnames(nm_row))
    o <- list()
    o[["obsTimes"]] <- sort(unique(nm_row[["observations"]][[1]][["time"]]))
    o[["nObsTimes"]] <- length(o[["obsTimes"]])
    o <- o[c("nObsTimes", "obsTimes")]
    return(o)
}

### * encode_pulse_events()

#' Encode pulse events (for Stan model with matrix exponential)
#'
#' @param nm A \code{networkModel} object.
#'
#' @keywords internal
#' @noRd

encode_pulse_events <- function(nm) {
    o <- list()
    if (!"events" %in% names(nm)) {
        nm[["events"]] <- rep(list(NULL), nrow(nm))
    }
    comps <- comps(nm)[[1]]
    nGroups <- nrow(nm)
    timelines <- lapply(seq_len(nrow(nm)), function(i) {
        nm_row_get_timeline(nm[i, ])
    })
    nPulseEvents <- sapply(seq_len(nrow(nm)), function(i) {
        n <- nrow(nm[i, ][["events"]][[1]])
        ifelse(is.null(n), 0, n)
    })
    o[["maxNpulseEvents"]] <- max(nPulseEvents)
    o[["nPulseEvents"]] <- setNames(c(nPulseEvents, 0), # Padded
                                    nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
    interval_indices <- list()
    comp_indices <- list()
    marked <- list()
    unmarked <- list()
    for (g in seq_len(nGroups)) {
        x <- nm[["events"]][[g]]
        if (!is.null(x)) {
            x <- x[order(x[["time"]]), ]
            stopifnot(all(x$event == "pulse"))
            interval_indices[[g]] <- match(x[["time"]], timelines[[g]][["intervalStarts"]])
            comp_indices[[g]] <- match(x[["compartment"]], comps)
            marked[[g]] <- sapply(x$characteristics, '[[', "marked")
            unmarked[[g]] <- sapply(x$characteristics, '[[', "unmarked")
        }
    }
    o[["pulseEventsIndices"]] <- array(0, dim = c(max(nPulseEvents), 2, nGroups),
                                       dimnames = list(seq_len(max(nPulseEvents)),
                                                       c("interval", "comp"),
                                                       paste0("grp", seq_len(nGroups))))
    o[["pulseEventsQuantities"]] <- array(0, dim = c(max(nPulseEvents), 2, nGroups),
                                          dimnames = list(seq_len(max(nPulseEvents)),
                                                          c("unmarked", "marked"),
                                                          paste0("grp", seq_len(nGroups))))
    for (g in seq_len(nGroups)) {
        if (!is.null(nm[["events"]][[g]])) {
            o[["pulseEventsIndices"]][1:(o[["nPulseEvents"]][g]), 1, g] <- interval_indices[[g]]
            o[["pulseEventsIndices"]][1:(o[["nPulseEvents"]][g]), 2, g] <- comp_indices[[g]]
            o[["pulseEventsQuantities"]][1:(o[["nPulseEvents"]][g]), 1, g] <- unmarked[[g]]
            o[["pulseEventsQuantities"]][1:(o[["nPulseEvents"]][g]), 2, g] <- marked[[g]]
        }
    }
    o
}

### * encode_unique_obs_times()

#' Encode unique observation times (for Stan model with matrix exponential)
#'
#' @param nm A \code{networkModel} object.
#'
#' @keywords internal
#' @noRd

encode_unique_obs_times <- function(nm) {
    o <- list()
    comps <- comps(nm)[[1]]
    nGroups <- nrow(nm)
    timelines <- lapply(seq_len(nrow(nm)), function(i) {
        nm_row_get_timeline(nm[i, ])
    })
    nObsTimes <- sapply(timelines, '[[', "nObsTimes")
    o[["maxNobsTimes"]] <- max(nObsTimes)
    o[["nObsTimes"]] <- setNames(c(nObsTimes, 0), # Padded
                                 nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
    o[["elapsedTimeSinceEvent"]] <- array(0, dim = c(nGroups, max(nObsTimes)),
                                           dimnames = list(paste0("grp", seq_len(nGroups)),
                                                           seq_len(max(nObsTimes))))
    o[["obsIntervalsIndices"]] <- array(0, dim = c(nGroups, max(nObsTimes)),
                                        dimnames = list(paste0("grp", seq_len(nGroups)),
                                                        seq_len(max(nObsTimes))))
    for (g in seq_len(nGroups)) {
        o[["elapsedTimeSinceEvent"]][g, 1:(o[["nObsTimes"]][g])] <- timelines[[g]][["elapsedTimeSinceEvent"]]
        o[["obsIntervalsIndices"]][g, 1:(o[["nObsTimes"]][g])] <- timelines[[g]][["obsIntervalIndex"]]
    }
    o
}

### * encode_individual_obs()

#' Encode individual observations (for Stan model with matrix exponential)
#'
#' @param nm A \code{networkModel} object.
#' @param allParams Parameters of the network model.
#'
#' @keywords internal
#' @noRd

encode_individual_obs <- function(nm, allParams) {
    o <- list()
    comps <- comps(nm)[[1]]
    nGroups <- nrow(nm)
    zeta_by_comp <- attr(nm, "size_zeta_per_compartment")
    if (is.null(zeta_by_comp)) {
        zeta_by_comp<- FALSE
    }
    timelines <- lapply(seq_len(nrow(nm)), function(i) {
        nm_row_get_timeline(nm[i, ])
    })
    # TODO Add filtering to keep only compartments present in topo
    # TODO Handle gracefully the case without observations
    # Get sizes
    sizes <- purrr::map(nm$observations, function(x) {
        na.omit(x[, c("compartment", "size", "time")])
    })
    # Get proportions
    props <- purrr::map(nm$observations, function(x) {
        na.omit(x[, c("compartment", "proportion", "time")])
    })
    # Convert original time into indices of unique observation times
    for (g in seq_len(nGroups)) {
        sizes[[g]][["timepoint"]] <- match(sizes[[g]][["time"]], timelines[[g]][["obsTimes"]])
        props[[g]][["timepoint"]] <- match(props[[g]][["time"]], timelines[[g]][["obsTimes"]])
    }
    # Encode compartments
    for (g in seq_len(nGroups)) {
        sizes[[g]][["compartment"]] <- match(sizes[[g]][["compartment"]], comps)
        props[[g]][["compartment"]] <- match(props[[g]][["compartment"]], comps)
    }
    # Encode sizes and props
    o[["nSizesObs"]] <- c(purrr::map_dbl(sizes, nrow), 0) # Padded
    names(o[["nSizesObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
    o[["nPropsObs"]] <- c(purrr::map_dbl(props, nrow), 0) # Padded
    names(o[["nPropsObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
    o[["maxNsizesObs"]] <- max(o[["nSizesObs"]])
    o[["maxNpropsObs"]] <- max(o[["nPropsObs"]])
    # Prepare containers
    o[["sizesObsIndices"]] <- array(0, dim = c(o[["maxNsizesObs"]], 3, nGroups),
                                    dimnames = list(seq_len(o[["maxNsizesObs"]]),
                                                    c("comp", "timepoint", "zeta"),
                                                    paste0("grp", seq_len(nGroups))))
    o[["sizesObs"]] <- array(0, dim = c(o[["maxNsizesObs"]], nGroups),
                             dimnames = list(seq_len(o[["maxNsizesObs"]]),
                                             paste0("grp", seq_len(nGroups))))
    o[["propsObsIndices"]] <- array(0, dim = c(o[["maxNpropsObs"]], 3, nGroups),
                                    dimnames = list(seq_len(o[["maxNpropsObs"]]),
                                                    c("comp", "timepoint", "eta"),
                                                    paste0("grp", seq_len(nGroups))))
    o[["propsObs"]] <- array(0, dim = c(o[["maxNpropsObs"]], nGroups),
                             dimnames = list(seq_len(o[["maxNpropsObs"]]),
                                             paste0("grp", seq_len(nGroups))))
    # Fill containers
    for (g in seq_len(nGroups)) {
        if (o[["nSizesObs"]][g] > 0) {
            o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 1:2, g] <- as.matrix(sizes[[g]][, c("compartment", "timepoint")])
            o[["sizesObs"]][1:o[["nSizesObs"]][g], g] <- as.matrix(sizes[[g]][, c("size")])
            if (!zeta_by_comp) {
                zeta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "zeta"]
                zeta_index <- match(zeta_global, allParams)
                o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
            } else {
                comps <- colnames(nm$topology[[g]])
                comps <- setNames(seq_along(comps), nm = comps)
                zeta_replicate <- paste0("zeta_", names(comps)[sizes[[g]][["compartment"]]])
                zeta_global <- nm[["parameters"]][[g]]$in_model[match(zeta_replicate, nm[["parameters"]][[g]]$in_replicate)]
                zeta_index <- match(zeta_global, allParams)
                o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
            }
        }
    }
    for (g in seq_len(nGroups)) {
        if (o[["nPropsObs"]][g] > 0) {
            o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 1:2, g] <- as.matrix(props[[g]][, c("compartment", "timepoint")])
            o[["propsObs"]][1:o[["nPropsObs"]][g], g] <- as.matrix(props[[g]][, c("proportion")])
            eta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "eta"]
            eta_index <- match(eta_global, allParams)
            o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 3, g] <- eta_index
        }
    }
    # Return
    return(o)
}

### * None of the functions in this file is exported

### * as.derived.mcmc.list()

#' @keywords internal
#' @noRd

as.derived.mcmc.list <- function(x) {
    if (!"derived.mcmc.list" %in% class(x)) {
        return(structure(x, class = c("derived.mcmc.list", class(x))))
    } else {
        return(x)
    }
}

### * build_uptake_mask

### ** Doc

#' Build a foodweb uptake mask based on links
#'
#' @section Link format:
#' 
#' Links are defined by a string describing connections between groups of
#' compartments and their directions using \code{->} and \code{<-}. The groups
#' being connected can be a single compartment or several compartments. Several
#' compartments can be separated either by commas or by spaces. Connection
#' descriptions can be chained in a single string.
#'
#' Some valid links are for example \code{"NH4, NO3 -> epi"} or
#' \code{"NH4, NO3 -> epi -> lepto, tricor"}.
#'
#' See the Examples section for more details.
#' 
#' @param links A vector of strings defining the trophic links between
#'     compartments (see the examples)
#' 
#' @return An uptake mask matrix with named columns and rows
#'
#' @examples
#' f <- isotracer:::build_uptake_mask(links = "NH4, NO3 -> epi -> pseph, tricor")
#' f
#'
#' # A larger foodweb
#' links <- c("NH4, NO3 -> seston, epi, CBOM, FBOM",
#'           "seston -> lepto", "epi -> petro, pseph",
#'           "CBOM, FBOM -> eudan", "CBOM -> phyllo",
#'           "FBOM -> tricor -> arg, euthy")
#' f2 <- isotracer:::build_uptake_mask(links = links)
#' f2
#'
#' @keywords internal
#' @noRd

### ** Code

build_uptake_mask <- function(links) {
    # Get the compartment names
    compartments <- compartments_from_links(links)
    nComp <- length(compartments)
    # Split the links
    elementaryLinks <- unlist(lapply(links, parse_link_string))
    stopifnot(all(grepl("->|<-", elementaryLinks)))
    pairs <- strsplit(elementaryLinks, "->|<-")
    stopifnot(all(unlist(pairs) %in% compartments))
    # Create the uptake rate mask
    mask <- matrix(0, ncol = nComp, nrow = nComp,
                   dimnames = list(compartments, compartments))
    # Add the links to the uptake rate mask
    for (k in 1:length(pairs)) {
        i <- match(pairs[[k]][1], compartments)
        j <- match(pairs[[k]][2], compartments)
        if (grepl("->", elementaryLinks[k])) {
            mask[j,i] = 1
        } else {
            mask[i,j] = 1
        }
    }
    # Return
    stopifnot(all(diag(mask) == 0)) # No rates to self
    # Return
    return(mask)
}

### * compartments_from_links()

#' Build a vector of unique compartments from link strings
#'
#' @param links A vector of link strings; see the examples for details about
#'     their format
#'
#' @return A string vector containing unique compartments present in the links
#'
#' @examples
#' links <- c("NH4, NO3 -> epi -> tricor, pseph, petro", "tricor -> arg")
#' compartments <- isotracer:::compartments_from_links(links)
#'
#' @keywords internal
#' @noRd

compartments_from_links <- function(links) {
    links <- unlist(lapply(links, parse_link_string))
    return(sort(unique(unlist(strsplit(links, "->|<-")))))
}

### * parse_link_string()

#' Parse a link string into simple links
#'
#' @param link String, see the examples for details about the format
#'
#' @return A vector containing the simple links. All simple links will have
#'     exactly one "->" or "<-" symbol, between two strings, with no
#'     whitespaces.
#'
#' @examples
#' isotracer:::parse_link_string("NH4, NO3 -> epi -> tricor, pseph, petro")
#' isotracer:::parse_link_string("tricor <- epi -> pseph")
#' isotracer:::parse_link_string("NH4 NO3 -> epi seston FBOM CBOM")
#'
#' @keywords internal
#' @noRd

parse_link_string <- function(link) {
    # Split by connections
    links <- unlist(strsplit(link, split = "<-|->"))
    stopifnot(length(links) > 1)
    # Build pairs of groups
    pairs <- list()
    kLinks <- 1
    for (i in 1:(length(links)-1)) {
        LHS <- unlist(strsplit(links[kLinks], split = " |,"))
        LHS <- LHS[LHS != ""]
        stopifnot(length(LHS) > 0)
        RHS <- unlist(strsplit(links[kLinks+1], split = " |,"))
        RHS <- RHS[RHS != ""]
        stopifnot(length(RHS) > 0)
        pairs[[kLinks]] <- list(LHS, RHS)
        kLinks <- kLinks + 1
    }
    # Get directions
    directions <- list()
    kLinkString <- 1
    for (i in 1:(length(links)-1)) {
        kLinkString <- kLinkString + nchar(links[i])
        directions[[i]] <- substr(link, start = kLinkString,
                                  stop = kLinkString + 1)
        kLinkString <- kLinkString + 2
    }
    # Function to trim whitespaces
    ## https://stackoverflow.com/questions/2261079/how-to-trim-leading-and-trailing-whitespace-in-r
    trim <- function(x) {
        return(gsub("^\\s+|\\s+$", "", x))
    }
    # Build simple pairs
    out <- list()
    kOut <- 1
    for (i in seq_along(pairs)) {
        for (k in seq_along(pairs[[i]][[1]])) {
            for (l in seq_along(pairs[[i]][[2]])) {
                out[kOut] <- paste0(trim(pairs[[i]][[1]][k]), trim(directions[[i]]),
                                   trim(pairs[[i]][[2]][l]))
                
                kOut <- kOut + 1
            }
        }
    }
    # Return
    return(unlist(out))
}

### * make_init()

### ** Doc

#' Build tibble of initial conditions for network model
#'
#' @param data Data frame
#' @param comp String, name of the column containing the names of the
#'     compartments
#' @param size String, name of the column containing the sizes of the
#'     compartments
#' @param prop String, name of the column containing values for the
#'     proportion of marked material
#' @param group_by Optional, vector of strings giving the name of the columns
#'     to use to group observations (e.g. per stream, per forest, per
#'     experiment, ...)
#' 
#' @return A tibble with one row per grouping level
#'
#' @importFrom stats setNames
#' 
#' @examples
#' library(tibble)
#' data <- tibble(comps = rep(c("NH4", "algae", "daphnia", "NH4", "algae",
#'                              "daphnia"), 2),
#'                sizes = runif(12, 1, 10),
#'                props = runif(12, 0.01, 0.05),
#'                aquariumID = c(rep("aq01", 6), rep("aq02", 6)),
#'                temperature = rep(rep(c("low", "high"), each = 3), 2))
#' data
#'
#' # No grouping variable
#' z <- isotracer:::make_init(data, "comps", "sizes", "props")
#' z$initial
#'
#' # One grouping variable
#' z <- isotracer:::make_init(data, "comps", "sizes", "props", group_by = "aquariumID")
#' z
#'
#' # Several grouping variables
#' z <- isotracer:::make_init(data, "comps", "sizes", "props",
#'                group_by = c("aquariumID", "temperature"))
#' z
#' 
#' @keywords internal
#' @noRd

### ** Code

make_init <- function(data, comp, size, prop, group_by = NULL) {
    # Extract the columns containing initial conditions information
    initial <- tibble::as_tibble(data[, c(comp, size, prop)])
    colnames(initial) <- c("compartment", "size", "proportion")
    initial$compartment <- as.character(initial$compartment)
    # If no grouping variable is given, just return a tibble with one row
    if (is.null(group_by)) {
        out <- tibble::tibble("initial" = list(initial),
                              "group" = list(NULL))
    } else {
        # Else, get group levels
        for (g in group_by) {
            data[[g]] <- as.character(data[[g]])
        }
        group <- as.character(interaction(data[, group_by]))
        groupLevels <- unique(group)
        # Build the initial conditions sets (list of data frames)
        initialSets <- lapply(seq_along(groupLevels), function(i) {
            focalGroup <- groupLevels[i]
            indices <- which(group == focalGroup)
            return(initial[indices, ])
        })
        # Build the grouping variables sets (list of named vectors)
        groupingVariablesSets <- lapply(seq_along(groupLevels), function(i) {
            focalGroup <- groupLevels[i]
            indices <- which(group == focalGroup)
            tmp <- unique(data[indices, group_by])
            stopifnot(nrow(tmp) == 1)
            tmp <- setNames(as.character(tmp), nm = group_by)
            return(tmp)
        })
        # Put initial conditions and groups together
        groups <- tibble::tibble("group" = groupingVariablesSets)
        initials <- tibble::tibble("initial" = initialSets)
        out <- tibble::as_tibble(cbind(initials, groups))
    }
    # Return
    row.names(out) <- NULL
    return(out)
}

### * nm_is_grouped()

#' Is a network model grouped into replicate units?
#'
#' @param nm Network model
#'
#' @return Boolean
#' 
#' @keywords internal
#' @noRd

nm_is_grouped <- function(nm) {
    if (!"group" %in% colnames(nm)) {
        return(FALSE)
    }
    if (nrow(nm) == 0) {
        return(FALSE)
    }
    if (nrow(nm) == 1 && is.null(nm$group[[1]])) {
        return(FALSE)
    }
    return(TRUE)
}

### * compatible_groups()

#' Check that two tibbles have compatible "group" columns for merging
#'
#' @param x First tibble
#' @param y Second tibble
#' @param error Boolean, raise error when incompatibility is encountered?
#'
#' @return TRUE if x and y are compatible. If they are not, return FALSE if
#'     \code{error} is FALSE (the default) or raise an error when \code{error}
#'     is TRUE.
#'
#' @keywords internal
#' @noRd

compatible_groups <- function(x, y, error = FALSE) {
    gx <- nm_get_groups(x)
    gy <- nm_get_groups(y)
    cx <- colnames(gx)
    cy <- colnames(gy)
    # Check that one column set is contained in the other
    if (!(all(cx %in% cy) | all(cy %in% cx))) {
        if (!error) {
            return(FALSE)
        } else {
            stop("One set of grouping variables is not contained within the other.\n",
                 "In x but not in y: ", paste0(cx[!cx %in% cy], collapse = ", "), "\n",
                 "In y but not in x: ", paste0(cy[!cy %in% cx], collapse = ", "))
        }
    }
    # Check that the levels of common columns are compatible
    cs <- intersect(cx, cy)
    for (ics in cs) {
        lcx <- unique(gx[[ics]])
        lcy <- unique(gy[[ics]])
        if (!setequal(lcx, lcy)) {
            if (!error) {
                return(FALSE)
            } else {
                stop("The levels for the grouping variable \"", ics, "\" are not the same ",
                     "across x and y.")
            }
        }
    }
    # Compatible groupings
    return(TRUE)
}

### * nm_get_groups()

#' Return a tibble with the groups of a network model
#'
#' @param nm A network model
#' @param error Boolean, if TRUE raise an error if nm is not grouped, otherwise
#'     return NULL if nm is not grouped.
#'
#' @return A tibble, with rows in the same order as in the input
#'
#' @examples
#' x <- tibble::tribble(~col, ~group,
#'              "red", c(sp = "dog", name = "toto"),
#'              "blue", c(sp = "dog", name = "tata"),
#'              "yellow", c(sp = "cat", name = "felix"))
#' isotracer:::nm_get_groups(x)
#' 
#' @keywords internal
#' @noRd

nm_get_groups <- function(nm, error = TRUE) {
    if (!nm_is_grouped(nm)) {
        if (error) {
            stop("Input is not grouped.")
        } else {
            return(NULL)
        }
    }
    rows <- purrr::map(nm$group, function(g) {
        tidyr::spread(tibble::enframe(g),
                      key = "name", value = "value")
    })
    return(dplyr::bind_rows(rows))
}

### * make_obs()

### ** Doc

#' Build observed data
#'
#' Note that nested grouping variables have to be coded appropriately by the
#' user. For example, if there are two forests, each with three plots, the
#' plots IDs cannot be "1", "2", "3" in both forests, but should be for example
#' "1-1", "1-2", "1-3" in the first forest and "2-1", "2-2" and "2-3" in the
#' second forest.
#'
#' @param data Data frame
#' @param comp String, name of the column containing the names of the
#'     compartments
#' @param size String, name of the column containing the sizes of the
#'     compartments
#' @param prop String, name of the column containing values for the proportion
#'     of heavy tracer
#' @param time String, name of the column containing values for the time
#' @param group_by Optional, vector of strings giving the name of the columns
#'     to use to group observations (e.g. per stream, per forest, per
#'     experiment, ...). The name \code{tracerObservations} is reserved and
#'     should not be used.
#'
#' @return A tibble with one row per grouping level
#'
#' @importFrom stats setNames
#'
#' @examples
#' library(tibble)
#' data <- tibble(comps = rep(c("NH4", "algae", "daphnia", "NH4", "algae",
#'                              "daphnia"), 2),
#'                sizes = runif(12, 1, 10),
#'                props = runif(12, 0.01, 0.05),
#'                time = runif(12, 0, 5),
#'                aquariumID = c(rep("aq01", 6), rep("aq02", 6)),
#'                temperature = rep(rep(c("low", "high"), each = 3), 2))
#' data
#'
#' # No grouping variable
#' z <- isotracer:::make_obs(data, "comps", "sizes", "props", "time")
#' z$observations
#'
#' # One grouping variable
#' z <- isotracer:::make_obs(data, "comps", "sizes", "props", "time",
#'                           group_by = "aquariumID")
#' z
#'
#' # Several grouping variables
#' z <- isotracer:::make_obs(data, "comps", "sizes", "props", "time", 
#'                group_by = c("aquariumID", "temperature"))
#' z
#' 
#' @keywords internal
#' @noRd

### ** Code

make_obs <- function(data, comp, size, prop, time, group_by = NULL) {
    # Extract the columns containing observations
    observations <- tibble::as_tibble(data[, c(comp, size, prop, time)])
    colnames(observations) <- c("compartment", "size", "proportion", "time")
    observations$compartment <- as.character(observations$compartment)
    # If no grouping variable is given, just return a tibble with one column
    # and one row
    if (is.null(group_by)) {
        out <- tibble::tibble("observations" = list(observations),
                              "group" = list(NULL))
    } else {
        # Else, build a tibble with the grouping applied and use dplyr::group_by_
        for (g in group_by) {
            data[[g]] <- as.character(data[[g]])
        }
        group <- as.character(interaction(data[, group_by]))
        groupLevels <- unique(group)
        # Build the observation sets (list of data frames)
        observationSets <- lapply(seq_along(groupLevels), function(i) {
            focalGroup <- groupLevels[i]
            indices <- which(group == focalGroup)
            return(observations[indices, ])
        })
        # Build the grouping variables sets (list of named vectors)
        groupingVariablesSets <- lapply(seq_along(groupLevels), function(i) {
            focalGroup <- groupLevels[i]
            indices <- which(group == focalGroup)
            tmp <- unique(data[indices, group_by])
            stopifnot(nrow(tmp) == 1)
            tmp <- setNames(as.character(tmp), nm = group_by)
            return(tmp)
        })
        # Put observations and groups together
        groups <- tibble::tibble("group" = groupingVariablesSets)
        observations <- tibble::tibble("observations" = observationSets)
        out <- tibble::as_tibble(cbind(observations, groups))
    }
    # Return
    row.names(out) <- NULL
    return(out)
}

### * merge_nm_by_groups()

#' Merge a network model object and a tibble taking grouping into account
#'
#' @param nm The original \code{networkModel} object.
#' @param tib The tibble to merge into \code{nm}.
#' @param destination String, name of the column to merge into the network
#'     model.
#' @param tib_name String, used when an error is raised.
#'
#' @return The updated network model object.
#' 
#' @keywords internal
#' @noRd

merge_nm_by_group <- function(nm, tib, destination, tib_name = "unnamed tib") {
    nm_grouped <- nm_is_grouped(nm)
    tib_grouped <- nm_is_grouped(tib)
    previous_priors <- attr(nm, "priors")
    # nm not grouped, tib not grouped
    if (!nm_grouped & !tib_grouped) {
        stopifnot(nrow(nm) == 1 & nrow(tib) == 1)
        nm[[destination]][[1]] <- tib[[destination]][[1]]
    }
    # nm not grouped, tib grouped
    if (!nm_grouped & tib_grouped) {
        stopifnot(nrow(nm) == 1)
        nm_orig <- nm
        for (j in seq_len(nrow(tib) - 1)) {
            nm <- dplyr::bind_rows(nm, nm_orig)
        }
        nm[[destination]] <- tib[[destination]]
        nm$group <- tib$group
    }
    # nm grouped, tib not grouped
    if (nm_grouped & !tib_grouped) {
        stopifnot(nrow(tib) == 1)
        tib_orig <- tib
        for (j in seq_len(nrow(nm) - 1)) {
            tib <- dplyr::bind_rows(tib,
                                    tib_orig)
        }
        nm[[destination]] <- tib[[destination]]
    }
    # nm grouped and tib grouped
    if (nm_grouped & tib_grouped) {
        if (!compatible_groups(nm, tib)) {
         stop("Network model and ", tib_name, " do not have compatible grouping.")
        }
        # Merge
        nm_g <- nm_get_groups(nm)
        tib_g <- nm_get_groups(tib)
        cols <- intersect(colnames(nm_g), colnames(tib_g))
        allCols <- unique(c(colnames(nm_g), colnames(tib_g)))
        stopifnot(!".myRowNumberNm" %in% colnames(nm_g))
        stopifnot(!".myRowNumberTib" %in% colnames(tib_g))
        nm_g[[".myRowNumberNm"]] <- seq_len(nrow(nm_g))
        tib_g[[".myRowNumberTib"]] <- seq_len(nrow(tib_g))
        merged <- dplyr::full_join(nm_g, tib_g, by = cols)
        out_nm <- nm[merged[[".myRowNumberNm"]], ]
        out_tib <- tib[merged[[".myRowNumberTib"]], ]
        out_nm[[destination]] <- out_tib[[destination]]
        # Update groups
        groups <- merged[, allCols]
        groups <- lapply(seq_len(nrow(groups)), function(i) {
            unlist(groups[i, ])
        })
        out_nm[["group"]] <- groups
        nm <- out_nm
    }
    # Return
    attr(nm, "priors") <- previous_priors
    return(nm)
}

### * get_n_cores()

# https://stackoverflow.com/questions/50571325/r-cran-check-fail-when-using-parallel-functions

# From https://cran.r-project.org/doc/manuals/r-release/R-ints.html (on 2021-09-13):
#
# "_R_CHECK_LIMIT_CORES_ If set, check the usage of too many cores in package
# parallel. If set to 'warn' gives a warning, to 'false' or 'FALSE' the check
# is skipped, and any other non-empty value gives an error when more than 2
# children are spawned. Default: unset (but 'TRUE' for CRAN submission checks)."

#' Determine the number of cores to use for parallelizable functions
#'
#' @param cores Number of cores to use. Default is \code{NULL}, which means to
#'     use the value stored in \code{options()[["mc.cores"]]} (or 1 if this
#'     value is not set).
#'
#' @return An integer, the number of cores to use for parallel computations.
#'
#' @keywords internal
#' @noRd

get_n_cores <- function(cores = NULL) {
    n_cores_max <- parallel::detectCores()
    n_cores_options <- options()[["mc.cores"]]
    on_cran_limit <- Sys.getenv("_R_CHECK_LIMIT_CORES_", "")
    on_cran_limit <- (nzchar(on_cran_limit) && on_cran_limit == "TRUE")
    if (is.null(cores)) { cores <- n_cores_options }
    if (is.null(cores)) { cores <- 1 }
    # The condition below is a convoluted way to check that cores is an integer
    # (because the simpler e.g. "is.integer(2)" is FALSE).
    # See also ?is.integer and the is.wholenumber() function in the examples.
    if ((!is.numeric(cores)) || (!((as.integer(cores) - cores) == 0)) || !(cores > 0)) {
        stop("`cores` must be an integer > 0.")
    }
    if (cores > n_cores_max) {
        warning(paste0("The provided number of cores (", cores, ") is greater ",
                       "than the number of available cores (", n_cores_max,
                       ").\n"),
                "Using the number of available cores instead.")
        cores <- n_cores_max
    }
    if (cores > 1) {
        if (.Platform$OS.type == "windows") {
            warning("Multiple core implementation not working on Windows; using 1 core.")
            cores <- 1
        }
    }
    if (on_cran_limit) {
        message("CRAN limit for the number of cores was detected. Using cores <- min(cores, 2).")
        cores <- min(cores, 2)
    }
    return(cores)
}

### * .onAttach()

# Inspired by rstan code from
# https://github.com/stan-dev/rstan/blob/develop/rstan/rstan/R/zzz.R

.onAttach <- function(...) {
    packageStartupMessage("To automatically run isotracer in parallel ",
                          "on a multicore CPU, you can call:\n",
                          "  options(mc.cores = parallel::detectCores())\n")
}

### * .onUnload()

# Following recommendations from https://r-pkgs.org/src.html

.onUnload <- function(libpath) {
    library.dynam.unload("isotracer", libpath)
}

### * release_questions()

# Cf. https://r-pkgs.org/release.html#release-submission
release_questions <- function() {
  c("Have you rebuilt the precompiled vignettes manually recently?",
    "Have you updated the CRAN badge by running `.download-cran-version-badge.R`?")
}

### * All functions in this file are exported

### * project()

#' Calculate the trajectories of a network model
#'
#' @param nm A \code{networkModel} object.
#' @param dt,grid_size Either the time step size for trajectory calculations
#'   (\code{dt}) or the number of points for the calculation (\code{grid_size})
#'   can be provided. If none is provided, then a default grid size of 256 steps
#'   is used.
#' @param at Optional, vector of time values at which the trajectory must be
#'   evaluated.
#' @param end Time value for end point. If not provided, the last observation or
#'   event is used.
#' @param flows Return flow values? The default is "no" and no flows are
#'   calculated. Other values are "total" (total flows summed up from beginning
#'   to end timepoint), "average" (average flows per time unit, equal to total
#'   flows divided by the projection duration), and "per_dt" (detailled flow
#'   values are returned for each interval dt of the projection).
#' @param cached_ts,cached_ee Used for optimization by other functions, not for
#'   use by the package user.
#' @param ignore_pulses Default to FALSE (i.e. apply pulses when projecting the
#'   network system). It is set to TRUE when calculating steady-state flows.
#'
#' @return A network model object with a \code{"trajectory"} column.
#' 
#' @examples
#' m <- aquarium_mod
#' m <- set_params(m, sample_params(m))
#' z <- project(m)
#' z <- project(m, flows = "per_dt")
#' z <- project(m, flows = "total")
#' z <- project(m, flows = "average")
#' 
#' @export

project <- function(nm, dt = NULL, grid_size = NULL, at = NULL, end = NULL,
                    flows = "no", cached_ts = NULL, cached_ee = NULL,
                    ignore_pulses = FALSE) {
    `!!` <- rlang::`!!`
    if (!flows %in% c("no", "total", "average", "per_dt")) {
        stop("\"flows\" must be on of \"no\", \"total\", \"average\", \"per_dt\".")
    }
    if (flows == "no") {
        get_flows <- FALSE
    } else {
        get_flows <- TRUE
    }
    flow_option <- flows
    # Check that all parameters have values assigned
    params <- dplyr::bind_rows(nm$parameters)
    stopifnot(!any(is.na(params$value)))
    # Project row by row
    trajectories <- list()
    flows <- list()
    for (i in seq_len(nrow(nm))) {
        z  <- project_row(nm[i, ], dt = dt, grid_size = grid_size,
                          at = at, end = end, flows = get_flows,
                          cached_ts = cached_ts[[i]], cached_ee = cached_ee[[i]],
                          lambda_decay = attr(nm, "lambda_hl"),
                          ignore_pulses = ignore_pulses)
        trajectories[[i]] <- z[, c("timepoints", "unmarked", "marked", "sizes", "proportions")]
        if (get_flows) {
            flows[[i]] <- z[, c("timepoints", "dt", "flows")]
        }
    }
    nm$trajectory <- trajectories
    if (get_flows) {
        if (flow_option == "per_dt") {
            nm$flows <- flows
        } else if (flow_option == "total") {
            for (i in seq_along(flows)) {
                z <- flows[[i]][["flows"]][[1]]
                if (is.na(z[[length(z)]] )) {
                    z <- z[1:(length(z)-1)]
                }
                z <- dplyr::bind_rows(z)
                z <- dplyr::group_by(z, `!!`(rlang::sym("from")),
                                     `!!`(rlang::sym("to")))
                z <- dplyr::summarize(z, total_flow = sum(`!!`(rlang::sym("flow"))))
                flows[[i]] <- z
            }
            nm$flows <- flows
        } else if (flow_option == "average") {
            for (i in seq_along(flows)) {
                z <- flows[[i]][["flows"]][[1]]
                if (is.na(z[[length(z)]] )) {
                    z <- z[1:(length(z)-1)]
                }
                z <- dplyr::bind_rows(z)
                z <- dplyr::group_by(z, `!!`(rlang::sym("from")),
                                     `!!`(rlang::sym("to")))
                z <- dplyr::summarize(z, total_flow = sum(`!!`(rlang::sym("flow"))))
                duration <- diff(range(flows[[i]][["timepoints"]][[1]]))
                z$average_flow <- z$total_flow / duration
                z$total_flow <- NULL
                flows[[i]] <- z
            }
            nm$flows <- flows
        } else {
            stop("Value of \"flows\" not allowed: ", flow_option)
        }
    }
    return(nm)
}

### * sample_from()

#' Generate samples from a network model
#'
#' @param nm A \code{networkModel} object.
#' @param at Vector of time values at which the samples should be taken.
#' @param dt,grid_size Time step size or grid points, respectively.
#' @param end Final timepoint used in the projections.
#' @param error.draws Integer, number of draws from the error distribution for
#'     each sample (default: 1).
#' @param cached_ts,cached_ee Used for optimization by other functions, not for
#'     use by the package user.
#'
#' @return A tibble containing the generated samples.
#' 
#' @importFrom stats rnorm
#' @importFrom stats rgamma
#' @importFrom stats rbeta
#'
#' @examples
#' library(magrittr)
#' mod <- new_networkModel() %>%
#'    set_topo("NH4 -> algae -> daphnia -> NH4")
#' inits <- tibble::tribble(
#'      ~comps, ~sizes, ~props, ~treatment,
#'       "NH4",    0.2,    0.8,    "light",
#'     "algae",      1,  0.004,    "light",
#'   "daphnia",      2,  0.004,    "light",
#'       "NH4",    0.5,    0.8,     "dark",
#'     "algae",    1.2,  0.004,     "dark",
#'   "daphnia",    1.3,  0.004,     "dark")
#' mod <- set_init(mod, inits, comp = "comps", size = "sizes",
#'                 prop = "props", group_by = "treatment")
#' mod <- add_covariates(mod, upsilon_NH4_to_algae ~ treatment)
#' mod <- mod %>%
#'   set_params(c("eta" = 0.2, "lambda_algae" = 0, "lambda_daphnia" = 0,
#'                "lambda_NH4" = 0, "upsilon_NH4_to_algae|light" = 0.3,
#'                "upsilon_NH4_to_algae|dark" = 0.1,
#'                "upsilon_algae_to_daphnia" = 0.13,
#'                "upsilon_daphnia_to_NH4" = 0.045, "zeta" = 0.1))
#' spl <- mod %>% sample_from(at = 1:10)
#' spl
#'
#' @export

sample_from <- function(nm, at, dt = NULL, grid_size = NULL, end = NULL, error.draws = 1,
                        cached_ts = NULL, cached_ee = NULL) {
    obs <- list()
    prop_family <- attr(nm, "prop_family")
    size_family <- attr(nm, "size_family")
    zeta_by_comp <- attr(nm, "size_zeta_per_compartment")
    if (is.null(zeta_by_comp)) {
        zeta_by_comp <- FALSE
    }
    # Project nm
    nm <- project(nm, at = at, dt = dt, grid_size = grid_size, end = end,
                  cached_ts = cached_ts, cached_ee = cached_ee)
    # Extract samples
    for (i in seq_len(nrow(nm))) {
        z <- nm$trajectory[[i]]
        params <- nm$parameters[[i]]
        indices <- sort(unique(match(at, z$timepoints[[1]])))
        sizes <- tibble::as_tibble(z$unmarked[[1]] + z$marked[[1]])[indices, ]
        props <- tibble::as_tibble(z$proportions[[1]])[indices, ]
        stopifnot(!any(c("time", "comp", "size", "prop") %in% names(sizes)))
        sizes$time <- z$timepoints[[1]][indices]
        props$time <- z$timepoints[[1]][indices]
        sizes <- data.table::melt(data.table::as.data.table(sizes),
                                  id.vars = "time",
                                  variable.name = "comp", value.name = "meanSize",
                                  variable.factor = FALSE)
        props <- data.table::melt(data.table::as.data.table(props),
                                  id.vars = "time",
                                  variable.name = "comp", value.name = "meanProp",
                                  variable.factor = FALSE)
        sizes <- dplyr::bind_rows(rep(list(tibble::as_tibble(sizes)), error.draws))
        props <- dplyr::bind_rows(rep(list(tibble::as_tibble(props)), error.draws))
        # Add zeta values to sizes tibble
        if (!zeta_by_comp) {
            sizes$zeta <- params$value[params$in_replicate == "zeta"]
        } else {
            zeta_params <- paste0("zeta_", sizes[["comp"]])
            sizes$zeta <- params$value[match(zeta_params, params$in_replicate)]
        }
        # Apply size "noise"
        if (size_family == "normal_cv") {
            sizes$size <- rnorm(nrow(sizes),
                                mean = sizes$meanSize,
                                sd = sizes$meanSize * sizes$zeta)
            negSizes <- which(sizes$size < 0)
            while (length(negSizes) > 0) {
                sizes$size[negSizes] <- rnorm(length(negSizes),
                                              sizes$meanSize[negSizes],
                                              sd = sizes$meanSize[negSizes] * sizes$zeta[negSizes])
                negSizes <- which(sizes$size < 0)
            }
        } else if (size_family == "normal_sd") {
            sizes$size <- rnorm(nrow(sizes),
                                mean = sizes$meanSize,
                                sd = sizes$zeta)
            negSizes <- which(sizes$size < 0)
            while (length(negSizes) > 0) {
                sizes$size[negSizes] <- rnorm(length(negSizes),
                                              sizes$meanSize[negSizes],
                                              sd = sizes$zeta)
                negSizes <- which(sizes$size < 0)
            }
        }
        sizes$zeta <- NULL
        # Apply prop "noise"
        if (prop_family == "gamma_cv") {
            shapes <- rep(params$value[params$in_replicate == "eta"], nrow(props))^(-2)
            rates <- shapes  / props$meanProp
            props$prop <- rgamma(nrow(props), shape = shapes, rate = rates)
        } else if (prop_family == "normal_cv") {
            means <- props$meanProp
            sds <- means * params$value[params$in_replicate == "eta"]
            props$prop <- rnorm(nrow(props), mean = means, sd = sds)
            negProps <- which(props$prop < 0)
            while (length(negProps) > 0) {
                props$prop[negProps] <- rnorm(length(negProps),
                                              means[negProps],
                                              sd = sds[negProps])
                negProps <- which(props$prop < 0)
            }
        } else if (prop_family == "normal_sd") {
            means <- props$meanProp
            sds <- rep(params$value[params$in_replicate == "eta"], nrow(props))
            props$prop <- rnorm(nrow(props), mean = means, sd = sds)
            negProps <- which(props$prop < 0)
            while (length(negProps) > 0) {
                props$prop[negProps] <- rnorm(length(negProps),
                                              means[negProps],
                                              sd = sds[negProps])
                negProps <- which(props$prop < 0)
            }
        } else if (prop_family == "beta_phi") {
            phis <- rep(params$value[params$in_replicate == "eta"], nrow(props))
            alphas <- props$meanProp * phis
            betas <- phis * (1 - props$meanProp)
            props$prop <- rbeta(nrow(props), shape1 = alphas, shape2 = betas)
        } else {
            stop("Unknown distribution family:", prop_family)
        }
        stopifnot(all(sizes[["time"]] == props[["time"]]))
        stopifnot(all(sizes[["comp"]] == props[["comp"]]))
        obs[[i]] <- dplyr::bind_cols(sizes[, c("time", "comp", "size")],
                                     props[, c("prop")])
    }
    if (is.null(groups(nm))) {
        stopifnot(nrow(nm) == 1)
        return(obs[[1]])
    }
    groups <- groups(nm)
    out <- dplyr::bind_cols(tibble::tibble(obs), groups)
    out <- tidyr::unnest(out, cols = "obs")
    return(out)
}

### * calculate_steady_state()

#' Calculate steady-state compartment sizes for a network
#'
#' This is an experimental function. It attempts to calculate steady-state
#' compartment sizes using the set parameter values and the initial compartment
#' sizes. Use it with caution!
#' 
#' Note about how steady state sizes for split compartments are calculated: the
#' steady size of the active portion is calculated divide it is divided by the
#' active fraction (portion.act parameter) to get the total size including the
#' refractory portion. In this case we get a "steady-state" refractory portion,
#' consistent with steady state size of active fraction and with portion.act
#' parameter.
#' 
#' @param nm A network model, with set parameter values.
#'
#' @return A tibble containing steady-state compartment sizes.
#'
#' @examples
#' m <- aquarium_mod
#' m <- set_prior(m, constant_p(0), "lambda")
#' m <- set_params(m, sample_params(m))
#' proj <- project(m, end = 40)
#' plot(proj)
#'
#' z <- calculate_steady_state(m)
#' z
#' z$stable_sizes
#'
#' @export

calculate_steady_state <- function(nm) {
    out <- lapply(seq_len(nrow(nm)), function(i) {
        tibble::tibble(stable_sizes = list(calculate_steady_state_one_row(nm[i, ])))
    })
    out <- dplyr::bind_rows(out)
    nm[["stable_sizes"]] <- out[["stable_sizes"]]
    return(nm)
}

### * All functions in this file are exported

### * available_priors()

#' List the available priors for model parameters
#'
#' @return A tibble containing information about the available priors.
#'
#' @examples
#' available_priors()
#'
#' @export

available_priors <- function() {
    fun_names <- c("constant_p",
                   "uniform_p",
                   "normal_p",
                   "hcauchy_p",
                   "exponential_p",
                   "gamma_p",
                   "scaled_beta_p")
    prior_names <- c("Constant value",
                     "Uniform prior",
                     "Normal distribution",
                     "Half-Cauchy distribution",
                     "Exponential distribution",
                     "Gamma distribution",
                     "Scaled beta distribution")
    usage <- c("constant_p(value)",
               "uniform_p(min, max)",
               "normal_p(mean, sd)",
               "hcauchy_p(scale)",
               "exponential_p(lambda)",
               "gamma_p(alpha, beta)",
               "scaled_beta_p(alpha, beta, scale = 1)")
    out <- tibble::tibble(function_name = fun_names,
                          description = prior_names,
                          usage = usage)
    return(structure(out, class = c("prior_tibble", class(out))))
}

### * Methods for nice display of prior tibble

### ** format.prior_tibble()

#' Pretty formatting of a \code{prior_tibble} object
#'
#' @param x An object of class \code{prior_tibble}.
#' @param ... Not used.
#'
#' @return A character string for pretty printing of a prior tibble.
#' 
#' @export

format.prior_tibble <- function(x, ...) {
    x <- structure(x, class = class(x)[class(x) != "prior_tibble"])
    f <- format(x)
    f <- c(f,
           "-------------------------------------------------------",
           "(Note: All priors distributions are truncated at zero.)")
    return(f)
}

### ** print.prior_tibble()

#' Pretty printing of a \code{prior_tibble} object
#'
#' @param x An object of class \code{prior_tibble}.
#' @param ... Not used.
#'
#' @return Mostly called for its side effect of printing, but also returns its
#'     input invisibly.
#' 
#' @export

print.prior_tibble <- function(x, ...) {
    cat(format(x), sep = "\n")
    invisible(x)
}

### * constant_p(value)

#' Define a fixed-value prior
#'
#' This is equivalent to having a fixed parameter.
#'
#' @param value The constant value of the parameter.
#'
#' @return A list defining the prior.
#'
#' @examples
#' constant_p(2)
#'
#' @export

constant_p <- function(value) {
    x <- list(type = "constant",
              parameters = c(value = value))
    x <- structure(x, class = "prior")
    return(x)
} 

### * hcauchy_p(scale)

#' Define a half-Cauchy prior (on [0;+Inf])
#'
#' @param scale Median of the half-Cauchy distribution.
#'
#' @return A list defining the prior.
#'
#' @importFrom stats rcauchy
#'
#' @examples
#' hcauchy_p(scale = 0.5)
#'
#' @export

hcauchy_p <- function(scale) {
    x <- list(type = "hcauchy",
              parameters = c(scale = scale))
    x <- structure(x, class = "prior")
    return(x)
}

### * normal_p(mean, sd)

#' Define a truncated normal prior (on [0;+Inf])
#'
#' @param mean Mean of the untruncated normal.
#' @param sd Standard deviation of the untruncated normal.
#'
#' @return A list defining the prior.
#'
#' @importFrom stats rnorm
#'
#' @examples
#' normal_p(mean = 0, sd = 4)
#'
#' @export

normal_p <- function(mean, sd) {
    x <- list(type = "trun_normal",
              parameters = c(mean = mean,
                             sd = sd))
    x <- structure(x, class = "prior")
    return(x)
}

### * uniform_p(min, max)

#' Define a uniform prior
#'
#' @param min,max Minimum and maximum boundaries for the uniform prior.
#'
#' @return A list defining the prior.
#'
#' @importFrom stats runif
#' 
#' @examples
#' uniform_p(min = 0, max= 1)
#'
#' @export

uniform_p <- function(min, max) {
    x <- list(type = "uniform",
              parameters = c(min = min, max = max))
    x <- structure(x, class = "prior")
    return(x)
}


### * scaled_beta_p(alpha, beta, scale=1)

#' Define a beta prior (on [0;scale])
#'
#' If a random variable X follows a scaled beta distribution with parameters
#' (alpha, beta, scale), then X/scale follows a beta distribution with
#' parameters (alpha, beta).
#' 
#' @param alpha Alpha parameter of the unscaled beta distribution.
#' @param beta Beta parameter of the unscaled beta distribution.
#' @param scale The upper boundary of the prior.
#'
#' @return A list defining the prior.
#'
#' @examples
#' scaled_beta_p(0.8, 20, scale = 10)
#'
#' @export

scaled_beta_p <- function(alpha, beta, scale = 1) {
    x <- list(type = "scaled_beta",
              parameters = c(alpha = alpha, beta = beta, scale = scale))
    x <- structure(x, class = "prior")
    return(x)
}

### * exponential_p(lambda)

#' Define an exponential prior
#'
#' @param lambda Lambda parameter (rate) of the exponential distribution. The
#'     mean of the exponential distribution is 1/lambda.
#'
#' @return A list defining the prior.
#'
#' @examples
#' exponential_p(0.5)
#'
#' @export

exponential_p <- function(lambda) {
    x <- list(type = "exponential",
              parameters = c(lambda = lambda))
    x <- structure(x, class = "prior")
    return(x)
}

### * gamma_p(alpha, beta)

#' Define a gamma prior
#'
#' Note the name of the function to define a prior (\code{gamma_p}), in order
#' to avoid confusion with the R mathematical function \code{gamma}.
#'
#' @param alpha Shape parameter (equivalent to the \code{shape} parameter of
#'     R's \code{rgamma}).
#' @param beta Rate parameter (equivalent to the \code{rate} parameter of R's
#'     \code{rgamma}).
#'
#' @return A list defining the prior.
#'
#' @examples
#' gamma_p(9, 2)
#' hist(sample_from_prior(gamma_p(9, 2), 1e3))
#' 
#' @export

gamma_p <- function(alpha, beta) {
    x <- list(type = "gamma",
              parameters = c(alpha = alpha, beta = beta))
    x <- structure(x, class = "prior")
    return(x)
}

### * Methods for nice display of priors

### ** format.prior()

#' Pretty formatting of a \code{prior} object
#'
#' @param x An object of class \code{prior}.
#' @param ... Not used.
#'
#' @return A character string for pretty printing of a prior.
#' 
#' @export

format.prior <- function(x, ...) {
    params <- paste0("(",
                     paste(paste(names(x[["parameters"]]), x[["parameters"]],
                                 sep = "="), collapse = ","),
                     ")")
    out <- paste0(x[["type"]], "", params)
    return(out)
}

### ** print.prior()

#' Pretty printing of a \code{prior} object
#'
#' @param x An object of class \code{prior}.
#' @param ... Not used.
#'
#' @return Mostly called for its side effect of printing, but also returns its
#'     input invisibly.
#' 
#' @export

print.prior <- function(x, ...) {
    cat(format(x), sep = "\n")
    invisible(x)
}

### * Extending tibbles

# https://cran.r-project.org/web/packages/tibble/vignettes/extending.html

#' Function used for displaying \code{prior} object in tibbles
#'
#' @param x An object of class \code{prior}.
#'
#' @return Input formatted with \code{format(x)}.
#' 
#' @importFrom pillar type_sum
#' @export
type_sum.prior <- function(x) {
    format(x)
}

#' Function used for displaying \code{prior} object in tibbles
#'
#' @param x An object of class \code{prior}.
#' 
#' @return Input formatted with \code{format(x)}.
#' 
#' @importFrom pillar obj_sum
#' @export
obj_sum.prior <- function(x) {
    format(x)
}

#' Function used for displaying \code{prior} object in tibbles
#'
#' @param x An object of class \code{prior}.
#' @param ... Not used.
#'
#' @return An object prepared with pillar::new_pillar_shaft_simple.
#' 
#' @importFrom pillar pillar_shaft
#' @export
pillar_shaft.prior <- function(x, ...) {
    out <- format(x)
    out[is.na(x)] <- NA
    pillar::new_pillar_shaft_simple(out, align = "right")
}

### * Methods for Ops on priors (implementing '==' operator)

# https://stackoverflow.com/a/35902710

#' Implementation of the '==' operator for priors
#'
#' @param e1,e2 Objects of class "prior".
#'
#' @return Boolean (or throws an error for unsupported operators).
#' 
#' @examples
#' p <- constant_p(0)
#' q <- constant_p(4)
#' p == q
#'
#' p <- hcauchy_p(2)
#' q <- hcauchy_p(2)
#' p == q
#'
#' @method Ops prior
#' 
#' @export

Ops.prior <- function(e1, e2) {
    op <- .Generic[[1]]
    switch(op,
           `==` = {
               if (e1$type != e2$type) {
                   return(FALSE)
               }
               if (!all(e1$parameters == e2$parameters)) {
                   return(FALSE)
               }
               return(TRUE)
           },
           stop("Undefined operation for objects of class \"priors\".")
           )
}

### * sample_from_prior()

#' Sample from a prior object
#'
#' @param x A \code{prior} object.
#' @param n Integer, number of samples to draw.
#'
#' @return A numeric vector of length \code{n}.
#' 
#' @examples
#' sample_from_prior(constant_p(1))
#' sample_from_prior(constant_p(1), 10)
#' sample_from_prior(hcauchy_p(0.5), 1)
#' hist(sample_from_prior(hcauchy_p(0.5), 20))
#' hist(sample_from_prior(uniform_p(0, 3), 1000))
#' hist(sample_from_prior(scaled_beta_p(3, 7, 2), 1e4))
#' 
#' @export
#'

sample_from_prior <- function(x, n = 1) {
    switch(x$type,
           "constant" = {
               rep(x$parameters[["value"]], n)
           },
           "hcauchy" = {
               scale <- x$parameters[["scale"]]
               replicate(n,
               {
                   o <- stats::rcauchy(1, location = 0, scale = scale)
                   while (o < 0) {
                       o <- stats::rcauchy(1, location = 0, scale = scale)
                   }
                   return(o)
               })
           },
           "trun_normal" = {
               mean <- x$parameters[["mean"]]
               sd <- x$parameters[["sd"]]
               replicate(n, {
                   o <- stats::rnorm(1, mean = mean, sd = sd)
                   while (o < 0) {
                       o <- stats::rnorm(1, mean = mean, sd = sd)
                   }
                   return(o)
               })
           },
           "uniform" = {
               stats::runif(n, min = x$parameters[["min"]], max = x$parameters[["max"]])
           },
           "scaled_beta" = {
               p <- x$parameters
               p[["scale"]] * stats::rbeta(n, shape1 = p[["alpha"]], shape2 = p[["beta"]])
           },
           "exponential" = {
               lambda <- x$parameters[["lambda"]]
               stats::rexp(n = n, rate = lambda)
           },
           "gamma" = {
               alpha <- x$parameters[["alpha"]]
               beta <- x$parameters[["beta"]]
               stats::rgamma(n = n, shape = alpha, rate = beta)
           },
           stop("Unknown prior type."))
}

### * TODO

# Clean-up this file

### * All functions in this file are exported

### * predict.networkModel()

#' Add a column with predictions from a fit
#'
#' @param object Network model
#' @param fit Model fit (mcmc.list object)
#' @param draws Integer, number of draws from the posteriors
#' @param error.draws Integer, number of draws from the error distribution, for
#'     a given posterior draw.
#' @param probs Credible interval (default 0.95).
#' @param cores Number of cores to use for parallel calculations. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param dt,grid_size Time step size or grid points, respectively.
#' @param at Timepoints at which the predictions should be returned.
#' @param end Final timepoint used in the projections.
#' @param ... Not used.
#'
#' @return A network model object with an added column \code{"prediction"}.
#' 
#' @importFrom stats quantile
#' 
#' @export

predict.networkModel <- function(object, fit, draws = NULL, error.draws = 5,
                                 probs = 0.95, cores = NULL,
                                 dt = NULL, grid_size = NULL, at = NULL, end = NULL,
                                 ...) {
    `!!` <- rlang::`!!`
    # Process `cores` argument
    cores <- get_n_cores(cores = cores)
    # Process nm
    nm <- object
    if (!"events" %in% colnames(nm)) {
        nm[["events"]] <- rep(list(NULL), nrow(nm))
    }
    if (!"group" %in% colnames(nm)) {
        nm[["group"]] <- rep(list(NULL), nrow(nm))
    }
    # Process projection arguments (always caching)
    arg_end <- end
    cache <- list()
    rows_time_schemes <- list()
    rows_encoded_events <- list()
    nmRow_ends <- list()
    nmRow_ats <- list()
    for (i in seq_len(nrow(nm))) {
        nmRow <- nm[i, ]
        end <- arg_end
        if (is.null(end)) {
            if (is.null(at)) {
                end <- max(nmRow$observations[[1]][["time"]])
                if (!is.null(nmRow[["events"]][[1]])) {
                    end <- max(c(end, nmRow$events[[1]][["time"]]))
                }
            } else {
                    end <- max(at)
            }
        }
        if (is.null(at)) {
            at <- seq(0, end, length.out = 65)
        }
        nmRow_ends[[i]] <- end
        nmRow_ats[[i]] <- at
        rows_time_schemes[[i]] <- nm_row_get_time_scheme(nm_row = nmRow, dt = dt,
                                                         grid_size = grid_size,
                                                         end = end, at = at)
        rows_encoded_events[[i]] <- encode_events(nmRow, dt = dt, grid_size = grid_size,
                                                  end = end)
    }
    cache[["rows_time_schemes"]] <- rows_time_schemes
    cache[["rows_encoded_events"]] <- rows_encoded_events
    cache[["nmRow_ends"]] <- nmRow_ends
    cache[["nmRow_ats"]] <- nmRow_ats
    end <- arg_end
    # See https://github.com/HenrikBengtsson/future/issues/263#issuecomment-445047269
    # for a reason not to manipulate future::plan() in the package code.
    if (is.null(draws)) {
        draws <- nrow(fit[[1]])
    }
    # Get parameter samples
    samples <- tidy_mcmc_list(fit)
    if (draws > nrow(samples)) {
        warning("Number of draws greater (", draws,
                ") than number of samples (", nrow(samples) ,").\n",
                "Setting number of draws to ", nrow(samples), ".")
        draws <- nrow(samples)
    }
    samples <- samples[sample(seq_len(nrow(samples)), draws), ]
    # Project rows for each set of parameter values
    nm$prediction <- purrr::map(seq_len(nrow(nm)), function(k) {
        nmRow <- nm[k, ]
        projections <- parallel::mclapply(seq_len(nrow(samples)), function(i) {
            nmRow <- set_params(nmRow, samples$mcmc.parameters[[i]], force = TRUE, quick = TRUE)
            pred <- sample_from(nmRow, at = cache[["nmRow_ats"]][[k]],
                                dt = dt, grid_size = grid_size, end = end, error.draws = error.draws,
                                cached_ts = list(cache[["rows_time_schemes"]][[k]]),
                                cached_ee = list(cache[["rows_encoded_events"]][[k]]))
            return(pred)
        }, mc.cores = cores)
        # Concatenate data
        pred <- dplyr::bind_rows(projections)
        pred <- tidyr::nest(dplyr::group_by(pred,
                                            `!!`(rlang::sym("time")),
                                            `!!`(rlang::sym("comp"))))
        pred$sizes <- purrr::map(pred$data, function(x) {
            z <- quantile(x$size, probs = c((1-probs)/2, 1 -(1-probs)/2))
            m <- mean(x$size)
            out <- c(z[1], m, z[2])
            names(out) <- c("low", "mean", "high")
            return(out)
        })
        pred$props <- purrr::map(pred$data, function(x) {
            if (length(na.omit(x$prop)) == 0) { # All NAs can happen when the size is zero for example
                return(c(low = NA, mean = NA, high = NA))
            }
            z <- quantile(x$prop, probs = c((1-probs)/2, 1 -(1-probs)/2))
            m <- c(mean = mean(x$prop))
            out <- c(z[1], m, z[2])
            names(out) <- c("low", "mean", "high")
            return(out)
        })
        sizes <- do.call(dplyr::bind_rows, pred$sizes)
        names(sizes) <- c("size_low", "size_mean", "size_high")
        props <- do.call(dplyr::bind_rows, pred$props)
        names(props) <- c("prop_low", "prop_mean", "prop_high")
        pred <- dplyr::bind_cols(pred[, c("time", "comp")], sizes, props)
        pred[["compartment"]] <- pred[["comp"]]
        pred[["comp"]] <- NULL
        return(pred)
    })
    # Return
    return(nm)
}

### * posterior_predict.networkModelStanfit()

### ** Generic

#' Draw from the posterior predictive distribution of the model outcome
#'
#' @param object Model from which posterior predictions can be made.
#' @param ... Passed to the appropriate method.
#' 
#' @return Usually methods will implement a \code{draw} parameter, and the
#'     returned object is a "draw" by N matrix where N is the number of data
#'     points predicted per draw.
#' 
#' @export

posterior_predict <- function(object, ...) {
    UseMethod("posterior_predict")
}

### ** Method

#' Draw from the posterior predictive distribution of the model outcome
#'
#' @method posterior_predict networkModelStanfit
#'
#' @param object A networkModelStanfit object.
#' @param draw Integer, number of draws to perform from the posterior. Default
#'     is 100.
#' @param newdata Should be the model used to fit the networkStanfit object.
#' @param cores Number of cores to use for parallel calculations. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param ... Not used for now.
#' 
#' @return A "draw" by N matrix where N is the number of data points predicted
#'     per draw.
#' 
#' @export

posterior_predict.networkModelStanfit <- function(object, newdata, draw = NULL,
                                                  cores = NULL, ...) {
    `!!` <- rlang::`!!`
    # Process `cores` argument
    cores <- get_n_cores(cores = cores)
    nm <- newdata
    fit <- object
    if (is.null(draw)) {
        draws <- min(100, nrow(fit[[1]]))
    }
    # Get parameter samples
    samples <- tidy_mcmc_list(fit)
    if (draws > nrow(samples)) {
        warning("Number of draws greater (", draws,
                ") than number of samples (", nrow(samples) ,").\n",
                "Setting number of draws to ", nrow(samples), ".")
        draws <- nrow(samples)
    }
    samples <- samples[sample(seq_len(nrow(samples)), draws), ]
    # Project rows for each set of parameter values
    nm$prediction <- purrr::map(seq_len(nrow(nm)), function(k) {
        nmRow <- nm[k, ]
        at <- unique(nmRow[["observations"]][[1]][["time"]])
        projections <- parallel::mclapply(seq_len(nrow(samples)), function(i) {
            nmRow <- set_params(nmRow, samples$mcmc.parameters[[i]],
                                force = TRUE)
            nmRow <- project(nmRow, at = at)
            pred <- sample_from(nmRow, at, error.draws = 1)
            pred$sample_id <- i
            return(pred)
        }, mc.cores = cores)
        # Concatenate data
        pred <- dplyr::bind_rows(projections)
        pred$group <- nmRow$group
        pred$group_str <- group2string(nmRow$group[[1]])
        return(pred)
    })
    # Return
    return(nm)
}

### * tidy_data()

#' Extract data from a networkModel object into a tidy tibble.
#'
#' @param x A networkModel object.
#'
#' @return A tibble (note: row ordering is not the same as in the input).
#'
#' @examples
#' tidy_data(aquarium_mod)
#' tidy_data(trini_mod)
#'
#' @export

tidy_data <- function(x) {
    # Remove "networkModel" class to avoid dplyr using groups.networkModel method
    stopifnot(class(x)[1] == "networkModel")
    stopifnot(length(class(x)) > 1)
    class(x) <- class(x)[2:length(class(x))]
    if (!"group" %in% colnames(x)) {
        x[["group"]] <- rep(list(NULL), nrow(x))
    }
    group_mapping <- x[["group"]]
    names(group_mapping) <- sapply(group_mapping, group2string)
    x[["group"]] <- names(group_mapping)
    obs <- tidyr::unnest(x[, c("observations", "group")], cols = "observations")
    tidy_obs <- tidyr::pivot_longer(obs, cols = c("size", "proportion"),
                                    names_to = "type", values_to = "value")
    tidy_obs <- tidy_obs[!is.na(tidy_obs[["value"]]), ]
    tidy_obs$group_str <- tidy_obs$group
    tidy_obs[["group"]] <- group_mapping[tidy_obs$group_str]
    tidy_obs <- tidy_obs[order(tidy_obs$compartment,
                               tidy_obs$time,
                               tidy_obs$group_str,
                               tidy_obs$type), ]
    tidy_obs <- tidy_obs[, c("compartment", "time", "group_str", "group",
                             "type", "value")]
    return(tidy_obs)
}

### * tidy_posterior_predict()

#' Draw from the posterior predictive distribution of the model outcome
#'
#' @param object A networkModelStanfit object.
#' @param draw Integer, number of draws to sample from the posterior. Default
#'     is 100.
#' @param newdata The original model used to fit the networkStanfit object.
#' @param cores Number of cores to use for parallel calculations. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param ... Not used for now.
#' 
#' @return A tidy table.
#'
#' @export

tidy_posterior_predict <- function(object, newdata, draw = NULL, cores = NULL,
                                   ...) {
    `!!` <- rlang::`!!`
    # Process `cores` argument
    cores <- get_n_cores(cores = cores)
    # Process nm
    nm <- newdata
    if (!"group" %in% colnames(nm)) {
        nm[["group"]] <- rep(list(NULL), nrow(nm))
    }
    fit <- object
    if (is.null(draw)) {
        draws <- min(100, nrow(fit[[1]]))
    } else {
        draws <- draw
    }
    # Get parameter samples
    samples <- tidy_mcmc_list(fit)
    if (draws > nrow(samples)) {
        warning("Number of draws greater (", draws,
                ") than number of samples (", nrow(samples) ,").\n",
                "Setting number of draws to ", nrow(samples), ".")
        draws <- nrow(samples)
    }
    samples <- samples[sample(seq_len(nrow(samples)), draws), ]
    # Project rows for each set of parameter values
    nm$prediction <- purrr::map(seq_len(nrow(nm)), function(k) {
        nmRow <- nm[k, ]
        at <- unique(nmRow[["observations"]][[1]][["time"]])
        projections <- parallel::mclapply(seq_len(nrow(samples)), function(i) {
            nmRow <- set_params(nmRow, samples$mcmc.parameters[[i]],
                                force = TRUE)
            nmRow <- project(nmRow, at = at)
            pred <- sample_from(nmRow, at, error.draws = 1)
            pred$random_sample_id <- i
            return(pred)
        }, mc.cores = cores)
        # Concatenate data
        pred <- dplyr::bind_rows(projections)
        pred$group <- nmRow$group
        pred$group_str <- group2string(nmRow$group[[1]])
        return(pred)
    })
    # Return
    z <- dplyr::bind_rows(nm$prediction)
    z$compartment <- z$comp
    z$comp <- NULL
    z <- tidyr::pivot_longer(z, cols = c("size", "prop"), names_to = "type",
                             values_to = "value")
    z <- z[, c("compartment", "time", "group_str", "group",
               "type", "value", "random_sample_id")]
    z <- z[order(z$compartment, z$time, z$group_str, z$random_sample_id, z$type), ]
    z[["type"]][z[["type"]] == "prop"] <- "proportion"
    return(z)
}

### * tidy_dpp()

#' Prepare tidy data and posterior predictions
#'
#' This function prepares both tidy data from a model and tidy posterior
#' predictions from a model fit. Having those two tibbles prepared at the same
#' time allows to merge them to ensure that observed data, predicted data and
#' original variables other than observations are all in sync when using y and
#' y_rep objects for bayesplot functions.
#'
#' @param model A networkModel object.
#' @param fit A networkModelStanfit object.
#' @param draw Integer, number of draws to sample from the posterior.
#' @param cores Number of cores to use for parallel calculations. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#'
#' @return A list with y, y_rep and vars.
#'
#' @export

tidy_dpp <- function(model, fit, draw = NULL, cores = NULL) {
    `!!` <- rlang::`!!`
    td <- tidy_data(model)
    tpp <- tidy_posterior_predict(fit, model, draw = draw, cores = cores)
    tpp$group <- NULL
    template <- unique(td[, c("compartment", "time", "group_str", "type")])
    tpp <- dplyr::left_join(template, tpp, by = c("compartment", "time",
                                                  "group_str", "type"))
    # Arrange td and tpp similarly
    tpp <- dplyr::group_by(tpp,
                           `!!`(rlang::sym("compartment")),
                           `!!`(rlang::sym("time")),
                           `!!`(rlang::sym("group_str")),
                           `!!`(rlang::sym("type")))
    tpp <- tidyr::nest(tpp)
    all <- dplyr::left_join(td, tpp, by = c("compartment", "time", "group_str", "type"))
    # Extract y and y_rep
    y <- all$value
    y_rep <- lapply(all$data, function(x) {
        x <- x[["value"]][order(x[["random_sample_id"]])]
        x
    })
    y_rep <- do.call(cbind, y_rep)
    # Extract vars
    vars <- all[, c("compartment", "time", "type", "group")]
    groups <- vars[["group"]]
    groups <- do.call(rbind, groups)
    if (is.null(groups)) {
        vars[["group."]] <- rep(list(NULL), nrow(vars))
        vars[["group"]] <- NULL
    } else {
        groups_cols <- paste0("group.", colnames(groups))
        if (any(groups_cols %in% colnames(vars))) {
            stop("One group column name already used (one of ",
                 groups_cols, ")", "\n",
                 "Group column names cannot be: ", colnames(vars), "\n")
        }
        for (i in seq_along(groups_cols)) {
            vars[[groups_cols[i]]] <- groups[, colnames(groups)[i]]
        }
        vars[["groups"]] <- NULL
    }
    # Return
    out <- list(y = y,
                y_rep = y_rep,
                vars = vars)
    return(structure(out, class = c("ppcNetworkModel", class(out))))
}

### * filter.ppcNetworkModel() (generic and method)

# Precious help from:
# https://r.789695.n4.nabble.com/R-CMD-check-warning-with-S3-method-td4692255.html
# https://github.com/wch/s3methodtest/blob/master/R/test.r
# to understand how to provide a filter method without loading dplyr by default.

#' Filter (alias for filter function from dplyr)
#'
#' @param .data Data to filter.
#' @param ... Passed to dplyr::filter.
#' @param preserve Ignored.
#'
#' @return See the returned value for dplyr::filter.
#' 
#' @name filter
#' @importFrom dplyr filter
#' @export filter
#'
NULL

#' Filter method for output of tidy_data_and_posterior_predict()
#'
#' @param .data A ppcNetworkModel object.
#' @param ... Passed to dplyr::filter.
#' @param .preserve Ignored.
#'
#' @return A pccNetworkModel object filtered appropriately based on the
#'     [["vars"]] tibble.
#'
#' @importFrom dplyr filter
#' @method filter ppcNetworkModel
#' @export
#' 

filter.ppcNetworkModel <- function(.data, ..., .preserve = FALSE) {
    out <- .data
    out[["vars"]][["row_id"]] <- seq_len(nrow(out[["vars"]]))
    out[["vars"]] <- dplyr::filter(out[["vars"]], ...)
    out[["y"]] <- out[["y"]][out[["vars"]][["row_id"]]]
    out[["y_rep"]] <- out[["y_rep"]][, out[["vars"]][["row_id"]]]
    out[["vars"]][["row_id"]] <- NULL
    return(out)
}

### * tidy_trajectories()

#' Build a tidy table with the trajectories for each iteration
#'
#' If neither \code{n_per_chain} and \code{n} are provided, all iterations are
#' used.
#'
#' Warning: This function is still maturing and its interface and output might
#' change in the future.
#' 
#' @param nm A \code{networkModel} object.
#' @param mcmc The corresponding output from \code{run_mcmc}.
#' @param n_per_chain Integer, number of iterations randomly drawn per
#'     chain. Note that iterations are in sync across chains (in practice,
#'     random iterations are chosen, and then parameter values extracted for
#'     those same iterations from all chains).
#' @param n Integer, number of iterations randomly drawn from \code{mcmc}. Note
#'     that iterations are *not* drawn in sync across chains in this case (use
#'     \code{n_per_chain} if you need to have the same iterations taken across
#'     all chains).
#' @param n_grid Size of the time grid used to calculate trajectories
#' @param cores Number of cores to use for parallel calculations. Default is
#'     \code{NULL}, which means to use the value stored in
#'     \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param dt,grid_size Time step size or grid points, respectively.
#' @param at Timepoints at which the predictions should be returned.
#' @param end Final timepoint used in the projections.
#' @param use_cache Boolean, use cache for faster calculations?
#'
#' @return A tidy table containing the mcmc iterations (chain, iteration,
#'     parameters), the grouping variables from the network model and the
#'     trajectories.
#'
#' @examples
#' tt <- tidy_trajectories(aquarium_mod, aquarium_run, n = 10, cores = 2)
#' tt
#' 
#' @export

tidy_trajectories <- function(nm, mcmc, n_per_chain = NULL, n = NULL, n_grid = 64,
                              dt = NULL, grid_size = NULL, at = NULL, end = NULL,
                              use_cache = TRUE, cores = NULL) {
    cores <- get_n_cores(cores = cores)
    to <- tidy_mcmc_list(mcmc)
    arg_end <- end
    if (use_cache) {
        cache <- list()
        rows_time_schemes <- list()
        rows_encoded_events <- list()
        for (i in seq_len(nrow(nm))) {
            nmRow <- nm[i, ]
            end <- arg_end
            if (is.null(end)) {
                if (is.null(at)) {
                    end <- max(nmRow$observations[[1]][["time"]])
                    if (!is.null(nmRow[["events"]][[1]])) {
                        end <- max(c(end, nmRow$events[[1]][["time"]]))
                    }
                } else {
                    end <- max(at)
                }
            }
            rows_time_schemes[[i]] <- nm_row_get_time_scheme(nm_row = nmRow, dt = dt,
                                                             grid_size = grid_size,
                                                             end = end, at = at)
            rows_encoded_events[[i]] <- encode_events(nmRow, end = end, dt = dt,
                                                      grid_size = grid_size)
        }
        cache[["rows_time_schemes"]] <- rows_time_schemes
        cache[["rows_encoded_events"]] <- rows_encoded_events
    } else {
        cache <- NULL
    }
    end <- arg_end
    if (!is.null(n_per_chain)) {
        my_iters <- sample(unique(to$mcmc.iteration), size = n_per_chain)
        to <- to[to$mcmc.iteration %in% my_iters, ]
    }
    if (!is.null(n)) {
        if (!is.null(n_per_chain)) {
            warning("Both \"n_per_chain\" and \"n\" are provided. Using \"n_per_chain\".")
        } else {
            to <- to[sample(1:nrow(to), size = n), ]
        }
    }
    # Run networks for each chain and each iteration
    trajectories <- purrr::map(seq_len(nrow(nm)), function(k) {
        nmRow <- nm[k, ]
        projections <- parallel::mclapply(seq_len(nrow(to)), function(i) {
            nmRow <- set_params(nmRow, to$mcmc.parameters[[i]], force = TRUE, quick = TRUE)
            nmRow <- project(nmRow, grid_size = n_grid, dt = dt, 
                             at = at, end = end, cached_ts = cache[["rows_time_schemes"]][k],
                             cached_ee = cache[["rows_encoded_events"]][k])
            return(nmRow$trajectory[[1]])
        }, mc.cores = cores)
        out <- to
        out$trajectories <- projections
        return(out)
    })
    # Unnest
    nm$trajectories <- trajectories
    if (is.null(groups(nm))) {
        my_out <- tidyr::unnest(nm[, "trajectories"], "trajectories")
    } else {
        # Careful unnesting to keep correct groups when there is more than
        # one grouping variable
        groups <- nm[["group"]]
        nm[["group"]] <- seq_len(nrow(nm))
        out <- tidyr::unnest(nm[, c("group", "trajectories")], "trajectories")
        group_list <- groups[out[["group"]]]
        out[["group"]] <- group_list
        my_out <- out
    }
    # Return
    return(my_out)
}

### * tidy_flows()

#' Build a tidy table with the flows for each iteration
#'
#' If neither \code{n_per_chain} and \code{n} are provided, all iterations are
#' used.
#'
#' Warning: This function is still maturing and its interface and output might
#' change in the future.
#'
#' Note about how steady state sizes for split compartments are calculated: the
#' steady size of the active portion is calculated divide it is divided by the
#' active fraction (portion.act parameter) to get the total size including the
#' refractory portion. In this case we get a "steady-state" refractory portion,
#' consistent with steady state size of active fraction and with portion.act
#' parameter.
#' 
#' @param nm A \code{networkModel} object.
#' @param mcmc The corresponding output from \code{run_mcmc}.
#' @param n_per_chain Integer, number of iterations randomly drawn per
#'   chain. Note that iterations are in sync across chains (in practice, random
#'   iterations are chosen, and then parameter values extracted for those same
#'   iterations from all chains).
#' @param n Integer, number of iterations randomly drawn from \code{mcmc}. Note
#'   that iterations are *not* drawn in sync across chains in this case (use
#'   \code{n_per_chain} if you need to have the same iterations taken across all
#'   chains).
#' @param n_grid Size of the time grid used to calculate trajectories
#' @param steady_state Boolean (default: FALSE). If TRUE, then steady state
#'   compartment sizes are calculated for each iteration and steady state flows
#'   are calculated from those compartment sizes. Note that any pulse that
#'   might be specified in the input model \code{nm} is ignored in this case.
#' @param cores Number of cores to use for parallel calculations. Default is
#'   \code{NULL}, which means to use the value stored in
#'   \code{options()[["mc.cores"]]} (or 1 if this value is not set).
#' @param dt,grid_size Time step size or grid points, respectively.
#' @param at Timepoints at which the predictions should be returned.
#' @param end Final timepoint used in the projections.
#' @param use_cache Boolean, use cache for faster calculations?
#'
#' @return A tidy table containing the mcmc iterations (chain, iteration,
#'     parameters), the grouping variables from the network model and the
#'     flows. The returned flow values are the average flow per unit of time
#'     over the trajectory calculations (or steady state flows if
#'     \code{steady_state} is TRUE).
#' 
#' @examples
#' tf <- tidy_flows(aquarium_mod, aquarium_run, n_per_chain = 25, cores = 2)
#' tf
#' tfmcmc <- as.mcmc.list(tf)
#' plot(tfmcmc)
#' 
#' @export

tidy_flows <- function(nm, mcmc, n_per_chain = NULL, n = NULL, n_grid = 64,
                       steady_state = FALSE,
                       dt = NULL, grid_size = NULL, at = NULL, end = NULL,
                       use_cache = TRUE, cores = NULL) {
    cores <- get_n_cores(cores = cores)
    to <- tidy_mcmc_list(mcmc)
    arg_end <- end
    if (use_cache) {
        cache <- list()
        rows_time_schemes <- list()
        rows_encoded_events <- list()
        for (i in seq_len(nrow(nm))) {
            nmRow <- nm[i, ]
            end <- arg_end
            if (is.null(end)) {
                if (is.null(at)) {
                    end <- max(nmRow$observations[[1]][["time"]])
                    if (!is.null(nmRow[["events"]][[1]])) {
                        end <- max(c(end, nmRow$events[[1]][["time"]]))
                    }
                } else {
                    end <- max(at)
                }
            }
            rows_time_schemes[[i]] <- nm_row_get_time_scheme(nm_row = nmRow, dt = dt,
                                                             grid_size = grid_size,
                                                             end = end, at = at)
            rows_encoded_events[[i]] <- encode_events(nmRow, end = end, dt = dt,
                                                      grid_size = grid_size)
        }
        cache[["rows_time_schemes"]] <- rows_time_schemes
        cache[["rows_encoded_events"]] <- rows_encoded_events
    } else {
        cache <- NULL
    }
    end <- arg_end
    if (!is.null(n_per_chain)) {
        my_iters <- sample(unique(to$mcmc.iteration), size = n_per_chain)
        to <- to[to$mcmc.iteration %in% my_iters, ]
    }
    if (!is.null(n)) {
        if (!is.null(n_per_chain)) {
            warning("Both \"n_per_chain\" and \"n\" are provided. Using \"n_per_chain\".")
        } else {
            to <- to[sample(1:nrow(to), size = n), ]
        }
    }
    # Run networks for each chain and each iteration
    if (!steady_state) {
        flows <- purrr::map(seq_len(nrow(nm)), function(k) {
            nmRow <- nm[k, ]
            flows <- parallel::mclapply(seq_len(nrow(to)), function(i) {
                nmRow <- set_params(nmRow, to$mcmc.parameters[[i]], force = TRUE, quick = TRUE)
                nmRow <- project(nmRow, flows = "average", grid_size = n_grid, dt = dt, 
                                 at = at, end = end, cached_ts = cache[["rows_time_schemes"]][k],
                                 cached_ee = cache[["rows_encoded_events"]][k])
                return(nmRow$flows[[1]])
            }, mc.cores = cores)
            out <- to
            out$flows <- flows
            return(out)
        })
    } else {
      flows <- purrr::map(seq_len(nrow(nm)), function(k) {
            nmRow <- nm[k, ]
            flows <- parallel::mclapply(seq_len(nrow(to)), function(i) {
                nmRow_to <- set_params(nmRow, to$mcmc.parameters[[i]], force = TRUE, quick = TRUE)
                ss_sizes <- calculate_steady_state_one_row(nmRow_to)
                ss_inits <- tibble::tibble(compartment = names(ss_sizes),
                                           size = ss_sizes,
                                           proportion = 0)
                nmRow_to$initial <- list(ss_inits)
                nmRow_to <- project(nmRow_to, grid_size = 3, flows = "average",
                                    ignore_pulses = TRUE)
                return(nmRow_to$flows[[1]])
            }, mc.cores = cores)
            out <- to
            out$flows <- flows
            return(out)
        })
    }
    # Unnest
    nm$flows <- flows
    if (is.null(groups(nm))) {
        my_out <- tidyr::unnest(nm[, "flows"], "flows")
    } else {
        # Careful unnesting to keep correct groups when there is more than
        # one grouping variable
        groups <- nm[["group"]]
        nm[["group"]] <- seq_len(nrow(nm))
        out <- tidyr::unnest(nm[, c("group", "flows")], "flows")
        group_list <- groups[out[["group"]]]
        out[["group"]] <- group_list
        my_out <- out
    }
    # Add a "tidy_flows" class
    return(structure(my_out, class = c("tidy_flows", class(my_out))))
}

### * as.mcmc.list.tidy_flows() method

#' Convert a \code{tidy_flows} object to an \code{mcmc.list}
#'
#' @param x A tidy flow object, as returned by \code{\link{tidy_flows}}. Note
#'     that all chains must have the same iterations extracted (i.e. you must
#'     use \code{n_per_chain} when calling \code{\link{tidy_flows}}).
#' @param ... Not used for now.
#'
#' @return A \code{mcmc.list} object, with ordered iterations.
#'
#' @method as.mcmc.list tidy_flows
#' 
#' @export

as.mcmc.list.tidy_flows <- function(x, ...) {
    `!!` <- rlang::`!!`
    if (!length(unique(table(x$mcmc.iteration))) == 1 |
        all(table(x$mcmc.iteration) == 1)) {
        stop("Not all chains have the same iterations in \"x\". Make sure you use \"n_per_chain\" (with a value > 1) and not \"n\" when calling \"tidy_flows()\".")
    }
    groups <- x[["group"]]
    if (!is.null(groups)) {
        groups <- sapply(groups, function(z) paste0(z, collapse = ","))
    }
    # Convert flow tibbles to named vectors
    for (i in seq_len(nrow(x))) {
        f <- x$flows[[i]]
        grp_suffix <- ""
        if (!is.null(groups)) {
            grp_suffix <- paste0("|", groups[i])
        }
        params <- paste0(f$from, "_to_", f$to, grp_suffix)
        f <- setNames(f$average_flow, nm = params)
        x$flows[[i]] <- f
    }
    # Pool parameter values per iteration per chain
    x <- dplyr::group_by(x[, c("mcmc.chain", "mcmc.iteration", "flows")],
                         `!!`(rlang::sym("mcmc.chain")),
                         `!!`(rlang::sym("mcmc.iteration")))
    x <- tidyr::nest(x)
    x$data <- lapply(x$data, function(z) unlist(z$flows))
    x <- dplyr::ungroup(x)
    x <- tidyr::nest(dplyr::group_by(x, `!!`(rlang::sym("mcmc.chain"))))
    x$data <- lapply(x$data, function(z) {
        z <- z[order(z$mcmc.iteration), ]
        params <- do.call(rbind, z$data)
        coda::as.mcmc(params)
    })
    # Return
    out <- coda::as.mcmc.list(x$data)
    return(structure(out, class = c("tidy_flows_mcmc.list", class(out))))
}


### * sample_params()

#' Sample parameter values from priors
#'
#' @param nm A \code{networkModel} object.
#'
#' @return A named vector containing parameter values.
#'
#' @examples
#' library(magrittr)
#' 
#' p <- sample_params(aquarium_mod)
#' p
#' 
#' proj <- aquarium_mod %>% set_params(p) %>% project(end = 10)
#' plot(proj)
#' 
#' @export

sample_params <- function(nm) {
    p <- priors(nm)
    p$value <- sapply(p$prior, function(x) sample_from_prior(x, n = 1))
    return(tibble::deframe(p[, c("in_model", "value")]))
}

### * tidy_steady_states()

#' Build a tidy table with the calculated steady states for each iteration
#'
#' If neither \code{n_per_chain} and \code{n} are provided, all iterations are
#' used.
#'
#' Note about how steady state sizes for split compartments are calculated: the
#' steady size of the active portion is calculated divide it is divided by the
#' active fraction (portion.act parameter) to get the total size including the
#' refractory portion. In this case we get a "steady-state" refractory portion,
#' consistent with steady state size of active fraction and with portion.act
#' parameter.
#' 
#' @param nm A \code{networkModel} object.
#' @param mcmc The corresponding output from \code{run_mcmc}.
#' @param n_per_chain Integer, number of iterations randomly drawn per
#'     chain. Note that iterations are in sync across chains (in practice,
#'     random iterations are chosen, and then parameter values extracted for
#'     those same iterations from all chains).
#' @param n Integer, number of iterations randomly drawn from \code{mcmc}. Note
#'     that iterations are *not* drawn in sync across chains in this case (use
#'     \code{n_per_chain} if you need to have the same iterations taken across
#'     all chains).
#'
#' @return A tidy table containing the mcmc iterations (chain, iteration,
#'     parameters), the grouping variables from the network model and the
#'     steady state sizes.
#' 
#' @export

tidy_steady_states <- function(nm, mcmc, n_per_chain = NULL, n = NULL) {
    to <- tidy_mcmc_list(mcmc)
    if (!is.null(n_per_chain)) {
        my_iters <- sample(unique(to$mcmc.iteration), size = n_per_chain)
        to <- to[to$mcmc.iteration %in% my_iters, ]
    }
    if (!is.null(n)) {
        if (!is.null(n_per_chain)) {
            warning("Both \"n_per_chain\" and \"n\" are provided. Using \"n_per_chain\".")
        } else {
            to <- to[sample(1:nrow(to), size = n), ]
        }
    }
    # Calculate steady states for each chain and each iteration
    ss_sizes <- purrr::map(seq_len(nrow(nm)), function(k) {
        nmRow <- nm[k, ]
        sizes <- list()
        for (i in seq_len(nrow(to))) {
            nmRow <- set_params(nmRow, to$mcmc.parameters[[i]], force = TRUE)
            sizes[[i]] <- calculate_steady_state_one_row(nmRow)
        }
        out <- to
        out$stable_sizes <- sizes
        return(out)
    })
    # Unnest
    nm$stable_sizes <- ss_sizes
    if (is.null(groups(nm))) {
        my_out <- tidyr::unnest(nm[, "stable_sizes"], "stable_sizes")
    } else {
        # Careful unnesting to keep correct groups when there is more than
        # one grouping variable
        groups <- nm[["group"]]
        nm[["group"]] <- seq_len(nrow(nm))
        out <- tidyr::unnest(nm[, c("group", "stable_sizes")], "stable_sizes")
        group_list <- groups[out[["group"]]]
        out[["group"]] <- group_list
        my_out <- out
    }
    # Add a "tidy_steady_states" class
    return(structure(my_out, class = c("tidy_steady_states", class(my_out))))
}

### * as.mcmc.list.tidy_steady_states() method

#' Convert a \code{tidy_steady_states} object to an \code{mcmc.list}
#'
#' @param x A tidy steady states object, as returned by
#'     \code{\link{tidy_steady_states}}. Note that all chains must have the
#'     same iterations extracted (i.e. you must use \code{n_per_chain} when
#'     calling \code{\link{tidy_flows}}).
#' @param ... Not used for now.
#'
#' @return A \code{mcmc.list} object, with ordered iterations.
#'
#' @method as.mcmc.list tidy_steady_states
#' 
#' @export

as.mcmc.list.tidy_steady_states <- function(x, ...) {
    `!!` <- rlang::`!!`
    if (!length(unique(table(x$mcmc.iteration))) == 1 |
        all(table(x$mcmc.iteration) == 1)) {
        stop("Not all chains have the same iterations in \"x\". Make sure you use \"n_per_chain\" (with a value > 1) and not \"n\" when calling \"tidy_flows()\".")
    }
    groups <- x[["group"]]
    if (!is.null(groups)) {
        groups <- sapply(groups, function(z) paste0(z, collapse = ","))
    }
    # Convert steady state names to incorporate group name
    for (i in seq_len(nrow(x))) {
        f <- x$stable_sizes[[i]]
        grp_suffix <- ""
        if (!is.null(groups)) {
            grp_suffix <- paste0("|", groups[i])
        }
        params <- paste0(names(f), grp_suffix)
        f <- setNames(f, nm = params)
        x$stable_sizes[[i]] <- f
    }
    # Pool parameter values per iteration per chain
    x <- dplyr::group_by(x[, c("mcmc.chain", "mcmc.iteration", "stable_sizes")],
                         `!!`(rlang::sym("mcmc.chain")),
                         `!!`(rlang::sym("mcmc.iteration")))
    x <- tidyr::nest(x)
    x$data <- lapply(x$data, function(z) unlist(z$stable_sizes))
    x <- dplyr::ungroup(x)
    x <- tidyr::nest(dplyr::group_by(x, `!!`(rlang::sym("mcmc.chain"))))
    x$data <- lapply(x$data, function(z) {
        z <- z[order(z$mcmc.iteration), ]
        params <- do.call(rbind, z$data)
        coda::as.mcmc(params)
    })
    # Return
    out <- coda::as.mcmc.list(x$data)
    return(structure(out, class = c("tidy_flows_mcmc.list", class(out))))
}

### * tidy_mcmc()

#' Extract a tidy output from an mcmc.list
#'
#' @param x An mcmc.list object
#' @param spread Boolean, spread the parameters into separate columns?
#' @param include_constant Boolean, include constant parameters as proper
#'     parameter traces?
#'
#' @return A tidy table containing one iteration per row
#'
#' @examples
#' fit <- lapply(1:4, function(i) {
#'   z <- matrix(rnorm(200), ncol = 2)
#'   colnames(z) <- c("alpha", "beta")
#'   coda::as.mcmc(z)
#' })
#' fit <- coda::as.mcmc.list(fit)
#' tidy_mcmc(fit)
#' tidy_mcmc(fit, spread = TRUE)
#'
#' @export

tidy_mcmc <- function(x, spread = FALSE, include_constant = TRUE) {
    z <- x
    n_iters <- nrow(z[[1]])
    constant_params <- attr(z, "constant_params")
    # Add traces for constant params (if needed)
    if (!is.null(constant_params) & include_constant) {
        constant_template <- matrix(NA, ncol = length(constant_params),
                                    nrow = n_iters)
        for (i in seq_along(constant_params)) {
            constant_template[, i] <- constant_params[i]
        }
        colnames(constant_template) <- names(constant_params)
        for (i in seq_along(z)) {
            zi <- coda::as.mcmc(cbind(z[[i]], constant_template))
            attr(zi, "mcpar") <- attr(z[[i]], "mcpar")
            z[[i]] <- zi
        }
    }
    paramNames <- colnames(z[[1]])
    # If spread = FALSE
    if (!spread) {
        tables <- lapply(seq_along(z), function(i) {
            my_chain <- as.matrix(z[[i]])
            tibble::tibble(mcmc.chain = i,
                           mcmc.iteration = seq_len(nrow(my_chain)),
                           mcmc.parameters = lapply(seq_len(nrow(my_chain)),
                                                    function(k) {
                                                        setNames(my_chain[k,], paramNames)
                                                    })
                           )
        })
        out <- dplyr::bind_rows(tables)
        return(out)
    }
    # If spread = TRUE
    mcmc_parameters <- lapply(seq_along(z), function(i) {
        my_chain <- tibble::as_tibble(as.matrix(z[[i]]))
        mcmc_pars <- tibble::tibble(mcmc.chain = i,
                                    mcmc.iteration = seq_len(nrow(my_chain)))
        dplyr::bind_cols(mcmc_pars, my_chain)
    })
    out <- dplyr::bind_rows(mcmc_parameters)
    return(out)
}


### * None of the functions in this file is exported

### * make_topology()

#' Build a network topology
#'
#' @section Link format:
#' 
#' Links are defined by a string describing connections between groups of
#' compartments and their directions using \code{->} and \code{<-}. The groups
#' being connected can be a single compartment or several compartments. Several
#' compartments can be separated either by commas or by spaces. Connection
#' descriptions can be chained in a single string.
#'
#' Some valid links are for example \code{"NH4, NO3 -> epi"} or
#' \code{"NH4, NO3 -> epi -> lepto, tricor"}.
#'
#' See the Examples section for more details.
#' 
#' @param links Vector of strings defining the connections between
#'     compartments. Alternatively, can be a data frame with two columns
#'     describing the source and destination of each link, in which case the
#'     arguments "from" and "to" must be provided.
#' @param from Optional, string containing the column name for sources if
#'     "links" is a data frame
#' @param to Optional, string containing the column name for destinations if
#'     "links" is a data frame
#' @param split Optional, vector of strings containing the names of the
#'     compartments which comprise an active and a refractory portions
#'
#' @return A matrix describing the topology of the network (with class
#'     topology). A coefficient (i,j) is 1 if material can flow from
#'     compartment j (column) into compartment i (row), and 0 otherwise.
#'
#' @examples
#' topo <- isotracer:::make_topology(links = "NH4, NO3 -> epi -> pseph, tricor")
#' topo
#'
#' # A larger foodweb
#' links <- c("NH4, NO3 -> seston, epi, CBOM, FBOM",
#'            "seston -> lepto", "epi -> petro, pseph",
#'            "CBOM, FBOM -> eudan", "CBOM -> phyllo",
#'            "FBOM -> tricor -> arg, euthy")
#' topo2 <- isotracer:::make_topology(links = links, split = "epi")
#' topo2
#'
#' # Using a data frame to specify the links
#' links <- data.frame(source = c("NH4", "NO3", "epi"),
#'                     consumer = c("epi", "epi", "petro"))
#' topo3 <- isotracer:::make_topology(links, from = "source", to = "consumer")
#' topo3
#' 
#' @keywords internal
#' @noRd

make_topology <- function(links, from = NULL, to = NULL, split = NULL) {
    # Links are provided as strings
    if (is.null(from) & is.null(to)) {
        out <- build_uptake_mask(links = links)
        out <- structure(out, class = c("topology", class(out)))
        attr(out, "split") = split
        return(out)
    }
    # Links are provided as a data frame
    # Build the links strings from the input data frame
    links <- paste(links[[from]], links[[to]], sep = " -> ")
    return(make_topology(links, split = split))
}

### * topo_get_upsilon_names()

#' @keywords internal
#' @noRd

topo_get_upsilon_names <- function(topo) {
    comps <- colnames(topo)
    out <- rep(NA, ncol(topo)^2)
    k <- 1
    for (i in seq_len(nrow(topo))) {
        for (j in seq_len(ncol(topo))) {
            if (topo[i,j] == 1) {
                out[k] <- paste("upsilon", comps[j], "to", comps[i], sep = "_")
                k = k + 1
            }
        }
    }
    if (k == 1) {
        return(vector())
    }
    return(out[1:(k-1)])
}

### * topo_get_lambda_names()

#' @keywords internal
#' @noRd

topo_get_lambda_names <- function(topo) {
    comps <- colnames(topo)
    out <- rep(NA, ncol(topo))
    k <- 1
    for (j in seq_len(ncol(topo))) {
        out[k] <- paste("lambda", comps[j], sep = "_")
        k = k + 1
    }
    if (k == 1) {
        return(vector())
    }
    return(out[1:(k-1)])
}

### * topo_get_portionAct_names()

#' @keywords internal
#' @noRd

topo_get_portionAct_names <- function(topo) {
    split <- attr(topo, "split")
    if (is.null(split)) {
        return(NULL)
    }
    params <- paste0("portion.act_", split)
    return(params)
}


### * All functions in this file are exported

### * topo()

#' Return the list of topologies, or a unique topology if all identical
#'
#' @param nm A \code{networkModel} object.
#' @param simplify Boolean, return only a unique topology if all topologies are
#'     identical or if there is only one? Default is TRUE.
#'
#' @return A list of the \code{networkModel} topologies or, if all topologies
#'     are identical (or if there is only one) and \code{simplify} is TRUE, a
#'     single topology (not wrapped into a single-element list).
#'
#' @examples
#' aquarium_mod
#' topo(aquarium_mod)
#'
#' trini_mod
#' topo(trini_mod)
#' @export

topo <- function(nm, simplify = TRUE) {
    out <- nm[["topology"]]
    if (simplify && length(unique(out)) == 1) {
        return(unique(out)[[1]])
    }
    return(out)
}

### * prop_family()

#' Return the distribution family for observed proportions
#'
#' @param nm A \code{networkModel} object.
#' @param quiet Boolean for being quiet about explaining the role of eta
#'     (default is \code{FALSE}).
#'
#' @return A character string describing the distribution family used to model
#'     observed proportions.
#'
#' @examples
#' prop_family(aquarium_mod)
#' prop_family(trini_mod)
#' 
#' @export

prop_family <- function(nm, quiet = FALSE) {
    z <- attr(nm, "prop_family")
    if (!quiet) {
        describe_z_eta("eta", z)
    }
    z
}

### * size_family()

#' Return the distribution family for observed sizes
#'
#' @param nm A \code{networkModel} object.
#' @param quiet Boolean for being quiet about explaining the role of zeta
#'     (default is \code{FALSE}).
#'
#' @return A character string describing the distribution family used to model
#'     observed sizes.
#'
#' @examples
#' size_family(aquarium_mod)
#' size_family(trini_mod)
#' 
#' @export

size_family <- function(nm, quiet = FALSE) {
    z <- attr(nm, "size_family")
    if (!quiet) {
        describe_z_eta("zeta", z)
    }
    z
}

### * groups() method for networkModel

#' Get the grouping for a \code{networkModel} object
#'
#' @param x A \code{networkModel} object.
#'
#' @return A tibble giving the grouping variable(s) for the input network
#'     model. This tibble is in the same order as the rows of the input network
#'     model. If the input network model did not have any grouping variable,
#'     returns \code{NULL}.
#' 
#' @importFrom dplyr groups
#' @method groups networkModel
#'
#' @examples
#' groups(aquarium_mod)
#' groups(trini_mod)
#' 
#' @export

groups.networkModel <- function(x) {
    nm_get_groups(x, error = FALSE)
}

### * priors()

#' Return the tibble containing the priors of a networkModel
#'
#' @param nm A \code{networkModel} object.
#' @param fix_set_params If TRUE, parameters for which a value is set are given a
#'     fixed value (i.e. their prior is equivalent to a point value).
#' @param quiet Boolean to control verbosity.
#'
#' @return A tibble giving the current priors defined for the input network
#'     model.
#'
#' @examples
#' priors(aquarium_mod)
#' priors(trini_mod)
#' 
#' @export

priors <- function(nm, fix_set_params = FALSE, quiet = FALSE) {
    if (fix_set_params) {
        set_params <- attr(nm, "parameterValues")
        if (!is.null(set_params)) {
            for (i in seq_len(nrow(set_params))) {
                myPrior <- constant_p(value = set_params[["value"]][i])
                nm <- set_prior(nm, myPrior, param = set_params[["parameter"]][i],
                                use_regexp = FALSE, quiet = quiet)
            }
        }
    }
    out <- attr(nm, "priors")
    return(out)
}

### * missing_priors()

#' Get a table with parameters which are missing priors
#'
#' @param nm A \code{networkModel} object.
#'
#' @return A tibble containing the parameters which are missing a prior. If no
#'     priors are missing, the tibble contains zero row.
#'
#' @examples
#'# Using a subset of the topology from the Trinidad case study
#' m <- new_networkModel() %>%
#'   set_topo("NH4, NO3 -> epi, FBOM", "epi -> petro, pseph")
#'
#' # No prior is set by default
#' priors(m)
#'
#' # Set some priors
#' m <- set_priors(m, normal_p(0, 10), "lambda")
#' priors(m)
#'
#' # Which parameters are missing a prior?
#' missing_priors(m)
#'
#' @export

missing_priors <- function(nm) {
    p <- priors(nm)
    p <- p[sapply(p$prior, is.null), ]
    return(p)
}

### * params()

#' Return the parameters of a network model
#'
#' @param nm A \code{networkModel} object.
#' @param simplify If \code{TRUE}, return a vector containing the names of all
#'     model parameters (default: \code{FALSE}).
#'
#' @return A tibble containing the parameter names and their current value (if
#'     set). If \code{simplify} is \code{TRUE}, only return a sorted character
#'     vector containing the parameters names.
#'
#' @examples
#' params(aquarium_mod)
#' params(trini_mod)
#' params(trini_mod, simplify = TRUE)
#' 
#' @export

params <- function(nm, simplify = FALSE) {
    stopifnot("parameters" %in% colnames(nm))
    params <- dplyr::bind_rows(nm[["parameters"]])
    if (simplify) {
        return(sort(unique(params[["in_model"]])))
    }
    if (!"value" %in% colnames(params)) {
        params[["value"]] <- as.numeric(rep(NA, nrow(params)))
    }
    params <- unique(params[, c("in_model", "value")])
    params <- params[order(params[["in_model"]]), ]
    if (!all(table(params[["in_model"]]) == 1)) {
        stop("Some parameters have two different values assigned to them.")
    }
    return(params)
}

### * comps()

#' Return the compartments of a network model
#'
#' @param nm A \code{networkModel} object.
#'
#' @return A list of character vectors, with one list element per row of the
#'     input network model (list elements are in the same order as the input
#'     network model rows). Each list element containing the names of the
#'     compartments in the topology defined in the corresponding row of the
#'     input network model.
#'
#' @examples
#' aquarium_mod
#' comps(aquarium_mod)
#'
#' trini_mod
#' comps(trini_mod)
#' 
#' @export

comps <- function(nm) {
    comps <- nm[, "topology"]
    comps$compartments <- lapply(comps$topology, colnames)
    return(comps[["compartments"]])
}


### * All functions in this file are exported

### * Description

# Methods for \code{coda::mcmc.list} objects:
#
# - Provide simple math operations for mcmc.list objects and also allows to use
# math functions such as log() or exp() on mcmc.list objects.
#
# - Provide simple interface to select parameters based on their name.
#
# Those methods are not designed specifically for this package, and could be
# submitted e.g. for integration in the coda package.

### * Helper functions / generics

### * Ops.mcmc.list()

# Based on
# ?groupGeneric
# ?.Generic
# https://stackoverflow.com/questions/35902360/r-implement-group-generics-ops-to-enable-comparison-of-s3-objects
# (cdeterman answer in the above)

#' Ops generics for \code{\link[coda]{mcmc.list}} objects
#'
#' @param e1 First operand
#' @param e2 Second operand
#'
#' @return A \code{mcmc.list} object (with the added class
#'     \code{derived.mcmc.list}).
#'
#' @examples
#' \dontrun{
#' # aquarium_run is a coda::mcmc.list object shipped with the isotracer package
#' a <- aquarium_run
#' plot(a)
#' # The calculations below are just given as examples of mathematical
#' # operations performed on an mcmc.list object, and do not make any sense
#' # from a modelling point of view.
#' plot(a[, "upsilon_algae_to_daphnia"] - a[, "lambda_algae"])
#' plot(a[, "upsilon_algae_to_daphnia"] + a[, "lambda_algae"])
#' plot(a[, "upsilon_algae_to_daphnia"] / a[, "lambda_algae"])
#' plot(a[, "upsilon_algae_to_daphnia"] * a[, "lambda_algae"])
#' plot(a[, "upsilon_algae_to_daphnia"] - 10)
#' plot(a[, "upsilon_algae_to_daphnia"] + 10)
#' plot(a[, "upsilon_algae_to_daphnia"] * 10)
#' plot(a[, "upsilon_algae_to_daphnia"] / 10)
#' plot(10 - a[, "upsilon_algae_to_daphnia"])
#' plot(10 + a[, "upsilon_algae_to_daphnia"])
#' plot(10 * a[, "upsilon_algae_to_daphnia"])
#' plot(10 / a[, "upsilon_algae_to_daphnia"])
#' }
#' 
#' @method Ops mcmc.list
#'
#' @export

Ops.mcmc.list = function(e1, e2) {
    # Modified from cdeterman answer from:
    # https://stackoverflow.com/questions/35902360/r-implement-group-generics-ops-to-enable-comparison-of-s3-objects
    op = .Generic[[1]]
    if ("mcmc.list" %in% class(e1) & "mcmc.list" %in% class(e2)) {
        areCompatible = function(m1, m2) {
            COMPATIBLE = TRUE
            if (coda::nvar(m1) != coda::nvar(m2)) {
                COMPATIBLE = FALSE
            } else if (coda::nchain(m1) != coda::nchain(m2)) {
                COMPATIBLE = FALSE
            } else if (!all(coda::varnames(m1) == coda::varnames(m1))) {
                COMPATIBLE = FALSE
            } else if (!all(coda::mcpar(m1[[1]]) == coda::mcpar(m2[[1]]))) {
                COMPATIBLE = FALSE
            }
            return(COMPATIBLE)
        }
        if (!areCompatible(e1, e2)) {
            stop("Incompatible inputs")
        }
        if (coda::nvar(e1) != 1) {
            stop("Ops implemented only for single-parameter chains")
        }
        switch(op,
               "+" = {
                   # Addition
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] + e2[[i]]
                   }
                   return(as.derived.mcmc.list(c))
               },
               "-" = {
                   # Subtraction
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] - e2[[i]]
                   }
                   return(as.derived.mcmc.list(c))
               },
               "*" = {
                   # Multiplication
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] * e2[[i]]
                   }
                   return(as.derived.mcmc.list(c))
               },
               "/" = {
                   # Division
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] / e2[[i]]
                   }
                   return(as.derived.mcmc.list(c))
               },
               stop("Undefined operation for mcmc.list objects"))
    } else if ("mcmc.list" %in% class(e1)) {
        stopifnot("mcmc.list" %in% class(e1) & ! "mcmc.list" %in% class(e2))
        stopifnot(is.numeric(e2) & length(e2) == 1)
        switch(op,
               "+" = {
                   # Addition
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] + e2
                   }
                   return(as.derived.mcmc.list(c))
               },
               "-" = {
                   # Subtraction
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] - e2
                   }
                   return(as.derived.mcmc.list(c))
               },
               "*" = {
                   # Multiplication
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] * e2
                   }
                   return(as.derived.mcmc.list(c))
               },
               "/" = {
                   # Division
                   c = e1
                   for (i in 1:coda::nchain(e1)) {
                       c[[i]] = c[[i]] / e2
                   }
                   return(as.derived.mcmc.list(c))
               },
               stop("Undefined operation for mcmc.list object and numeric")
               )
    } else {
        stopifnot("mcmc.list" %in% class(e2) & ! "mcmc.list" %in% class(e1))
        stopifnot(is.numeric(e1) & length(e1) == 1)
        switch(op,
               "+" = {
                   # Addition
                   c = e2
                   for (i in 1:coda::nchain(e2)) {
                       c[[i]] = c[[i]] + e1
                   }
                   return(as.derived.mcmc.list(c))
               },
               "-" = {
                   # Subtraction
                   c = e2
                   for (i in 1:coda::nchain(e2)) {
                       c[[i]] = e1 - c[[i]]
                   }
                   return(as.derived.mcmc.list(c))
               },
               "*" = {
                   # Multiplication
                   c = e2
                   for (i in 1:coda::nchain(e2)) {
                       c[[i]] = c[[i]] * e1
                   }
                   return(as.derived.mcmc.list(c))
               },
               "/" = {
                   # Division
                   c = e2
                   for (i in 1:coda::nchain(e2)) {
                       c[[i]] = e1 / c[[i]]
                   }
                   return(as.derived.mcmc.list(c))
               },
               stop("Undefined operation for mcmc.list object and numeric")
               )
    }
}

### * Math.mcmc.list()

#' Math generics for mcmc.list objects
#'
#' @param x \code{\link[coda]{mcmc.list}} object
#' @param ... Other arguments passed to corresponding methods
#'
#' @return A \code{mcmc.list} object (with the added class
#'     \code{derived.mcmc.list}).
#' 
#' @method Math mcmc.list
#'
#' @export

Math.mcmc.list = function(x, ...) {
    out = lapply(x, .Generic, ...)
    out = lapply(out, coda::mcmc)
    out = coda::mcmc.list(out)
    out = as.derived.mcmc.list(out)
    return(out)
}

### * select.mcmc.list()

#' Select parameters based on their names
#'
#' @param .data A \code{coda::mcmc.list} object.
#' @param ... Strings used to select variables using pattern matching with
#'     \code{grepl}.
#'
#' @return An \code{mcmc.list} object, with the same extra class(es) as
#'     \code{.data} (if any).
#' 
#' @method select mcmc.list
#' @export

select.mcmc.list <- function(.data, ...) {
    params <- coda::varnames(.data)
    patterns <- rlang::ensyms(...)
    patterns <- purrr::map(patterns, rlang::as_string)
    matches <- lapply(patterns, function(p) which(grepl(p, params)))
    matches <- sort(unique(unlist(matches)))
    if (length(matches) == 0) { return(NULL) }
    out <- .data[, matches]
    class(out) <- class(.data)
    return(out)
}


### * c.mcmc.list()

#' Combine mcmc.list objects
#'
#' @param ... \code{mcmc.list} objects.
#'
#' @return A \code{mcmc.list} object.
#'
#' @method c mcmc.list
#' @export

c.mcmc.list <- function(...) {
    z <- list(...)
    is_mcmc.list <- sapply(z, function(x) is(x, "mcmc.list"))
    if (!all(is_mcmc.list)) {
        stop("Not all arguments are mcmc.list objects.")
    }
    if (length(z) == 1) {
        return(z)
    }
    # Check objects compatibility
    areCompatible <- function(m1, m2) {
        COMPATIBLE <- TRUE
        if (coda::nchain(m1) != coda::nchain(m2)) {
            COMPATIBLE <- FALSE
        } else if (coda::niter(m1) != coda::niter(m2)) {
            COMPATIBLE <- FALSE
        } else if (!all(coda::mcpar(m1[[1]]) == coda::mcpar(m2[[1]]))) {
            COMPATIBLE <- FALSE
        }
        return(COMPATIBLE)
    }
    if (is.null(coda::mcpar(z[[1]]))) {
        if (is.null(coda::mcpar(z[[1]][[1]]))) {
            stop("One mcmc.list object has no mcpar attribute.")
        }
        attr(z[[1]], "mcpar") <- coda::mcpar(z[[1]][[1]])
    }
    for (i in 2:length(z)) {
        if (is.null(coda::mcpar(z[[i]]))) {
            if (is.null(coda::mcpar(z[[i]][[1]]))) {
                stop("One mcmc.list object has no mcpar attribute.")
            }
            attr(z[[i]], "mcpar") <- coda::mcpar(z[[i]][[1]])
        }
        compatible <- areCompatible(z[[1]], z[[i]])
        if (!compatible) {
            stop("Not all provided mcmc.list objects are compatible.")
        }
    }
    # Check that no variable is unnamed
    var_names <- lapply(z, coda::varnames)
    for (i in seq_along(var_names)) {
        if (is.null(var_names[[i]])) {
            # Check that there is only one variable
            if (coda::nvar(z[[i]]) > 1) {
                stop("One mcmc.list does not have a variable name and contains more than one variable.")
            }
            # Check that a name was provided
            if (is.null(names(z)) || names(z)[i] == "") {
                stop("Some mcmc.list have unnamed variables.\n",
                     "You should pass those mcmc.list to c(...) using named arguments.")
            }
            # Name the variable
            x <- z[[i]]
            var_name <- names(z)[i]
            mcpars <- coda::mcpar(x)
            x <- lapply(x, function(y) {
                out <- array(as.vector(y), dim = c(length(as.vector(y)), 1))
                colnames(out) <- var_name
                out <- coda::as.mcmc(out)
                attr(out, "mcpar") <- attr(y, "mcpar")
                out
            })
            attr(x, "mcpar") <- attr(z[[i]], "mcpar")
            class(x) <- class(z[[i]])
            z[[i]] <- x
        }
    }
    # Check that no variable names is present twice
    var_names <- lapply(z, coda::varnames)
    if (length(var_names) != length(unique(var_names))) {
        stop("Some variable names are duplicated.")
    }
    # Combine the variables
    n_chains <- coda::nchain(z[[1]])
    out <- lapply(seq_len(n_chains), function(i) {
        variables <- lapply(z, function(y) y[[i]])
        combined <- coda::as.mcmc(do.call(cbind, variables))
        attr(combined, "mcpar") <- attr(z[[1]][[1]], "mcpar")
        combined
    })
    out <- coda::as.mcmc.list(out)
    attr(out, "mcpar") <- attr(z[[1]], "mcpar")
    return(as.derived.mcmc.list(out))
}

### * `[.networkModelStanfit`()

#' Subset method for \code{networkModelStanfit} objects
#'
#' @param x A \code{networkModelStanfit} object.
#' @param i A vector of iteration indices.
#' @param j A vector of parameter names or indices.
#' @param drop Boolean.
#'
#' @return A \code{networkModelStanfit} object.
#' 
#' @method [ networkModelStanfit
#' 
#' @export

`[.networkModelStanfit` <- function(x, i, j, drop = TRUE) {
    o <- NextMethod()
    class(o) <- c("networkModelStanfit", class(o))
    return(o)
}

### * All functions in this file are exported

### * Ops.topology()

# Based on
# ?groupGeneric
# ?.Generic
# https://stackoverflow.com/questions/35902360/r-implement-group-generics-ops-to-enable-comparison-of-s3-objects
# (cdeterman answer in the above)

#' Ops generics for \code{topology} objects
#'
#' @param e1 First operand
#' @param e2 Second operand
#'
#' @return Boolean (or throws an error for unsupported operators).
#'
#' @examples
#' topo(aquarium_mod) == topo(trini_mod)
#' topo(aquarium_mod) == topo(aquarium_mod)
#' 
#' @method Ops topology
#'
#' @export

Ops.topology <- function(e1, e2) {
    op <- .Generic[[1]]
    if (!(is(e1, "topology") & is(e2, "topology"))) {
        stop("Both objects must be topologies!")
    }
    switch(op,
           "==" = {
               # Equality
               if (ncol(e1) != ncol(e2)) {
                   return(FALSE)
               }
               if (!setequal(colnames(e1), colnames(e2))) {
                   return(FALSE)
               }
               e2 <- e2[match(colnames(e2), colnames(e1)), ]
               e2 <- e2[, match(rownames(e2), rownames(e1))]
               if (!all(unclass(e1) == unclass(e2))) {
                   return(FALSE)
               }
               e1_split <- attr(e1, "split")
               e2_split <- attr(e2, "split")
               split_compatible <- (
                   (is.null(e1_split) & is.null(e2_split)) |
                   (!is.null(e1_split) && !is.null(e2_split) &&
                    all(sort(e1_split) == sort(e2_split)))
               )
               if (!split_compatible) {
                   return(FALSE)
               }
               e1_steadyState <- attr(e1, "steadyState")
               e2_steadyState <- attr(e2, "steadyState")
               steadyState_compatible <- (
                   (is.null(e1_steadyState) & is.null(e2_steadyState)) |
                   (!is.null(e1_steadyState) && !is.null(e2_steadyState) &&
                    all(sort(e1_steadyState) == sort(e2_steadyState)))
               )
               if (!steadyState_compatible) {
                   return(FALSE)
               }
               return(TRUE)
           },
           "!=" = {
               # Difference
               return(!(e1 == e2))
           },
           stop("Undefined operation for topology objects: `", op, "`"))
}

### * Methods for nice display of topologies

### ** print.topology()

#' Pretty printing of a \code{topology} object
#'
#' @param x An object of class \code{topology}.
#' @param help If TRUE, display a short help after the topology object
#'     explaining e.g. the steady state or the split compartment symbols.
#' @param ... Not used.
#'
#' @return Mostly called for its side effect (printing).
#' 
#' @export

print.topology <- function(x, help = TRUE, ...) {
    attr(x, "class") <- NULL
    nComps <- ncol(x)
    steady <- attr(x, "steadyState")
    split <- attr(x, "split")
    merge <- attr(x, "merge")
    for (s in steady) {
        i <- which(colnames(x) == s)
        colnames(x)[i] <- paste0(s, "*")
        rownames(x)[i] <- paste0(s, "*")
    }
    for (s in split) {
        i <- which(colnames(x) == s)
        colnames(x)[i] <- paste0(s, "<|>")
        rownames(x)[i] <- paste0(s, "<|>")
    }
    attr(x, "steadyState") <- NULL
    attr(x, "split") <- NULL
    attr(x, "merge") <- NULL
    cat(paste0("<", nComps, " comps>"), "\n")
    print(x)
    if (help) {
        if (length(steady) > 0) {
            cat("[ * : steady-state]", "\n")
        }
        if (length(split) > 0) {
            cat("[<|>: split]", "\n")
        }
        if (!is.null(merge)) {
            for (i in seq_along(merge)) {
                cat("[", names(merge)[i], " = ", merge[[i]][1], " + ", merge[[i]][2], "]", "\n",
                    sep = "")
            }
        }
    }
    invisible(x)
}

### * as_tbl_graph() generic and method

#' Generic for as_tbl_graph()
#'
#' Convert a compatible object to a tbl_graph object (from the tidygraph package)
#'
#' @param x Object to convert to a tbl_graph.
#' @param ... Passed to the appropriate method.
#'
#' @return A tbl_graph object.
#'
#' @export

as_tbl_graph <- function(x, ...) {
    UseMethod("as_tbl_graph")
}

#' Convert a network topology to a tbl_graph
#'
#' @param x A network topology.
#' @param ... Not used.
#'
#' @return A tbl_graph object.
#'
#' @export

# Note for testing:
# https://community.rstudio.com/t/how-can-i-make-testthat-think-i-dont-have-a-package-installed/33441/2

as_tbl_graph.topology <- function(x, ...) {
    if (!requireNamespace("tidygraph", quietly = TRUE)) {
        stop("Package \"tidygraph\" needed for this function to work. Please install it.",
             call. = FALSE)
    }
    if (!requireNamespace("igraph", quietly = TRUE)) {
        stop("Package \"igraph\" needed for this function to work. Please install it.",
             call. = FALSE)
    }
    graph <- igraph::graph_from_adjacency_matrix(t(x))
    t_graph <- tidygraph::as_tbl_graph(graph)
    steady_state <- attr(x, "steadyState")
    split <- attr(x, "split")
    attributes <- tibble::tibble(name = colnames(x))
    attributes[["steady_state"]] <- attributes[["name"]] %in% steady_state
    attributes[["split"]] <- attributes[["name"]] %in% split
    t_graph <- dplyr::left_join(t_graph, attributes, by = "name")
    return(t_graph)
}

1		### * None of the functions in this file is exported
2
3		### * describe_z_eta()
4
5		#' Print a message describing the role of eta or zeta in a distribution family
6		#'
7		#' @param param_name Name of the parameter (e.g. "eta" or "zeta").
8		#' @param family Family string.
9		#' @param prefix,suffix Strings appended to the message.
10		#'
11		#' @keywords internal
12		#' @noRd
13
14		describe_z_eta <- function(param_name, family, prefix = " (", suffix = ")") {
15	!	msg <- list(
16	!	"gamma_cv" = " is the coefficient of variation of gamma distributions.",
17	!	"normal_cv" = " is the coefficient of variation of normal distributions.",
18	!	"normal_sd" = " is the standard deviation of normal distributions.",
19	!	"beta_phi" = " is the precision (phi) of beta distributions.")
20	!	if (!family %in% names(msg)) {
21	!	stop("The provided value for the family argument is not allowed.")
22		}
23	!	message(prefix, param_name, msg[[family]], suffix, sep = "")
24		}
25
26		### * valid_prior_tbl()
27
28		#' Test if the input is a valid prior tibble
29		#'
30		#' @param x Some input to test.
31		#'
32		#' @return Boolean.
33		#'
34		#' @examples
35		#' valid_prior_tbl(priors(aquarium_mod))
36		#' valid_prior_tbl(mtcars)
37		#'
38		#' @keywords internal
39		#' @noRd
40
41		valid_prior_tbl <- function(x) {
42		# Is tibble?
43	!	if (!is(x, "tbl_df")) return(FALSE)
44		# Has at least columns "in_model" and "prior"?
45	!	if (!all(c("in_model", "prior") %in% colnames(x))) return(FALSE)
46		# "in_model" is a character vector?
47	!	if (!is(x[["in_model"]], "character")) return(FALSE)
48		# "prior" is a list?
49	!	if (!is(x[["prior"]], "list")) return(FALSE)
50		# Are all the entries in the "prior" column NULL or priors?
51	!	non_null <- x[["prior"]][!is.null(x[["prior"]])]
52	!	if (!all(sapply(non_null, is, "prior"))) return(FALSE)
53		# End of tests
54	!	return(TRUE)
55		}

1		### * None of the functions in this file is exported
2
3		### * encode_priors()
4
5		#' Prepare the prior encoding for stan data
6		#'
7		#' @param params_nm Output from params(nm, simplify = TRUE).
8		#' @param priors_nm Output from priors(nm) (must have the same parameter order
9		#' as params_nm).
10		#'
11		#' @keywords internal
12		#' @noRd
13
14		encode_priors <- function(params_nm, priors_nm) {
15	27x	if (any(sapply(priors_nm$prior, is.null))) {
16	!	stop("One or several parameters are missing a prior.\n",
17	!	"You can list the current model priors with `priors(...)`.\n",
18	!	"You can list the missing model priors with `missing_priors(...)`.")
19		}
20	27x	d <- list()
21	27x	d[["nPriorConstant_code0"]] <- 0
22	27x	d[["nPriorUniform_code1"]] <- 0
23	27x	d[["nPriorHcauchy_code2"]] <- 0
24	27x	d[["nPriorBeta_code3"]] <- 0
25	27x	d[["nPriorTrNormal_code4"]] <- 0
26	27x	d[["nPriorExponential_code5"]] <- 0
27	27x	d[["nPriorGamma_code6"]] <- 0
28		### Prior types (used to map the correct prior in the stan model)
29	27x	priorTypes <- c("constant" = 0, "uniform" = 1, "hcauchy" = 2, "scaled_beta" = 3,
30	27x	"trun_normal" = 4, "exponential" = 5, "gamma" = 6)
31		### Parameter priors
32	27x	d[["mappingParamPriorType"]] <- rep(NA, length(params_nm))
33	27x	d[["mappingParamPriorID"]] <- rep(NA, length(params_nm))
34	27x	prior_i <- c("constant" = 1, "uniform" = 1, "hcauchy" = 1,
35	27x	"scaled_beta" = 1, "trun_normal" = 1, "exponential" = 1,
36	27x	"gamma" = 1) # Counts for each prior type
37		# Set some defaults
38	27x	for (priorDistParam in c("constantParams", "lowerParams", "upperParams", "hcauchyScaleParams",
39	27x	"rawBetaAlpha", "rawBetaBeta", "betaScaleParams",
40	27x	"trNormMeanParams", "trNormSdParams", "exponentialRateParams",
41	27x	"gammaAlphaParams", "gammaBetaParams")) {
42		# Set zero as default for all prior distribution parameters
43	324x	d[[priorDistParam]] <- rep(0, length(params_nm))
44		}
45		# Go through each param prior
46	27x	for (i in seq_along(params_nm)) {
47	258x	p <- priors_nm[["prior"]][[i]]
48	258x	stopifnot(p[["type"]] %in% names(priorTypes))
49	258x	d[["mappingParamPriorType"]][i] <- priorTypes[p[["type"]]]
50	258x	d[["mappingParamPriorID"]][i] <- prior_i[p[["type"]]]
51	258x	prior_i[p[["type"]]] <- prior_i[p[["type"]]] + 1
52	258x	if (p[["type"]] == "constant") {
53	24x	d[["constantParams"]][i] <- p[["parameters"]][["value"]]
54	24x	d[["nPriorConstant_code0"]] <- d[["nPriorConstant_code0"]] + 1
55		}
56	258x	if (p[["type"]] == "uniform") {
57	2x	d[["lowerParams"]][i] <- p[["parameters"]]["min"]
58	2x	d[["upperParams"]][i] <- p[["parameters"]]["max"]
59	2x	d[["nPriorUniform_code1"]] <- d[["nPriorUniform_code1"]] + 1
60		}
61	258x	if (p[["type"]] == "hcauchy") {
62	62x	d[["hcauchyScaleParams"]][i] <- p[["parameters"]]["scale"]
63	62x	d[["nPriorHcauchy_code2"]] <- d[["nPriorHcauchy_code2"]] + 1
64		}
65	258x	if (p[["type"]] == "scaled_beta") {
66	!	d[["rawBetaAlpha"]][i] <- p[["parameters"]]["alpha"]
67	!	d[["rawBetaBeta"]][i] <- p[["parameters"]]["beta"]
68	!	d[["betaScaleParams"]][i] <- p[["parameters"]]["scale"]
69	!	d[["nPriorBeta_code3"]] <- d[["nPriorBeta_code3"]] + 1
70		}
71	258x	if (p[["type"]] == "trun_normal") {
72	166x	d[["trNormMeanParams"]][i] <- p[["parameters"]][["mean"]]
73	166x	d[["trNormSdParams"]][i] <- p[["parameters"]][["sd"]]
74	166x	d[["nPriorTrNormal_code4"]] <- d[["nPriorTrNormal_code4"]] + 1
75		}
76	258x	if (p[["type"]] == "exponential") {
77	2x	d[["exponentialRateParams"]][i] <- p[["parameters"]][["lambda"]]
78	2x	d[["nPriorExponential_code5"]] <- d[["nPriorExponential_code5"]] + 1
79		}
80	258x	if (p[["type"]] == "gamma") {
81	2x	d[["gammaAlphaParams"]][i] <- p[["parameters"]][["alpha"]]
82	2x	d[["gammaBetaParams"]][i] <- p[["parameters"]][["beta"]]
83	2x	d[["nPriorGamma_code6"]] <- d[["nPriorGamma_code6"]] + 1
84		}
85		}
86		# Count non-constant priors
87	27x	d[["nNonConstantPriors"]] <- length(params_nm) - d[["nPriorConstant_code0"]]
88		# Return
89	27x	return(d)
90		}
91
92		### * encode_steady()
93
94		#' Encode steady compartments for stan data
95		#'
96		#' @param nm A \code{networkModel} object.
97		#'
98		#' @keywords internal
99		#' @noRd
100
101		encode_steady <- function(nm) {
102	27x	d <- list()
103	27x	steady <- lapply(nm[["topology"]], function(x) {
104	40x	match(attr(x, "steadyState"), colnames(x))
105		})
106	27x	d[["maxNsteady"]] <- max(sapply(steady, length))
107	27x	d[["nSteady"]] <- setNames(c(sapply(steady, length), 0), # Padded
108	27x	nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
109	27x	d[["steadyIndices"]] <- array(0, dim = c(d[["maxNsteady"]], nrow(nm)),
110	27x	dimnames = list(seq_len(d[["maxNsteady"]]),
111	27x	paste0("grp", seq_len(nrow(nm)))))
112	27x	for (i in seq_len(nrow(nm))) {
113	40x	d[["steadyIndices"]][seq_along(steady[[i]]),i] <- steady[[i]]
114		}
115		# Return
116	27x	return(d)
117		}
118
119		### * encode_split()
120
121		#' Encode split compartments for stan data
122		#'
123		#' @param nm A \code{networkModel} object.
124		#' @param allParams Parameters of the network model.
125		#'
126		#' @keywords internal
127		#' @noRd
128
129		encode_split <- function(nm, allParams) {
130	27x	d <- list()
131	27x	split <- lapply(nm[["topology"]], function(x) {
132	40x	match(attr(x, "split"), colnames(x))
133		})
134	27x	d[["splitPresent"]] <- as.numeric(max(sapply(split, length)) > 0)
135	27x	nGroups <- nrow(nm)
136	27x	splitComps <- array(0, dim = c(length(comps(nm)[[1]]), nGroups),
137	27x	dimnames = list(seq_along(comps(nm)[[1]]),
138	27x	paste0("grp", seq_len(nrow(nm)))))
139	27x	for (i in seq_along(split)) {
140	40x	splitComps[split[[i]], i] <- 1
141		}
142	27x	d[["splitComps"]] <- splitComps
143		# Parameter mapping
144	27x	piMapping <- array(0, dim = c(length(comps(nm)[[1]]), nGroups),
145	27x	dimnames = list(seq_along(comps(nm)[[1]]),
146	27x	paste0("grp", seq_len(nrow(nm)))))
147	27x	for (g in seq_len(nGroups)) {
148	40x	compNames <- colnames(nm$topology[[g]])
149	40x	stopifnot(length(compNames) == length(comps(nm)[[1]]))
150	40x	for (k in seq_along(compNames)) {
151	112x	if (splitComps[k, g] > 0) {
152	9x	paramName <- paste0("portion.act_", compNames[k])
153	9x	paramGlobal <- nm$parameters[[g]]$in_model[nm$parameters[[g]]$in_replicate == paramName]
154	9x	stopifnot(length(paramGlobal) == 1)
155	9x	piMapping[k, g] <- match(paramGlobal, allParams)
156		}
157		}
158		}
159	27x	d[["piMapping"]] <- piMapping
160		# Return
161	27x	return(d)
162		}
163
164		### * encode_init()
165
166		#' Encode initial conditions for a network model
167		#'
168		#' For now this function assumes that each row has the same number of
169		#' compartments.
170		#'
171		#' @param nm A \code{networkModel} object.
172		#'
173		#' @keywords internal
174		#' @noRd
175
176		encode_init <- function(nm) {
177	27x	nComps <- sapply(comps(nm), length)
178	27x	stopifnot(all(nComps == nComps[1]))
179	27x	nGroups <- nrow(nm)
180	27x	d <- array(0, dim = c(nComps[1], 2, nGroups),
181	27x	dimnames = list(1:nComps[1], c("unmarked", "marked"),
182	27x	c(paste0("grp", seq_len(nGroups)))))
183	27x	for (i in seq_len(nGroups)) {
184	40x	comps <- colnames(nm$topology[[i]])
185	40x	stopifnot(nrow(nm$initial[[i]]) == length(comps))
186	40x	stopifnot(setequal(nm$initial[[i]][["compartment"]], comps))
187	40x	comps <- nm$initial[[i]][match(comps, nm$initial[[i]][["compartment"]]), ]
188	40x	stopifnot(all(comps$compartment == colnames(nm$topology[[i]])))
189	40x	unmarked <- comps$size * (1 - comps$proportion)
190	40x	marked <- comps$size * comps$proportion
191	40x	d[,,i] <- cbind(unmarked, marked)
192		}
193	27x	return(list(initialQuantities = d))
194		}
195
196		### * encode_distrib_families()
197
198		#' Encode the families for proportions and sizes distributions
199		#'
200		#' @param nm A \code{networkModel} object.
201		#'
202		#' @keywords internal
203		#' @noRd
204
205		encode_distrib_families <- function(nm) {
206	27x	o <- list()
207		# Encode distribution family for proportions
208	27x	known_families <- c("gamma_cv" = 1, "normal_cv" = 2, "normal_sd" = 3,
209	27x	"beta_phi" = 4)
210	27x	prop_family <- attr(nm, "prop_family")
211	27x	if (!prop_family %in% names(known_families)) {
212	!	stop("Unknown distribution family for proportions. Got value: ",
213	!	prop_family, "\n",
214	!	"Allowed values are: ", names(known_families))
215		}
216	27x	o[["propFamily"]] <- known_families[prop_family]
217		# Encode distribution family for sizes
218	27x	size_known_families <- c("normal_cv" = 1, "normal_sd" = 2)
219	27x	size_family <- attr(nm, "size_family")
220	27x	if (!size_family %in% names(size_known_families)) {
221	!	stop("Unknown distribution family for sizes. Got value: ",
222	!	size_family, "\n",
223	!	"Allowed values are: ", names(size_known_families))
224		}
225	27x	o[["sizeFamily"]] <- size_known_families[size_family]
226	27x	return(o)
227		}
228
229		### * encode_upsilons()
230
231		#' Encode the uptake rates for stan data
232		#'
233		#' @param nm A \code{networkModel} object.
234		#' @param allParams Parameters of the network model.
235		#'
236		#' @keywords internal
237		#' @noRd
238
239		encode_upsilons <- function(nm, allParams) {
240	27x	nGroups <- nrow(nm)
241	27x	upsilons <- nm_get_upsilons(nm, allParams)
242	27x	nUpsilons <- setNames(c(upsilons[["nUpsilons"]], 0), # Padding
243	27x	nm = c(paste0("grp", seq_len(nGroups)), "padding"))
244	27x	maxNupsilons <- max(nUpsilons)
245	27x	upsilonMapping <- array(0, dim = c(maxNupsilons, 3, nGroups),
246	27x	dimnames = list(1:maxNupsilons,
247	27x	c("from", "to", "param"),
248	27x	paste0("grp", seq_len(nGroups))))
249	27x	for (i in seq_len(nGroups)) {
250	40x	upsilonMapping[1:nUpsilons[i], 1:3, i] <- as.matrix(upsilons[["upsilons"]][[i]])
251		}
252	27x	return(list(nUpsilons = nUpsilons,
253	27x	maxNupsilons = maxNupsilons,
254	27x	upsilonMapping = upsilonMapping))
255		}
256
257		### ** nm_get_upsilons()
258
259		#' Get upsilons for a network model
260		#'
261		#' @param nm A \code{networkModel} object.
262		#' @param allParams Parameters of the network model.
263		#'
264		#' @keywords internal
265		#' @noRd
266
267		nm_get_upsilons <- function(nm, allParams) {
268	27x	upsilons <- lapply(seq_len(nrow(nm)), function(i) {
269	40x	z <- nm_row_get_upsilons(nm[i, ], allParams = allParams)
270	40x	tibble::tibble(upsilons = list(z), nUpsilons = nrow(z))
271		})
272	27x	return(dplyr::bind_rows(upsilons))
273		}
274
275		### ** nm_row_get_upsilons()
276
277		#' Get upsilons for one row of a network model
278		#'
279		#' @param nm_row A row from a \code{networkModel} object.
280		#' @param allParams Parameters of the network model.
281		#'
282		#' @keywords internal
283		#' @noRd
284
285		nm_row_get_upsilons <- function(nm_row, allParams) {
286	40x	nmRow <- nm_row
287	40x	stopifnot(nrow(nmRow) == 1)
288		# Get data
289	40x	topo <- nmRow[["topology"]][[1]]
290	40x	mapping <- nmRow[["parameters"]][[1]][, c("in_replicate", "in_model")]
291	40x	mapping <- tibble::deframe(mapping)
292		# Build output
293	40x	from <- vector()
294	40x	to <- vector()
295	40x	param <- vector()
296	40x	compartments <- colnames(topo)
297	40x	stopifnot(all(compartments == rownames(topo)))
298	40x	for (j in seq_len(ncol(topo))) {
299	112x	for (i in seq_len(nrow(topo))) {
300	320x	if (topo[i,j] == 1) {
301	100x	from <- c(from, j)
302	100x	to <- c(to, i)
303	100x	paramName <- paste0("upsilon_", compartments[j], "_to_",
304	100x	compartments[i])
305	100x	param <- c(param, match(mapping[paramName], allParams))
306		}
307		}
308		}
309	40x	return(tibble::tibble(from = from, to = to, param = param))
310		}
311
312		### * encode_lambdas()
313
314		#' Encode the loss rates for stan data
315		#'
316		#' @param nm A \code{networkModel} object.
317		#' @param allParams Parameters of the network model.
318		#'
319		#' @keywords internal
320		#' @noRd
321
322		encode_lambdas <- function(nm, allParams) {
323	27x	nGroups <- nrow(nm)
324	27x	lambdas <- nm_get_lambdas(nm, allParams)
325	27x	nLambdas <- setNames(c(lambdas[["nLambdas"]], 0), # Padding
326	27x	nm = c(paste0("grp", seq_len(nGroups)), "padding"))
327	27x	maxNlambdas <- max(nLambdas)
328	27x	lambdaMapping <- array(0, dim = c(maxNlambdas, 2, nGroups),
329	27x	dimnames = list(1:maxNlambdas,
330	27x	c("from", "param"),
331	27x	paste0("grp", seq_len(nGroups))))
332	27x	for (i in seq_len(nGroups)) {
333	40x	lambdaMapping[1:nLambdas[i], 1:2, i] <- as.matrix(lambdas[["lambdas"]][[i]])
334		}
335	27x	return(list(nLambdas = nLambdas,
336	27x	maxNlambdas = maxNlambdas,
337	27x	lambdaMapping = lambdaMapping))
338		}
339
340		### ** nm_get_lambdas()
341
342		#' Get lambdas for a network model
343		#'
344		#' @param nm A \code{networkModel} object.
345		#' @param allParams Parameters of the network model.
346		#'
347		#' @keywords internal
348		#' @noRd
349
350		nm_get_lambdas <- function(nm, allParams) {
351	27x	lambdas <- lapply(seq_len(nrow(nm)), function(i) {
352	40x	z <- nm_row_get_lambdas(nm[i, ], allParams = allParams)
353	40x	tibble::tibble(lambdas = list(z), nLambdas = nrow(z))
354		})
355	27x	return(dplyr::bind_rows(lambdas))
356		}
357
358		### ** nm_row_get_lambdas()
359
360		#' Get lambdas for one row of a network model
361		#'
362		#' @param nm_row A row from a \code{networkModel} object.
363		#' @param allParams Parameters of the network model.
364		#'
365		#' @keywords internal
366		#' @noRd
367
368		nm_row_get_lambdas <- function(nm_row, allParams) {
369	40x	nmRow <- nm_row
370	40x	stopifnot(nrow(nmRow) == 1)
371		# Get data
372	40x	topo <- nmRow[["topology"]][[1]]
373	40x	mapping <- nmRow[["parameters"]][[1]][, c("in_replicate", "in_model")]
374	40x	mapping <- tibble::deframe(mapping)
375		# Build output
376	40x	from <- vector()
377	40x	param <- vector()
378	40x	compartments <- colnames(topo)
379	40x	stopifnot(all(compartments == rownames(topo)))
380	40x	for (j in seq_len(ncol(topo))) {
381	112x	paramName <- paste0("lambda_", compartments[j])
382	112x	if (paramName %in% names(mapping)) {
383	112x	from <- c(from, j)
384	112x	param <- c(param, match(mapping[paramName], allParams))
385		}
386		}
387	40x	return(tibble::tibble(from = from, param = param))
388		}

1		### * All functions in this file are exported
2
3		### * run_mcmc()
4
5		### ** Doc
6
7		#' Run a MCMC sampler on a network model using Stan
8		#'
9		#' @param model A \code{networkModel}.
10		#' @param iter A positive integer specifying the number of iterations for each
11		#' chain (including warmup). The default is 2000.
12		#' @param chains A positive integer specifying the number of Markov chains.
13		#' The default is 4.
14		#' @param method A character string indicating the method to use to solve ODE
15		#' in the Stan model; available methods are "matrix_exp" and "euler". The
16		#' default is "matrix_exp", which uses matrix exponential and is reasonably
17		#' fast for small networks. For large networks, the "euler" method can be
18		#' used. It implements a simple forward Euler method to solve the ODE and can
19		#' be faster than the matrix exponential approach, but extra caution must be
20		#' taken to check for numerical accuracy (e.g. testing different \code{dt}
21		#' time step values, ensuring that the product between \code{dt} and the
22		#' largest transfer rates expected from the priors is always very small
23		#' compared to 1).
24		#' @param euler_control An optional list containing extra parameters when using
25		#' \code{method = "euler"}. Allowed list elements are \code{"dt"} and
26		#' \code{"grid_size"}, which are respectively the time step size for
27		#' trajectory calculations (\code{"dt"}) or the number of points for the
28		#' calculation (\code{"grid_size"}). Only one of "dt" or "grid_size" can be
29		#' specified, not both. If none is provided, a default grid size of 256 steps
30		#' is used.
31		#' @param cores Number of cores to use for parallel use. Default is
32		#' \code{NULL}, which means to use the value stored in
33		#' \code{options()[["mc.cores"]]} (or 1 if this value is not set).
34		#' @param stanfit If TRUE, returns a `stanfit` object instead of the more
35		#' classical `mcmc.list` object. Note that when an `mcmc.list` object is
36		#' returned, the original `stanfit` object is still accessible as an
37		#' attribute of that object (see Examples).
38		#' @param vb Boolean, if TRUE will use \code{rstan::vb} for a quick approximate
39		#' sampling of the posterior. Important note from \code{?rstan::vb}:
40		#' "This is still considered an experimental feature. We recommend calling
41		#' \code{stan} or \code{sampling} for final inferences and only using ‘vb’ to
42		#' get a rough idea of the parameter distributions."
43		#' @param ... Arguments passed to `rstan::sampling` (e.g. iter, chains).
44		#'
45		#' @return An object of class `stanfit` returned by `rstan::sampling` if
46		#' \code{stanfit = TRUE}, otherwise the result of converting this
47		#' \code{stanfit} object with \code{stanfit_to_named_mcmclist} (i.e. an object
48		#' of class \code{networkModelStanfit} and \code{mcmc.list}, which still
49		#' carries the original `stanfit` object stored as an attribute).
50		#'
51		#' @examples
52		#' aquarium_mod
53		#' \dontrun{
54		#' # The 'aquarium_run' object is shipped with the package, so you don't
55		#' # actually need to run the line below to obtain it
56		#' aquarium_run <- run_mcmc(aquarium_mod)
57		#'
58		#' plot(aquarium_run)
59		#' summary(aquarium_run)
60		#'
61		#' # The original stanfit object returned by Stan
62		#' sfit <- attr(aquarium_run, "stanfit")
63		#' sfit
64		#'
65		#' # The stanfit object can be used for diagnostics, LOO cross-validation, etc.
66		#' rstan::loo(sfit)
67		#' }
68		#'
69		#' @export
70
71		### ** Code
72
73		run_mcmc <- function(model, iter = 2000, chains = 4, method = "matrix_exp",
74		euler_control = list(),
75		cores = NULL, stanfit = FALSE, vb = FALSE, ...) {
76	27x	stopifnot(method %in% c("matrix_exp", "euler"))
77	27x	if (method != "euler" & length(euler_control) != 0) {
78	!	stop("The `euler_control` parameter is not empty, but `method` is not set to \"euler\".")
79		}
80	27x	if (method == "euler") {
81	8x	if (vb) {
82	!	stop("vb not implemented for euler method")
83		}
84	8x	fit <- mugen_stan(nm = model, iter = iter, chains = chains,
85	8x	euler_control = euler_control,
86	8x	cores = cores, stanfit = stanfit, ...)
87		}
88	27x	if (method == "matrix_exp") {
89	19x	fit <- matrix_exp_stan(nm = model, iter = iter, chains = chains,
90	19x	cores = cores, stanfit = stanfit,
91	19x	vb = vb, ...)
92		}
93	27x	return(fit)
94		}
95
96		### * stanfit_to_named_mcmclist()
97
98		#' Convert a Stanfit object to a nicely named mcmc.list object
99		#'
100		#' When running \code{run_mcmc} with \code{stanfit = FALSE} (typically for
101		#' debugging purposes), the parameters in the returned \code{stanfit} object
102		#' are named using a base label and an indexing system. This function provides
103		#' a way to convert this \code{stanfit} object into a more conventional
104		#' \code{mcmc.list} object where parameters are named according to their role
105		#' in the original network model used when running \code{run_mcmc}.
106		#'
107		#' @param stanfit A stanfit object returned by \code{rstan::sampling}.
108		#'
109		#' @return An \code{mcmc.list} object. It also has the original stanfit object
110		#' stored as an attribute \code{"stanfit"}.
111		#'
112		#' @export
113
114		stanfit_to_named_mcmclist <- function(stanfit) {
115	26x	stan_data <- attr(stanfit, "isotracer_stan_data")
116	26x	fit <- stanfit
117		# Get mcpars
118	26x	start <- fit@sim[["warmup"]] + 1
119	26x	end <- fit@sim[["iter"]]
120	26x	thin <- fit@sim[["thin"]]
121	26x	n_kept <- fit@sim[["n_save"]] - fit@sim[["warmup2"]]
122	26x	mcpars <- c(start, end, thin)
123		# Prepare the mcmc.list object
124	26x	out <- rstan::As.mcmc.list(fit)
125	26x	for (i in seq_along(out)) {
126	52x	stopifnot(nrow(out[[i]]) == n_kept)
127		}
128	26x	attr(out, "mcpar") <- mcpars
129	26x	rawNames <- coda::varnames(out)
130	26x	nonConstantParamNames <- rawNames[grepl("^nonConstantParams[\\[\\.]",
131	26x	rawNames)]
132	26x	loglikNames <- rawNames[grepl("^log_lik[\\[\\.]", rawNames)]
133	26x	ll <- out[, loglikNames]
134	26x	out <- out[, nonConstantParamNames]
135	26x	coda::varnames(out) <- stan_data[["allParams"]][stan_data[["mappingParamPriorType"]] != 0]
136	26x	llTrace <- lapply(ll, function(x) {
137	52x	out <- coda::as.mcmc(apply(as.matrix(x), 1, sum))
138	52x	attr(out, "mcpar") <- attr(x, "mcpar")
139	52x	return(out)
140		})
141	26x	llTrace <- coda::as.mcmc.list(llTrace)
142	26x	attr(out, "loglik") <- llTrace
143	26x	attr(out, "mcpar") <- mcpars
144		# Add values of constant parameters (if any)
145	26x	n_constant_params <- sum(stan_data[["mappingParamPriorType"]] == 0)
146	26x	if (n_constant_params > 0) {
147	5x	constant_params <- stan_data[["allParams"]][stan_data[["mappingParamPriorType"]] == 0]
148	5x	constant_values <- stan_data[["constantParams"]][stan_data[["mappingParamPriorType"]] == 0]
149	5x	constant_params <- setNames(constant_values, nm = constant_params)
150	5x	attr(out, "constant_params") <- constant_params
151		}
152		# Return the mcmc.list object
153	26x	outClass <- c("networkModelStanfit", class(out))
154	26x	attr(out, "stanfit") <- stanfit
155	26x	return(structure(out, class = outClass))
156		}

1		### * All functions in this file are exported
2
3		### * delta2prop()
4
5		#' Convert delta notation to proportion of heavy isotope
6		#'
7		#' For details and references about quantities used in expressing isotopic
8		#' ratios, see:
9		#'
10		#' - Figure 1 in Coplen, Tyler B. “Guidelines and Recommended Terms for
11		#' Expression of Stable-Isotope-Ratio and Gas-Ratio Measurement Results.” Rapid
12		#' Communications in Mass Spectrometry 25, no. 17 (September 15, 2011):
13		#' 2538–60. https://doi.org/10.1002/rcm.5129.
14		#'
15		#' - Table 2.1 in Fry, Brian. Stable Isotope Ecology. New York:
16		#' Springer-Verlag, 2006. //www.springer.com/gp/book/9780387305134.
17		#'
18		#' @section Ratios for reference standards:
19		#'
20		#' The ratios for reference standards are taken from the Table 2.1 from Fry
21		#' 2006. Note that the values used for oxygen isotopes are from the standard
22		#' mean ocean water (SMOW).
23		#'
24		#' Standards recognized by this function are: \code{c("d15N", "d2H", "d13C",
25		#' "d17O.SMOW", "d18O.SMOW", "d33S", "d34S", "d36S")}
26		#'
27		#' @param x Vector of delta values.
28		#' @param Rstandard String describing the isotopic measurement, e.g. "d15N",
29		#' "d13C" and used to set automatically Rstandards (see the Section
30		#' "Ratios for reference standards" for more details). Alternatively, a
31		#' numeric value to use for Rstandard, e.g. 0.0036765.
32		#'
33		#' @return A vector of same length of x, containing the proportion (numeric
34		#' between 0 and 1) of heavy isotope based on the delta values and the
35		#' Rstandard provided.
36		#'
37		#' @examples
38		#' deltas <- c(78, 5180, 263, 1065, NA, 153, 345)
39		#'
40		#' # Rstandard can be specified with a string for some preset references
41		#' prop15N <- delta2prop(deltas, "d15N")
42		#' prop13C <- delta2prop(deltas, "d13C")
43		#'
44		#' # Rstandard can also be specified manually for non-preset references
45		#' prop15N_manual <- delta2prop(deltas, 0.0036765)
46		#' prop13C_manual <- delta2prop(deltas, 0.011180)
47		#'
48		#' # Call delta2prop() to get the detail of available references
49		#' delta2prop()
50		#'
51		#' @export
52		#'
53
54		delta2prop <- function(x = NULL, Rstandard = NULL) {
55		# Known standards
56	10x	Rstandards <- list("d15N" = 0.0036765,
57	10x	"d2H" = 0.00015576,
58	10x	"d13C" = 0.011180,
59	10x	"d17O.SMOW" = 0.0003799,
60	10x	"d18O.SMOW" = 0.0020052,
61	10x	"d33S" = 0.0078772,
62	10x	"d34S" = 0.0441626,
63	10x	"d36S" = 0.0001533)
64		# Message about available standards
65	10x	msg <- paste0("Available standards are:")
66	10x	for (i in seq_along(Rstandards)) {
67	80x	label <- names(Rstandards)[i]
68	80x	string <- paste(label, paste(rep("_", 13 - nchar(label)), collapse = ""))
69	80x	value <- Rstandards[[i]]
70	80x	msg <- paste(msg, paste(string, value, collapse = ""), sep = "\n ")
71		}
72		# Parse argument
73	10x	if (is.null(Rstandard)) {
74	2x	Rstandard <- "non-specified"
75	2x	if (is.null(x)) {
76	2x	message(paste(msg, sep = "\n"))
77	2x	return(invisible(NULL))
78		}
79		}
80	8x	if (length(Rstandard) > 1) {
81	3x	msg <- paste0(
82	3x	"The Rstandard argument must be of length 1 but the argument provided was ",
83	3x	ifelse(is.numeric(Rstandard), "a numeric vector", "an object"),
84	3x	" of length ", length(Rstandard), ".")
85	3x	if (is.numeric(Rstandard)) {
86	2x	msg <- paste0(
87	2x	msg, "\n",
88	2x	"If you did not want to pass a numeric vector but rather wanted to ",
89	2x	"pass a string defining the standard to use (such as \"d15N\"), maybe ",
90	2x	"you forgot the quotes?")
91		}
92	3x	stop(msg)
93		}
94	5x	if (is.character(Rstandard)) {
95	3x	if (!Rstandard %in% names(Rstandards)) {
96	1x	unk_std <- paste0("Rstandard argument (", Rstandard, "): unknown. ",
97	1x	collapse = "")
98	1x	msg <- paste0(unk_std, msg, collapse = "")
99	1x	stop(msg)
100		}
101	2x	Rstandard <- Rstandards[[Rstandard]]
102	2x	} else if (!is.numeric(Rstandard)) {
103	!	stop("Provided value must the name of a known measurement type or a numeric.")
104		}
105		# Calculate proportions and return
106	4x	R0 <- Rstandard
107	4x	props <- R0 * (x/1000 + 1) / (R0 * (x/1000 + 1) + 1)
108	4x	return(props)
109		}
110
111		### * prop2delta()
112
113		#' Convert isotopic proportions to delta values
114		#'
115		#' This function performs the inverse of the operation performed by
116		#' \code{delta2prop()}.
117		#'
118		#' @param x Vector of proportions values.
119		#' @param Rstandard String describing the isotopic measurement, e.g. "d15N",
120		#' "d13C" and used to set automatically Rstandards (see the Section
121		#' "Ratios for reference standards" for more details). Alternatively, a
122		#' numeric value to use for Rstandard, e.g. 0.0036765.
123		#'
124		#' @return A vector of same length of x, containing the delta values based on
125		#' the proportions of heavy isotope provided as x and the Rstandard provided.
126		#'
127		#' @examples
128		#' prop15N <- c(0.00395, 0.02222, 0.00462, 0.00753, NA, 0.00422, 0.00492)
129		#'
130		#' # Rstandard can be specified with a string for some preset references
131		#' d15N <- prop2delta(prop15N, "d15N")
132		#' d15N
133		#'
134		#' # Rstandard can also be specified manually for non-preset references
135		#' d15N_manual <- prop2delta(prop15N, 0.0036765)
136		#' d15N_manual
137		#'
138		#' # Call delta2prop() to get the detail of available references
139		#' delta2prop()
140		#'
141		#' @export
142
143		prop2delta <- function(x = NULL, Rstandard = NULL) {
144		# Known standards
145	!	Rstandards <- list("d15N" = 0.0036765,
146	!	"d2H" = 0.00015576,
147	!	"d13C" = 0.011180,
148	!	"d17O.SMOW" = 0.0003799,
149	!	"d18O.SMOW" = 0.0020052,
150	!	"d33S" = 0.0078772,
151	!	"d34S" = 0.0441626,
152	!	"d36S" = 0.0001533)
153		# Message about available standards
154	!	msg <- paste0("Available standards are:")
155	!	for (i in seq_along(Rstandards)) {
156	!	label <- names(Rstandards)[i]
157	!	string <- paste(label, paste(rep("_", 13 - nchar(label)), collapse = ""))
158	!	value <- Rstandards[[i]]
159	!	msg <- paste(msg, paste(string, value, collapse = ""), sep = "\n ")
160		}
161		# Parse argument
162	!	if (is.null(Rstandard)) {
163	!	Rstandard <- "non-specified"
164	!	if (is.null(x)) {
165	!	message(paste(msg, sep = "\n"))
166	!	return(invisible(NULL))
167		}
168		}
169	!	if (length(Rstandard) > 1) {
170	!	msg <- paste0(
171	!	"The Rstandard argument must be of length 1 but the argument provided was ",
172	!	ifelse(is.numeric(Rstandard), "a numeric vector", "an object"),
173	!	" of length ", length(Rstandard), ".")
174	!	if (is.numeric(Rstandard)) {
175	!	msg <- paste0(
176	!	msg, "\n",
177	!	"If you did not want to pass a numeric vector but rather wanted to ",
178	!	"pass a string defining the standard to use (such as \"d15N\"), maybe ",
179	!	"you forgot the quotes?")
180		}
181	!	stop(msg)
182		}
183	!	if (is.character(Rstandard)) {
184	!	if (!Rstandard %in% names(Rstandards)) {
185	!	unk_std <- paste0("Rstandard argument (", Rstandard, "): unknown. ",
186	!	collapse = "")
187	!	msg <- paste0(unk_std, msg, collapse = "")
188	!	stop(msg)
189		}
190	!	Rstandard <- Rstandards[[Rstandard]]
191	!	} else if (!is.numeric(Rstandard)) {
192	!	stop("Provided value must the name of a known measurement type or a numeric.")
193		}
194		# Calculate deltas and return
195	!	R0 <- Rstandard
196	!	deltas <- (1/R0 * x / (1 - x) - 1) * 1000
197	!	return(deltas)
198		}
199
200		### * filter_by_group
201
202		#' Filter a tibble based on the "group" column
203		#'
204		#' This function can be used to filter any tibble (e.g. network model object)
205		#' that has a "group" column. See the Examples for more details and syntax.
206		#'
207		#' @param .data A tibble that has a `group` column, such as a `networkModel`
208		#' object.
209		#' @param ... Conditional expressions for filtering (see the Examples).
210		#'
211		#' @return A tibble similar to the input object, but with rows filtered based
212		#' on \code{...}.
213		#'
214		#' @examples
215		#' trini_mod
216		#' trini_mod$group
217		#' groups(trini_mod)
218		#' filter_by_group(trini_mod, stream == "LL", transect == "transect.1")
219		#' filter_by_group(trini_mod, transect == "transect.1")
220		#' \dontrun{
221		#' # The code below would raise an error because there is no "color" grouping variable.
222		#' filter_by_group(trini_mod, color == "red")
223		#' }
224		#'
225		#' @export
226		#'
227
228		filter_by_group <- function(.data, ...) {
229	!	if (dplyr::is_grouped_df(.data)) {
230	!	warning("\"groups\" attribute is not kept in returned object.")
231		}
232	!	is_grouped <- TRUE
233	!	if (!"group" %in% colnames(.data)) {
234	!	is_grouped <- FALSE
235		}
236	!	if (nrow(.data) == 0 \|
237	!	(nrow(.data) == 1 && is.null(.data$group[[1]]))) {
238	!	is_grouped <- FALSE
239		}
240	!	if (!is_grouped) {
241	!	stop("Input data does not have a valid \"group\" column.")
242		}
243	!	if (!length(unique(lapply(.data$group, names))) == 1) {
244	!	stop("Variable names are not consistent in \"group\" column.")
245		}
246	!	grp <- tibble::as_tibble(do.call(rbind, .data$group))
247	!	if (".my_index" %in% names(grp)) {
248	!	stop("\"group\" column already has the reserved \".my_index\" field.")
249		}
250	!	grp$.my_index <- seq_len(nrow(grp))
251	!	filtered <- dplyr::filter(grp, ...)
252	!	return(.data[filtered$.my_index, ])
253		}
254
255		### * dic()
256
257		#' Calculate DIC from a model output
258		#'
259		#' Note that DIC might not be indicated for network models, as the posteriors
260		#' are often not multinormal distributions.
261		#'
262		#' LOO is probably not a good choice either since the data is akin to a time
263		#' series (so data points are not independent). Maybe WAIC could be an option?
264		#' (TODO: read about this.)
265		#'
266		#' DIC is calculated as:
267		#'
268		#' DIC = Dbar + pD
269		#'
270		#' where D are deviance values calculated as -2 * loglik for each MCMC
271		#' iteration, Dbar is the mean deviance value and pD is the effective number of
272		#' parameters in the model and can be calculated as var(D)/2 (Gelman 2003).
273		#'
274		#' @param ... One or several \code{mcmc.list} objects, output(s) from
275		#' \code{\link{run_mcmc}}.
276		#' @param weight Boolean, if TRUE calculate DIC weights based on Link and
277		#' Barker 2010 (Link, W. A., and R. J. Barker. 2010. Bayesian Inference
278		#' With Ecological Applications. Amsterdam Boston Heidelberg London:
279		#' Elsevier/Academic Press).
280		#'
281		#' @return A tibble with one row per \code{mcmc.list} object provided in
282		#' \code{...}. This tibble is sorted by DIC, so the row order might be
283		#' different from the \code{mcmc.list} objects order.
284		#'
285		#' @examples
286		#' \donttest{
287		#' # Define two different models
288		#' m1 <- aquarium_mod
289		#' m2 <- set_topo(m1, c("NH4 -> algae -> daphnia -> NH4", "algae -> NH4"))
290		#' m2 <- set_priors(m2, priors(m1))
291		#' m2 <- set_priors(m2, normal_p(0, 0.5), "upsilon_algae_to_NH4")
292		#' # Run the models
293		#' r1 <- run_mcmc(m1, chains = 2)
294		#' r2 <- run_mcmc(m2, chains = 2)
295		#' # Model comparison with DIC
296		#' dic(r1, r2)
297		#' }
298		#'
299		#' @export
300		#'
301
302		# TODO add formula for DIC calculation in function doc.
303
304		dic <- function(..., weight = TRUE) {
305		# Deparse based on https://stackoverflow.com/questions/51259346/how-to-get-names-of-dot-dot-dot-arguments-in-r
306		# (but I don't understand how it works)
307	!	names <- sapply(substitute(list(...))[-1], deparse)
308	!	logliks <- lapply(list(...), function(x) attr(x, "loglik"))
309	!	if (any(sapply(logliks, is.null))) {
310	!	stop("No \"loglik\" attribute found for at least one input object.")
311		}
312	!	logliks <- lapply(logliks, unlist)
313	!	D <- lapply(logliks, function(x) -2 * x)
314	!	Dbar <- sapply(D, mean)
315	!	pD <- sapply(D, function(x) var(x) / 2)
316	!	out <- tibble::tibble(fit = names,
317	!	Dbar = Dbar,
318	!	pD = pD)
319	!	out[["DIC"]] <- out$Dbar + out$pD
320	!	min_DIC <- min(out[["DIC"]])
321	!	out[["delta_DIC"]] <- out[["DIC"]] - min_DIC
322	!	num <- exp(- out[["delta_DIC"]] / 2)
323	!	denom <- sum(num)
324	!	out[["weight"]] <- num / denom
325	!	out <- out[order(out$delta_DIC), ]
326	!	return(out)
327		}

1		### * All functions in this file are exported
2
3		### * ggtopo (generic)
4
5		#' Plot a topology
6		#'
7		#' A quick plot using ggraph
8		#'
9		#' @param x A network model or a topology matrix.
10		#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
11		#' @param edge "fan" (the default) or "line" or "curve".
12		#' @param ... Passed to the methods.
13		#'
14		#' @return A ggplot2 plot.
15		#'
16		#' @examples
17		#' if (requireNamespace("ggraph")) {
18		#' ggtopo(aquarium_mod, edge = "line")
19		#' }
20		#'
21		#' @export
22
23		ggtopo <- function(x, layout = "auto", edge = "fan", ...) {
24	6x	UseMethod("ggtopo")
25		}
26
27		### * ggtopo.networkModel
28
29		#' Plot a network topology
30		#'
31		#' A quick plot using ggraph
32		#'
33		#' @param x A topology matrix.
34		#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
35		#' @param edge "curve" (the default) or "line".
36		#' @param ... Not used for now.
37		#'
38		#' @return A ggplot2 plot.
39		#'
40		#' @examples
41		#' if (requireNamespace("ggraph")) {
42		#' ggtopo(aquarium_mod, edge = "line")
43		#' ggtopo(trini_mod)
44		#' }
45		#'
46		#' @export
47
48		ggtopo.networkModel <- function(x, layout = "auto", edge = "fan", ...) {
49	3x	topos <- topo(x, simplify = FALSE)
50	3x	if (length(unique(topos)) > 1) {
51	!	message("Plotting the topology of the first row of the networkModel.")
52		}
53	3x	topo <- topos[[1]]
54	3x	ggtopo(topo, layout = layout, edge = edge)
55		}
56
57		### * ggtopo.topology
58
59		#' Plot a topology
60		#'
61		#' A quick plot using ggraph
62		#'
63		#' @param x A topology matrix.
64		#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
65		#' @param edge "curve" (the default), "line" or "fan".
66		#' @param ... Not used for now.
67		#'
68		#' @return A ggplot2 plot.
69		#'
70		#' @examples
71		#' if (requireNamespace("ggraph")) {
72		#' z <- topo(aquarium_mod)
73		#' ggtopo(z)
74		#' ggtopo(z, edge = "line")
75		#'
76		#' z <- topo(trini_mod)
77		#' ggtopo(z)
78		#'
79		#' # For finer control, one can build a tbl_graph from the topology and
80		#' # use ggraph directly
81		#' x <- as_tbl_graph(z)
82		#' library(ggraph)
83		#' ggraph(x) + geom_edge_link()
84		#' }
85		#'
86		#' @export
87
88		ggtopo.topology <- function(x, layout = "auto", edge = "fan", ...) {
89	3x	`!!` <- rlang::`!!`
90	3x	topo <- x
91	3x	if (!edge %in% c("curve", "line", "fan")) {
92	!	stop("edge should be either \"curve\", \"fan\", or \"line\".")
93		}
94	3x	if (!requireNamespace("ggraph", quietly = TRUE)) {
95	!	stop("Package \"ggraph\" needed for this function to work. Please install it.",
96	!	call. = FALSE)
97		}
98	3x	x <- as_tbl_graph(topo)
99		# https://stackoverflow.com/questions/49989158/how-to-have-a-removed-from-a-ggraph-plot-legend
100	3x	GeomLabel <- ggplot2::GeomLabel
101	3x	GeomLabel$draw_key <- function(data, params, size) {
102	4x	ggplot2::draw_key_rect(data)
103		}
104		# Check that the random seed is not reset by graphlayouts functions
105	3x	if (exists(".Random.seed", .GlobalEnv)) {
106	3x	prev_seed <- .GlobalEnv[[".Random.seed"]]
107	!	} else { prev_seed <- NULL }
108	3x	msg_ggraph <- capture_msg(ggraph::ggraph(x, layout = layout))
109	3x	if (!is.null(msg_ggraph) && msg_ggraph$message == "Multiple parents. Unfolding graph\n") {
110	!	message("\"stress\" layout cannot handle this topology. ",
111	!	"Using \"kk\" layout instead.")
112	!	layout <- "kk"
113		}
114	3x	g <- ggraph::ggraph(x, layout = layout)
115	3x	if (exists(".Random.seed", .GlobalEnv)) {
116	3x	new_seed <- .GlobalEnv[[".Random.seed"]]
117	!	} else { new_seed <- NULL }
118	3x	if (!identical(prev_seed, new_seed)) {
119	!	stop("Random seed was reset when calling ggraph::ggraph() in ggtopo().\n",
120	!	"This is unwanted behaviour, please report it as a bug to the isotracer authors.")
121		}
122	3x	if (edge == "curve") {
123	!	g <- g +
124	!	ggraph::geom_edge_diagonal(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
125	!	end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name")))),
126	!	arrow = grid::arrow(length = grid::unit(1, "line")))
127	3x	} else if (edge == "fan") {
128	2x	g <- g +
129	2x	ggraph::geom_edge_fan(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
130	2x	end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name")))),
131	2x	arrow = grid::arrow(length = grid::unit(1, "line")))
132		} else {
133	1x	g <- g +
134	1x	ggraph::geom_edge_link(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
135	1x	end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name")))),
136	1x	arrow = grid::arrow(length = grid::unit(1, "line")))
137		}
138	3x	g <- g +
139	3x	ggraph::geom_node_label(ggplot2::aes(label = `!!`(rlang::sym("name")),
140	3x	fill = `!!`(rlang::sym("steady_state"))),
141	3x	col = "black",
142	3x	fontface = 1,
143	3x	label.padding = grid::unit(0.5, "line"),
144	3x	label.r = grid::unit(0.5, "line")) +
145	3x	ggplot2::coord_cartesian(clip = "off") +
146	3x	ggraph::theme_graph(base_family = "sans") # https://github.com/thomasp85/ggraph/issues/67
147	3x	g <- g + ggplot2::scale_fill_manual(values = c("FALSE" = "#a6cee3",
148	3x	"TRUE" = "#b2df8a"),
149	3x	labels = c("FALSE" = "No",
150	3x	"TRUE" = "Yes")) +
151	3x	ggplot2::labs(fill = "Steady state")
152	3x	if (length(attr(topo, "steadyState")) == 0) {
153	1x	g <- g + ggplot2::theme(legend.position = "none")
154		}
155	3x	return(g)
156		}
157
158		### * ggflows()
159
160		#' A quick-and-dirty way of visualizing relative flows in a network
161		#'
162		#' @param x A tibble with the flow estimates, with columns "from", "to", and
163		#' "flow".
164		#' @param layout Optional, layout to use (e.g. "sugiyama", "kk", "stress")
165		#' @param edge "curve" (the default), "line" or "fan".
166		#' @param max_width Optional, numeric giving the maximum edge width (minimum
167		#' width is always 1).
168		#' @param legend Boolean, display edge width legend?
169		#' @param ... Not used.
170		#'
171		#' @return A ggplot2 plot.
172		#'
173		#' @examples
174		#' if (requireNamespace("ggraph")) {
175		#' z <- tibble::tribble(
176		#' ~from, ~to, ~flow,
177		#' "leavesAndStem", "rootsAndRhizome", 333.929866077124,
178		#' "lowerWater", "rootsAndRhizome", 4425.15780019304,
179		#' "rootsAndRhizome", "leavesAndStem", 525.208837577916,
180		#' "upperWater", "leavesAndStem", 11224.0814971855
181		#' )
182		#' ggflows(z)
183		#' ggflows(z, max_width = 15)
184		#' }
185		#'
186		#' @export
187		#'
188
189		ggflows <- function(x, layout = "auto", edge = "fan", max_width, legend = TRUE, ...) {
190	!	`!!` <- rlang::`!!`
191	!	if (! all(c("from", "to", "flow") %in% colnames(x))) {
192	!	stop("`x` must have at least columns \"from\", \"to\", and \"flow\".")
193		}
194	!	if (!requireNamespace("ggraph", quietly = TRUE)) {
195	!	stop("Package \"ggraph\" needed for this function to work. Please install it.",
196	!	call. = FALSE)
197		}
198	!	if (!requireNamespace("tidygraph", quietly = TRUE)) {
199	!	stop("Package \"tidygraph\" needed for this function to work. Please install it.",
200	!	call. = FALSE)
201		}
202	!	x <- x[, c("from", "to", "flow")]
203	!	if (!edge %in% c("curve", "line", "fan")) {
204	!	stop("edge should be either \"curve\", \"fan\", or \"line\".")
205		}
206		# https://stackoverflow.com/questions/49989158/how-to-have-a-removed-from-a-ggraph-plot-legend
207		# https://stackoverflow.com/questions/56173310/how-to-adjust-the-width-of-edges-by-weight-in-ggraph-network-in-r
208	!	GeomLabel <- ggplot2::GeomLabel
209	!	GeomLabel$draw_key <- function(data, params, size) {
210	!	ggplot2::draw_key_rect(data)
211		}
212	!	g <- ggraph::ggraph(x, layout = layout)
213	!	if (edge == "curve") {
214	!	g <- g +
215	!	ggraph::geom_edge_diagonal(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
216	!	end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name"))),
217	!	width = `!!`(rlang::sym("flow"))),
218	!	arrow = grid::arrow(length = grid::unit(1, "line")))
219	!	} else if (edge == "fan") {
220	!	g <- g +
221	!	ggraph::geom_edge_fan(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
222	!	end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name"))),
223	!	width = `!!`(rlang::sym("flow"))),
224	!	arrow = grid::arrow(length = grid::unit(1, "line")))
225		} else {
226	!	g <- g +
227	!	ggraph::geom_edge_link(ggplot2::aes(start_cap = ggraph::label_rect(`!!`(rlang::sym("node1.name"))),
228	!	end_cap = ggraph::label_rect(`!!`(rlang::sym("node2.name"))),
229	!	width = `!!`(rlang::sym("flow"))),
230	!	arrow = grid::arrow(length = grid::unit(1, "line")))
231		}
232	!	g <- g +
233	!	ggraph::geom_node_label(ggplot2::aes(label = `!!`(rlang::sym("name"))),
234	!	fill = grey(0.9),
235	!	fontface = 1,
236	!	label.padding = grid::unit(0.5, "line"),
237	!	label.r = grid::unit(0.5, "line")) +
238	!	ggplot2::coord_cartesian(clip = "off") +
239	!	ggraph::theme_graph(base_family = "sans") # https://github.com/thomasp85/ggraph/issues/67
240	!	if (!missing(max_width)) {
241	!	if (max_width < 1) {
242	!	stop("`max_width` must be >= 1.")
243		}
244	!	g <- g +
245	!	ggraph::scale_edge_width(range = c(1, max_width))
246		}
247	!	if (!legend) {
248	!	g <- g + ggplot2::theme(legend.position = "none")
249		}
250	!	return(g)
251		}

1		### * TODO
2
3		# Clean-up this file
4
5		### * None of the functions in this file is exported
6
7		### * group2string()
8
9		#' Convert a group entry to a string
10		#'
11		#' @param x A vector describing a group. Can be NULL.
12		#'
13		#' @return A string.
14		#'
15		#' @keywords internal
16		#' @noRd
17
18		group2string <- function(x) {
19	!	if (is.null(x)) {
20	!	return("NULL")
21		}
22	!	n <- names(x)
23	!	s <- paste(paste(n, x, sep = "="), collapse = "; ")
24	!	return(s)
25		}
26
27		### * Alias for tidy_mcmc()
28
29		#' @keywords internal
30		#' @noRd
31
32		tidy_mcmc_list <- function(...) {
33	22x	tidy_mcmc(...)
34		}

1		### * None of the functions in this file is exported
2
3		### * mugen_stan()
4
5		#' Run a stan model from a network model (temporary name)
6		#'
7		#' Incorporate a loglik trace: https://mc-stan.org/loo/reference/extract_log_lik.html
8		#'
9		#' @param nm A \code{networkModel} object.
10		#' @param iter A positive integer specifying the number of iterations for each
11		#' chain (including warmup). The default is 2000.
12		#' @param chains A positive integer specifying the number of Markov chains.
13		#' The default is 4.
14		#' @param euler_control An optional list containing extra parameters for the
15		#' Euler method. The list elements can be \code{"dt"} or
16		#' \code{"grid_size"}, which are respectively the time step size for
17		#' trajectory calculations (\code{"dt"}) or the number of points for the
18		#' calculation (\code{"grid_size"}). If none is provided, a default grid
19		#' size of 256 steps is used.
20		#' @param cores Number of cores to use for parallel run. Default is
21		#' \code{NULL}, which means to use the value stored in
22		#' \code{options()[["mc.cores"]]} (or 1 if this value is not set).
23		#' @param stanfit If TRUE, returns a `stanfit` object instead of the more
24		#' classical `mcmc.list` object.
25		#' @param use_fixed_values Boolean, if TRUE any parameter value set with
26		#' \code{set_params()} will be taken as fixed during the MCMC run. Default
27		#' is FALSE.
28		#' @param ... Passed to \code{rstan::sampling}.
29		#'
30		#' @keywords internal
31		#' @noRd
32
33		mugen_stan <- function(nm, iter = 2000, chains = 4, euler_control = list(),
34		cores = NULL, stanfit = FALSE,
35		use_fixed_values = FALSE, ...) {
36		# Detect cores
37	8x	cores <- get_n_cores(cores = cores)
38		# Convert network model to stan data
39	8x	stan.data <- prep_stan_data_euler(nm, dt = euler_control[["dt"]],
40	8x	grid_size = euler_control[["grid_size"]],
41	8x	use_fixed_values = use_fixed_values)
42		# Fit the model
43	8x	stan.data[["ode_method"]] <- 2 # For Euler scheme
44	8x	fit <- rstan::sampling(stanmodels[["networkModel"]],
45	8x	data = stan.data,
46	8x	iter = iter,
47	8x	chains = chains,
48	8x	cores = cores,
49	8x	pars = c("nonConstantParams", "log_lik",
50	8x	"rawUniformParams", "rawHcauchyParams",
51	8x	"rawBetaParams", "rawTrNormParams",
52	8x	"rawExponentialParams", "rawGammaParams"), ...)
53	8x	stopifnot(!"isotracer_stan_data" %in% names(attributes(fit)))
54	8x	attr(fit, "isotracer_stan_data") <- stan.data
55		# Return
56	8x	if (stanfit) {
57	!	return(fit)
58		} else {
59	8x	return(stanfit_to_named_mcmclist(stanfit = fit))
60		}
61		}
62
63		### * prep_stan_data_euler()
64
65		#' Prepare stan data from a network model
66		#'
67		#' @param nm A \code{networkModel} object.
68		#' @param dt,grid_size Either the time step size for trajectory calculations
69		#' (\code{dt}) or the number of points for the calculation
70		#' (\code{grid_size}) can be provided. If none is provided, then a default
71		#' grid size of 256 steps is used.
72		#' @param use_fixed_values Boolean, if TRUE any parameter value set with
73		#' \code{set_params()} will be taken as fixed during the MCMC run. Default
74		#' is FALSE.
75		#'
76		#' @keywords internal
77		#' @noRd
78
79		prep_stan_data_euler <- function(nm, dt = NULL, grid_size = NULL,
80		use_fixed_values = FALSE) {
81	8x	d <- list()
82	8x	end <- NULL
83	8x	params_nm <- params(nm, simplify = TRUE)
84	8x	priors_nm <- priors(nm, fix_set_params = use_fixed_values,
85	8x	quiet = TRUE)
86	8x	priors_nm <- priors_nm[match(params_nm, priors_nm[["in_model"]]), ]
87	8x	stopifnot(all(params_nm == priors_nm[["in_model"]]))
88		# For now the stan model is only implemented for network models with the
89		# same number of compartments on each row (a more general case where rows
90		# can have different numbers of compartments is easily converted to this
91		# case, by adding compartments without connections to fill the topology in
92		# each row).
93	8x	stopifnot(length(unique(sapply(comps(nm), length))) == 1)
94		# Counts
95	8x	d[["nComps"]] <- length(comps(nm)[[1]])
96	8x	d[["nGroups"]] <- nrow(nm)
97	8x	d[["nParams"]] <- length(params_nm)
98		# Encode steady state compartments
99	8x	dSteady <- encode_steady(nm)
100	8x	d <- c(d, dSteady)
101		# Encode split compartments
102	8x	dSplit <- encode_split(nm, params_nm)
103	8x	d <- c(d, dSplit)
104		# Encode initial conditions
105	8x	dInit <- encode_init(nm)
106	8x	d <- c(d, dInit)
107		# Encode events
108	8x	dEvents <- encode_events(nm, dt = dt, grid_size = grid_size, end = end)
109	8x	d <- c(d, dEvents)
110		# Encode observations (including eta and zeta parameter indices)
111	8x	dObs <- encode_obs(nm, params_nm, dt = dt, grid_size = grid_size, end = end)
112	8x	d <- c(d, dObs)
113		# Encode parameter priors
114	8x	dPriors <- encode_priors(params_nm, priors_nm)
115	8x	d <- c(d, dPriors)
116		# Encode time schemes
117	8x	dTimeSchemes <- encode_time_schemes(nm, dt = dt, grid_size = grid_size,
118	8x	end = end)
119	8x	d <- c(d, dTimeSchemes)
120		# Encode uptake rates (upsilons)
121	8x	dUpsilons <- encode_upsilons(nm, params_nm)
122	8x	d <- c(d, dUpsilons)
123		# Encode losses (lambdas)
124	8x	dLambdas <- encode_lambdas(nm, params_nm)
125	8x	d <- c(d, dLambdas)
126		# Encode decay rate for radioactive tracers
127	8x	lambda_decay <- attr(nm, "lambda_hl")
128	8x	if (is.null(lambda_decay)) {
129	8x	lambda_decay <- 0
130		}
131	8x	d[["lambda_decay"]] <- lambda_decay
132		# Encode distribution families (for proportions and sizes)
133	8x	d <- c(d, encode_distrib_families(nm))
134		# Add encoding for matrix exponential (so that the Stan model does not crash)
135	8x	d[["allParams"]] <- params_nm
136	8x	matrix_exp <- encode_intervals(nm)
137	8x	matrix_exp <- c(matrix_exp, encode_unique_obs_times(nm))
138	8x	stopifnot(!any(names(matrix_exp) %in% names(d)))
139	8x	d <- c(d, matrix_exp)
140	8x	return(d)
141		}
142
143		### * encode_events()
144
145		#' Encode events (for Stan model using Euler integration)
146		#'
147		#' For now, only pulse events are encoded.
148		#'
149		#' @param nm A \code{networkModel} object.
150		#' @param dt,grid_size Either the time step size for trajectory calculations
151		#' (\code{dt}) or the number of points for the calculation
152		#' (\code{grid_size}) can be provided. If none is provided, then a default
153		#' grid size of 256 steps is used.
154		#' @param end Time value for end point. If not provided, the last observation
155		#' or event is used.
156		#'
157		#' @examples
158		#' encode_events <- isotracer:::encode_events
159		#' encode_events(aquarium_mod)
160		#' encode_events(trini_mod)
161		#'
162		#' @keywords internal
163		#' @noRd
164
165		encode_events <- function(nm, dt = NULL, grid_size = NULL, end = NULL) {
166	345x	d <- nm_get_time_schemes(nm, dt = dt, grid_size = grid_size, end = end)
167	345x	nGroups <- nrow(nm)
168	345x	o <- list()
169	345x	events <- nm[["events"]]
170	345x	stopifnot(all(dplyr::bind_rows(events)[["event"]] == "pulse"))
171		# Encode compartments and timepoints
172	345x	for (i in seq_len(nrow(nm))) {
173	347x	comps <- colnames(nm$topology[[i]])
174	347x	comps <- setNames(seq_along(comps), nm = comps)
175	347x	if (!is.null(events[[i]])) {
176	2x	events[[i]]$compartment <- comps[events[[i]]$compartment]
177	2x	events[[i]]$timepoints <- match(events[[i]]$time, d$timepoints[[i]])
178		}
179		}
180		# Encode the number of events
181	345x	if (length(events) == 0) {
182	330x	nEvents <- rep(0, nrow(nm))
183		} else {
184	15x	nEvents <- sapply(events, function(x) {
185	14x	if (is.null(x)) return(0)
186	2x	return(nrow(x))
187		})
188		}
189	345x	o[["maxNpulseEvents"]] <- max(nEvents)
190	345x	o[["nPulseEvents"]] <- setNames(c(nEvents, 0), # Padded
191	345x	nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
192		# Encode pulses
193	345x	o[["pulseEventsIndices"]] <- array(0, dim = c(max(nEvents), 2, nGroups),
194	345x	dimnames = list(seq_len(max(nEvents)),
195	345x	c("timepoint", "comp"),
196	345x	paste0("grp", seq_len(nGroups))))
197	345x	o[["pulseEventsQuantities"]] <- array(0, dim = c(max(nEvents), 2, nGroups),
198	345x	dimnames = list(seq_len(max(nEvents)),
199	345x	c("unmarked", "marked"),
200	345x	paste0("grp", seq_len(nGroups))))
201	345x	for (i in seq_len(nGroups)) {
202	347x	if (!is.null(events[[i]])) {
203	2x	o[["pulseEventsIndices"]][1:nEvents[i], 1:2, i] <-
204	2x	as.matrix(events[[i]][, c("timepoints", "compartment")])
205	2x	chars <- lapply(events[[i]]$characteristics, tibble::as_tibble)
206	2x	chars <- dplyr::bind_rows(chars)[, c("unmarked", "marked")]
207	2x	o[["pulseEventsQuantities"]][1:nEvents[i], 1:2, i] <-
208	2x	as.matrix(chars)
209		}
210		}
211		# Return
212	345x	return(o)
213		}
214
215		### ** nm_get_time_schemes()
216
217		#' Build the time schemes for numerical solving of the system of differential equations
218		#'
219		#' This function processes each row of a networkModel. It always assumes that
220		#' the starting time point is t=0.
221		#'
222		#' @param nm A networkModel
223		#' @param dt,grid_size Either the time step size for trajectory calculations
224		#' (\code{dt}) or the number of points for the calculation
225		#' (\code{grid_size}) can be provided. If none is provided, then a default
226		#' grid size of 256 steps is used.
227		#' @param end Time value for end point. If not provided, the last observation
228		#' or event is used.
229		#' @param at Optional, vector of time values at which the trajectory must be
230		#' evaluated
231		#'
232		#' @keywords internal
233		#' @noRd
234
235		nm_get_time_schemes <- function(nm, dt = NULL, grid_size = NULL, end = NULL,
236		at = NULL) {
237		# Get the time schemes for each row of nm
238	380x	ts <- lapply(seq_len(nrow(nm)), function(i) {
239	397x	z <- nm_row_get_time_scheme(nm[i, ], dt = dt, grid_size = grid_size,
240	397x	end = end, at = at)
241	397x	z <- tibble::as_tibble(lapply(z, list))
242		})
243	380x	ts <- dplyr::bind_rows(ts)
244	380x	return(ts)
245		}
246
247		### ** nm_row_get_time_scheme()
248
249		#' Build the time scheme for numerical solving of the system of differential equations
250		#'
251		#' This function is applied to one row of a networkModel. It always assumes
252		#' that the starting time point is t=0.
253		#'
254		#' @param nm_row A row from a \code{networkModel} object.
255		#' @param dt,grid_size Either the time step size for trajectory calculations
256		#' (\code{dt}) or the number of points for the calculation
257		#' (\code{grid_size}) can be provided. If none is provided, then a default
258		#' grid size of 256 steps is used.
259		#' @param end Time value for end point. If not provided, the last observation
260		#' or event is used.
261		#' @param at Optional, vector of time values at which the trajectory must be
262		#' evaluated
263		#'
264		#' @examples
265		#' isotracer:::nm_row_get_time_scheme(aquarium_mod)
266		#'
267		#' @keywords internal
268		#' @noRd
269
270		nm_row_get_time_scheme <- function(nm_row, dt = NULL, grid_size = NULL, end = NULL,
271		at = NULL) {
272	734x	nmRow <- nm_row
273	734x	stopifnot(nrow(nmRow) == 1)
274		# Parse dt and gridsize
275	734x	if (!(is.null(dt) \| is.null(grid_size))) {
276	!	stop("Only \"dt\" or \"grid_size\" can be specified, not both.")
277		}
278	734x	if (is.null(dt) & is.null(grid_size)) {
279	171x	grid_size <- 256
280		}
281		# Get observation times
282	734x	observations <- nmRow[["observations"]][[1]]
283	734x	obsTimes <- observations[["time"]]
284	734x	obsTimes <- sort(unique(obsTimes))
285		# Get events time
286	734x	eventTimes <- c()
287	734x	if (!is.null(nmRow[["events"]][[1]])) {
288	8x	eventTimes <- unique(nmRow[["events"]][[1]]$time)
289		}
290		# Get "at" times
291	734x	atTimes <- c()
292	734x	if (!is.null(at)) {
293	29x	atTimes <- unique(at)
294		}
295		# Get end time
296	734x	if (is.null(end)) {
297	60x	maxTime <- max(c(obsTimes, eventTimes, atTimes))
298		} else {
299	674x	maxTime <- end
300		}
301		# Calculate dt
302	734x	if (is.null(dt)) {
303	734x	dt <- maxTime / grid_size
304		}
305		# Generate a time scheme
306	734x	timepoints <- c(seq(0, maxTime, by = dt), obsTimes, eventTimes, atTimes)
307	734x	timepoints <- sort(unique(timepoints))
308	734x	timepoints <- timepoints[timepoints <= maxTime]
309		# (if end = NULL, timepoints is a timeline with timesteps at most dt wide
310		# and containing all the observations sampling times and the event times,
311		# even if not a multiple of dt.)
312		# (else, timepoints is truncated at end.)
313		# Annotate the observations tibble with the timepoints ids
314	734x	observations[["timepoint"]] <- match(observations[["time"]], timepoints)
315	734x	if (is.null(end)) {
316	60x	stopifnot(!any(is.na(observations[["timepoint"]])))
317		}
318		# Get unique dts
319	734x	dts <- timepoints_to_dt(timepoints)
320		# Return
321	734x	return(list(timepoints = timepoints,
322	734x	unique_dt = dts[["unique_dt"]],
323	734x	dt_i = dts[["dt_i"]],
324	734x	observations = observations))
325		}
326
327		### ** timepoints_to_dt()
328
329		#' Prepare the set of unique dt from a vector of timepoints
330		#'
331		#' Useful to identify how many different transfer matrices have to be calculated.
332		#'
333		#' @param timepoints Numeric vector of timepoints, sorted.
334		#'
335		#' @keywords internal
336		#' @noRd
337
338		timepoints_to_dt <- function(timepoints) {
339	734x	dts <- diff(timepoints)
340	734x	uniqueDts <- sort(unique(dts))
341	734x	dt_i <- match(dts, uniqueDts)
342	734x	stopifnot(!any(is.na(dt_i)))
343	734x	return(list(unique_dt = uniqueDts,
344	734x	dt_i = dt_i))
345		}
346
347		### * encode_obs()
348
349		#' Encode observations for a network model
350		#'
351		#' @param nm A \code{networkModel} object.
352		#' @param allParams Parameters of the network model.
353		#' @param dt,grid_size Either the time step size for trajectory calculations
354		#' (\code{dt}) or the number of points for the calculation
355		#' (\code{grid_size}) can be provided. If none is provided, then a default
356		#' grid size of 256 steps is used.
357		#' @param end Time value for end point. If not provided, the last observation
358		#' or event is used.
359		#'
360		#' @return NULL if the observations column only contain NULLs.
361		#'
362		#' @importFrom stats na.omit
363		#'
364		#' @keywords internal
365		#' @noRd
366
367		encode_obs <- function(nm, allParams, dt = NULL, grid_size = NULL, end = NULL) {
368	8x	d <- nm_get_time_schemes(nm, dt = dt, grid_size = grid_size, end = end)
369	8x	nGroups <- nrow(nm)
370	8x	zeta_by_comp <- attr(nm, "size_zeta_per_compartment")
371	8x	if (is.null(zeta_by_comp)) {
372	!	zeta_by_comp<- FALSE
373		}
374		# TODO Add filtering to keep only compartments present in topo
375		# TODO Handle gracefully the case without observations
376	8x	if (all(sapply(nm$observations, is.null))) {
377	!	return(NULL)
378		}
379		# Get sizes
380	8x	sizes <- purrr::map(d$observations, function(x) {
381	10x	na.omit(x[, c("compartment", "size", "timepoint")])
382		})
383		# Get proportions
384	8x	props <- purrr::map(d$observations, function(x) {
385	10x	na.omit(x[, c("compartment", "proportion", "timepoint")])
386		})
387		# Encode compartments
388	8x	for (i in seq_len(nrow(nm))) {
389	10x	comps <- colnames(nm$topology[[i]])
390	10x	comps <- setNames(seq_along(comps), nm = comps)
391	10x	sizes[[i]]$compartment <- comps[sizes[[i]]$compartment]
392	10x	props[[i]]$compartment <- comps[props[[i]]$compartment]
393		}
394		# Encode sizes and props
395	8x	o <- list()
396	8x	o[["nSizesObs"]] <- c(purrr::map_dbl(sizes, nrow), 0) # Padded
397	8x	names(o[["nSizesObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
398	8x	o[["nPropsObs"]] <- c(purrr::map_dbl(props, nrow), 0) # Padded
399	8x	names(o[["nPropsObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
400	8x	o[["maxNsizesObs"]] <- max(o[["nSizesObs"]])
401	8x	o[["maxNpropsObs"]] <- max(o[["nPropsObs"]])
402		# Prepare containers
403	8x	o[["sizesObsIndices"]] <- array(0, dim = c(o[["maxNsizesObs"]], 3, nGroups),
404	8x	dimnames = list(seq_len(o[["maxNsizesObs"]]),
405	8x	c("comp", "timepoint", "zeta"),
406	8x	paste0("grp", seq_len(nGroups))))
407	8x	o[["sizesObs"]] <- array(0, dim = c(o[["maxNsizesObs"]], nGroups),
408	8x	dimnames = list(seq_len(o[["maxNsizesObs"]]),
409	8x	paste0("grp", seq_len(nGroups))))
410	8x	o[["propsObsIndices"]] <- array(0, dim = c(o[["maxNpropsObs"]], 3, nGroups),
411	8x	dimnames = list(seq_len(o[["maxNpropsObs"]]),
412	8x	c("comp", "timepoint", "eta"),
413	8x	paste0("grp", seq_len(nGroups))))
414	8x	o[["propsObs"]] <- array(0, dim = c(o[["maxNpropsObs"]], nGroups),
415	8x	dimnames = list(seq_len(o[["maxNpropsObs"]]),
416	8x	paste0("grp", seq_len(nGroups))))
417		# Fill containers
418	8x	for (g in seq_len(nGroups)) {
419	10x	if (o[["nSizesObs"]][g] > 0) {
420	10x	o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 1:2, g] <- as.matrix(sizes[[g]][, c("compartment", "timepoint")])
421	10x	o[["sizesObs"]][1:o[["nSizesObs"]][g], g] <- as.matrix(sizes[[g]][, c("size")])
422	10x	if (!zeta_by_comp) {
423	10x	zeta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "zeta"]
424	10x	zeta_index <- match(zeta_global, allParams)
425	10x	o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
426		} else {
427	!	comps <- colnames(nm$topology[[g]])
428	!	comps <- setNames(seq_along(comps), nm = comps)
429	!	zeta_replicate <- paste0("zeta_", names(comps)[sizes[[g]][["compartment"]]])
430	!	zeta_global <- nm[["parameters"]][[g]]$in_model[match(zeta_replicate, nm[["parameters"]][[g]]$in_replicate)]
431	!	zeta_index <- match(zeta_global, allParams)
432	!	o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
433		}
434		}
435		}
436	8x	for (g in seq_len(nGroups)) {
437	10x	if (o[["nPropsObs"]][g] > 0) {
438	10x	o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 1:2, g] <- as.matrix(props[[g]][, c("compartment", "timepoint")])
439	10x	o[["propsObs"]][1:o[["nPropsObs"]][g], g] <- as.matrix(props[[g]][, c("proportion")])
440	10x	eta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "eta"]
441	10x	eta_index <- match(eta_global, allParams)
442	10x	o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 3, g] <- eta_index
443		}
444		}
445		# Return
446	8x	return(o)
447		}
448
449		### * encode_time_schemes()
450
451		#' Encode the time schemes for stan data
452		#'
453		#' @param nm A \code{networkModel} object.
454		#' @param dt,grid_size Either the time step size for trajectory calculations
455		#' (\code{dt}) or the number of points for the calculation
456		#' (\code{grid_size}) can be provided. If none is provided, then a default
457		#' grid size of 256 steps is used.
458		#' @param end Time value for end point. If not provided, the last observation
459		#' or event is used.
460		#'
461		#' @keywords internal
462		#' @noRd
463
464		encode_time_schemes <- function(nm, dt = NULL, grid_size = NULL, end = NULL) {
465		# (timestep and dt are used interchangeably)
466		# Get the time schemes
467	27x	ts <- nm_get_time_schemes(nm, dt = dt, grid_size = grid_size, end = end)
468		# Build the arrays
469	27x	nGroups <- nrow(nm)
470	27x	n_unique_dts <- purrr::map_dbl(ts$unique_dt, length)
471	27x	maxN_unique_dts <- max(n_unique_dts)
472	27x	n_timesteps <- purrr::map_dbl(ts$dt_i, length)
473	27x	maxN_timesteps <- max(n_timesteps)
474	27x	unique_dts <- array(0, dim = c(maxN_unique_dts, nGroups),
475	27x	dimnames = list(c(1:maxN_unique_dts),
476	27x	paste0("grp", 1:nGroups)))
477	27x	timesteps <- array(0, c(maxN_timesteps, nGroups),
478	27x	dimnames = list(c(1:maxN_timesteps),
479	27x	paste0("grp", 1:nGroups)))
480		# Fill the arrays
481	27x	for (i in seq_len(nrow(nm))) {
482	40x	unique_dts[1:n_unique_dts[i], i] <- ts[["unique_dt"]][[i]]
483	40x	timesteps[1:n_timesteps[i], i] <- ts[["dt_i"]][[i]]
484		}
485		# Prepare data
486	27x	d <- list()
487	27x	d[["nTimesteps"]] <- setNames(c(n_timesteps, 0), # Padded
488	27x	nm = c(paste0("grp", 1:nGroups), "padding"))
489	27x	d[["nUniqueDts"]] <- setNames(c(n_unique_dts, 0), # Padded
490	27x	nm = c(paste0("grp", 1:nGroups), "padding"))
491	27x	d[["timesteps"]] <- timesteps
492	27x	d[["unique_dts"]] <- unique_dts
493	27x	d[["maxNtimesteps"]] <- max(d[["nTimesteps"]])
494	27x	d[["maxNuniqueDts"]] <- max(d[["nUniqueDts"]])
495	27x	return(d)
496		}

1		### * None of the functions in this file is exported
2
3		### * add_param_mapping()
4
5		#' Build the (default) parameter mapping in a \code{networkModel} object
6		#'
7		#' For now this function just builds the default base mapping. Improvements
8		#' are: taking into account fixed effect of discrete variables and updating
9		#' gracefully when grouping or topology is modified. Maybe this is not doable
10		#' in a clean way, and the best option is just to reset the mapping when
11		#' grouping or topo is modified and warn the user.
12		#'
13		#' This function also sets the default priors
14		#'
15		#' @param nm A \code{networkModel} object.
16		#'
17		#' @return A \code{networkModel} object.
18		#'
19		#' @keywords internal
20		#' @noRd
21
22		add_param_mapping <- function(nm, use_default = FALSE) {
23		# Build canonical mapping
24	37x	mapping <- lapply(seq_len(nrow(nm)), function(i) {
25	37x	params <- nm_base_params(nm[i, ])
26	37x	tibble::tibble(in_replicate = params,
27	37x	in_model = params)
28		})
29	37x	nm$parameters <- mapping
30		# Set default priors
31	37x	priors <- tibble::tibble(in_model = nm_base_params(nm))
32	37x	if (use_default) {
33	!	priors$prior <- lapply(seq_len(nrow(priors)), function(i) {
34	!	hcauchy_p(scale = 0.1)
35		})
36	!	for (i in which(grepl("^portion[.]act_", priors$in_model))) {
37	!	priors$prior[[i]] <- uniform_p(0, 1)
38		}
39		} else {
40	37x	priors$prior <- lapply(seq_len(nrow(priors)), function(i) {
41	306x	NULL
42		})
43		}
44	37x	attr(nm, "priors") <- priors
45		# Return
46	37x	return(nm)
47		}
48
49		### * nm_base_params()
50
51		#' Get the vector of default parameter names
52		#'
53		#' @param nm A \code{networkModel} object
54		#'
55		#' @return A vector of strings
56		#'
57		#' @keywords internal
58		#' @noRd
59
60		nm_base_params <- function(nm) {
61	79x	params <- c(lapply(nm$topology, topo_get_upsilon_names),
62	79x	lapply(nm$topology, topo_get_lambda_names),
63	79x	lapply(nm$topology, topo_get_portionAct_names),
64	79x	"eta")
65		# (eta is a parameter for the variation of observed proportions)
66		# Check if zeta should be compartment-specific
67		# (zeta is a parameter for the variation of observed sizes)
68	79x	z <- attr(nm, "size_zeta_per_compartment")
69	79x	if (!is.null(z) && z) {
70	!	comps <- unique(unlist(lapply(nm$topology, colnames)))
71	!	zetas <- paste0("zeta_", comps)
72	!	params <- c(params, zetas)
73		} else {
74	79x	params <- c(params, "zeta")
75		}
76	79x	params <- sort(unique(unlist(params)))
77	79x	return(params)
78		}
79
80		### * refresh_param_mapping()
81
82		#' Apply a formula on param mapping
83		#'
84		#' @param nm A \code{networkModel} object.
85		#' @param formula A list of formulas describing the parameter dependencies on
86		#' covariates. Formulas are applied sequentially.
87		#' @param use_regexpr Boolean. Use regular expression to match the left-hand
88		#' terms to replicate parameters?
89		#'
90		#' @return An updated \code{networkModel}
91		#'
92		#' @importFrom stats update
93		#'
94		#' @keywords internal
95		#' @noRd
96
97		refresh_param_mapping <- function(nm, formula, use_regexpr = TRUE) {
98	5x	base_params <- nm_base_params(nm)
99		# Parse formula
100	5x	leftTerms <- all.vars(update(formula, . ~ 0))
101	5x	rightTerms <- all.vars(update(formula, 0 ~ .))
102		# Apply regexpr if needed
103	5x	if (use_regexpr) {
104	5x	for (lt in leftTerms) {
105	9x	matches <- any(grepl(lt, base_params))
106	9x	leftTerms <- c(leftTerms, base_params[grepl(lt, base_params)])
107	9x	if (matches && !lt %in% base_params) {
108		# Terms with regexpr match are allowed to be dropped if needed
109	6x	leftTerms <- leftTerms[leftTerms != lt]
110		}
111		}
112	5x	leftTerms <- unique(leftTerms)
113		}
114		# Check that the left terms make sense (they are default parameter names)
115	5x	stopifnot(all(leftTerms %in% c(".", base_params)))
116		# Get all the parameter names if "." was specified
117	!	if ("." %in% leftTerms) { leftTerms <- base_params }
118		# Check that the right terms make sense (they are grouping variables)
119	5x	stopifnot(!is.null(nm$group))
120	5x	groups <- groups(nm)
121	5x	stopifnot(all(rightTerms %in% c(colnames(groups), ".")))
122	5x	rightTerms <- rightTerms[rightTerms != "."]
123		# Go over the rows of the design data frame
124	5x	for (i in seq_len(nrow(nm))) {
125	16x	mapping <- nm$parameters[[i]]
126	16x	if (length(rightTerms) > 0) {
127	16x	covariates <- groups[, rightTerms]
128	16x	covariatesString <- apply(covariates, 1, paste, collapse = "\|")
129	16x	for (lt in leftTerms) {
130	78x	g <- paste(lt, covariatesString, sep = "\|")
131	78x	mapping$in_model[mapping$in_replicate == lt] <- g[i]
132		}
133		} else {
134	!	for (lt in leftTerms) {
135	!	g <- lt
136	!	mapping$in_model[mapping$in_replicate == lt] <- g
137		}
138		}
139	16x	nm$parameters[[i]] <- mapping
140		}
141		# Return
142	5x	return(nm)
143		}

1		### * None of the functions in this file is exported
2
3		### * matrix_exp_stan()
4
5		#' Run a stan model from a network model, using matrix exponential to solve ODEs.
6		#'
7		#' Incorporate a loglik trace: https://mc-stan.org/loo/reference/extract_log_lik.html
8		#'
9		#' @param nm A \code{networkModel} object.
10		#' @param iter A positive integer specifying the number of iterations for each
11		#' chain (including warmup). The default is 2000.
12		#' @param chains A positive integer specifying the number of Markov chains.
13		#' The default is 4.
14		#' @param cores Number of cores to use for parallel run. Default is
15		#' \code{NULL}, which means to use the value stored in
16		#' \code{options()[["mc.cores"]]} (or 1 if this value is not set).
17		#' @param stanfit If TRUE, returns a `stanfit` object instead of the more
18		#' classical `mcmc.list` object.
19		#' @param use_fixed_values Boolean, if TRUE any parameter value set with
20		#' \code{set_params()} will be taken as fixed during the MCMC run. Default
21		#' is FALSE.
22		#' @param vb Boolean, if TRUE will use \code{rstan::vb} for a quick approximate
23		#' sampling of the posterior. Important note from \code{?rstan::vb}:
24		#' "This is still considered an experimental feature. We recommend calling
25		#' \code{stan} or \code{sampling} for final inferences and only using ‘vb’ to
26		#' get a rough idea of the parameter distributions."
27		#' @param ... Passed to \code{rstan::sampling}.
28		#'
29		#' @keywords internal
30		#' @noRd
31
32		matrix_exp_stan <- function(nm, iter = 2000, chains = 4, cores = NULL,
33		stanfit = FALSE, use_fixed_values = FALSE,
34		vb = FALSE, ...) {
35		# Detect cores
36	19x	cores <- get_n_cores(cores = cores)
37		# Convert network model to stan data
38	19x	stan.data <- prep_stan_data_expm(nm, use_fixed_values = use_fixed_values)
39		# Fit the model
40	19x	stan.data[["ode_method"]] <- 1 # For matrix exponential
41		# Approximate sampling (vb = TRUE)
42	19x	if (vb) {
43	!	if (stanfit) {
44	!	stop("vb not implemented for stanfit = TRUE")
45		}
46	!	fits <- lapply(seq_len(chains), function(i) {
47	!	fit <- rstan::vb(stanmodels[["networkModel"]],
48	!	data = stan.data,
49	!	iter = iter,
50	!	pars = c("nonConstantParams", "log_lik",
51	!	"rawUniformParams", "rawHcauchyParams",
52	!	"rawBetaParams", "rawTrNormParams",
53	!	"rawExponentialParams", "rawGammaParams"), ...)
54	!	stopifnot(!"isotracer_stan_data" %in% names(attributes(fit)))
55	!	attr(fit, "isotracer_stan_data") <- stan.data
56	!	fit
57		})
58	!	fits <- lapply(fits, stanfit_to_named_mcmclist)
59	!	fits <- lapply(fits, function(i) i[[1]])
60	!	return(coda::as.mcmc.list(fits))
61		}
62		# Accurate sampling (vb = FALSE)
63	19x	fit <- rstan::sampling(stanmodels[["networkModel"]],
64	19x	data = stan.data,
65	19x	iter = iter,
66	19x	chains = chains,
67	19x	cores = cores,
68	19x	pars = c("nonConstantParams", "log_lik",
69	19x	"rawUniformParams", "rawHcauchyParams",
70	19x	"rawBetaParams", "rawTrNormParams",
71	19x	"rawExponentialParams", "rawGammaParams"), ...)
72	19x	stopifnot(!"isotracer_stan_data" %in% names(attributes(fit)))
73	19x	attr(fit, "isotracer_stan_data") <- stan.data
74		# Return
75	19x	if (stanfit) {
76	1x	return(fit)
77		} else {
78	18x	return(stanfit_to_named_mcmclist(stanfit = fit))
79		}
80		}
81
82		### * prep_stan_data_expm()
83
84		#' Prepare stan data from a network model
85		#'
86		#' @param nm A \code{networkModel} object.
87		#' @param use_fixed_values Boolean, if TRUE any parameter value set with
88		#' \code{set_params()} will be taken as fixed during the MCMC run. Default
89		#' is FALSE.
90		#'
91		#' @keywords internal
92		#' @noRd
93
94		prep_stan_data_expm <- function(nm, use_fixed_values = FALSE) {
95	19x	d <- list()
96	19x	params_nm <- params(nm, simplify = TRUE)
97	19x	priors_nm <- priors(nm, fix_set_params = use_fixed_values,
98	19x	quiet = TRUE)
99	19x	priors_nm <- priors_nm[match(params_nm, priors_nm[["in_model"]]), ]
100	19x	stopifnot(all(params_nm == priors_nm[["in_model"]]))
101		# For now the stan model is only implemented for network models with the
102		# same number of compartments on each row (a more general case where rows
103		# can have different numbers of compartments is easily converted to this
104		# case, by adding compartments without connections to fill the topology in
105		# each row).
106	19x	stopifnot(length(unique(sapply(comps(nm), length))) == 1)
107		# Counts
108	19x	d[["nComps"]] <- length(comps(nm)[[1]])
109	19x	d[["nGroups"]] <- nrow(nm)
110	19x	d[["nParams"]] <- length(params_nm)
111		# Encode priors
112	19x	d <- c(d, encode_priors(params_nm, priors_nm))
113		# Encode distribution families (for proportions and sizes)
114	19x	d <- c(d, encode_distrib_families(nm))
115		# Encode initial conditions
116	19x	d <- c(d, encode_init(nm))
117		# Encode steady state compartments
118	19x	d <- c(d, encode_steady(nm))
119		# Encode split compartments
120	19x	d <- c(d, encode_split(nm, params_nm))
121		# Encode decay rate for radioactive tracers
122	19x	lambda_decay <- attr(nm, "lambda_hl")
123	19x	if (is.null(lambda_decay)) {
124	19x	lambda_decay <- 0
125		}
126	19x	d[["lambda_decay"]] <- lambda_decay
127		# Encode intervals in-between events
128	19x	d <- c(d, encode_intervals(nm))
129		# Encode pulse events
130	19x	d <- c(d, encode_pulse_events(nm))
131		# Encode unique obs times
132	19x	d <- c(d, encode_unique_obs_times(nm))
133		# Encode individual obs
134	19x	d <- c(d, encode_individual_obs(nm, params_nm))
135		# Encode uptake rates (upsilons)
136	19x	d <- c(d, encode_upsilons(nm, params_nm))
137		# Encode losses (lambdas)
138	19x	d <- c(d, encode_lambdas(nm, params_nm))
139		# Add encoding for Euler (so that the Stan model does not crash)
140	19x	d[["allParams"]] <- params_nm
141	19x	euler <- encode_time_schemes(nm)
142	19x	stopifnot(!any(names(euler) %in% names(d)))
143	19x	d <- c(d, euler)
144	19x	return(d)
145		}
146
147		### * encode_intervals()
148
149		#' Encode time intervals between events
150		#'
151		#' @param nm A \code{networkModel} object.
152		#'
153		#' @keywords internal
154		#' @noRd
155
156		encode_intervals <- function(nm) {
157	27x	o <- list()
158	27x	nGroups <- nrow(nm)
159	27x	timelines <- lapply(seq_len(nrow(nm)), function(i) {
160	40x	nm_row_get_timeline(nm[i, ])
161		})
162	27x	nTimeIntervals <- sapply(timelines, '[[', "nIntervals")
163	27x	o[["maxNtimeIntervals"]] <- max(nTimeIntervals)
164	27x	o[["nTimeIntervals"]] <- setNames(c(nTimeIntervals, 0), # Padded
165	27x	nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
166	27x	durations <- lapply(timelines, function(x) {
167	40x	x[["intervalEnds"]] - x[["intervalStarts"]]
168		})
169	27x	o[["intervalsLengths"]] <- array(0, dim = c(max(nTimeIntervals), nGroups),
170	27x	dimnames = list(seq_len(max(nTimeIntervals)),
171	27x	paste0("grp", seq_len(nGroups))))
172	27x	for (g in seq_len(nGroups)) {
173	40x	o[["intervalsLengths"]][1:(o[["nTimeIntervals"]][g]), g] <- durations[[g]]
174		}
175	27x	o
176		}
177
178		### ** nm_row_get_timeline()
179
180		#' @examples
181		#' nm_row_get_timeline(aquarium_mod[1, ])
182		#' nm_row_get_timeline(trini_mod[1, ])
183		#' @keywords internal
184		#' @noRd
185		nm_row_get_timeline <- function(nm_row) {
186	140x	events <- nm_row_get_events(nm_row)
187	140x	obs <- nm_row_get_obs(nm_row)
188	140x	o <- c(events, obs)
189	140x	o[["maxTime"]] <- max(c(o[["eventTimes"]], o[["obsTimes"]]))
190	140x	o[["nIntervals"]] <- o[["nEventTimes"]] + 1
191	140x	o[["intervalStarts"]] <- c(0, o[["eventTimes"]])
192	140x	o[["intervalEnds"]] <- c(o[["eventTimes"]], o[["maxTime"]])
193	140x	o[["intervalStartsWithAnEvent"]] <- o[["intervalStarts"]] %in% o[["eventTimes"]]
194	140x	o[["obsIntervalIndex"]] <- sapply(o[["obsTimes"]], function(i) {
195	704x	w <- which(o[["intervalStarts"]] <= i)
196	704x	if (length(w) > 0) { return(max(w)) }
197	!	return(o[["nIntervals"]])
198		})
199	140x	o[["elapsedTimeSinceEvent"]] <- o[["obsTimes"]] - o[["intervalStarts"]][o[["obsIntervalIndex"]]]
200	140x	return(o)
201		}
202
203		### ** plot_nm_row_timeline()
204
205		#' @param nm_row_timeline Output from \code{nm_row_get_timeline}.
206		#' @return None, called for side-effect of drawing a timeline plot where
207		#' boundaries are light gray, events are red, and observation times are
208		#' blue.
209		#' @examples
210		#' plot_nm_row_timeline(nm_row_get_timeline(aquarium_mod[1, ]))
211		#' plot_nm_row_timeline(nm_row_get_timeline(trini_mod[1, ]))
212		#' @keywords internal
213		#' @noRd
214		plot_nm_row_timeline <- function(nm_row_timeline) {
215	!	z <- nm_row_timeline
216	!	plot(0, type = "n", xlim = c(0, z[["maxTime"]]), ylim = c(0, 1),
217	!	xlab = "Time", axes = FALSE, ylab = "")
218	!	graphics::axis(1)
219	!	graphics::lines(c(0, 0), c(0, 1), col = "lightgray")
220	!	graphics::lines(rep(z[["maxTime"]], 2), c(0, 1), col = "lightgray")
221	!	for (i in seq_along(z[["eventTimes"]])) {
222	!	graphics::lines(rep(z[["eventTimes"]], 2), c(0, 1), col = "red", lty = 2, lwd = 2)
223		}
224	!	graphics::points(z[["obsTimes"]], y = rep(0.5, length(z[["obsTimes"]])),
225	!	pch = 21, col = "blue", bg = "blue")
226		}
227
228		### ** nm_row_get_events()
229
230		nm_row_get_events <- function(nm_row) {
231	140x	stopifnot(nrow(nm_row) == 1)
232	140x	o <- list()
233	140x	if (!"events" %in% colnames(nm_row)) {
234	100x	o[["eventTimes"]] <- numeric()
235		} else {
236	40x	o[["eventTimes"]] <- sort(unique(nm_row[["events"]][[1]][["time"]]))
237		}
238	140x	o[["nEventTimes"]] <- length(o[["eventTimes"]])
239	140x	o <- o[c("nEventTimes", "eventTimes")]
240	140x	return(o)
241		}
242
243		### ** nm_row_get_obs()
244
245		nm_row_get_obs <- function(nm_row) {
246	140x	stopifnot(nrow(nm_row) == 1)
247	140x	stopifnot("observations" %in% colnames(nm_row))
248	140x	o <- list()
249	140x	o[["obsTimes"]] <- sort(unique(nm_row[["observations"]][[1]][["time"]]))
250	140x	o[["nObsTimes"]] <- length(o[["obsTimes"]])
251	140x	o <- o[c("nObsTimes", "obsTimes")]
252	140x	return(o)
253		}
254
255		### * encode_pulse_events()
256
257		#' Encode pulse events (for Stan model with matrix exponential)
258		#'
259		#' @param nm A \code{networkModel} object.
260		#'
261		#' @keywords internal
262		#' @noRd
263
264		encode_pulse_events <- function(nm) {
265	19x	o <- list()
266	19x	if (!"events" %in% names(nm)) {
267	18x	nm[["events"]] <- rep(list(NULL), nrow(nm))
268		}
269	19x	comps <- comps(nm)[[1]]
270	19x	nGroups <- nrow(nm)
271	19x	timelines <- lapply(seq_len(nrow(nm)), function(i) {
272	30x	nm_row_get_timeline(nm[i, ])
273		})
274	19x	nPulseEvents <- sapply(seq_len(nrow(nm)), function(i) {
275	30x	n <- nrow(nm[i, ][["events"]][[1]])
276	30x	ifelse(is.null(n), 0, n)
277		})
278	19x	o[["maxNpulseEvents"]] <- max(nPulseEvents)
279	19x	o[["nPulseEvents"]] <- setNames(c(nPulseEvents, 0), # Padded
280	19x	nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
281	19x	interval_indices <- list()
282	19x	comp_indices <- list()
283	19x	marked <- list()
284	19x	unmarked <- list()
285	19x	for (g in seq_len(nGroups)) {
286	30x	x <- nm[["events"]][[g]]
287	30x	if (!is.null(x)) {
288	2x	x <- x[order(x[["time"]]), ]
289	2x	stopifnot(all(x$event == "pulse"))
290	2x	interval_indices[[g]] <- match(x[["time"]], timelines[[g]][["intervalStarts"]])
291	2x	comp_indices[[g]] <- match(x[["compartment"]], comps)
292	2x	marked[[g]] <- sapply(x$characteristics, '[[', "marked")
293	2x	unmarked[[g]] <- sapply(x$characteristics, '[[', "unmarked")
294		}
295		}
296	19x	o[["pulseEventsIndices"]] <- array(0, dim = c(max(nPulseEvents), 2, nGroups),
297	19x	dimnames = list(seq_len(max(nPulseEvents)),
298	19x	c("interval", "comp"),
299	19x	paste0("grp", seq_len(nGroups))))
300	19x	o[["pulseEventsQuantities"]] <- array(0, dim = c(max(nPulseEvents), 2, nGroups),
301	19x	dimnames = list(seq_len(max(nPulseEvents)),
302	19x	c("unmarked", "marked"),
303	19x	paste0("grp", seq_len(nGroups))))
304	19x	for (g in seq_len(nGroups)) {
305	30x	if (!is.null(nm[["events"]][[g]])) {
306	2x	o[["pulseEventsIndices"]][1:(o[["nPulseEvents"]][g]), 1, g] <- interval_indices[[g]]
307	2x	o[["pulseEventsIndices"]][1:(o[["nPulseEvents"]][g]), 2, g] <- comp_indices[[g]]
308	2x	o[["pulseEventsQuantities"]][1:(o[["nPulseEvents"]][g]), 1, g] <- unmarked[[g]]
309	2x	o[["pulseEventsQuantities"]][1:(o[["nPulseEvents"]][g]), 2, g] <- marked[[g]]
310		}
311		}
312	19x	o
313		}
314
315		### * encode_unique_obs_times()
316
317		#' Encode unique observation times (for Stan model with matrix exponential)
318		#'
319		#' @param nm A \code{networkModel} object.
320		#'
321		#' @keywords internal
322		#' @noRd
323
324		encode_unique_obs_times <- function(nm) {
325	27x	o <- list()
326	27x	comps <- comps(nm)[[1]]
327	27x	nGroups <- nrow(nm)
328	27x	timelines <- lapply(seq_len(nrow(nm)), function(i) {
329	40x	nm_row_get_timeline(nm[i, ])
330		})
331	27x	nObsTimes <- sapply(timelines, '[[', "nObsTimes")
332	27x	o[["maxNobsTimes"]] <- max(nObsTimes)
333	27x	o[["nObsTimes"]] <- setNames(c(nObsTimes, 0), # Padded
334	27x	nm = c(paste0("grp", seq_len(nrow(nm))), "padding"))
335	27x	o[["elapsedTimeSinceEvent"]] <- array(0, dim = c(nGroups, max(nObsTimes)),
336	27x	dimnames = list(paste0("grp", seq_len(nGroups)),
337	27x	seq_len(max(nObsTimes))))
338	27x	o[["obsIntervalsIndices"]] <- array(0, dim = c(nGroups, max(nObsTimes)),
339	27x	dimnames = list(paste0("grp", seq_len(nGroups)),
340	27x	seq_len(max(nObsTimes))))
341	27x	for (g in seq_len(nGroups)) {
342	40x	o[["elapsedTimeSinceEvent"]][g, 1:(o[["nObsTimes"]][g])] <- timelines[[g]][["elapsedTimeSinceEvent"]]
343	40x	o[["obsIntervalsIndices"]][g, 1:(o[["nObsTimes"]][g])] <- timelines[[g]][["obsIntervalIndex"]]
344		}
345	27x	o
346		}
347
348		### * encode_individual_obs()
349
350		#' Encode individual observations (for Stan model with matrix exponential)
351		#'
352		#' @param nm A \code{networkModel} object.
353		#' @param allParams Parameters of the network model.
354		#'
355		#' @keywords internal
356		#' @noRd
357
358		encode_individual_obs <- function(nm, allParams) {
359	19x	o <- list()
360	19x	comps <- comps(nm)[[1]]
361	19x	nGroups <- nrow(nm)
362	19x	zeta_by_comp <- attr(nm, "size_zeta_per_compartment")
363	19x	if (is.null(zeta_by_comp)) {
364	!	zeta_by_comp<- FALSE
365		}
366	19x	timelines <- lapply(seq_len(nrow(nm)), function(i) {
367	30x	nm_row_get_timeline(nm[i, ])
368		})
369		# TODO Add filtering to keep only compartments present in topo
370		# TODO Handle gracefully the case without observations
371		# Get sizes
372	19x	sizes <- purrr::map(nm$observations, function(x) {
373	30x	na.omit(x[, c("compartment", "size", "time")])
374		})
375		# Get proportions
376	19x	props <- purrr::map(nm$observations, function(x) {
377	30x	na.omit(x[, c("compartment", "proportion", "time")])
378		})
379		# Convert original time into indices of unique observation times
380	19x	for (g in seq_len(nGroups)) {
381	30x	sizes[[g]][["timepoint"]] <- match(sizes[[g]][["time"]], timelines[[g]][["obsTimes"]])
382	30x	props[[g]][["timepoint"]] <- match(props[[g]][["time"]], timelines[[g]][["obsTimes"]])
383		}
384		# Encode compartments
385	19x	for (g in seq_len(nGroups)) {
386	30x	sizes[[g]][["compartment"]] <- match(sizes[[g]][["compartment"]], comps)
387	30x	props[[g]][["compartment"]] <- match(props[[g]][["compartment"]], comps)
388		}
389		# Encode sizes and props
390	19x	o[["nSizesObs"]] <- c(purrr::map_dbl(sizes, nrow), 0) # Padded
391	19x	names(o[["nSizesObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
392	19x	o[["nPropsObs"]] <- c(purrr::map_dbl(props, nrow), 0) # Padded
393	19x	names(o[["nPropsObs"]]) <- c(paste0("grp", seq_len(nrow(nm))), "padding")
394	19x	o[["maxNsizesObs"]] <- max(o[["nSizesObs"]])
395	19x	o[["maxNpropsObs"]] <- max(o[["nPropsObs"]])
396		# Prepare containers
397	19x	o[["sizesObsIndices"]] <- array(0, dim = c(o[["maxNsizesObs"]], 3, nGroups),
398	19x	dimnames = list(seq_len(o[["maxNsizesObs"]]),
399	19x	c("comp", "timepoint", "zeta"),
400	19x	paste0("grp", seq_len(nGroups))))
401	19x	o[["sizesObs"]] <- array(0, dim = c(o[["maxNsizesObs"]], nGroups),
402	19x	dimnames = list(seq_len(o[["maxNsizesObs"]]),
403	19x	paste0("grp", seq_len(nGroups))))
404	19x	o[["propsObsIndices"]] <- array(0, dim = c(o[["maxNpropsObs"]], 3, nGroups),
405	19x	dimnames = list(seq_len(o[["maxNpropsObs"]]),
406	19x	c("comp", "timepoint", "eta"),
407	19x	paste0("grp", seq_len(nGroups))))
408	19x	o[["propsObs"]] <- array(0, dim = c(o[["maxNpropsObs"]], nGroups),
409	19x	dimnames = list(seq_len(o[["maxNpropsObs"]]),
410	19x	paste0("grp", seq_len(nGroups))))
411		# Fill containers
412	19x	for (g in seq_len(nGroups)) {
413	30x	if (o[["nSizesObs"]][g] > 0) {
414	30x	o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 1:2, g] <- as.matrix(sizes[[g]][, c("compartment", "timepoint")])
415	30x	o[["sizesObs"]][1:o[["nSizesObs"]][g], g] <- as.matrix(sizes[[g]][, c("size")])
416	30x	if (!zeta_by_comp) {
417	30x	zeta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "zeta"]
418	30x	zeta_index <- match(zeta_global, allParams)
419	30x	o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
420		} else {
421	!	comps <- colnames(nm$topology[[g]])
422	!	comps <- setNames(seq_along(comps), nm = comps)
423	!	zeta_replicate <- paste0("zeta_", names(comps)[sizes[[g]][["compartment"]]])
424	!	zeta_global <- nm[["parameters"]][[g]]$in_model[match(zeta_replicate, nm[["parameters"]][[g]]$in_replicate)]
425	!	zeta_index <- match(zeta_global, allParams)
426	!	o[["sizesObsIndices"]][1:o[["nSizesObs"]][g], 3, g] <- zeta_index
427		}
428		}
429		}
430	19x	for (g in seq_len(nGroups)) {
431	30x	if (o[["nPropsObs"]][g] > 0) {
432	30x	o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 1:2, g] <- as.matrix(props[[g]][, c("compartment", "timepoint")])
433	30x	o[["propsObs"]][1:o[["nPropsObs"]][g], g] <- as.matrix(props[[g]][, c("proportion")])
434	30x	eta_global <- nm[["parameters"]][[g]]$in_model[nm[["parameters"]][[g]]$in_replicate == "eta"]
435	30x	eta_index <- match(eta_global, allParams)
436	30x	o[["propsObsIndices"]][1:o[["nPropsObs"]][g], 3, g] <- eta_index
437		}
438		}
439		# Return
440	19x	return(o)
441		}

1		### * None of the functions in this file is exported
2
3		### * as.derived.mcmc.list()
4
5		#' @keywords internal
6		#' @noRd
7
8		as.derived.mcmc.list <- function(x) {
9	!	if (!"derived.mcmc.list" %in% class(x)) {
10	!	return(structure(x, class = c("derived.mcmc.list", class(x))))
11		} else {
12	!	return(x)
13		}
14		}
15
16		### * build_uptake_mask
17
18		### ** Doc
19
20		#' Build a foodweb uptake mask based on links
21		#'
22		#' @section Link format:
23		#'
24		#' Links are defined by a string describing connections between groups of
25		#' compartments and their directions using \code{->} and \code{<-}. The groups
26		#' being connected can be a single compartment or several compartments. Several
27		#' compartments can be separated either by commas or by spaces. Connection
28		#' descriptions can be chained in a single string.
29		#'
30		#' Some valid links are for example \code{"NH4, NO3 -> epi"} or
31		#' \code{"NH4, NO3 -> epi -> lepto, tricor"}.
32		#'
33		#' See the Examples section for more details.
34		#'
35		#' @param links A vector of strings defining the trophic links between
36		#' compartments (see the examples)
37		#'
38		#' @return An uptake mask matrix with named columns and rows
39		#'
40		#' @examples
41		#' f <- isotracer:::build_uptake_mask(links = "NH4, NO3 -> epi -> pseph, tricor")
42		#' f
43		#'
44		#' # A larger foodweb
45		#' links <- c("NH4, NO3 -> seston, epi, CBOM, FBOM",
46		#' "seston -> lepto", "epi -> petro, pseph",
47		#' "CBOM, FBOM -> eudan", "CBOM -> phyllo",
48		#' "FBOM -> tricor -> arg, euthy")
49		#' f2 <- isotracer:::build_uptake_mask(links = links)
50		#' f2
51		#'
52		#' @keywords internal
53		#' @noRd
54
55		### ** Code
56
57		build_uptake_mask <- function(links) {
58		# Get the compartment names
59	40x	compartments <- compartments_from_links(links)
60	40x	nComp <- length(compartments)
61		# Split the links
62	40x	elementaryLinks <- unlist(lapply(links, parse_link_string))
63	40x	stopifnot(all(grepl("->\|<-", elementaryLinks)))
64	40x	pairs <- strsplit(elementaryLinks, "->\|<-")
65	40x	stopifnot(all(unlist(pairs) %in% compartments))
66		# Create the uptake rate mask
67	40x	mask <- matrix(0, ncol = nComp, nrow = nComp,
68	40x	dimnames = list(compartments, compartments))
69		# Add the links to the uptake rate mask
70	40x	for (k in 1:length(pairs)) {
71	135x	i <- match(pairs[[k]][1], compartments)
72	135x	j <- match(pairs[[k]][2], compartments)
73	135x	if (grepl("->", elementaryLinks[k])) {
74	132x	mask[j,i] = 1
75		} else {
76	3x	mask[i,j] = 1
77		}
78		}
79		# Return
80	40x	stopifnot(all(diag(mask) == 0)) # No rates to self
81		# Return
82	40x	return(mask)
83		}
84
85		### * compartments_from_links()
86
87		#' Build a vector of unique compartments from link strings
88		#'
89		#' @param links A vector of link strings; see the examples for details about
90		#' their format
91		#'
92		#' @return A string vector containing unique compartments present in the links
93		#'
94		#' @examples
95		#' links <- c("NH4, NO3 -> epi -> tricor, pseph, petro", "tricor -> arg")
96		#' compartments <- isotracer:::compartments_from_links(links)
97		#'
98		#' @keywords internal
99		#' @noRd
100
101		compartments_from_links <- function(links) {
102	40x	links <- unlist(lapply(links, parse_link_string))
103	40x	return(sort(unique(unlist(strsplit(links, "->\|<-")))))
104		}
105
106		### * parse_link_string()
107
108		#' Parse a link string into simple links
109		#'
110		#' @param link String, see the examples for details about the format
111		#'
112		#' @return A vector containing the simple links. All simple links will have
113		#' exactly one "->" or "<-" symbol, between two strings, with no
114		#' whitespaces.
115		#'
116		#' @examples
117		#' isotracer:::parse_link_string("NH4, NO3 -> epi -> tricor, pseph, petro")
118		#' isotracer:::parse_link_string("tricor <- epi -> pseph")
119		#' isotracer:::parse_link_string("NH4 NO3 -> epi seston FBOM CBOM")
120		#'
121		#' @keywords internal
122		#' @noRd
123
124		parse_link_string <- function(link) {
125		# Split by connections
126	116x	links <- unlist(strsplit(link, split = "<-\|->"))
127	116x	stopifnot(length(links) > 1)
128		# Build pairs of groups
129	116x	pairs <- list()
130	116x	kLinks <- 1
131	116x	for (i in 1:(length(links)-1)) {
132	224x	LHS <- unlist(strsplit(links[kLinks], split = " \|,"))
133	224x	LHS <- LHS[LHS != ""]
134	224x	stopifnot(length(LHS) > 0)
135	224x	RHS <- unlist(strsplit(links[kLinks+1], split = " \|,"))
136	224x	RHS <- RHS[RHS != ""]
137	224x	stopifnot(length(RHS) > 0)
138	224x	pairs[[kLinks]] <- list(LHS, RHS)
139	224x	kLinks <- kLinks + 1
140		}
141		# Get directions
142	116x	directions <- list()
143	116x	kLinkString <- 1
144	116x	for (i in 1:(length(links)-1)) {
145	224x	kLinkString <- kLinkString + nchar(links[i])
146	224x	directions[[i]] <- substr(link, start = kLinkString,
147	224x	stop = kLinkString + 1)
148	224x	kLinkString <- kLinkString + 2
149		}
150		# Function to trim whitespaces
151		## https://stackoverflow.com/questions/2261079/how-to-trim-leading-and-trailing-whitespace-in-r
152	116x	trim <- function(x) {
153	810x	return(gsub("^\\s+\|\\s+$", "", x))
154		}
155		# Build simple pairs
156	116x	out <- list()
157	116x	kOut <- 1
158	116x	for (i in seq_along(pairs)) {
159	224x	for (k in seq_along(pairs[[i]][[1]])) {
160	236x	for (l in seq_along(pairs[[i]][[2]])) {
161	270x	out[kOut] <- paste0(trim(pairs[[i]][[1]][k]), trim(directions[[i]]),
162	270x	trim(pairs[[i]][[2]][l]))
163
164	270x	kOut <- kOut + 1
165		}
166		}
167		}
168		# Return
169	116x	return(unlist(out))
170		}
171
172		### * make_init()
173
174		### ** Doc
175
176		#' Build tibble of initial conditions for network model
177		#'
178		#' @param data Data frame
179		#' @param comp String, name of the column containing the names of the
180		#' compartments
181		#' @param size String, name of the column containing the sizes of the
182		#' compartments
183		#' @param prop String, name of the column containing values for the
184		#' proportion of marked material
185		#' @param group_by Optional, vector of strings giving the name of the columns
186		#' to use to group observations (e.g. per stream, per forest, per
187		#' experiment, ...)
188		#'
189		#' @return A tibble with one row per grouping level
190		#'
191		#' @importFrom stats setNames
192		#'
193		#' @examples
194		#' library(tibble)
195		#' data <- tibble(comps = rep(c("NH4", "algae", "daphnia", "NH4", "algae",
196		#' "daphnia"), 2),
197		#' sizes = runif(12, 1, 10),
198		#' props = runif(12, 0.01, 0.05),
199		#' aquariumID = c(rep("aq01", 6), rep("aq02", 6)),
200		#' temperature = rep(rep(c("low", "high"), each = 3), 2))
201		#' data
202		#'
203		#' # No grouping variable
204		#' z <- isotracer:::make_init(data, "comps", "sizes", "props")
205		#' z$initial
206		#'
207		#' # One grouping variable
208		#' z <- isotracer:::make_init(data, "comps", "sizes", "props", group_by = "aquariumID")
209		#' z
210		#'
211		#' # Several grouping variables
212		#' z <- isotracer:::make_init(data, "comps", "sizes", "props",
213		#' group_by = c("aquariumID", "temperature"))
214		#' z
215		#'
216		#' @keywords internal
217		#' @noRd
218
219		### ** Code
220
221		make_init <- function(data, comp, size, prop, group_by = NULL) {
222		# Extract the columns containing initial conditions information
223	29x	initial <- tibble::as_tibble(data[, c(comp, size, prop)])
224	29x	colnames(initial) <- c("compartment", "size", "proportion")
225	29x	initial$compartment <- as.character(initial$compartment)
226		# If no grouping variable is given, just return a tibble with one row
227	29x	if (is.null(group_by)) {
228	17x	out <- tibble::tibble("initial" = list(initial),
229	17x	"group" = list(NULL))
230		} else {
231		# Else, get group levels
232	12x	for (g in group_by) {
233	15x	data[[g]] <- as.character(data[[g]])
234		}
235	12x	group <- as.character(interaction(data[, group_by]))
236	12x	groupLevels <- unique(group)
237		# Build the initial conditions sets (list of data frames)
238	12x	initialSets <- lapply(seq_along(groupLevels), function(i) {
239	30x	focalGroup <- groupLevels[i]
240	30x	indices <- which(group == focalGroup)
241	30x	return(initial[indices, ])
242		})
243		# Build the grouping variables sets (list of named vectors)
244	12x	groupingVariablesSets <- lapply(seq_along(groupLevels), function(i) {
245	30x	focalGroup <- groupLevels[i]
246	30x	indices <- which(group == focalGroup)
247	30x	tmp <- unique(data[indices, group_by])
248	30x	stopifnot(nrow(tmp) == 1)
249	30x	tmp <- setNames(as.character(tmp), nm = group_by)
250	30x	return(tmp)
251		})
252		# Put initial conditions and groups together
253	12x	groups <- tibble::tibble("group" = groupingVariablesSets)
254	12x	initials <- tibble::tibble("initial" = initialSets)
255	12x	out <- tibble::as_tibble(cbind(initials, groups))
256		}
257		# Return
258	29x	row.names(out) <- NULL
259	29x	return(out)
260		}
261
262		### * nm_is_grouped()
263
264		#' Is a network model grouped into replicate units?
265		#'
266		#' @param nm Network model
267		#'
268		#' @return Boolean
269		#'
270		#' @keywords internal
271		#' @noRd
272
273		nm_is_grouped <- function(nm) {
274	182x	if (!"group" %in% colnames(nm)) {
275	62x	return(FALSE)
276		}
277	120x	if (nrow(nm) == 0) {
278	!	return(FALSE)
279		}
280	120x	if (nrow(nm) == 1 && is.null(nm$group[[1]])) {
281	30x	return(FALSE)
282		}
283	90x	return(TRUE)
284		}
285
286		### * compatible_groups()
287
288		#' Check that two tibbles have compatible "group" columns for merging
289		#'
290		#' @param x First tibble
291		#' @param y Second tibble
292		#' @param error Boolean, raise error when incompatibility is encountered?
293		#'
294		#' @return TRUE if x and y are compatible. If they are not, return FALSE if
295		#' \code{error} is FALSE (the default) or raise an error when \code{error}
296		#' is TRUE.
297		#'
298		#' @keywords internal
299		#' @noRd
300
301		compatible_groups <- function(x, y, error = FALSE) {
302	11x	gx <- nm_get_groups(x)
303	11x	gy <- nm_get_groups(y)
304	11x	cx <- colnames(gx)
305	11x	cy <- colnames(gy)
306		# Check that one column set is contained in the other
307	11x	if (!(all(cx %in% cy) \| all(cy %in% cx))) {
308	!	if (!error) {
309	!	return(FALSE)
310		} else {
311	!	stop("One set of grouping variables is not contained within the other.\n",
312	!	"In x but not in y: ", paste0(cx[!cx %in% cy], collapse = ", "), "\n",
313	!	"In y but not in x: ", paste0(cy[!cy %in% cx], collapse = ", "))
314		}
315		}
316		# Check that the levels of common columns are compatible
317	11x	cs <- intersect(cx, cy)
318	11x	for (ics in cs) {
319	14x	lcx <- unique(gx[[ics]])
320	14x	lcy <- unique(gy[[ics]])
321	14x	if (!setequal(lcx, lcy)) {
322	!	if (!error) {
323	!	return(FALSE)
324		} else {
325	!	stop("The levels for the grouping variable \"", ics, "\" are not the same ",
326	!	"across x and y.")
327		}
328		}
329		}
330		# Compatible groupings
331	11x	return(TRUE)
332		}
333
334		### * nm_get_groups()
335
336		#' Return a tibble with the groups of a network model
337		#'
338		#' @param nm A network model
339		#' @param error Boolean, if TRUE raise an error if nm is not grouped, otherwise
340		#' return NULL if nm is not grouped.
341		#'
342		#' @return A tibble, with rows in the same order as in the input
343		#'
344		#' @examples
345		#' x <- tibble::tribble(~col, ~group,
346		#' "red", c(sp = "dog", name = "toto"),
347		#' "blue", c(sp = "dog", name = "tata"),
348		#' "yellow", c(sp = "cat", name = "felix"))
349		#' isotracer:::nm_get_groups(x)
350		#'
351		#' @keywords internal
352		#' @noRd
353
354		nm_get_groups <- function(nm, error = TRUE) {
355	74x	if (!nm_is_grouped(nm)) {
356	19x	if (error) {
357	!	stop("Input is not grouped.")
358		} else {
359	19x	return(NULL)
360		}
361		}
362	55x	rows <- purrr::map(nm$group, function(g) {
363	152x	tidyr::spread(tibble::enframe(g),
364	152x	key = "name", value = "value")
365		})
366	55x	return(dplyr::bind_rows(rows))
367		}
368
369		### * make_obs()
370
371		### ** Doc
372
373		#' Build observed data
374		#'
375		#' Note that nested grouping variables have to be coded appropriately by the
376		#' user. For example, if there are two forests, each with three plots, the
377		#' plots IDs cannot be "1", "2", "3" in both forests, but should be for example
378		#' "1-1", "1-2", "1-3" in the first forest and "2-1", "2-2" and "2-3" in the
379		#' second forest.
380		#'
381		#' @param data Data frame
382		#' @param comp String, name of the column containing the names of the
383		#' compartments
384		#' @param size String, name of the column containing the sizes of the
385		#' compartments
386		#' @param prop String, name of the column containing values for the proportion
387		#' of heavy tracer
388		#' @param time String, name of the column containing values for the time
389		#' @param group_by Optional, vector of strings giving the name of the columns
390		#' to use to group observations (e.g. per stream, per forest, per
391		#' experiment, ...). The name \code{tracerObservations} is reserved and
392		#' should not be used.
393		#'
394		#' @return A tibble with one row per grouping level
395		#'
396		#' @importFrom stats setNames
397		#'
398		#' @examples
399		#' library(tibble)
400		#' data <- tibble(comps = rep(c("NH4", "algae", "daphnia", "NH4", "algae",
401		#' "daphnia"), 2),
402		#' sizes = runif(12, 1, 10),
403		#' props = runif(12, 0.01, 0.05),
404		#' time = runif(12, 0, 5),
405		#' aquariumID = c(rep("aq01", 6), rep("aq02", 6)),
406		#' temperature = rep(rep(c("low", "high"), each = 3), 2))
407		#' data
408		#'
409		#' # No grouping variable
410		#' z <- isotracer:::make_obs(data, "comps", "sizes", "props", "time")
411		#' z$observations
412		#'
413		#' # One grouping variable
414		#' z <- isotracer:::make_obs(data, "comps", "sizes", "props", "time",
415		#' group_by = "aquariumID")
416		#' z
417		#'
418		#' # Several grouping variables
419		#' z <- isotracer:::make_obs(data, "comps", "sizes", "props", "time",
420		#' group_by = c("aquariumID", "temperature"))
421		#' z
422		#'
423		#' @keywords internal
424		#' @noRd
425
426		### ** Code
427
428		make_obs <- function(data, comp, size, prop, time, group_by = NULL) {
429		# Extract the columns containing observations
430	25x	observations <- tibble::as_tibble(data[, c(comp, size, prop, time)])
431	25x	colnames(observations) <- c("compartment", "size", "proportion", "time")
432	25x	observations$compartment <- as.character(observations$compartment)
433		# If no grouping variable is given, just return a tibble with one column
434		# and one row
435	25x	if (is.null(group_by)) {
436	13x	out <- tibble::tibble("observations" = list(observations),
437	13x	"group" = list(NULL))
438		} else {
439		# Else, build a tibble with the grouping applied and use dplyr::group_by_
440	12x	for (g in group_by) {
441	15x	data[[g]] <- as.character(data[[g]])
442		}
443	12x	group <- as.character(interaction(data[, group_by]))
444	12x	groupLevels <- unique(group)
445		# Build the observation sets (list of data frames)
446	12x	observationSets <- lapply(seq_along(groupLevels), function(i) {
447	30x	focalGroup <- groupLevels[i]
448	30x	indices <- which(group == focalGroup)
449	30x	return(observations[indices, ])
450		})
451		# Build the grouping variables sets (list of named vectors)
452	12x	groupingVariablesSets <- lapply(seq_along(groupLevels), function(i) {
453	30x	focalGroup <- groupLevels[i]
454	30x	indices <- which(group == focalGroup)
455	30x	tmp <- unique(data[indices, group_by])
456	30x	stopifnot(nrow(tmp) == 1)
457	30x	tmp <- setNames(as.character(tmp), nm = group_by)
458	30x	return(tmp)
459		})
460		# Put observations and groups together
461	12x	groups <- tibble::tibble("group" = groupingVariablesSets)
462	12x	observations <- tibble::tibble("observations" = observationSets)
463	12x	out <- tibble::as_tibble(cbind(observations, groups))
464		}
465		# Return
466	25x	row.names(out) <- NULL
467	25x	return(out)
468		}
469
470		### * merge_nm_by_groups()
471
472		#' Merge a network model object and a tibble taking grouping into account
473		#'
474		#' @param nm The original \code{networkModel} object.
475		#' @param tib The tibble to merge into \code{nm}.
476		#' @param destination String, name of the column to merge into the network
477		#' model.
478		#' @param tib_name String, used when an error is raised.
479		#'
480		#' @return The updated network model object.
481		#'
482		#' @keywords internal
483		#' @noRd
484
485		merge_nm_by_group <- function(nm, tib, destination, tib_name = "unnamed tib") {
486	54x	nm_grouped <- nm_is_grouped(nm)
487	54x	tib_grouped <- nm_is_grouped(tib)
488	54x	previous_priors <- attr(nm, "priors")
489		# nm not grouped, tib not grouped
490	54x	if (!nm_grouped & !tib_grouped) {
491	30x	stopifnot(nrow(nm) == 1 & nrow(tib) == 1)
492	30x	nm[[destination]][[1]] <- tib[[destination]][[1]]
493		}
494		# nm not grouped, tib grouped
495	54x	if (!nm_grouped & tib_grouped) {
496	13x	stopifnot(nrow(nm) == 1)
497	13x	nm_orig <- nm
498	13x	for (j in seq_len(nrow(tib) - 1)) {
499	19x	nm <- dplyr::bind_rows(nm, nm_orig)
500		}
501	13x	nm[[destination]] <- tib[[destination]]
502	13x	nm$group <- tib$group
503		}
504		# nm grouped, tib not grouped
505	54x	if (nm_grouped & !tib_grouped) {
506	!	stopifnot(nrow(tib) == 1)
507	!	tib_orig <- tib
508	!	for (j in seq_len(nrow(nm) - 1)) {
509	!	tib <- dplyr::bind_rows(tib,
510	!	tib_orig)
511		}
512	!	nm[[destination]] <- tib[[destination]]
513		}
514		# nm grouped and tib grouped
515	54x	if (nm_grouped & tib_grouped) {
516	11x	if (!compatible_groups(nm, tib)) {
517	!	stop("Network model and ", tib_name, " do not have compatible grouping.")
518		}
519		# Merge
520	11x	nm_g <- nm_get_groups(nm)
521	11x	tib_g <- nm_get_groups(tib)
522	11x	cols <- intersect(colnames(nm_g), colnames(tib_g))
523	11x	allCols <- unique(c(colnames(nm_g), colnames(tib_g)))
524	11x	stopifnot(!".myRowNumberNm" %in% colnames(nm_g))
525	11x	stopifnot(!".myRowNumberTib" %in% colnames(tib_g))
526	11x	nm_g[[".myRowNumberNm"]] <- seq_len(nrow(nm_g))
527	11x	tib_g[[".myRowNumberTib"]] <- seq_len(nrow(tib_g))
528	11x	merged <- dplyr::full_join(nm_g, tib_g, by = cols)
529	11x	out_nm <- nm[merged[[".myRowNumberNm"]], ]
530	11x	out_tib <- tib[merged[[".myRowNumberTib"]], ]
531	11x	out_nm[[destination]] <- out_tib[[destination]]
532		# Update groups
533	11x	groups <- merged[, allCols]
534	11x	groups <- lapply(seq_len(nrow(groups)), function(i) {
535	28x	unlist(groups[i, ])
536		})
537	11x	out_nm[["group"]] <- groups
538	11x	nm <- out_nm
539		}
540		# Return
541	54x	attr(nm, "priors") <- previous_priors
542	54x	return(nm)
543		}
544
545		### * get_n_cores()
546
547		# https://stackoverflow.com/questions/50571325/r-cran-check-fail-when-using-parallel-functions
548
549		# From https://cran.r-project.org/doc/manuals/r-release/R-ints.html (on 2021-09-13):
550		#
551		# "_R_CHECK_LIMIT_CORES_ If set, check the usage of too many cores in package
552		# parallel. If set to 'warn' gives a warning, to 'false' or 'FALSE' the check
553		# is skipped, and any other non-empty value gives an error when more than 2
554		# children are spawned. Default: unset (but 'TRUE' for CRAN submission checks)."
555
556		#' Determine the number of cores to use for parallelizable functions
557		#'
558		#' @param cores Number of cores to use. Default is \code{NULL}, which means to
559		#' use the value stored in \code{options()[["mc.cores"]]} (or 1 if this
560		#' value is not set).
561		#'
562		#' @return An integer, the number of cores to use for parallel computations.
563		#'
564		#' @keywords internal
565		#' @noRd
566
567		get_n_cores <- function(cores = NULL) {
568	44x	n_cores_max <- parallel::detectCores()
569	44x	n_cores_options <- options()[["mc.cores"]]
570	44x	on_cran_limit <- Sys.getenv("_R_CHECK_LIMIT_CORES_", "")
571	44x	on_cran_limit <- (nzchar(on_cran_limit) && on_cran_limit == "TRUE")
572	5x	if (is.null(cores)) { cores <- n_cores_options }
573	5x	if (is.null(cores)) { cores <- 1 }
574		# The condition below is a convoluted way to check that cores is an integer
575		# (because the simpler e.g. "is.integer(2)" is FALSE).
576		# See also ?is.integer and the is.wholenumber() function in the examples.
577	44x	if ((!is.numeric(cores)) \|\| (!((as.integer(cores) - cores) == 0)) \|\| !(cores > 0)) {
578	!	stop("`cores` must be an integer > 0.")
579		}
580	44x	if (cores > n_cores_max) {
581	!	warning(paste0("The provided number of cores (", cores, ") is greater ",
582	!	"than the number of available cores (", n_cores_max,
583	!	").\n"),
584	!	"Using the number of available cores instead.")
585	!	cores <- n_cores_max
586		}
587	44x	if (cores > 1) {
588	39x	if (.Platform$OS.type == "windows") {
589	!	warning("Multiple core implementation not working on Windows; using 1 core.")
590	!	cores <- 1
591		}
592		}
593	44x	if (on_cran_limit) {
594	!	message("CRAN limit for the number of cores was detected. Using cores <- min(cores, 2).")
595	!	cores <- min(cores, 2)
596		}
597	44x	return(cores)
598		}

1		### * .onAttach()
2
3		# Inspired by rstan code from
4		# https://github.com/stan-dev/rstan/blob/develop/rstan/rstan/R/zzz.R
5
6		.onAttach <- function(...) {
7	2x	packageStartupMessage("To automatically run isotracer in parallel ",
8	2x	"on a multicore CPU, you can call:\n",
9	2x	" options(mc.cores = parallel::detectCores())\n")
10		}
11
12		### * .onUnload()
13
14		# Following recommendations from https://r-pkgs.org/src.html
15
16		.onUnload <- function(libpath) {
17	!	library.dynam.unload("isotracer", libpath)
18		}
19
20		### * release_questions()
21
22		# Cf. https://r-pkgs.org/release.html#release-submission
23		release_questions <- function() {
24	!	c("Have you rebuilt the precompiled vignettes manually recently?",
25	!	"Have you updated the CRAN badge by running `.download-cran-version-badge.R`?")
26		}

1		### * All functions in this file are exported
2
3		### * project()
4
5		#' Calculate the trajectories of a network model
6		#'
7		#' @param nm A \code{networkModel} object.
8		#' @param dt,grid_size Either the time step size for trajectory calculations
9		#' (\code{dt}) or the number of points for the calculation (\code{grid_size})
10		#' can be provided. If none is provided, then a default grid size of 256 steps
11		#' is used.
12		#' @param at Optional, vector of time values at which the trajectory must be
13		#' evaluated.
14		#' @param end Time value for end point. If not provided, the last observation or
15		#' event is used.
16		#' @param flows Return flow values? The default is "no" and no flows are
17		#' calculated. Other values are "total" (total flows summed up from beginning
18		#' to end timepoint), "average" (average flows per time unit, equal to total
19		#' flows divided by the projection duration), and "per_dt" (detailled flow
20		#' values are returned for each interval dt of the projection).
21		#' @param cached_ts,cached_ee Used for optimization by other functions, not for
22		#' use by the package user.
23		#' @param ignore_pulses Default to FALSE (i.e. apply pulses when projecting the
24		#' network system). It is set to TRUE when calculating steady-state flows.
25		#'
26		#' @return A network model object with a \code{"trajectory"} column.
27		#'
28		#' @examples
29		#' m <- aquarium_mod
30		#' m <- set_params(m, sample_params(m))
31		#' z <- project(m)
32		#' z <- project(m, flows = "per_dt")
33		#' z <- project(m, flows = "total")
34		#' z <- project(m, flows = "average")
35		#'
36		#' @export
37
38		project <- function(nm, dt = NULL, grid_size = NULL, at = NULL, end = NULL,
39		flows = "no", cached_ts = NULL, cached_ee = NULL,
40		ignore_pulses = FALSE) {
41	309x	`!!` <- rlang::`!!`
42	309x	if (!flows %in% c("no", "total", "average", "per_dt")) {
43	!	stop("\"flows\" must be on of \"no\", \"total\", \"average\", \"per_dt\".")
44		}
45	309x	if (flows == "no") {
46	29x	get_flows <- FALSE
47		} else {
48	280x	get_flows <- TRUE
49		}
50	309x	flow_option <- flows
51		# Check that all parameters have values assigned
52	309x	params <- dplyr::bind_rows(nm$parameters)
53	309x	stopifnot(!any(is.na(params$value)))
54		# Project row by row
55	309x	trajectories <- list()
56	309x	flows <- list()
57	309x	for (i in seq_len(nrow(nm))) {
58	309x	z <- project_row(nm[i, ], dt = dt, grid_size = grid_size,
59	309x	at = at, end = end, flows = get_flows,
60	309x	cached_ts = cached_ts[[i]], cached_ee = cached_ee[[i]],
61	309x	lambda_decay = attr(nm, "lambda_hl"),
62	309x	ignore_pulses = ignore_pulses)
63	309x	trajectories[[i]] <- z[, c("timepoints", "unmarked", "marked", "sizes", "proportions")]
64	309x	if (get_flows) {
65	280x	flows[[i]] <- z[, c("timepoints", "dt", "flows")]
66		}
67		}
68	309x	nm$trajectory <- trajectories
69	309x	if (get_flows) {
70	280x	if (flow_option == "per_dt") {
71	!	nm$flows <- flows
72	280x	} else if (flow_option == "total") {
73	!	for (i in seq_along(flows)) {
74	!	z <- flows[[i]][["flows"]][[1]]
75	!	if (is.na(z[[length(z)]] )) {
76	!	z <- z[1:(length(z)-1)]
77		}
78	!	z <- dplyr::bind_rows(z)
79	!	z <- dplyr::group_by(z, `!!`(rlang::sym("from")),
80	!	`!!`(rlang::sym("to")))
81	!	z <- dplyr::summarize(z, total_flow = sum(`!!`(rlang::sym("flow"))))
82	!	flows[[i]] <- z
83		}
84	!	nm$flows <- flows
85	280x	} else if (flow_option == "average") {
86	280x	for (i in seq_along(flows)) {
87	280x	z <- flows[[i]][["flows"]][[1]]
88	280x	if (is.na(z[[length(z)]] )) {
89	280x	z <- z[1:(length(z)-1)]
90		}
91	280x	z <- dplyr::bind_rows(z)
92	280x	z <- dplyr::group_by(z, `!!`(rlang::sym("from")),
93	280x	`!!`(rlang::sym("to")))
94	280x	z <- dplyr::summarize(z, total_flow = sum(`!!`(rlang::sym("flow"))))
95	280x	duration <- diff(range(flows[[i]][["timepoints"]][[1]]))
96	280x	z$average_flow <- z$total_flow / duration
97	280x	z$total_flow <- NULL
98	280x	flows[[i]] <- z
99		}
100	280x	nm$flows <- flows
101		} else {
102	!	stop("Value of \"flows\" not allowed: ", flow_option)
103		}
104		}
105	309x	return(nm)
106		}
107
108		### * sample_from()
109
110		#' Generate samples from a network model
111		#'
112		#' @param nm A \code{networkModel} object.
113		#' @param at Vector of time values at which the samples should be taken.
114		#' @param dt,grid_size Time step size or grid points, respectively.
115		#' @param end Final timepoint used in the projections.
116		#' @param error.draws Integer, number of draws from the error distribution for
117		#' each sample (default: 1).
118		#' @param cached_ts,cached_ee Used for optimization by other functions, not for
119		#' use by the package user.
120		#'
121		#' @return A tibble containing the generated samples.
122		#'
123		#' @importFrom stats rnorm
124		#' @importFrom stats rgamma
125		#' @importFrom stats rbeta
126		#'
127		#' @examples
128		#' library(magrittr)
129		#' mod <- new_networkModel() %>%
130		#' set_topo("NH4 -> algae -> daphnia -> NH4")
131		#' inits <- tibble::tribble(
132		#' ~comps, ~sizes, ~props, ~treatment,
133		#' "NH4", 0.2, 0.8, "light",
134		#' "algae", 1, 0.004, "light",
135		#' "daphnia", 2, 0.004, "light",
136		#' "NH4", 0.5, 0.8, "dark",
137		#' "algae", 1.2, 0.004, "dark",
138		#' "daphnia", 1.3, 0.004, "dark")
139		#' mod <- set_init(mod, inits, comp = "comps", size = "sizes",
140		#' prop = "props", group_by = "treatment")
141		#' mod <- add_covariates(mod, upsilon_NH4_to_algae ~ treatment)
142		#' mod <- mod %>%
143		#' set_params(c("eta" = 0.2, "lambda_algae" = 0, "lambda_daphnia" = 0,
144		#' "lambda_NH4" = 0, "upsilon_NH4_to_algae\|light" = 0.3,
145		#' "upsilon_NH4_to_algae\|dark" = 0.1,
146		#' "upsilon_algae_to_daphnia" = 0.13,
147		#' "upsilon_daphnia_to_NH4" = 0.045, "zeta" = 0.1))
148		#' spl <- mod %>% sample_from(at = 1:10)
149		#' spl
150		#'
151		#' @export
152
153		sample_from <- function(nm, at, dt = NULL, grid_size = NULL, end = NULL, error.draws = 1,
154		cached_ts = NULL, cached_ee = NULL) {
155	15x	obs <- list()
156	15x	prop_family <- attr(nm, "prop_family")
157	15x	size_family <- attr(nm, "size_family")
158	15x	zeta_by_comp <- attr(nm, "size_zeta_per_compartment")
159	15x	if (is.null(zeta_by_comp)) {
160	!	zeta_by_comp <- FALSE
161		}
162		# Project nm
163	15x	nm <- project(nm, at = at, dt = dt, grid_size = grid_size, end = end,
164	15x	cached_ts = cached_ts, cached_ee = cached_ee)
165		# Extract samples
166	15x	for (i in seq_len(nrow(nm))) {
167	15x	z <- nm$trajectory[[i]]
168	15x	params <- nm$parameters[[i]]
169	15x	indices <- sort(unique(match(at, z$timepoints[[1]])))
170	15x	sizes <- tibble::as_tibble(z$unmarked[[1]] + z$marked[[1]])[indices, ]
171	15x	props <- tibble::as_tibble(z$proportions[[1]])[indices, ]
172	15x	stopifnot(!any(c("time", "comp", "size", "prop") %in% names(sizes)))
173	15x	sizes$time <- z$timepoints[[1]][indices]
174	15x	props$time <- z$timepoints[[1]][indices]
175	15x	sizes <- data.table::melt(data.table::as.data.table(sizes),
176	15x	id.vars = "time",
177	15x	variable.name = "comp", value.name = "meanSize",
178	15x	variable.factor = FALSE)
179	15x	props <- data.table::melt(data.table::as.data.table(props),
180	15x	id.vars = "time",
181	15x	variable.name = "comp", value.name = "meanProp",
182	15x	variable.factor = FALSE)
183	15x	sizes <- dplyr::bind_rows(rep(list(tibble::as_tibble(sizes)), error.draws))
184	15x	props <- dplyr::bind_rows(rep(list(tibble::as_tibble(props)), error.draws))
185		# Add zeta values to sizes tibble
186	15x	if (!zeta_by_comp) {
187	15x	sizes$zeta <- params$value[params$in_replicate == "zeta"]
188		} else {
189	!	zeta_params <- paste0("zeta_", sizes[["comp"]])
190	!	sizes$zeta <- params$value[match(zeta_params, params$in_replicate)]
191		}
192		# Apply size "noise"
193	15x	if (size_family == "normal_cv") {
194	15x	sizes$size <- rnorm(nrow(sizes),
195	15x	mean = sizes$meanSize,
196	15x	sd = sizes$meanSize * sizes$zeta)
197	15x	negSizes <- which(sizes$size < 0)
198	15x	while (length(negSizes) > 0) {
199	!	sizes$size[negSizes] <- rnorm(length(negSizes),
200	!	sizes$meanSize[negSizes],
201	!	sd = sizes$meanSize[negSizes] * sizes$zeta[negSizes])
202	!	negSizes <- which(sizes$size < 0)
203		}
204	!	} else if (size_family == "normal_sd") {
205	!	sizes$size <- rnorm(nrow(sizes),
206	!	mean = sizes$meanSize,
207	!	sd = sizes$zeta)
208	!	negSizes <- which(sizes$size < 0)
209	!	while (length(negSizes) > 0) {
210	!	sizes$size[negSizes] <- rnorm(length(negSizes),
211	!	sizes$meanSize[negSizes],
212	!	sd = sizes$zeta)
213	!	negSizes <- which(sizes$size < 0)
214		}
215		}
216	15x	sizes$zeta <- NULL
217		# Apply prop "noise"
218	15x	if (prop_family == "gamma_cv") {
219	12x	shapes <- rep(params$value[params$in_replicate == "eta"], nrow(props))^(-2)
220	12x	rates <- shapes / props$meanProp
221	12x	props$prop <- rgamma(nrow(props), shape = shapes, rate = rates)
222	3x	} else if (prop_family == "normal_cv") {
223	1x	means <- props$meanProp
224	1x	sds <- means * params$value[params$in_replicate == "eta"]
225	1x	props$prop <- rnorm(nrow(props), mean = means, sd = sds)
226	1x	negProps <- which(props$prop < 0)
227	1x	while (length(negProps) > 0) {
228	!	props$prop[negProps] <- rnorm(length(negProps),
229	!	means[negProps],
230	!	sd = sds[negProps])
231	!	negProps <- which(props$prop < 0)
232		}
233	2x	} else if (prop_family == "normal_sd") {
234	1x	means <- props$meanProp
235	1x	sds <- rep(params$value[params$in_replicate == "eta"], nrow(props))
236	1x	props$prop <- rnorm(nrow(props), mean = means, sd = sds)
237	1x	negProps <- which(props$prop < 0)
238	1x	while (length(negProps) > 0) {
239	6x	props$prop[negProps] <- rnorm(length(negProps),
240	6x	means[negProps],
241	6x	sd = sds[negProps])
242	6x	negProps <- which(props$prop < 0)
243		}
244	1x	} else if (prop_family == "beta_phi") {
245	1x	phis <- rep(params$value[params$in_replicate == "eta"], nrow(props))
246	1x	alphas <- props$meanProp * phis
247	1x	betas <- phis * (1 - props$meanProp)
248	1x	props$prop <- rbeta(nrow(props), shape1 = alphas, shape2 = betas)
249		} else {
250	!	stop("Unknown distribution family:", prop_family)
251		}
252	15x	stopifnot(all(sizes[["time"]] == props[["time"]]))
253	15x	stopifnot(all(sizes[["comp"]] == props[["comp"]]))
254	15x	obs[[i]] <- dplyr::bind_cols(sizes[, c("time", "comp", "size")],
255	15x	props[, c("prop")])
256		}
257	15x	if (is.null(groups(nm))) {
258	15x	stopifnot(nrow(nm) == 1)
259	15x	return(obs[[1]])
260		}
261	!	groups <- groups(nm)
262	!	out <- dplyr::bind_cols(tibble::tibble(obs), groups)
263	!	out <- tidyr::unnest(out, cols = "obs")
264	!	return(out)
265		}
266
267		### * calculate_steady_state()
268
269		#' Calculate steady-state compartment sizes for a network
270		#'
271		#' This is an experimental function. It attempts to calculate steady-state
272		#' compartment sizes using the set parameter values and the initial compartment
273		#' sizes. Use it with caution!
274		#'
275		#' Note about how steady state sizes for split compartments are calculated: the
276		#' steady size of the active portion is calculated divide it is divided by the
277		#' active fraction (portion.act parameter) to get the total size including the
278		#' refractory portion. In this case we get a "steady-state" refractory portion,
279		#' consistent with steady state size of active fraction and with portion.act
280		#' parameter.
281		#'
282		#' @param nm A network model, with set parameter values.
283		#'
284		#' @return A tibble containing steady-state compartment sizes.
285		#'
286		#' @examples
287		#' m <- aquarium_mod
288		#' m <- set_prior(m, constant_p(0), "lambda")
289		#' m <- set_params(m, sample_params(m))
290		#' proj <- project(m, end = 40)
291		#' plot(proj)
292		#'
293		#' z <- calculate_steady_state(m)
294		#' z
295		#' z$stable_sizes
296		#'
297		#' @export
298
299		calculate_steady_state <- function(nm) {
300	!	out <- lapply(seq_len(nrow(nm)), function(i) {
301	!	tibble::tibble(stable_sizes = list(calculate_steady_state_one_row(nm[i, ])))
302		})
303	!	out <- dplyr::bind_rows(out)
304	!	nm[["stable_sizes"]] <- out[["stable_sizes"]]
305	!	return(nm)
306		}

1		### * All functions in this file are exported
2
3		### * available_priors()
4
5		#' List the available priors for model parameters
6		#'
7		#' @return A tibble containing information about the available priors.
8		#'
9		#' @examples
10		#' available_priors()
11		#'
12		#' @export
13
14		available_priors <- function() {
15	!	fun_names <- c("constant_p",
16	!	"uniform_p",
17	!	"normal_p",
18	!	"hcauchy_p",
19	!	"exponential_p",
20	!	"gamma_p",
21	!	"scaled_beta_p")
22	!	prior_names <- c("Constant value",
23	!	"Uniform prior",
24	!	"Normal distribution",
25	!	"Half-Cauchy distribution",
26	!	"Exponential distribution",
27	!	"Gamma distribution",
28	!	"Scaled beta distribution")
29	!	usage <- c("constant_p(value)",
30	!	"uniform_p(min, max)",
31	!	"normal_p(mean, sd)",
32	!	"hcauchy_p(scale)",
33	!	"exponential_p(lambda)",
34	!	"gamma_p(alpha, beta)",
35	!	"scaled_beta_p(alpha, beta, scale = 1)")
36	!	out <- tibble::tibble(function_name = fun_names,
37	!	description = prior_names,
38	!	usage = usage)
39	!	return(structure(out, class = c("prior_tibble", class(out))))
40		}
41
42		### * Methods for nice display of prior tibble
43
44		### ** format.prior_tibble()
45
46		#' Pretty formatting of a \code{prior_tibble} object
47		#'
48		#' @param x An object of class \code{prior_tibble}.
49		#' @param ... Not used.
50		#'
51		#' @return A character string for pretty printing of a prior tibble.
52		#'
53		#' @export
54
55		format.prior_tibble <- function(x, ...) {
56	!	x <- structure(x, class = class(x)[class(x) != "prior_tibble"])
57	!	f <- format(x)
58	!	f <- c(f,
59		"-------------------------------------------------------",
60	!	"(Note: All priors distributions are truncated at zero.)")
61	!	return(f)
62		}
63
64		### ** print.prior_tibble()
65
66		#' Pretty printing of a \code{prior_tibble} object
67		#'
68		#' @param x An object of class \code{prior_tibble}.
69		#' @param ... Not used.
70		#'
71		#' @return Mostly called for its side effect of printing, but also returns its
72		#' input invisibly.
73		#'
74		#' @export
75
76		print.prior_tibble <- function(x, ...) {
77	!	cat(format(x), sep = "\n")
78	!	invisible(x)
79		}
80
81		### * constant_p(value)
82
83		#' Define a fixed-value prior
84		#'
85		#' This is equivalent to having a fixed parameter.
86		#'
87		#' @param value The constant value of the parameter.
88		#'
89		#' @return A list defining the prior.
90		#'
91		#' @examples
92		#' constant_p(2)
93		#'
94		#' @export
95
96		constant_p <- function(value) {
97	8x	x <- list(type = "constant",
98	8x	parameters = c(value = value))
99	8x	x <- structure(x, class = "prior")
100	8x	return(x)
101		}
102
103		### * hcauchy_p(scale)
104
105		#' Define a half-Cauchy prior (on [0;+Inf])
106		#'
107		#' @param scale Median of the half-Cauchy distribution.
108		#'
109		#' @return A list defining the prior.
110		#'
111		#' @importFrom stats rcauchy
112		#'
113		#' @examples
114		#' hcauchy_p(scale = 0.5)
115		#'
116		#' @export
117
118		hcauchy_p <- function(scale) {
119	10x	x <- list(type = "hcauchy",
120	10x	parameters = c(scale = scale))
121	10x	x <- structure(x, class = "prior")
122	10x	return(x)
123		}
124
125		### * normal_p(mean, sd)
126
127		#' Define a truncated normal prior (on [0;+Inf])
128		#'
129		#' @param mean Mean of the untruncated normal.
130		#' @param sd Standard deviation of the untruncated normal.
131		#'
132		#' @return A list defining the prior.
133		#'
134		#' @importFrom stats rnorm
135		#'
136		#' @examples
137		#' normal_p(mean = 0, sd = 4)
138		#'
139		#' @export
140
141		normal_p <- function(mean, sd) {
142	10x	x <- list(type = "trun_normal",
143	10x	parameters = c(mean = mean,
144	10x	sd = sd))
145	10x	x <- structure(x, class = "prior")
146	10x	return(x)
147		}
148
149		### * uniform_p(min, max)
150
151		#' Define a uniform prior
152		#'
153		#' @param min,max Minimum and maximum boundaries for the uniform prior.
154		#'
155		#' @return A list defining the prior.
156		#'
157		#' @importFrom stats runif
158		#'
159		#' @examples
160		#' uniform_p(min = 0, max= 1)
161		#'
162		#' @export
163
164		uniform_p <- function(min, max) {
165	9x	x <- list(type = "uniform",
166	9x	parameters = c(min = min, max = max))
167	9x	x <- structure(x, class = "prior")
168	9x	return(x)
169		}
170
171
172		### * scaled_beta_p(alpha, beta, scale=1)
173
174		#' Define a beta prior (on [0;scale])
175		#'
176		#' If a random variable X follows a scaled beta distribution with parameters
177		#' (alpha, beta, scale), then X/scale follows a beta distribution with
178		#' parameters (alpha, beta).
179		#'
180		#' @param alpha Alpha parameter of the unscaled beta distribution.
181		#' @param beta Beta parameter of the unscaled beta distribution.
182		#' @param scale The upper boundary of the prior.
183		#'
184		#' @return A list defining the prior.
185		#'
186		#' @examples
187		#' scaled_beta_p(0.8, 20, scale = 10)
188		#'
189		#' @export
190
191		scaled_beta_p <- function(alpha, beta, scale = 1) {
192	!	x <- list(type = "scaled_beta",
193	!	parameters = c(alpha = alpha, beta = beta, scale = scale))
194	!	x <- structure(x, class = "prior")
195	!	return(x)
196		}
197
198		### * exponential_p(lambda)
199
200		#' Define an exponential prior
201		#'
202		#' @param lambda Lambda parameter (rate) of the exponential distribution. The
203		#' mean of the exponential distribution is 1/lambda.
204		#'
205		#' @return A list defining the prior.
206		#'
207		#' @examples
208		#' exponential_p(0.5)
209		#'
210		#' @export
211
212		exponential_p <- function(lambda) {
213	1x	x <- list(type = "exponential",
214	1x	parameters = c(lambda = lambda))
215	1x	x <- structure(x, class = "prior")
216	1x	return(x)
217		}
218
219		### * gamma_p(alpha, beta)
220
221		#' Define a gamma prior
222		#'
223		#' Note the name of the function to define a prior (\code{gamma_p}), in order
224		#' to avoid confusion with the R mathematical function \code{gamma}.
225		#'
226		#' @param alpha Shape parameter (equivalent to the \code{shape} parameter of
227		#' R's \code{rgamma}).
228		#' @param beta Rate parameter (equivalent to the \code{rate} parameter of R's
229		#' \code{rgamma}).
230		#'
231		#' @return A list defining the prior.
232		#'
233		#' @examples
234		#' gamma_p(9, 2)
235		#' hist(sample_from_prior(gamma_p(9, 2), 1e3))
236		#'
237		#' @export
238
239		gamma_p <- function(alpha, beta) {
240	1x	x <- list(type = "gamma",
241	1x	parameters = c(alpha = alpha, beta = beta))
242	1x	x <- structure(x, class = "prior")
243	1x	return(x)
244		}
245
246		### * Methods for nice display of priors
247
248		### ** format.prior()
249
250		#' Pretty formatting of a \code{prior} object
251		#'
252		#' @param x An object of class \code{prior}.
253		#' @param ... Not used.
254		#'
255		#' @return A character string for pretty printing of a prior.
256		#'
257		#' @export
258
259		format.prior <- function(x, ...) {
260	!	params <- paste0("(",
261	!	paste(paste(names(x[["parameters"]]), x[["parameters"]],
262	!	sep = "="), collapse = ","),
263		")")
264	!	out <- paste0(x[["type"]], "", params)
265	!	return(out)
266		}
267
268		### ** print.prior()
269
270		#' Pretty printing of a \code{prior} object
271		#'
272		#' @param x An object of class \code{prior}.
273		#' @param ... Not used.
274		#'
275		#' @return Mostly called for its side effect of printing, but also returns its
276		#' input invisibly.
277		#'
278		#' @export
279
280		print.prior <- function(x, ...) {
281	!	cat(format(x), sep = "\n")
282	!	invisible(x)
283		}
284
285		### * Extending tibbles
286
287		# https://cran.r-project.org/web/packages/tibble/vignettes/extending.html
288
289		#' Function used for displaying \code{prior} object in tibbles
290		#'
291		#' @param x An object of class \code{prior}.
292		#'
293		#' @return Input formatted with \code{format(x)}.
294		#'
295		#' @importFrom pillar type_sum
296		#' @export
297		type_sum.prior <- function(x) {
298	!	format(x)
299		}
300
301		#' Function used for displaying \code{prior} object in tibbles
302		#'
303		#' @param x An object of class \code{prior}.
304		#'
305		#' @return Input formatted with \code{format(x)}.
306		#'
307		#' @importFrom pillar obj_sum
308		#' @export
309		obj_sum.prior <- function(x) {
310	!	format(x)
311		}
312
313		#' Function used for displaying \code{prior} object in tibbles
314		#'
315		#' @param x An object of class \code{prior}.
316		#' @param ... Not used.
317		#'
318		#' @return An object prepared with pillar::new_pillar_shaft_simple.
319		#'
320		#' @importFrom pillar pillar_shaft
321		#' @export
322		pillar_shaft.prior <- function(x, ...) {
323	!	out <- format(x)
324	!	out[is.na(x)] <- NA
325	!	pillar::new_pillar_shaft_simple(out, align = "right")
326		}
327
328		### * Methods for Ops on priors (implementing '==' operator)
329
330		# https://stackoverflow.com/a/35902710
331
332		#' Implementation of the '==' operator for priors
333		#'
334		#' @param e1,e2 Objects of class "prior".
335		#'
336		#' @return Boolean (or throws an error for unsupported operators).
337		#'
338		#' @examples
339		#' p <- constant_p(0)
340		#' q <- constant_p(4)
341		#' p == q
342		#'
343		#' p <- hcauchy_p(2)
344		#' q <- hcauchy_p(2)
345		#' p == q
346		#'
347		#' @method Ops prior
348		#'
349		#' @export
350
351		Ops.prior <- function(e1, e2) {
352	!	op <- .Generic[[1]]
353	!	switch(op,
354		`==` = {
355	!	if (e1$type != e2$type) {
356	!	return(FALSE)
357		}
358	!	if (!all(e1$parameters == e2$parameters)) {
359	!	return(FALSE)
360		}
361	!	return(TRUE)
362		},
363	!	stop("Undefined operation for objects of class \"priors\".")
364		)
365		}
366
367		### * sample_from_prior()
368
369		#' Sample from a prior object
370		#'
371		#' @param x A \code{prior} object.
372		#' @param n Integer, number of samples to draw.
373		#'
374		#' @return A numeric vector of length \code{n}.
375		#'
376		#' @examples
377		#' sample_from_prior(constant_p(1))
378		#' sample_from_prior(constant_p(1), 10)
379		#' sample_from_prior(hcauchy_p(0.5), 1)
380		#' hist(sample_from_prior(hcauchy_p(0.5), 20))
381		#' hist(sample_from_prior(uniform_p(0, 3), 1000))
382		#' hist(sample_from_prior(scaled_beta_p(3, 7, 2), 1e4))
383		#'
384		#' @export
385		#'
386
387		sample_from_prior <- function(x, n = 1) {
388	88x	switch(x$type,
389		"constant" = {
390	9x	rep(x$parameters[["value"]], n)
391		},
392		"hcauchy" = {
393	17x	scale <- x$parameters[["scale"]]
394	17x	replicate(n,
395		{
396	17x	o <- stats::rcauchy(1, location = 0, scale = scale)
397	17x	while (o < 0) {
398	20x	o <- stats::rcauchy(1, location = 0, scale = scale)
399		}
400	17x	return(o)
401		})
402		},
403		"trun_normal" = {
404	54x	mean <- x$parameters[["mean"]]
405	54x	sd <- x$parameters[["sd"]]
406	54x	replicate(n, {
407	54x	o <- stats::rnorm(1, mean = mean, sd = sd)
408	54x	while (o < 0) {
409	60x	o <- stats::rnorm(1, mean = mean, sd = sd)
410		}
411	54x	return(o)
412		})
413		},
414		"uniform" = {
415	8x	stats::runif(n, min = x$parameters[["min"]], max = x$parameters[["max"]])
416		},
417		"scaled_beta" = {
418	!	p <- x$parameters
419	!	p[["scale"]] * stats::rbeta(n, shape1 = p[["alpha"]], shape2 = p[["beta"]])
420		},
421		"exponential" = {
422	!	lambda <- x$parameters[["lambda"]]
423	!	stats::rexp(n = n, rate = lambda)
424		},
425		"gamma" = {
426	!	alpha <- x$parameters[["alpha"]]
427	!	beta <- x$parameters[["beta"]]
428	!	stats::rgamma(n = n, shape = alpha, rate = beta)
429		},
430	!	stop("Unknown prior type."))
431		}

1		### * None of the functions in this file is exported
2
3		### * make_topology()
4
5		#' Build a network topology
6		#'
7		#' @section Link format:
8		#'
9		#' Links are defined by a string describing connections between groups of
10		#' compartments and their directions using \code{->} and \code{<-}. The groups
11		#' being connected can be a single compartment or several compartments. Several
12		#' compartments can be separated either by commas or by spaces. Connection
13		#' descriptions can be chained in a single string.
14		#'
15		#' Some valid links are for example \code{"NH4, NO3 -> epi"} or
16		#' \code{"NH4, NO3 -> epi -> lepto, tricor"}.
17		#'
18		#' See the Examples section for more details.
19		#'
20		#' @param links Vector of strings defining the connections between
21		#' compartments. Alternatively, can be a data frame with two columns
22		#' describing the source and destination of each link, in which case the
23		#' arguments "from" and "to" must be provided.
24		#' @param from Optional, string containing the column name for sources if
25		#' "links" is a data frame
26		#' @param to Optional, string containing the column name for destinations if
27		#' "links" is a data frame
28		#' @param split Optional, vector of strings containing the names of the
29		#' compartments which comprise an active and a refractory portions
30		#'
31		#' @return A matrix describing the topology of the network (with class
32		#' topology). A coefficient (i,j) is 1 if material can flow from
33		#' compartment j (column) into compartment i (row), and 0 otherwise.
34		#'
35		#' @examples
36		#' topo <- isotracer:::make_topology(links = "NH4, NO3 -> epi -> pseph, tricor")
37		#' topo
38		#'
39		#' # A larger foodweb
40		#' links <- c("NH4, NO3 -> seston, epi, CBOM, FBOM",
41		#' "seston -> lepto", "epi -> petro, pseph",
42		#' "CBOM, FBOM -> eudan", "CBOM -> phyllo",
43		#' "FBOM -> tricor -> arg, euthy")
44		#' topo2 <- isotracer:::make_topology(links = links, split = "epi")
45		#' topo2
46		#'
47		#' # Using a data frame to specify the links
48		#' links <- data.frame(source = c("NH4", "NO3", "epi"),
49		#' consumer = c("epi", "epi", "petro"))
50		#' topo3 <- isotracer:::make_topology(links, from = "source", to = "consumer")
51		#' topo3
52		#'
53		#' @keywords internal
54		#' @noRd
55
56		make_topology <- function(links, from = NULL, to = NULL, split = NULL) {
57		# Links are provided as strings
58	42x	if (is.null(from) & is.null(to)) {
59	40x	out <- build_uptake_mask(links = links)
60	40x	out <- structure(out, class = c("topology", class(out)))
61	40x	attr(out, "split") = split
62	40x	return(out)
63		}
64		# Links are provided as a data frame
65		# Build the links strings from the input data frame
66	2x	links <- paste(links[[from]], links[[to]], sep = " -> ")
67	2x	return(make_topology(links, split = split))
68		}
69
70		### * topo_get_upsilon_names()
71
72		#' @keywords internal
73		#' @noRd
74
75		topo_get_upsilon_names <- function(topo) {
76	90x	comps <- colnames(topo)
77	90x	out <- rep(NA, ncol(topo)^2)
78	90x	k <- 1
79	90x	for (i in seq_len(nrow(topo))) {
80	290x	for (j in seq_len(ncol(topo))) {
81	1058x	if (topo[i,j] == 1) {
82	270x	out[k] <- paste("upsilon", comps[j], "to", comps[i], sep = "_")
83	270x	k = k + 1
84		}
85		}
86		}
87	90x	if (k == 1) {
88	!	return(vector())
89		}
90	90x	return(out[1:(k-1)])
91		}
92
93		### * topo_get_lambda_names()
94
95		#' @keywords internal
96		#' @noRd
97
98		topo_get_lambda_names <- function(topo) {
99	90x	comps <- colnames(topo)
100	90x	out <- rep(NA, ncol(topo))
101	90x	k <- 1
102	90x	for (j in seq_len(ncol(topo))) {
103	290x	out[k] <- paste("lambda", comps[j], sep = "_")
104	290x	k = k + 1
105		}
106	90x	if (k == 1) {
107	!	return(vector())
108		}
109	90x	return(out[1:(k-1)])
110		}
111
112		### * topo_get_portionAct_names()
113
114		#' @keywords internal
115		#' @noRd
116
117		topo_get_portionAct_names <- function(topo) {
118	90x	split <- attr(topo, "split")
119	90x	if (is.null(split)) {
120	86x	return(NULL)
121		}
122	4x	params <- paste0("portion.act_", split)
123	4x	return(params)
124		}
125

1		### * All functions in this file are exported
2
3		### * topo()
4
5		#' Return the list of topologies, or a unique topology if all identical
6		#'
7		#' @param nm A \code{networkModel} object.
8		#' @param simplify Boolean, return only a unique topology if all topologies are
9		#' identical or if there is only one? Default is TRUE.
10		#'
11		#' @return A list of the \code{networkModel} topologies or, if all topologies
12		#' are identical (or if there is only one) and \code{simplify} is TRUE, a
13		#' single topology (not wrapped into a single-element list).
14		#'
15		#' @examples
16		#' aquarium_mod
17		#' topo(aquarium_mod)
18		#'
19		#' trini_mod
20		#' topo(trini_mod)
21		#' @export
22
23		topo <- function(nm, simplify = TRUE) {
24	1131x	out <- nm[["topology"]]
25	1131x	if (simplify && length(unique(out)) == 1) {
26	1128x	return(unique(out)[[1]])
27		}
28	3x	return(out)
29		}
30
31		### * prop_family()
32
33		#' Return the distribution family for observed proportions
34		#'
35		#' @param nm A \code{networkModel} object.
36		#' @param quiet Boolean for being quiet about explaining the role of eta
37		#' (default is \code{FALSE}).
38		#'
39		#' @return A character string describing the distribution family used to model
40		#' observed proportions.
41		#'
42		#' @examples
43		#' prop_family(aquarium_mod)
44		#' prop_family(trini_mod)
45		#'
46		#' @export
47
48		prop_family <- function(nm, quiet = FALSE) {
49	!	z <- attr(nm, "prop_family")
50	!	if (!quiet) {
51	!	describe_z_eta("eta", z)
52		}
53	!	z
54		}
55
56		### * size_family()
57
58		#' Return the distribution family for observed sizes
59		#'
60		#' @param nm A \code{networkModel} object.
61		#' @param quiet Boolean for being quiet about explaining the role of zeta
62		#' (default is \code{FALSE}).
63		#'
64		#' @return A character string describing the distribution family used to model
65		#' observed sizes.
66		#'
67		#' @examples
68		#' size_family(aquarium_mod)
69		#' size_family(trini_mod)
70		#'
71		#' @export
72
73		size_family <- function(nm, quiet = FALSE) {
74	!	z <- attr(nm, "size_family")
75	!	if (!quiet) {
76	!	describe_z_eta("zeta", z)
77		}
78	!	z
79		}
80
81		### * groups() method for networkModel
82
83		#' Get the grouping for a \code{networkModel} object
84		#'
85		#' @param x A \code{networkModel} object.
86		#'
87		#' @return A tibble giving the grouping variable(s) for the input network
88		#' model. This tibble is in the same order as the rows of the input network
89		#' model. If the input network model did not have any grouping variable,
90		#' returns \code{NULL}.
91		#'
92		#' @importFrom dplyr groups
93		#' @method groups networkModel
94		#'
95		#' @examples
96		#' groups(aquarium_mod)
97		#' groups(trini_mod)
98		#'
99		#' @export
100
101		groups.networkModel <- function(x) {
102	30x	nm_get_groups(x, error = FALSE)
103		}
104
105		### * priors()
106
107		#' Return the tibble containing the priors of a networkModel
108		#'
109		#' @param nm A \code{networkModel} object.
110		#' @param fix_set_params If TRUE, parameters for which a value is set are given a
111		#' fixed value (i.e. their prior is equivalent to a point value).
112		#' @param quiet Boolean to control verbosity.
113		#'
114		#' @return A tibble giving the current priors defined for the input network
115		#' model.
116		#'
117		#' @examples
118		#' priors(aquarium_mod)
119		#' priors(trini_mod)
120		#'
121		#' @export
122
123		priors <- function(nm, fix_set_params = FALSE, quiet = FALSE) {
124	74x	if (fix_set_params) {
125	!	set_params <- attr(nm, "parameterValues")
126	!	if (!is.null(set_params)) {
127	!	for (i in seq_len(nrow(set_params))) {
128	!	myPrior <- constant_p(value = set_params[["value"]][i])
129	!	nm <- set_prior(nm, myPrior, param = set_params[["parameter"]][i],
130	!	use_regexp = FALSE, quiet = quiet)
131		}
132		}
133		}
134	74x	out <- attr(nm, "priors")
135	74x	return(out)
136		}
137
138		### * missing_priors()
139
140		#' Get a table with parameters which are missing priors
141		#'
142		#' @param nm A \code{networkModel} object.
143		#'
144		#' @return A tibble containing the parameters which are missing a prior. If no
145		#' priors are missing, the tibble contains zero row.
146		#'
147		#' @examples
148		#'# Using a subset of the topology from the Trinidad case study
149		#' m <- new_networkModel() %>%
150		#' set_topo("NH4, NO3 -> epi, FBOM", "epi -> petro, pseph")
151		#'
152		#' # No prior is set by default
153		#' priors(m)
154		#'
155		#' # Set some priors
156		#' m <- set_priors(m, normal_p(0, 10), "lambda")
157		#' priors(m)
158		#'
159		#' # Which parameters are missing a prior?
160		#' missing_priors(m)
161		#'
162		#' @export
163
164		missing_priors <- function(nm) {
165	!	p <- priors(nm)
166	!	p <- p[sapply(p$prior, is.null), ]
167	!	return(p)
168		}
169
170		### * params()
171
172		#' Return the parameters of a network model
173		#'
174		#' @param nm A \code{networkModel} object.
175		#' @param simplify If \code{TRUE}, return a vector containing the names of all
176		#' model parameters (default: \code{FALSE}).
177		#'
178		#' @return A tibble containing the parameter names and their current value (if
179		#' set). If \code{simplify} is \code{TRUE}, only return a sorted character
180		#' vector containing the parameters names.
181		#'
182		#' @examples
183		#' params(aquarium_mod)
184		#' params(trini_mod)
185		#' params(trini_mod, simplify = TRUE)
186		#'
187		#' @export
188
189		params <- function(nm, simplify = FALSE) {
190	75x	stopifnot("parameters" %in% colnames(nm))
191	75x	params <- dplyr::bind_rows(nm[["parameters"]])
192	75x	if (simplify) {
193	75x	return(sort(unique(params[["in_model"]])))
194		}
195	!	if (!"value" %in% colnames(params)) {
196	!	params[["value"]] <- as.numeric(rep(NA, nrow(params)))
197		}
198	!	params <- unique(params[, c("in_model", "value")])
199	!	params <- params[order(params[["in_model"]]), ]
200	!	if (!all(table(params[["in_model"]]) == 1)) {
201	!	stop("Some parameters have two different values assigned to them.")
202		}
203	!	return(params)
204		}
205
206		### * comps()
207
208		#' Return the compartments of a network model
209		#'
210		#' @param nm A \code{networkModel} object.
211		#'
212		#' @return A list of character vectors, with one list element per row of the
213		#' input network model (list elements are in the same order as the input
214		#' network model rows). Each list element containing the names of the
215		#' compartments in the topology defined in the corresponding row of the
216		#' input network model.
217		#'
218		#' @examples
219		#' aquarium_mod
220		#' comps(aquarium_mod)
221		#'
222		#' trini_mod
223		#' comps(trini_mod)
224		#'
225		#' @export
226
227		comps <- function(nm) {
228	628x	comps <- nm[, "topology"]
229	628x	comps$compartments <- lapply(comps$topology, colnames)
230	628x	return(comps[["compartments"]])
231		}
232

1		### * All functions in this file are exported
2
3		### * Description
4
5		# Methods for \code{coda::mcmc.list} objects:
6		#
7		# - Provide simple math operations for mcmc.list objects and also allows to use
8		# math functions such as log() or exp() on mcmc.list objects.
9		#
10		# - Provide simple interface to select parameters based on their name.
11		#
12		# Those methods are not designed specifically for this package, and could be
13		# submitted e.g. for integration in the coda package.
14
15		### * Helper functions / generics
16
17		### * Ops.mcmc.list()
18
19		# Based on
20		# ?groupGeneric
21		# ?.Generic
22		# https://stackoverflow.com/questions/35902360/r-implement-group-generics-ops-to-enable-comparison-of-s3-objects
23		# (cdeterman answer in the above)
24
25		#' Ops generics for \code{\link[coda]{mcmc.list}} objects
26		#'
27		#' @param e1 First operand
28		#' @param e2 Second operand
29		#'
30		#' @return A \code{mcmc.list} object (with the added class
31		#' \code{derived.mcmc.list}).
32		#'
33		#' @examples
34		#' \dontrun{
35		#' # aquarium_run is a coda::mcmc.list object shipped with the isotracer package
36		#' a <- aquarium_run
37		#' plot(a)
38		#' # The calculations below are just given as examples of mathematical
39		#' # operations performed on an mcmc.list object, and do not make any sense
40		#' # from a modelling point of view.
41		#' plot(a[, "upsilon_algae_to_daphnia"] - a[, "lambda_algae"])
42		#' plot(a[, "upsilon_algae_to_daphnia"] + a[, "lambda_algae"])
43		#' plot(a[, "upsilon_algae_to_daphnia"] / a[, "lambda_algae"])
44		#' plot(a[, "upsilon_algae_to_daphnia"] * a[, "lambda_algae"])
45		#' plot(a[, "upsilon_algae_to_daphnia"] - 10)
46		#' plot(a[, "upsilon_algae_to_daphnia"] + 10)
47		#' plot(a[, "upsilon_algae_to_daphnia"] * 10)
48		#' plot(a[, "upsilon_algae_to_daphnia"] / 10)
49		#' plot(10 - a[, "upsilon_algae_to_daphnia"])
50		#' plot(10 + a[, "upsilon_algae_to_daphnia"])
51		#' plot(10 * a[, "upsilon_algae_to_daphnia"])
52		#' plot(10 / a[, "upsilon_algae_to_daphnia"])
53		#' }
54		#'
55		#' @method Ops mcmc.list
56		#'
57		#' @export
58
59		Ops.mcmc.list = function(e1, e2) {
60		# Modified from cdeterman answer from:
61		# https://stackoverflow.com/questions/35902360/r-implement-group-generics-ops-to-enable-comparison-of-s3-objects
62	!	op = .Generic[[1]]
63	!	if ("mcmc.list" %in% class(e1) & "mcmc.list" %in% class(e2)) {
64	!	areCompatible = function(m1, m2) {
65	!	COMPATIBLE = TRUE
66	!	if (coda::nvar(m1) != coda::nvar(m2)) {
67	!	COMPATIBLE = FALSE
68	!	} else if (coda::nchain(m1) != coda::nchain(m2)) {
69	!	COMPATIBLE = FALSE
70	!	} else if (!all(coda::varnames(m1) == coda::varnames(m1))) {
71	!	COMPATIBLE = FALSE
72	!	} else if (!all(coda::mcpar(m1[[1]]) == coda::mcpar(m2[[1]]))) {
73	!	COMPATIBLE = FALSE
74		}
75	!	return(COMPATIBLE)
76		}
77	!	if (!areCompatible(e1, e2)) {
78	!	stop("Incompatible inputs")
79		}
80	!	if (coda::nvar(e1) != 1) {
81	!	stop("Ops implemented only for single-parameter chains")
82		}
83	!	switch(op,
84		"+" = {
85		# Addition
86	!	c = e1
87	!	for (i in 1:coda::nchain(e1)) {
88	!	c[[i]] = c[[i]] + e2[[i]]
89		}
90	!	return(as.derived.mcmc.list(c))
91		},
92		"-" = {
93		# Subtraction
94	!	c = e1
95	!	for (i in 1:coda::nchain(e1)) {
96	!	c[[i]] = c[[i]] - e2[[i]]
97		}
98	!	return(as.derived.mcmc.list(c))
99		},
100		"*" = {
101		# Multiplication
102	!	c = e1
103	!	for (i in 1:coda::nchain(e1)) {
104	!	c[[i]] = c[[i]] * e2[[i]]
105		}
106	!	return(as.derived.mcmc.list(c))
107		},
108		"/" = {
109		# Division
110	!	c = e1
111	!	for (i in 1:coda::nchain(e1)) {
112	!	c[[i]] = c[[i]] / e2[[i]]
113		}
114	!	return(as.derived.mcmc.list(c))
115		},
116	!	stop("Undefined operation for mcmc.list objects"))
117	!	} else if ("mcmc.list" %in% class(e1)) {
118	!	stopifnot("mcmc.list" %in% class(e1) & ! "mcmc.list" %in% class(e2))
119	!	stopifnot(is.numeric(e2) & length(e2) == 1)
120	!	switch(op,
121		"+" = {
122		# Addition
123	!	c = e1
124	!	for (i in 1:coda::nchain(e1)) {
125	!	c[[i]] = c[[i]] + e2
126		}
127	!	return(as.derived.mcmc.list(c))
128		},
129		"-" = {
130		# Subtraction
131	!	c = e1
132	!	for (i in 1:coda::nchain(e1)) {
133	!	c[[i]] = c[[i]] - e2
134		}
135	!	return(as.derived.mcmc.list(c))
136		},
137		"*" = {
138		# Multiplication
139	!	c = e1
140	!	for (i in 1:coda::nchain(e1)) {
141	!	c[[i]] = c[[i]] * e2
142		}
143	!	return(as.derived.mcmc.list(c))
144		},
145		"/" = {
146		# Division
147	!	c = e1
148	!	for (i in 1:coda::nchain(e1)) {
149	!	c[[i]] = c[[i]] / e2
150		}
151	!	return(as.derived.mcmc.list(c))
152		},
153	!	stop("Undefined operation for mcmc.list object and numeric")
154		)
155		} else {
156	!	stopifnot("mcmc.list" %in% class(e2) & ! "mcmc.list" %in% class(e1))
157	!	stopifnot(is.numeric(e1) & length(e1) == 1)
158	!	switch(op,
159		"+" = {
160		# Addition
161	!	c = e2
162	!	for (i in 1:coda::nchain(e2)) {
163	!	c[[i]] = c[[i]] + e1
164		}
165	!	return(as.derived.mcmc.list(c))
166		},
167		"-" = {
168		# Subtraction
169	!	c = e2
170	!	for (i in 1:coda::nchain(e2)) {
171	!	c[[i]] = e1 - c[[i]]
172		}
173	!	return(as.derived.mcmc.list(c))
174		},
175		"*" = {
176		# Multiplication
177	!	c = e2
178	!	for (i in 1:coda::nchain(e2)) {
179	!	c[[i]] = c[[i]] * e1
180		}
181	!	return(as.derived.mcmc.list(c))
182		},
183		"/" = {
184		# Division
185	!	c = e2
186	!	for (i in 1:coda::nchain(e2)) {
187	!	c[[i]] = e1 / c[[i]]
188		}
189	!	return(as.derived.mcmc.list(c))
190		},
191	!	stop("Undefined operation for mcmc.list object and numeric")
192		)
193		}
194		}
195
196		### * Math.mcmc.list()
197
198		#' Math generics for mcmc.list objects
199		#'
200		#' @param x \code{\link[coda]{mcmc.list}} object
201		#' @param ... Other arguments passed to corresponding methods
202		#'
203		#' @return A \code{mcmc.list} object (with the added class
204		#' \code{derived.mcmc.list}).
205		#'
206		#' @method Math mcmc.list
207		#'
208		#' @export
209
210		Math.mcmc.list = function(x, ...) {
211	!	out = lapply(x, .Generic, ...)
212	!	out = lapply(out, coda::mcmc)
213	!	out = coda::mcmc.list(out)
214	!	out = as.derived.mcmc.list(out)
215	!	return(out)
216		}
217
218		### * select.mcmc.list()
219
220		#' Select parameters based on their names
221		#'
222		#' @param .data A \code{coda::mcmc.list} object.
223		#' @param ... Strings used to select variables using pattern matching with
224		#' \code{grepl}.
225		#'
226		#' @return An \code{mcmc.list} object, with the same extra class(es) as
227		#' \code{.data} (if any).
228		#'
229		#' @method select mcmc.list
230		#' @export
231
232		select.mcmc.list <- function(.data, ...) {
233	!	params <- coda::varnames(.data)
234	!	patterns <- rlang::ensyms(...)
235	!	patterns <- purrr::map(patterns, rlang::as_string)
236	!	matches <- lapply(patterns, function(p) which(grepl(p, params)))
237	!	matches <- sort(unique(unlist(matches)))
238	!	if (length(matches) == 0) { return(NULL) }
239	!	out <- .data[, matches]
240	!	class(out) <- class(.data)
241	!	return(out)
242		}
243
244
245		### * c.mcmc.list()
246
247		#' Combine mcmc.list objects
248		#'
249		#' @param ... \code{mcmc.list} objects.
250		#'
251		#' @return A \code{mcmc.list} object.
252		#'
253		#' @method c mcmc.list
254		#' @export
255
256		c.mcmc.list <- function(...) {
257	!	z <- list(...)
258	!	is_mcmc.list <- sapply(z, function(x) is(x, "mcmc.list"))
259	!	if (!all(is_mcmc.list)) {
260	!	stop("Not all arguments are mcmc.list objects.")
261		}
262	!	if (length(z) == 1) {
263	!	return(z)
264		}
265		# Check objects compatibility
266	!	areCompatible <- function(m1, m2) {
267	!	COMPATIBLE <- TRUE
268	!	if (coda::nchain(m1) != coda::nchain(m2)) {
269	!	COMPATIBLE <- FALSE
270	!	} else if (coda::niter(m1) != coda::niter(m2)) {
271	!	COMPATIBLE <- FALSE
272	!	} else if (!all(coda::mcpar(m1[[1]]) == coda::mcpar(m2[[1]]))) {
273	!	COMPATIBLE <- FALSE
274		}
275	!	return(COMPATIBLE)
276		}
277	!	if (is.null(coda::mcpar(z[[1]]))) {
278	!	if (is.null(coda::mcpar(z[[1]][[1]]))) {
279	!	stop("One mcmc.list object has no mcpar attribute.")
280		}
281	!	attr(z[[1]], "mcpar") <- coda::mcpar(z[[1]][[1]])
282		}
283	!	for (i in 2:length(z)) {
284	!	if (is.null(coda::mcpar(z[[i]]))) {
285	!	if (is.null(coda::mcpar(z[[i]][[1]]))) {
286	!	stop("One mcmc.list object has no mcpar attribute.")
287		}
288	!	attr(z[[i]], "mcpar") <- coda::mcpar(z[[i]][[1]])
289		}
290	!	compatible <- areCompatible(z[[1]], z[[i]])
291	!	if (!compatible) {
292	!	stop("Not all provided mcmc.list objects are compatible.")
293		}
294		}
295		# Check that no variable is unnamed
296	!	var_names <- lapply(z, coda::varnames)
297	!	for (i in seq_along(var_names)) {
298	!	if (is.null(var_names[[i]])) {
299		# Check that there is only one variable
300	!	if (coda::nvar(z[[i]]) > 1) {
301	!	stop("One mcmc.list does not have a variable name and contains more than one variable.")
302		}
303		# Check that a name was provided
304	!	if (is.null(names(z)) \|\| names(z)[i] == "") {
305	!	stop("Some mcmc.list have unnamed variables.\n",
306	!	"You should pass those mcmc.list to c(...) using named arguments.")
307		}
308		# Name the variable
309	!	x <- z[[i]]
310	!	var_name <- names(z)[i]
311	!	mcpars <- coda::mcpar(x)
312	!	x <- lapply(x, function(y) {
313	!	out <- array(as.vector(y), dim = c(length(as.vector(y)), 1))
314	!	colnames(out) <- var_name
315	!	out <- coda::as.mcmc(out)
316	!	attr(out, "mcpar") <- attr(y, "mcpar")
317	!	out
318		})
319	!	attr(x, "mcpar") <- attr(z[[i]], "mcpar")
320	!	class(x) <- class(z[[i]])
321	!	z[[i]] <- x
322		}
323		}
324		# Check that no variable names is present twice
325	!	var_names <- lapply(z, coda::varnames)
326	!	if (length(var_names) != length(unique(var_names))) {
327	!	stop("Some variable names are duplicated.")
328		}
329		# Combine the variables
330	!	n_chains <- coda::nchain(z[[1]])
331	!	out <- lapply(seq_len(n_chains), function(i) {
332	!	variables <- lapply(z, function(y) y[[i]])
333	!	combined <- coda::as.mcmc(do.call(cbind, variables))
334	!	attr(combined, "mcpar") <- attr(z[[1]][[1]], "mcpar")
335	!	combined
336		})
337	!	out <- coda::as.mcmc.list(out)
338	!	attr(out, "mcpar") <- attr(z[[1]], "mcpar")
339	!	return(as.derived.mcmc.list(out))
340		}
341
342		### * `[.networkModelStanfit`()
343
344		#' Subset method for \code{networkModelStanfit} objects
345		#'
346		#' @param x A \code{networkModelStanfit} object.
347		#' @param i A vector of iteration indices.
348		#' @param j A vector of parameter names or indices.
349		#' @param drop Boolean.
350		#'
351		#' @return A \code{networkModelStanfit} object.
352		#'
353		#' @method [ networkModelStanfit
354		#'
355		#' @export
356
357		`[.networkModelStanfit` <- function(x, i, j, drop = TRUE) {
358	!	o <- NextMethod()
359	!	class(o) <- c("networkModelStanfit", class(o))
360	!	return(o)
361		}

1		### * All functions in this file are exported
2
3		### * Ops.topology()
4
5		# Based on
6		# ?groupGeneric
7		# ?.Generic
8		# https://stackoverflow.com/questions/35902360/r-implement-group-generics-ops-to-enable-comparison-of-s3-objects
9		# (cdeterman answer in the above)
10
11		#' Ops generics for \code{topology} objects
12		#'
13		#' @param e1 First operand
14		#' @param e2 Second operand
15		#'
16		#' @return Boolean (or throws an error for unsupported operators).
17		#'
18		#' @examples
19		#' topo(aquarium_mod) == topo(trini_mod)
20		#' topo(aquarium_mod) == topo(aquarium_mod)
21		#'
22		#' @method Ops topology
23		#'
24		#' @export
25
26		Ops.topology <- function(e1, e2) {
27	6x	op <- .Generic[[1]]
28	6x	if (!(is(e1, "topology") & is(e2, "topology"))) {
29	!	stop("Both objects must be topologies!")
30		}
31	6x	switch(op,
32		"==" = {
33		# Equality
34	5x	if (ncol(e1) != ncol(e2)) {
35	3x	return(FALSE)
36		}
37	2x	if (!setequal(colnames(e1), colnames(e2))) {
38	!	return(FALSE)
39		}
40	2x	e2 <- e2[match(colnames(e2), colnames(e1)), ]
41	2x	e2 <- e2[, match(rownames(e2), rownames(e1))]
42	2x	if (!all(unclass(e1) == unclass(e2))) {
43	!	return(FALSE)
44		}
45	2x	e1_split <- attr(e1, "split")
46	2x	e2_split <- attr(e2, "split")
47	2x	split_compatible <- (
48	2x	(is.null(e1_split) & is.null(e2_split)) \|
49	2x	(!is.null(e1_split) && !is.null(e2_split) &&
50	2x	all(sort(e1_split) == sort(e2_split)))
51		)
52	2x	if (!split_compatible) {
53	1x	return(FALSE)
54		}
55	1x	e1_steadyState <- attr(e1, "steadyState")
56	1x	e2_steadyState <- attr(e2, "steadyState")
57	1x	steadyState_compatible <- (
58	1x	(is.null(e1_steadyState) & is.null(e2_steadyState)) \|
59	1x	(!is.null(e1_steadyState) && !is.null(e2_steadyState) &&
60	1x	all(sort(e1_steadyState) == sort(e2_steadyState)))
61		)
62	1x	if (!steadyState_compatible) {
63	!	return(FALSE)
64		}
65	1x	return(TRUE)
66		},
67		"!=" = {
68		# Difference
69	1x	return(!(e1 == e2))
70		},
71	!	stop("Undefined operation for topology objects: `", op, "`"))
72		}
73
74		### * Methods for nice display of topologies
75
76		### ** print.topology()
77
78		#' Pretty printing of a \code{topology} object
79		#'
80		#' @param x An object of class \code{topology}.
81		#' @param help If TRUE, display a short help after the topology object
82		#' explaining e.g. the steady state or the split compartment symbols.
83		#' @param ... Not used.
84		#'
85		#' @return Mostly called for its side effect (printing).
86		#'
87		#' @export
88
89		print.topology <- function(x, help = TRUE, ...) {
90	!	attr(x, "class") <- NULL
91	!	nComps <- ncol(x)
92	!	steady <- attr(x, "steadyState")
93	!	split <- attr(x, "split")
94	!	merge <- attr(x, "merge")
95	!	for (s in steady) {
96	!	i <- which(colnames(x) == s)
97	!	colnames(x)[i] <- paste0(s, "*")
98	!	rownames(x)[i] <- paste0(s, "*")
99		}
100	!	for (s in split) {
101	!	i <- which(colnames(x) == s)
102	!	colnames(x)[i] <- paste0(s, "<\|>")
103	!	rownames(x)[i] <- paste0(s, "<\|>")
104		}
105	!	attr(x, "steadyState") <- NULL
106	!	attr(x, "split") <- NULL
107	!	attr(x, "merge") <- NULL
108	!	cat(paste0("<", nComps, " comps>"), "\n")
109	!	print(x)
110	!	if (help) {
111	!	if (length(steady) > 0) {
112	!	cat("[ * : steady-state]", "\n")
113		}
114	!	if (length(split) > 0) {
115	!	cat("[<\|>: split]", "\n")
116		}
117	!	if (!is.null(merge)) {
118	!	for (i in seq_along(merge)) {
119	!	cat("[", names(merge)[i], " = ", merge[[i]][1], " + ", merge[[i]][2], "]", "\n",
120	!	sep = "")
121		}
122		}
123		}
124	!	invisible(x)
125		}
126
127		### * as_tbl_graph() generic and method
128
129		#' Generic for as_tbl_graph()
130		#'
131		#' Convert a compatible object to a tbl_graph object (from the tidygraph package)
132		#'
133		#' @param x Object to convert to a tbl_graph.
134		#' @param ... Passed to the appropriate method.
135		#'
136		#' @return A tbl_graph object.
137		#'
138		#' @export
139
140		as_tbl_graph <- function(x, ...) {
141	9x	UseMethod("as_tbl_graph")
142		}
143
144		#' Convert a network topology to a tbl_graph
145		#'
146		#' @param x A network topology.
147		#' @param ... Not used.
148		#'
149		#' @return A tbl_graph object.
150		#'
151		#' @export
152
153		# Note for testing:
154		# https://community.rstudio.com/t/how-can-i-make-testthat-think-i-dont-have-a-package-installed/33441/2
155
156		as_tbl_graph.topology <- function(x, ...) {
157	9x	if (!requireNamespace("tidygraph", quietly = TRUE)) {
158	!	stop("Package \"tidygraph\" needed for this function to work. Please install it.",
159	!	call. = FALSE)
160		}
161	9x	if (!requireNamespace("igraph", quietly = TRUE)) {
162	!	stop("Package \"igraph\" needed for this function to work. Please install it.",
163	!	call. = FALSE)
164		}
165	9x	graph <- igraph::graph_from_adjacency_matrix(t(x))
166	9x	t_graph <- tidygraph::as_tbl_graph(graph)
167	9x	steady_state <- attr(x, "steadyState")
168	9x	split <- attr(x, "split")
169	9x	attributes <- tibble::tibble(name = colnames(x))
170	9x	attributes[["steady_state"]] <- attributes[["name"]] %in% steady_state
171	9x	attributes[["split"]] <- attributes[["name"]] %in% split
172	9x	t_graph <- dplyr::left_join(t_graph, attributes, by = "name")
173	9x	return(t_graph)
174		}