Go back to the About page. This link might be useful to keep track of the files created during the preprocessing.
Let us set some global options for all code chunks in this document.
# Set seed for reproducibility
set.seed(1982)
# Set global options for all code chunks
knitr::opts_chunk$set(
# Disable messages printed by R code chunks
message = FALSE,
# Disable warnings printed by R code chunks
warning = FALSE,
# Show R code within code chunks in output
echo = TRUE,
# Include both R code and its results in output
include = TRUE,
# Evaluate R code chunks
eval = TRUE,
# Enable caching of R code chunks for faster rendering
cache = FALSE,
# Align figures in the center of the output
fig.align = "center",
# Enable retina display for high-resolution figures
retina = 2,
# Show errors in the output instead of stopping rendering
error = TRUE,
# Do not collapse code and output into a single block
collapse = FALSE
)
# Start the figure counter
fig_count <- 0
# Define the captioner function
captioner <- function(caption) {
fig_count <<- fig_count + 1
paste0("Figure ", fig_count, ": ", caption)
}
Press the Show button below to reveal the code.
# library calls
library(MetricGraph)
library(Matrix)
library(rSPDE)
# function 1
gets_graph_interval <- function(n){
edge <- rbind(c(0,0),c(1,0))
edges = list(edge)
graph <- metric_graph$new(edges = edges)
graph$build_mesh(n = n)
return(graph)
}
# matern covariance function. Same as in the package
matern.covariance <- function(h, kappa, nu, sigma) {
if (nu == 1 / 2) {
C <- sigma^2 * exp(-kappa * abs(h))
} else {
C <- (sigma^2 / (2^(nu - 1) * gamma(nu))) *
((kappa * abs(h))^nu) * besselK(kappa * abs(h), nu)
}
C[h == 0] <- sigma^2
return(as.matrix(C))
}
# folded.matern.covariance.1d I edited
folded.matern.covariance.1d.local <- function(x, kappa, nu, sigma,
L = 1, N = 10,
boundary = c("neumann",
"dirichlet", "periodic")) {
boundary <- tolower(boundary[1])
if (!(boundary %in% c("neumann", "dirichlet", "periodic"))) {
stop("The possible boundary conditions are 'neumann',
'dirichlet' or 'periodic'!")
}
addi = t(outer(x, x, "+"))
diff = t(outer(x, x, "-"))
s1 <- sapply(-N:N, function(j) {
diff + 2 * j * L
})
s2 <- sapply(-N:N, function(j) {
addi + 2 * j * L
})
if (boundary == "neumann") {
C <- rowSums(matern.covariance(h = s1, kappa = kappa,
nu = nu, sigma = sigma) +
matern.covariance(h = s2, kappa = kappa,
nu = nu, sigma = sigma))
} else if (boundary == "dirichlet") {
C <- rowSums(matern.covariance(h = s1, kappa = kappa,
nu = nu, sigma = sigma) -
matern.covariance(h = s2, kappa = kappa,
nu = nu, sigma = sigma))
} else {
C <- rowSums(matern.covariance(h = s1,
kappa = kappa, nu = nu, sigma = sigma))
}
return(matrix(C, nrow = length(x)))
}
# function 2
gets_true_cov_mat = function(graph, kappa, nu, sigma, N, boundary){
h = graph$mesh$V[,1]
true_cov_mat = folded.matern.covariance.1d.local(x = h, kappa = kappa, nu = nu, sigma = sigma, N = N, boundary = boundary)
return(true_cov_mat)
}
# parameters
n_vector = c(998, 198, 98, 8)
type_vector = c("covariance", "operator")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
rho_vector = c(0.1, 0.5, 1, 2)
m_vector = c(0,1,2,3,4,5)
nu_vector = c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))
boundary = "neumann"
sigma = 1
N.folded = 10
Error = list()
for (s in c(1,2,3,4)) { # loop over n_vector
Error[[as.character(n_vector[s])]] = list()
n = n_vector[s]
graph = gets_graph_interval(n = n)
for (i in c(1)) { # loop over type_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]] = list()
type = type_vector[i]
for (j in c(1,2,3)) { # loop over type_rational_approximation_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]] = list()
type_rational_approximation = type_rational_approximation_vector[j]
for (k in c(1,2,3,4)) { # loop over rho_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]] = list()
rho = rho_vector[k]
for (l in 1:length(m_vector)) { # loop over m_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]] = matrix(NA, nrow = length(nu_vector), ncol = 2)
colnames(Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]]) = c("L_inf_error", "L_2_error")
m = m_vector[l]
for (r in 1:length(nu_vector)) { # loop over nu_vector
nu = nu_vector[r]
kappa = sqrt(8*nu)/rho
tau = sqrt(gamma(nu) / (sigma^2 * kappa^(2*nu) * (4*pi)^(1/2) * gamma(nu + 1/2))) #sigma = 1, d = 1
alpha = nu + 1/2
tryCatch({
# getting true covariance
true_cov_mat = gets_true_cov_mat(graph = graph,
kappa = kappa,
nu = nu,
sigma = sigma,
N = N.folded,
boundary = boundary)
# getting the approximate covariance matrix
op = matern.operators(alpha = alpha,
kappa = kappa,
tau = tau,
m = m,
graph = graph,
type = type,
type_rational_approximation = type_rational_approximation)
appr_cov_mat = op$covariance_mesh()
# computing the errors
L_inf_error = max(abs(true_cov_mat - appr_cov_mat))
L_2_error = sqrt(as.double(t(graph$mesh$weights)%*%(true_cov_mat - appr_cov_mat)^2%*%graph$mesh$weights))
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,1] = L_inf_error
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,2] = L_2_error
}, error = function(err){
warning(paste("Error occurred at iteration n=", n, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
print(paste("Error occurred at iteration n=", n, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,1] = NA
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,2] = NA
})
print(paste("n=", n, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu))
}
}
}
}
}
}
Error_interval_DEF = Error
save(Error_interval_DEF, file = here("data_files/Error_interval_DEF.RData"))
load(here("data_files/Error_interval_DEF.RData"))
n_vector = c("998", "198", "98", "8")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
nu_max = 53
nu_vector = 0.5 + c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))[1:nu_max]
n = "998"
t = "chebfun"
dat = rbind(
data.frame(nu = rep(nu_vector,5),
rho = rep(0.1, times = 5*nu_max),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["1"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["2"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["3"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["4"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(0.5, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["1"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["2"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["3"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["4"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(1, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["1"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["2"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["3"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["4"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(2, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["1"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["2"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["3"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["4"]][1:nu_max,1],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
## L2
data.frame(nu = rep(nu_vector,5),
rho = rep(0.1, times = 5*nu_max),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["1"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["2"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["3"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["4"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.1"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(0.5, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["1"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["2"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["3"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["4"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["0.5"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(1, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["1"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["2"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["3"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["4"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["1"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(2, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["1"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["2"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["3"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["4"]][1:nu_max,2],
Error_interval_DEF[[n]][["covariance"]][[t]][["2"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
)
)
dat$rho = factor(dat$rho, levels = c("0.1", "0.5", "1", "2"))
dat$L = factor(dat$L, levels = c("L2", "Linf"))
levels(dat$rho) = c("0.1" = latex2exp::TeX("$\\rho = 0.1$"), "0.5" = latex2exp::TeX("$\\rho = 0.5$"), "1" = latex2exp::TeX("$\\rho = 1$"), "2" = latex2exp::TeX("$\\rho = 2$"))
levels(dat$L) = c("L2" = latex2exp::TeX("$L_2(\\Gamma\\times\\Gamma)$ error"), "Linf" = latex2exp::TeX("$L_\\infty(\\Gamma\\times\\Gamma)$ error"))
p <- ggplot(dat, aes(nu, error, colour = as.factor(m))) +
facet_grid(L ~ rho, labeller = label_parsed) +
geom_line() +
scale_y_log10(n.breaks = 5) +
scale_x_continuous(n.breaks = 10) +
theme_bw() +
theme(panel.spacing = unit(0.3, "cm"), text = element_text(family = "Palatino"),
plot.title = element_text(size = 16),
strip.text = element_text(size = 12), # Panel titles
axis.title = element_text(size = 14), # Axis titles
axis.text = element_text(size = 12), # Axis text
legend.title = element_text(size = 14), # Legend title
legend.text = element_text(size = 12)) +
labs(x = bquote(alpha ~ "(smoothness parameter)"), y = "Covariance Error", color = "m") + ggtitle("Interval graph")
Figure 1: Covariance error for the interval graph.
Press the Show button below to reveal the code.
# library calls
library(MetricGraph)
library(Matrix)
library(rSPDE)
# function 1
gets_graph_circle <- function(n){
r = 1/(pi)
theta <- seq(from=-pi,to=pi,length.out = 10000)
edge <- cbind(1+r+r*cos(theta),r*sin(theta))
edges = list(edge)
graph <- metric_graph$new(edges = edges)
graph$set_manual_edge_lengths(edge_lengths = 2)
graph$build_mesh(n = n)
return(graph)
}
# matern covariance function. Same as in the package
matern.covariance <- function(h, kappa, nu, sigma) {
if (nu == 1 / 2) {
C <- sigma^2 * exp(-kappa * abs(h))
} else {
C <- (sigma^2 / (2^(nu - 1) * gamma(nu))) *
((kappa * abs(h))^nu) * besselK(kappa * abs(h), nu)
}
C[h == 0] <- sigma^2
return(as.matrix(C))
}
# folded.matern.covariance.1d I edited
folded.matern.covariance.1d.local <- function(x, kappa, nu, sigma, L = 1, N = 10, boundary = c("neumann",
"dirichlet", "periodic")) {
boundary <- tolower(boundary[1])
if (!(boundary %in% c("neumann", "dirichlet", "periodic"))) {
stop("The possible boundary conditions are 'neumann',
'dirichlet' or 'periodic'!")
}
addi = t(outer(x, x, "+"))
diff = t(outer(x, x, "-"))
s1 <- sapply(-N:N, function(j) { # s1 is a matrix of size length(h)x(2N+1)
diff + 2 * j * L
})
s2 <- sapply(-N:N, function(j) {
addi + 2 * j * L
})
if (boundary == "neumann") {
C <- rowSums(matern.covariance(h = s1, kappa = kappa,
nu = nu, sigma = sigma) +
matern.covariance(h = s2, kappa = kappa,
nu = nu, sigma = sigma))
} else if (boundary == "dirichlet") {
C <- rowSums(matern.covariance(h = s1, kappa = kappa,
nu = nu, sigma = sigma) -
matern.covariance(h = s2, kappa = kappa,
nu = nu, sigma = sigma))
} else {
C <- rowSums(matern.covariance(h = s1,
kappa = kappa, nu = nu, sigma = sigma))
}
return(matrix(C, nrow = length(x)))
}
# function 2
gets_true_cov_mat = function(graph, kappa, nu, sigma, N, boundary){
h = c(0,graph$get_edge_lengths()[1]*graph$mesh$PtE[,2])
true_cov_mat = folded.matern.covariance.1d.local(x = h, kappa = kappa, nu = nu, sigma = sigma, N = N, boundary = boundary)
return(true_cov_mat)
}
# parameters
n_vector = 2*c(998, 198, 98, 8)
type_vector = c("covariance", "operator")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
rho_vector = c(0.1, 0.5, 1, 2)
m_vector = c(0,1,2,3,4,5)
nu_vector = c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))
boundary = "periodic"
sigma = 1
N.folded = 10
Error = list()
for (s in c(1,2,3,4)) { # loop over n_vector
Error[[as.character(n_vector[s])]] = list()
n = n_vector[s]
graph = gets_graph_circle(n = n)
for (i in c(1)) { # loop over type_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]] = list()
type = type_vector[i]
for (j in c(1,2,3)) { # loop over type_rational_approximation_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]] = list()
type_rational_approximation = type_rational_approximation_vector[j]
for (k in c(1,2,3,4)) { # loop over rho_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]] = list()
rho = rho_vector[k]
for (l in 1:length(m_vector)) { # loop over m_vector
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]] = matrix(NA, nrow = length(nu_vector), ncol = 2)
colnames(Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]]) = c("L_inf_error", "L_2_error")
m = m_vector[l]
for (r in 1:length(nu_vector)) { # loop over nu_vector
nu = nu_vector[r]
kappa = sqrt(8*nu)/rho
tau = sqrt(gamma(nu) / (sigma^2 * kappa^(2*nu) * (4*pi)^(1/2) * gamma(nu + 1/2))) #sigma = 1, d = 1
alpha = nu + 1/2
tryCatch({
# getting true covariance
true_cov_mat = gets_true_cov_mat(graph = graph,
kappa = kappa,
nu = nu,
sigma = sigma,
N = N.folded,
boundary = boundary)
# getting the approximate covariance matrix
op = matern.operators(alpha = alpha,
kappa = kappa,
tau = tau,
m = m,
graph = graph,
type = type,
type_rational_approximation = type_rational_approximation)
appr_cov_mat = op$covariance_mesh()
# computing the errors
L_inf_error = max(abs(true_cov_mat - appr_cov_mat))
L_2_error = sqrt(as.double(t(graph$mesh$weights)%*%(true_cov_mat - appr_cov_mat)^2%*%graph$mesh$weights))
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,1] = L_inf_error
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,2] = L_2_error
}, error = function(err){
warning(paste("Error occurred at iteration n=", n, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
print(paste("Error occurred at iteration n=", n, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,1] = NA
Error[[as.character(n_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][r,2] = NA
})
print(paste("n=", n, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu))
}
}
}
}
}
}
Error_circle_DEF = Error
save(Error_circle_DEF, file = here("data_files/Error_circle_DEF.RData"))
load(here("data_files/Error_circle_DEF.RData"))
n_vector = c("1996", "396", "196", "16")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
nu_max = 53
nu_vector = 0.5 + c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))[1:nu_max]
n = "1996"
t = "chebfun"
dat = rbind(
data.frame(nu = rep(nu_vector,5),
rho = rep(0.1, times = 5*nu_max),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["1"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["2"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["3"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["4"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(0.5, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["1"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["2"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["3"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["4"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(1, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["1"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["2"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["3"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["4"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(2, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["1"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["2"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["3"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["4"]][1:nu_max,1],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
## L2
data.frame(nu = rep(nu_vector,5),
rho = rep(0.1, times = 5*nu_max),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["1"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["2"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["3"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["4"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.1"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(0.5, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["1"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["2"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["3"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["4"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["0.5"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(1, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["1"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["2"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["3"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["4"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["1"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(2, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["1"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["2"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["3"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["4"]][1:nu_max,2],
Error_circle_DEF[[n]][["covariance"]][[t]][["2"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
)
)
dat$rho = factor(dat$rho, levels = c("0.1", "0.5", "1", "2"))
dat$L = factor(dat$L, levels = c("L2", "Linf"))
levels(dat$rho) = c("0.1" = latex2exp::TeX("$\\rho = 0.1$"), "0.5" = latex2exp::TeX("$\\rho = 0.5$"), "1" = latex2exp::TeX("$\\rho = 1$"), "2" = latex2exp::TeX("$\\rho = 2$"))
levels(dat$L) = c("L2" = latex2exp::TeX("$L_2(\\Gamma\\times\\Gamma)$ error"), "Linf" = latex2exp::TeX("$L_\\infty(\\Gamma\\times\\Gamma)$ error"))
p <- ggplot(dat, aes(nu, error, colour = as.factor(m))) +
facet_grid(L ~ rho, labeller = label_parsed) +
geom_line() +
scale_y_log10(n.breaks = 5) +
scale_x_continuous(n.breaks = 10) +
theme_bw() +
theme(panel.spacing = unit(0.3, "cm"), text = element_text(family = "Palatino"),
plot.title = element_text(size = 16),
strip.text = element_text(size = 12), # Panel titles
axis.title = element_text(size = 14), # Axis titles
axis.text = element_text(size = 12), # Axis text
legend.title = element_text(size = 14), # Legend title
legend.text = element_text(size = 12)) +
labs(x = bquote(alpha ~ "(smoothness parameter)"), y = "Covariance Error", color = "m") + ggtitle("Circle graph")
Figure 2: Covariance error for the circle graph.
rho = 0.1
Press the Show button below to reveal the code.
# library calls
library(MetricGraph)
library(Matrix)
library(rSPDE)
# function 1
tadpole.eig <- function(k,graph){
x1 <- c(0,graph$get_edge_lengths()[1]*graph$mesh$PtE[graph$mesh$PtE[,1]==1,2])
x2 <- c(0,graph$get_edge_lengths()[2]*graph$mesh$PtE[graph$mesh$PtE[,1]==2,2])
if(k==0){
f.e1 <- rep(1,length(x1))
f.e2 <- rep(1,length(x2))
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- -2*sin(pi*k*1/2)*cos(pi*k*x1/2)
f.e2 <- sin(pi*k*x2/2)
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
if((k %% 2)==1){
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- (-1)^{k/2}*cos(pi*k*x1/2)
f.e2 <- cos(pi*k*x2/2)
f2 = c(f.e1[1],f.e2[1],f.e1[-1],f.e2[-1])
f <- list(phi=f1,psi=f2/sqrt(3/2))
}
}
return(f)
}
# function 2
gets_graph <- function(h){
edge1 <- rbind(c(0,0),c(1,0))
theta <- seq(from=-pi,to=pi,length.out = 10000)
edge2 <- cbind(1+1/pi+cos(theta)/pi,sin(theta)/pi)
edges = list(edge1, edge2)
graph <- metric_graph$new(edges = edges)
graph$set_manual_edge_lengths(edge_lengths = c(1,2))
graph$build_mesh(h=h)
return(graph)
}
#function 3
gets_true_cov_mat <- function(graph, kappa, tau, alpha, n.overkill){
Sigma.kl <- matrix(0,nrow = dim(graph$mesh$V)[1],ncol = dim(graph$mesh$V)[1])
for(i in 0:n.overkill){
phi <- tadpole.eig(i,graph)$phi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*phi%*%t(phi)
if(i>0 && (i %% 2)==0){
psi <- tadpole.eig(i,graph)$psi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*psi%*%t(psi)
}
}
Sigma.kl <- Sigma.kl/tau^2
return(Sigma.kl)
}
# parameters
h_vector = c(0.001, 0.005, 0.01, 0.1)
type_vector = c("covariance", "operator")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
rho_vector = c(0.1, 0.5, 1, 2)
m_vector = c(0,1,2,3,4,5)
nu_vector = c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))
n.overkill = 1000
sigma = 1
Error = list()
for (s in c(1,2,3,4)) { # loop over h_vector
Error[[as.character(h_vector[s])]] = list()
h = h_vector[s]
graph = gets_graph(h = h)
for (i in c(1)) { # loop over type_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]] = list()
type = type_vector[i]
for (j in c(1,2,3)) { # loop over type_rational_approximation_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]] = list()
type_rational_approximation = type_rational_approximation_vector[j]
for (k in c(1)) { # loop over rho_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]] = list()
rho = rho_vector[k]
for (l in 1:length(m_vector)) { # loop over m_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]] = matrix(NA, nrow = length(nu_vector), ncol = 2)
colnames(Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]]) = c("L_inf_error", "L_2_error")
m = m_vector[l]
for (n in 1:length(nu_vector)) { # loop over nu_vector
nu = nu_vector[n]
kappa = sqrt(8*nu)/rho
tau = sqrt(gamma(nu) / (sigma^2 * kappa^(2*nu) * (4*pi)^(1/2) * gamma(nu + 1/2))) #sigma = 1, d = 1
alpha = nu + 1/2
tryCatch({
# getting true covariance
true_cov_mat = gets_true_cov_mat(graph = graph,
kappa = kappa,
tau = tau,
alpha = alpha,
n.overkill = n.overkill)
# getting the approximate covariance matrix
op = matern.operators(alpha = alpha,
kappa = kappa,
tau = tau,
m = m,
graph = graph,
type = type,
type_rational_approximation = type_rational_approximation)
appr_cov_mat = op$covariance_mesh()
# computing the errors
L_inf_error = max(abs(true_cov_mat - appr_cov_mat))
L_2_error = sqrt(as.double(t(graph$mesh$weights)%*%(true_cov_mat - appr_cov_mat)^2%*%graph$mesh$weights))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = L_inf_error
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = L_2_error
}, error = function(err){
warning(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
print(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = NA
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = NA
})
print(paste("h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu))
}
}
}
}
}
}
Error_tadpole_DEF_rho0.1 = Error
save(Error_tadpole_DEF_rho0.1, file = here("data_files/Error_tadpole_DEF_rho0.1.RData"))
rho = 0.5
Press the Show button below to reveal the code.
# library calls
library(MetricGraph)
library(Matrix)
library(rSPDE)
# function 1
tadpole.eig <- function(k,graph){
x1 <- c(0,graph$get_edge_lengths()[1]*graph$mesh$PtE[graph$mesh$PtE[,1]==1,2])
x2 <- c(0,graph$get_edge_lengths()[2]*graph$mesh$PtE[graph$mesh$PtE[,1]==2,2])
if(k==0){
f.e1 <- rep(1,length(x1))
f.e2 <- rep(1,length(x2))
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- -2*sin(pi*k*1/2)*cos(pi*k*x1/2)
f.e2 <- sin(pi*k*x2/2)
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
if((k %% 2)==1){
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- (-1)^{k/2}*cos(pi*k*x1/2)
f.e2 <- cos(pi*k*x2/2)
f2 = c(f.e1[1],f.e2[1],f.e1[-1],f.e2[-1])
f <- list(phi=f1,psi=f2/sqrt(3/2))
}
}
return(f)
}
# function 2
gets_graph <- function(h){
edge1 <- rbind(c(0,0),c(1,0))
theta <- seq(from=-pi,to=pi,length.out = 10000)
edge2 <- cbind(1+1/pi+cos(theta)/pi,sin(theta)/pi)
edges = list(edge1, edge2)
graph <- metric_graph$new(edges = edges)
graph$set_manual_edge_lengths(edge_lengths = c(1,2))
graph$build_mesh(h=h)
return(graph)
}
#function 3
gets_true_cov_mat <- function(graph, kappa, tau, alpha, n.overkill){
Sigma.kl <- matrix(0,nrow = dim(graph$mesh$V)[1],ncol = dim(graph$mesh$V)[1])
for(i in 0:n.overkill){
phi <- tadpole.eig(i,graph)$phi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*phi%*%t(phi)
if(i>0 && (i %% 2)==0){
psi <- tadpole.eig(i,graph)$psi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*psi%*%t(psi)
}
}
Sigma.kl <- Sigma.kl/tau^2
return(Sigma.kl)
}
# parameters
h_vector = c(0.001, 0.005, 0.01, 0.1)
type_vector = c("covariance", "operator")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
rho_vector = c(0.1, 0.5, 1, 2)
m_vector = c(0,1,2,3,4,5)
nu_vector = c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))
n.overkill = 1000
sigma = 1
Error = list()
for (s in c(1,2,3,4)) { # loop over h_vector
Error[[as.character(h_vector[s])]] = list()
h = h_vector[s]
graph = gets_graph(h = h)
for (i in c(1)) { # loop over type_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]] = list()
type = type_vector[i]
for (j in c(1,2,3)) { # loop over type_rational_approximation_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]] = list()
type_rational_approximation = type_rational_approximation_vector[j]
for (k in c(2)) { # loop over rho_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]] = list()
rho = rho_vector[k]
for (l in 1:length(m_vector)) { # loop over m_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]] = matrix(NA, nrow = length(nu_vector), ncol = 2)
colnames(Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]]) = c("L_inf_error", "L_2_error")
m = m_vector[l]
for (n in 1:length(nu_vector)) { # loop over nu_vector
nu = nu_vector[n]
kappa = sqrt(8*nu)/rho
tau = sqrt(gamma(nu) / (sigma^2 * kappa^(2*nu) * (4*pi)^(1/2) * gamma(nu + 1/2))) #sigma = 1, d = 1
alpha = nu + 1/2
tryCatch({
# getting true covariance
true_cov_mat = gets_true_cov_mat(graph = graph,
kappa = kappa,
tau = tau,
alpha = alpha,
n.overkill = n.overkill)
# getting the approximate covariance matrix
op = matern.operators(alpha = alpha,
kappa = kappa,
tau = tau,
m = m,
graph = graph,
type = type,
type_rational_approximation = type_rational_approximation)
appr_cov_mat = op$covariance_mesh()
# computing the errors
L_inf_error = max(abs(true_cov_mat - appr_cov_mat))
L_2_error = sqrt(as.double(t(graph$mesh$weights)%*%(true_cov_mat - appr_cov_mat)^2%*%graph$mesh$weights))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = L_inf_error
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = L_2_error
}, error = function(err){
warning(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
print(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = NA
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = NA
})
print(paste("h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu))
}
}
}
}
}
}
Error_tadpole_DEF_rho0.5 = Error
save(Error_tadpole_DEF_rho0.5, file = here("data_files/Error_tadpole_DEF_rho0.5.RData"))
rho = 1
Press the Show button below to reveal the code.
# library calls
library(MetricGraph)
library(Matrix)
library(rSPDE)
# function 1
tadpole.eig <- function(k,graph){
x1 <- c(0,graph$get_edge_lengths()[1]*graph$mesh$PtE[graph$mesh$PtE[,1]==1,2])
x2 <- c(0,graph$get_edge_lengths()[2]*graph$mesh$PtE[graph$mesh$PtE[,1]==2,2])
if(k==0){
f.e1 <- rep(1,length(x1))
f.e2 <- rep(1,length(x2))
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- -2*sin(pi*k*1/2)*cos(pi*k*x1/2)
f.e2 <- sin(pi*k*x2/2)
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
if((k %% 2)==1){
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- (-1)^{k/2}*cos(pi*k*x1/2)
f.e2 <- cos(pi*k*x2/2)
f2 = c(f.e1[1],f.e2[1],f.e1[-1],f.e2[-1])
f <- list(phi=f1,psi=f2/sqrt(3/2))
}
}
return(f)
}
# function 2
gets_graph <- function(h){
edge1 <- rbind(c(0,0),c(1,0))
theta <- seq(from=-pi,to=pi,length.out = 10000)
edge2 <- cbind(1+1/pi+cos(theta)/pi,sin(theta)/pi)
edges = list(edge1, edge2)
graph <- metric_graph$new(edges = edges)
graph$set_manual_edge_lengths(edge_lengths = c(1,2))
graph$build_mesh(h=h)
return(graph)
}
#function 3
gets_true_cov_mat <- function(graph, kappa, tau, alpha, n.overkill){
Sigma.kl <- matrix(0,nrow = dim(graph$mesh$V)[1],ncol = dim(graph$mesh$V)[1])
for(i in 0:n.overkill){
phi <- tadpole.eig(i,graph)$phi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*phi%*%t(phi)
if(i>0 && (i %% 2)==0){
psi <- tadpole.eig(i,graph)$psi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*psi%*%t(psi)
}
}
Sigma.kl <- Sigma.kl/tau^2
return(Sigma.kl)
}
# parameters
h_vector = c(0.001, 0.005, 0.01, 0.1)
type_vector = c("covariance", "operator")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
rho_vector = c(0.1, 0.5, 1, 2)
m_vector = c(0,1,2,3,4,5)
nu_vector = c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))
n.overkill = 1000
sigma = 1
Error = list()
for (s in c(1,2,3,4)) { # loop over h_vector
Error[[as.character(h_vector[s])]] = list()
h = h_vector[s]
graph = gets_graph(h = h)
for (i in c(1)) { # loop over type_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]] = list()
type = type_vector[i]
for (j in c(1,2,3)) { # loop over type_rational_approximation_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]] = list()
type_rational_approximation = type_rational_approximation_vector[j]
for (k in c(3)) { # loop over rho_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]] = list()
rho = rho_vector[k]
for (l in 1:length(m_vector)) { # loop over m_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]] = matrix(NA, nrow = length(nu_vector), ncol = 2)
colnames(Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]]) = c("L_inf_error", "L_2_error")
m = m_vector[l]
for (n in 1:length(nu_vector)) { # loop over nu_vector
nu = nu_vector[n]
kappa = sqrt(8*nu)/rho
tau = sqrt(gamma(nu) / (sigma^2 * kappa^(2*nu) * (4*pi)^(1/2) * gamma(nu + 1/2))) #sigma = 1, d = 1
alpha = nu + 1/2
tryCatch({
# getting true covariance
true_cov_mat = gets_true_cov_mat(graph = graph,
kappa = kappa,
tau = tau,
alpha = alpha,
n.overkill = n.overkill)
# getting the approximate covariance matrix
op = matern.operators(alpha = alpha,
kappa = kappa,
tau = tau,
m = m,
graph = graph,
type = type,
type_rational_approximation = type_rational_approximation)
appr_cov_mat = op$covariance_mesh()
# computing the errors
L_inf_error = max(abs(true_cov_mat - appr_cov_mat))
L_2_error = sqrt(as.double(t(graph$mesh$weights)%*%(true_cov_mat - appr_cov_mat)^2%*%graph$mesh$weights))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = L_inf_error
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = L_2_error
}, error = function(err){
warning(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
print(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = NA
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = NA
})
print(paste("h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu))
}
}
}
}
}
}
Error_tadpole_DEF_rho1 = Error
save(Error_tadpole_DEF_rho1, file = here("data_files/Error_tadpole_DEF_rho1.RData"))
rho = 2
Press the Show button below to reveal the code.
# library calls
library(MetricGraph)
library(Matrix)
library(rSPDE)
# function 1
tadpole.eig <- function(k,graph){
x1 <- c(0,graph$get_edge_lengths()[1]*graph$mesh$PtE[graph$mesh$PtE[,1]==1,2])
x2 <- c(0,graph$get_edge_lengths()[2]*graph$mesh$PtE[graph$mesh$PtE[,1]==2,2])
if(k==0){
f.e1 <- rep(1,length(x1))
f.e2 <- rep(1,length(x2))
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- -2*sin(pi*k*1/2)*cos(pi*k*x1/2)
f.e2 <- sin(pi*k*x2/2)
f1 = c(f.e1[1],f.e2[1],f.e1[-1], f.e2[-1])
if((k %% 2)==1){
f = list(phi=f1/sqrt(3))
} else {
f.e1 <- (-1)^{k/2}*cos(pi*k*x1/2)
f.e2 <- cos(pi*k*x2/2)
f2 = c(f.e1[1],f.e2[1],f.e1[-1],f.e2[-1])
f <- list(phi=f1,psi=f2/sqrt(3/2))
}
}
return(f)
}
# function 2
gets_graph <- function(h){
edge1 <- rbind(c(0,0),c(1,0))
theta <- seq(from=-pi,to=pi,length.out = 10000)
edge2 <- cbind(1+1/pi+cos(theta)/pi,sin(theta)/pi)
edges = list(edge1, edge2)
graph <- metric_graph$new(edges = edges)
graph$set_manual_edge_lengths(edge_lengths = c(1,2))
graph$build_mesh(h=h)
return(graph)
}
#function 3
gets_true_cov_mat <- function(graph, kappa, tau, alpha, n.overkill){
Sigma.kl <- matrix(0,nrow = dim(graph$mesh$V)[1],ncol = dim(graph$mesh$V)[1])
for(i in 0:n.overkill){
phi <- tadpole.eig(i,graph)$phi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*phi%*%t(phi)
if(i>0 && (i %% 2)==0){
psi <- tadpole.eig(i,graph)$psi
Sigma.kl <- Sigma.kl + (1/(kappa^2 + (i*pi/2)^2)^(alpha))*psi%*%t(psi)
}
}
Sigma.kl <- Sigma.kl/tau^2
return(Sigma.kl)
}
# parameters
h_vector = c(0.001, 0.005, 0.01, 0.1)
type_vector = c("covariance", "operator")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
rho_vector = c(0.1, 0.5, 1, 2)
m_vector = c(0,1,2,3,4,5)
nu_vector = c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))
n.overkill = 1000
sigma = 1
Error = list()
for (s in c(1,2,3,4)) { # loop over h_vector
Error[[as.character(h_vector[s])]] = list()
h = h_vector[s]
graph = gets_graph(h = h)
for (i in c(1)) { # loop over type_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]] = list()
type = type_vector[i]
for (j in c(1,2,3)) { # loop over type_rational_approximation_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]] = list()
type_rational_approximation = type_rational_approximation_vector[j]
for (k in c(4)) { # loop over rho_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]] = list()
rho = rho_vector[k]
for (l in 1:length(m_vector)) { # loop over m_vector
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]] = matrix(NA, nrow = length(nu_vector), ncol = 2)
colnames(Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]]) = c("L_inf_error", "L_2_error")
m = m_vector[l]
for (n in 1:length(nu_vector)) { # loop over nu_vector
nu = nu_vector[n]
kappa = sqrt(8*nu)/rho
tau = sqrt(gamma(nu) / (sigma^2 * kappa^(2*nu) * (4*pi)^(1/2) * gamma(nu + 1/2))) #sigma = 1, d = 1
alpha = nu + 1/2
tryCatch({
# getting true covariance
true_cov_mat = gets_true_cov_mat(graph = graph,
kappa = kappa,
tau = tau,
alpha = alpha,
n.overkill = n.overkill)
# getting the approximate covariance matrix
op = matern.operators(alpha = alpha,
kappa = kappa,
tau = tau,
m = m,
graph = graph,
type = type,
type_rational_approximation = type_rational_approximation)
appr_cov_mat = op$covariance_mesh()
# computing the errors
L_inf_error = max(abs(true_cov_mat - appr_cov_mat))
L_2_error = sqrt(as.double(t(graph$mesh$weights)%*%(true_cov_mat - appr_cov_mat)^2%*%graph$mesh$weights))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = L_inf_error
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = L_2_error
}, error = function(err){
warning(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
print(paste("Error occurred at iteration h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu, "Error:", conditionMessage(err)))
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,1] = NA
Error[[as.character(h_vector[s])]][[type_vector[i]]][[type_rational_approximation_vector[j]]][[as.character(rho_vector[k])]][[as.character(m_vector[l])]][n,2] = NA
})
print(paste("h=", h, ",type=", type, ",type_rational_approximation=", type_rational_approximation, ",rho=", rho, ",m=", m, ",nu=", nu))
}
}
}
}
}
}
Error_tadpole_DEF_rho2 = Error
save(Error_tadpole_DEF_rho2, file = here("data_files/Error_tadpole_DEF_rho2.RData"))
load(here("data_files/Error_tadpole_DEF_rho0.1.RData"))
load(here("data_files/Error_tadpole_DEF_rho0.5.RData"))
load(here("data_files/Error_tadpole_DEF_rho1.RData"))
load(here("data_files/Error_tadpole_DEF_rho2.RData"))
h_vector = c("0.001", "0.005", "0.01", "0.1")
type_rational_approximation_vector = c("chebfun", "brasil", "chebfunLB")
nu_max = 53
nu_vector = 0.5 + c(seq(0.1,0.4,by=0.05), seq(0.41,0.59,by=0.01), seq(0.6,1.4,by=0.05), seq(1.41,1.59,by=0.01), seq(1.6,2.4,by=0.05), seq(2.41,2.49,by=0.01))[1:nu_max]
n = "0.001"
t = "chebfun"
dat = rbind(
data.frame(nu = rep(nu_vector,5),
rho = rep(0.1, times = 5*nu_max),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["1"]][1:nu_max,1],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["2"]][1:nu_max,1],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["3"]][1:nu_max,1],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["4"]][1:nu_max,1],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(0.5, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["1"]][1:nu_max,1],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["2"]][1:nu_max,1],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["3"]][1:nu_max,1],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["4"]][1:nu_max,1],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(1, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["1"]][1:nu_max,1],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["2"]][1:nu_max,1],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["3"]][1:nu_max,1],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["4"]][1:nu_max,1],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(2, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["1"]][1:nu_max,1],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["2"]][1:nu_max,1],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["3"]][1:nu_max,1],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["4"]][1:nu_max,1],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["5"]][1:nu_max,1]),
L = rep("Linf", times = 5*nu_max)
),
## L2
data.frame(nu = rep(nu_vector,5),
rho = rep(0.1, times = 5*nu_max),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["1"]][1:nu_max,2],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["2"]][1:nu_max,2],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["3"]][1:nu_max,2],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["4"]][1:nu_max,2],
Error_tadpole_DEF_rho0.1[[n]][["covariance"]][[t]][["0.1"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(0.5, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["1"]][1:nu_max,2],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["2"]][1:nu_max,2],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["3"]][1:nu_max,2],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["4"]][1:nu_max,2],
Error_tadpole_DEF_rho0.5[[n]][["covariance"]][[t]][["0.5"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(1, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["1"]][1:nu_max,2],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["2"]][1:nu_max,2],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["3"]][1:nu_max,2],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["4"]][1:nu_max,2],
Error_tadpole_DEF_rho1[[n]][["covariance"]][[t]][["1"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
),
data.frame(nu = rep(nu_vector,5),
rho = c(rep(2, times = 5*nu_max)),
m = rep(1:5, each = nu_max),
error = c(Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["1"]][1:nu_max,2],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["2"]][1:nu_max,2],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["3"]][1:nu_max,2],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["4"]][1:nu_max,2],
Error_tadpole_DEF_rho2[[n]][["covariance"]][[t]][["2"]][["5"]][1:nu_max,2]),
L = rep("L2", times = 5*nu_max)
)
)
dat$rho = factor(dat$rho, levels = c("0.1", "0.5", "1", "2"))
dat$L = factor(dat$L, levels = c("L2", "Linf"))
levels(dat$rho) = c("0.1" = latex2exp::TeX("$\\rho = 0.1$"), "0.5" = latex2exp::TeX("$\\rho = 0.5$"), "1" = latex2exp::TeX("$\\rho = 1$"), "2" = latex2exp::TeX("$\\rho = 2$"))
levels(dat$L) = c("L2" = latex2exp::TeX("$L_2(\\Gamma\\times\\Gamma)$ error"), "Linf" = latex2exp::TeX("$L_\\infty(\\Gamma\\times\\Gamma)$ error"))
p <- ggplot(dat, aes(nu, error, colour = as.factor(m))) +
facet_grid(L ~ rho, labeller = label_parsed) +
geom_line() +
scale_y_log10(n.breaks = 5) +
scale_x_continuous(n.breaks = 10) +
theme_bw() +
theme(panel.spacing = unit(0.3, "cm"), text = element_text(family = "Palatino"),
plot.title = element_text(size = 16),
strip.text = element_text(size = 12), # Panel titles
axis.title = element_text(size = 14), # Axis titles
axis.text = element_text(size = 12), # Axis text
legend.title = element_text(size = 14), # Legend title
legend.text = element_text(size = 12)) +
labs(x = bquote(alpha ~ "(smoothness parameter)"), y = "Covariance Error", color = "m") + ggtitle("Tadpole graph")
Figure 3: Covariance error for the tadpole graph.
We used R version 4.4.1 (R Core Team 2024a) and the following R packages: cowplot v. 1.1.3 (Wilke 2024), ggmap v. 4.0.0.900 (Kahle and Wickham 2013), ggpubr v. 0.6.0 (Kassambara 2023), ggtext v. 0.1.2 (Wilke and Wiernik 2022), grid v. 4.4.1 (R Core Team 2024b), here v. 1.0.1 (Müller 2020), htmltools v. 0.5.8.1 (Cheng et al. 2024), INLA v. 24.12.11 (Rue, Martino, and Chopin 2009; Lindgren, Rue, and Lindström 2011; Martins et al. 2013; Lindgren and Rue 2015; De Coninck et al. 2016; Rue et al. 2017; Verbosio et al. 2017; Bakka et al. 2018; Kourounis, Fuchs, and Schenk 2018), inlabru v. 2.12.0.9002 (Yuan et al. 2017; Bachl et al. 2019), knitr v. 1.48 (Xie 2014, 2015, 2024), latex2exp v. 0.9.6 (Meschiari 2022), Matrix v. 1.6.5 (Bates, Maechler, and Jagan 2024), MetricGraph v. 1.4.0.9000 (Bolin, Simas, and Wallin 2023b, 2023a, 2023c, 2024; Bolin et al. 2024), OpenStreetMap v. 0.4.0 (Fellows and JMapViewer library by Jan Peter Stotz 2023), osmdata v. 0.2.5 (Mark Padgham et al. 2017), patchwork v. 1.2.0 (Pedersen 2024), plotly v. 4.10.4 (Sievert 2020), plotrix v. 3.8.4 (J 2006), reshape2 v. 1.4.4 (Wickham 2007), rmarkdown v. 2.28 (Xie, Allaire, and Grolemund 2018; Xie, Dervieux, and Riederer 2020; Allaire et al. 2024), rSPDE v. 2.4.0.9000 (Bolin and Kirchner 2020; Bolin and Simas 2023; Bolin, Simas, and Xiong 2024), scales v. 1.3.0 (Wickham, Pedersen, and Seidel 2023), sf v. 1.0.19 (E. Pebesma 2018; E. Pebesma and Bivand 2023), sp v. 2.1.4 (E. J. Pebesma and Bivand 2005; Bivand, Pebesma, and Gomez-Rubio 2013), tidyverse v. 2.0.0 (Wickham et al. 2019), viridis v. 0.6.4 (Garnier et al. 2023), xaringanExtra v. 0.8.0 (Aden-Buie and Warkentin 2024).