rk_order <- function(A, b, tol = 1e-12) {
A <- as.matrix(A); b <- as.numeric(b)
s <- nrow(A); one <- rep(1, s)
cc <- as.numeric(A %*% one) # stage consistency defines c
d <- as.numeric(A %*% cc)
e <- as.numeric(t(A) %*% b)
ok <- function(x, target) abs(x - target) < tol
lev <- list(
`1` = c(sum(b) - 1),
`2` = c(sum(b * cc) - 1/2),
`3` = c(sum(b * cc^2) - 1/3, sum(b * d) - 1/6),
`4` = c(sum(b * cc^3) - 1/4, sum(b * cc * d) - 1/8,
sum(e * cc^2) - 1/12, sum(e * d) - 1/24)
)
p <- 0
for (k in names(lev)) {
if (all(abs(lev[[k]]) < tol)) p <- as.integer(k) else break
}
p
}
g <- sqrt(3) / 6
tableaux <- list(
"Explicit Euler" = list(A = matrix(0, 1, 1), b = 1),
"Explicit midpoint" = list(A = rbind(c(0,0), c(1/2,0)), b = c(0,1)),
"Ralston 2" = list(A = rbind(c(0,0), c(2/3,0)), b = c(1/4,3/4)),
"RK3" = list(A = rbind(c(0,0,0), c(1/2,0,0), c(-1,2,0)),
b = c(1/6,2/3,1/6)),
"RK4 (classical)" = list(A = rbind(c(0,0,0,0), c(1/2,0,0,0),
c(0,1/2,0,0), c(0,0,1,0)),
b = c(1/6,1/3,1/3,1/6)),
"RK4 (3/8 rule)" = list(A = rbind(c(0,0,0,0), c(1/3,0,0,0),
c(-1/3,1,0,0), c(1,-1,1,0)),
b = c(1/8,3/8,3/8,1/8)),
"Implicit midpoint" = list(A = matrix(1/2, 1, 1), b = 1),
"Crank--Nicolson" = list(A = rbind(c(0,0), c(1/2,1/2)), b = c(1/2,1/2)),
"Gauss--Legendre 4" = list(A = rbind(c(1/4, 1/4 - g), c(1/4 + g, 1/4)),
b = c(1/2,1/2)),
"Lobatto IIIA 4" = list(A = rbind(c(0,0,0), c(5/24,1/3,-1/24),
c(1/6,2/3,1/6)),
b = c(1/6,2/3,1/6)),
"Lobatto IIIB 4" = list(A = rbind(c(1/6,-1/6,0), c(1/6,1/3,0),
c(1/6,5/6,0)),
b = c(1/6,2/3,1/6))
)
res <- data.frame(
Method = names(tableaux),
Stages = vapply(tableaux, function(m) nrow(as.matrix(m$A)), integer(1)),
Order = vapply(tableaux, function(m) rk_order(m$A, m$b), integer(1)),
row.names = NULL
)
knitr::kable(res, align = "lrr",
caption = "Order determined from the conditions of @eq-order-conditions-table (capped at 4).")