Go back to the Contents page.
Press Show to reveal the code chunks.
# Create a clipboard button on the rendeblack HTML page
source(here::here("clipboard.R")); clipboard# 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 = FALSE,
# 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)
}library(MetricGraph)
library(ggplot2)
library(reshape2)
library(dplyr)
library(viridis)
library(plotly)
library(patchwork)
library(slackr)
source("keys.R")
slackr_setup(token = token) # token comes from keys.R## [1] "Successfully connected to Slack"
capture.output(
knitr::purl(here::here("functionality1.Rmd"), output = here::here("functionality1.R")),
file = here::here("old/purl_log.txt")
)
source(here::here("functionality1.R"))For example, consider the regular curve \(\gamma(t) = (bt +c,a\cos(t), a\sin(t))\) for \(t\in[0,T]\), where \(a = 1\), \(b=0.5\), \(T=6\pi\), and \(c\) is a constant to be defined later. The curve has arc-length \(\ell = T\sqrt{a^2+b^2}\) and its arc-length parameterization is given by \(\tilde{\gamma}(s) = \gamma\left(s/\sqrt{a^2+b^2}\right)\) for \(s\in[0,\ell]\). Let \(\Gamma = (\mathcal{V}, \mathcal{E})\) denote the one edge graph induced by \(\tilde{\gamma}\), where \(\mathcal{V} = \{v_1 = \tilde{\gamma}(0), v_2 = \tilde{\gamma}(\ell)\}\) and \(\mathcal{E}=\{e = \tilde{\gamma}([0,\ell])\}\). Then we have the identification \(e=[0,\ell]\). For visualization purposes, we let \(c = T(\sqrt{a^2+b^2}-b)/2\). This makes the \(\gamma\) and the interval \([0,\ell]\) in Figure~\(\ref{arc_length_par}\) centered with respect to each other.
library(plotly)
# Parameters
a <- 1
b <- 0.5
TT <- 6*pi
# Total arc-length
L <- sqrt(a^2 + b^2) * TT
half_L <- L / 2
max_x <- b * (L / sqrt(a^2 + b^2))
half_max_x <- max_x / 2
dist_to_move <- half_L - half_max_x
# Arc-length parametrization (helix around x-axis)
alpha_tilde <- function(s){
t <- s / sqrt(a^2 + b^2)
x_shift <- TT*(sqrt(a^2 + b^2) - b) / 2
x <- b * t + x_shift
y <- a * cos(t)
z <- a * sin(t)
data.frame(x=x, y=y, z=z)
}
a0 = alpha_tilde(0)
aL = alpha_tilde(L)
aLh = alpha_tilde(half_L)
hhhh <- 3
ff <- function(s) 2*abs(sin(hhhh*pi*s/L))
k <- 0:hhhh
s_special <- k*L/hhhh
# Smooth helix
n_smooth <- 500
#s_smooth <- seq(0, L, length.out = n_smooth)
s_smooth <- sort(unique(c(
seq(0, L, length.out = n_smooth),
s_special
)))
curve_smooth <- alpha_tilde(s_smooth)
# Points for mapping lines
n_map <- 100
s_map <- seq(0, L, length.out = n_map)
curve_map <- alpha_tilde(s_map)
#s_semi_coarse <- seq(0, L, length.out = n_smooth/2)
# Interval along x-axis
int_map <- data.frame(
x = s_map,
y = rep(0, n_map)+4,
z = rep(0, n_map)
)
ff_eval_coarse <- ff(s_map)
ff_eval <- ff(s_smooth)
curve_smooth$height <- ff_eval
s_semi_coarse <- s_smooth
ff_s_semi_coarse <- ff(s_semi_coarse)
y_semi_coarse <- rep(0, length(s_semi_coarse)) + 4
ff_df <- data.frame(x = s_smooth, y = rep(0, length(s_smooth))+4, z = ff_eval)
ff_df_coarse <- data.frame(x = s_map, y = rep(0, length(s_map))+4, z = ff_eval_coarse)
# Build mapping lines
rows <- lapply(1:n_map, function(i) {
list(int_map[i, ], curve_map[i, ], data.frame(x = NA, y = NA, z = NA))
})
result <- do.call(rbind, unlist(rows, recursive = FALSE))
# Build mapping lines
rows <- lapply(1:n_map, function(i) {
list(curve_map[i, ], ff_df_coarse[i, ], data.frame(x = NA, y = NA, z = NA))
})
result2 <- do.call(rbind, unlist(rows, recursive = FALSE))
rows <- lapply(1:n_map, function(i) {
val <- ff_eval_coarse[i]
rbind(
cbind(curve_map[i, ], val = val),
cbind(ff_df_coarse[i, ], val = val),
data.frame(x = NA, y = NA, z = NA, val = NA)
)
})
result2 <- do.call(rbind, rows)
ff_df_coarse_new <- result2$val
zero <- int_map[1, ]
ell <- int_map[n_map, ]
vertex <- rbind(a0, aL, zero, ell)
ttt <- half_L / sqrt(a^2 + b^2)
u <- b
v <- -a*sin(ttt)
w <- a*cos(ttt)
zmin <- min(ff_eval)
zmax <- max(ff_eval)
# Plot
p <- plot_ly() |>
# Smooth helix
add_trace(
data = curve_smooth,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = ff_eval,
colorscale = "Viridis",
cmin = zmin,
cmax = zmax,
width = 7),
showlegend = FALSE
) |>
# Interval [0,L]
add_trace(
data = int_map,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = "black", width = 7),
showlegend = FALSE
) |>
add_trace(
data = result2,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(
color = ff_df_coarse_new,
colorscale = "Viridis",
cmin = zmin,
cmax = zmax,
width = 1
),
showlegend = FALSE
) |>
add_trace(data = vertex,
x = ~x,
y = ~y,
z = ~z,
type = "scatter3d",
mode = "markers",
marker = list(size = 5, color = "black"),
showlegend = FALSE
) |>
add_trace(
type = "cone",
x = aLh$x,
y = aLh$y,
z = aLh$z,
u = u,
v = v,
w = w,
sizemode = "absolute",
sizeref = 0.4,
colorscale = list(c(0, 1), c("green", "green")),
showscale = FALSE
) |>
# function on interval
add_trace(
data = ff_df,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(
color = ~z, # color based on height
colorscale = "Viridis", # choose any colorscale you like
cmin = zmin,
cmax = zmax,
width = 7
),
showlegend = FALSE
) |>
add_trace(x = rep(s_semi_coarse, each = 3),
y = rep(y_semi_coarse, each = 3),
z = unlist(lapply(ff_s_semi_coarse, function(zj) c(0, zj, NA))),
type = "scatter3d",
mode = "lines",
line = list(color = "lightgray", width = 0.5),
showlegend = FALSE)
dx <- int_map$x - curve_map$x
dy <- int_map$y - curve_map$y
dz <- int_map$z - curve_map$z
norm <- sqrt(dx^2 + dy^2 + dz^2)
u <- dx / norm
v <- dy / norm
w <- dz / norm
dx2 <- curve_map$x - ff_df_coarse$x
dy2 <- curve_map$y - ff_df_coarse$y
dz2 <- curve_map$z - ff_df_coarse$z
norm2 <- sqrt(dx2^2 + dy2^2 + dz2^2)
u2 <- dx2 / norm2
v2 <- dy2 / norm2
w2 <- dz2 / norm2
mag <- sqrt(u2^2 + v2^2 + w2^2)
scale <- ff_eval_coarse / mag
u_col <- u2 * scale
v_col <- v2 * scale
w_col <- w2 * scale
p <- p |>
add_trace(
type = "cone",
x = curve_map$x,
y = curve_map$y,
z = curve_map$z,
u = u_col,
v = v_col,
w = w_col,
colorscale = "Viridis",
cmin = zmin,
cmax = zmax,
sizemode = "absolute",
sizeref = 0.2,
anchor = "tip",
showscale = FALSE
)
rv <- 0.65
p2fhelix <- p |> config(mathjax = 'cdn') |>
layout(p,
font = list(family = "Palatino"),
margin = list(l = 0, r = 0, b = 0, t = 0),
scene = list(xaxis = list(title = list(text = "x", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(0, L)),
yaxis = list(title = list(text = "y", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(-1, 4.1)),
zaxis = list(title = list(text = "z", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(-1, max(ff_eval))),
#aspectmode="data",
aspectratio = list(x = L/9, y = 5/3, z = (max(ff_eval)+1)/3),
camera = list(eye = list(x = -3*rv, y = -6*rv, z = 6*rv),
center = list(x = 0, y = 0, z = 0)),
annotations = list(
list(
x = zero$x, y = zero$y, z = zero$z,
text = TeX("0"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = ell$x, y = ell$y, z = ell$z,
text = TeX("\\ell"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = aLh$x, y = aLh$y, z = aLh$z,
text = TeX("e_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = aL$x, y = aL$y, z = aL$z,
text = TeX("v_2"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = a0$x, y = a0$y, z = a0$z,
text = TeX("v_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1))
)
)
save(p2fhelix, file = here::here("data_files/graphs6p2fhelix.Rdata"))library(plotly)
# Parameters
a <- 1
b <- 0.5
TT <- 6*pi
# Total arc-length
L <- sqrt(a^2 + b^2) * TT
half_L <- L / 2
max_x <- b * (L / sqrt(a^2 + b^2))
half_max_x <- max_x / 2
dist_to_move <- half_L - half_max_x
# Arc-length parametrization (helix around x-axis)
alpha_tilde <- function(s){
t <- s / sqrt(a^2 + b^2)
x_shift <- TT*(sqrt(a^2 + b^2) - b) / 2
x <- b * t + x_shift
y <- a * cos(t)
z <- a * sin(t)
data.frame(x=x, y=y, z=z)
}
a0 = alpha_tilde(0)
aL = alpha_tilde(L)
aLh = alpha_tilde(half_L)
# Smooth helix
n_smooth <- 500
s_smooth <- seq(0, L, length.out = n_smooth)
curve_smooth <- alpha_tilde(s_smooth)
# Points for mapping lines
n_map <- 100
s_map <- seq(0, L, length.out = n_map)
curve_map <- alpha_tilde(s_map)
# Interval along x-axis
int_map <- data.frame(
x = s_map,
y = rep(0, n_map)+4,
z = rep(0, n_map)
)
zero <- int_map[1, ]
ell <- int_map[n_map, ]
vertex <- rbind(a0, aL, zero, ell)
ttt <- half_L / sqrt(a^2 + b^2)
u <- b
v <- -a*sin(ttt)
w <- a*cos(ttt)
# Plot
p <- plot_ly() |>
# Smooth helix
add_trace(
data = curve_smooth,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = "darkred", width = 7),
showlegend = FALSE
) |>
# Interval [0,L]
add_trace(
data = int_map,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = "#0000C8", width = 7),
showlegend = FALSE
) |>
add_trace(data = vertex,
x = ~x,
y = ~y,
z = ~z,
type = "scatter3d",
mode = "markers",
marker = list(size = 5, color = "black"),
showlegend = FALSE
) |>
add_trace(
type = "cone",
x = aLh$x,
y = aLh$y,
z = aLh$z,
u = u,
v = v,
w = w,
sizemode = "absolute",
sizeref = 0.4,
colorscale = list(c(0, 1), c("green", "green")),
showscale = FALSE
)
pal <- colorRampPalette(c(
"#0000C8", # dark navy
"#0074D9", # royalblue
"#7FDBFF", # cyan
"#2ECC40", # green
"#FFDC00", # yellow
"#FF851B", # orange
"#FF4136", # red
"darkred"
))(100)
gradient_line <- function(p0, p1, n = 20){
t <- seq(0,1,length.out = n)
x <- (1-t)*p0$x + t*p1$x
y <- (1-t)*p0$y + t*p1$y
z <- (1-t)*p0$z + t*p1$z
data.frame(x=x,y=y,z=z,t=t)
}
dx <- int_map$x - curve_map$x
dy <- int_map$y - curve_map$y
dz <- int_map$z - curve_map$z
norm <- sqrt(dx^2 + dy^2 + dz^2)
u <- dx / norm
v <- dy / norm
w <- dz / norm
p <- p |>
add_trace(
type = "cone",
x = int_map$x,
y = int_map$y,
z = int_map$z,
u = u,
v = v,
w = w,
sizemode = "absolute",
sizeref = 0.6,
anchor = "tip",
colorscale = list(c(0, "#0000C8"), c(1, "#0000C8")),
showscale = FALSE
)
for(i in 1:n_map){
g <- gradient_line(int_map[i,], curve_map[i,])
for(j in 1:(nrow(g)-1)){
seg <- g[j:(j+1),]
col <- pal[ round(seg$t[1]*(length(pal)-1))+1 ]
p <- p |> add_trace(
data = seg,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = col, width = 1),
showlegend = FALSE
)
}
}
rv <- 0.65
p2 <- p |> config(mathjax = 'cdn') |>
layout(p,
font = list(family = "Palatino"),
margin = list(l = 0, r = 0, b = 0, t = 0),
scene = list(xaxis = list(title = list(text = "x", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(0, L)),
yaxis = list(title = list(text = "y", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(-1, 4.1)),
zaxis = list(title = list(text = "z", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(-1, 2)),
#aspectmode="data",
aspectratio = list(x = L/9, y = 5/3, z = (2+1)/3),
camera = list(eye = list(x = -3*rv, y = -6*rv, z = 6*rv),
center = list(x = 0, y = 0, z = 0)),
annotations = list(
list(
x = zero$x, y = zero$y, z = zero$z,
text = TeX("0"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = ell$x, y = ell$y, z = ell$z,
text = TeX("\\ell"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = aLh$x, y = aLh$y, z = aLh$z,
text = TeX("e_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = aL$x, y = aL$y, z = aL$z,
text = TeX("v_2"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = a0$x, y = a0$y, z = a0$z,
text = TeX("v_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1))
)
)
save(p2, file = here::here("data_files/graphs6p2.Rdata"))library(plotly)
n_smooth <- 250
TT <- 3*pi
# parameter
t <- seq(0, TT, length.out = n_smooth)
# speed
speed <- sqrt(1 + cos(t)^2)
# arc-length function
s <- pracma::cumtrapz(t, speed)
L <- max(s)
# s <- cumsum(c(0, diff(t) * (head(speed,-1) + tail(speed,-1))/2))
f1 <- function(t) exp(t/4)
f1_on_curve <- f1(s)
y_up_range <- max(f1_on_curve)
f2 <- function(t) sin(3*pi*t/L) + y_up_range
f1df_int <- data.frame(x = s, y = rep(0, n_smooth), z = f1_on_curve)
half_L <- L / 2
half_TT <- TT / 2
dist_to_move <- abs(half_L - half_TT)
y_shift <- 4
# curve alpha(t)
x <- t + dist_to_move
y <- sin(t) + y_shift
z <- rep(0,length(t))
curve_smooth <- data.frame(x = x, y = y, z = z)
f1_on_curve_smooth <- data.frame(x = x, y = y, z = f1_on_curve)
n_map <- 25
# points where we draw connectors
idx <- seq(1, length(t), length.out = n_map)
f1df_int_map <- f1df_int[idx,]
f1_on_curve_smooth_map <- f1_on_curve_smooth[idx,]
# Build mapping lines
rows <- lapply(1:n_map, function(i) {
list(f1df_int_map[i, ], f1_on_curve_smooth_map[i, ], data.frame(x = NA, y = NA, z = NA))
})
resultee1 <- do.call(rbind, unlist(rows, recursive = FALSE))
curve_map <- data.frame(x = x[idx], y = y[idx], z = z[idx])
int_map <- data.frame(x = s[idx], y = rep(0, n_map), z = rep(0, n_map))
#
# # Build mapping lines
# rows <- lapply(1:n_map, function(i) {
# list(int_map[i, ], curve_map[i, ], data.frame(x = NA, y = NA, z = NA))
# })
#
# result <- do.call(rbind, unlist(rows, recursive = FALSE))
s_circ <- L
radius <- s_circ / (2*pi)
x_shift_for_circle <- radius + TT + dist_to_move
theta <- seq(from=-pi,to=pi,length.out = n_smooth)
circle_curve <- data.frame(x = radius*cos(theta) + x_shift_for_circle,
y = radius*sin(theta) + y_shift,
z = rep(0, length(theta)))
arclength_circle <- radius * (theta + pi)
dist_to_move_circle <- abs(half_L - y_shift)
f2_on_curve <- f2(arclength_circle)
f2df_int <- data.frame(x = rep(x_shift_for_circle +2*radius, n_smooth),
y = arclength_circle-dist_to_move_circle,
z = f2_on_curve)
f2_on_curve_smooth <- data.frame(x = radius*cos(theta) + x_shift_for_circle,
y = radius*sin(theta) + y_shift,
z = f2_on_curve)
f2df_int_map <- f2df_int[idx,]
f2_on_curve_smooth_map <- f2_on_curve_smooth[idx,]
# Build mapping lines
rows <- lapply(1:n_map, function(i) {
list(f2df_int_map[i, ], f2_on_curve_smooth_map[i, ], data.frame(x = NA, y = NA, z = NA))
})
resultee2 <- do.call(rbind, unlist(rows, recursive = FALSE))
circle_map <- circle_curve[idx, ]
int_map_circle <- data.frame(x = rep(x_shift_for_circle +2*radius, n_map),
y = s[idx]-dist_to_move_circle,
z = rep(0, n_map))
# # Build mapping lines for circle
# rows <- lapply(1:n_map, function(i) {
# list(int_map_circle[i, ], circle_map[i, ], data.frame(x = NA, y = NA, z = NA))
# })
#
# result_for_circle <- do.call(rbind, unlist(rows, recursive = FALSE))
v1 <- curve_map[1, ]
v2 <- curve_map[n_map, ]
e1 <- curve_map[ceiling(n_map/2), ]
e2 <- circle_map[ceiling(n_map/2), ]
zero1 <- int_map[1, ]
le1 <- int_map[n_map, ]
zero2 <- int_map_circle[1, ]
le2 <- int_map_circle[n_map, ]
vertex <- rbind(v1, v2, zero1, zero2, le1, le2)
zmin <- min(f1_on_curve, f2_on_curve)
zmax <- max(f1_on_curve, f2_on_curve)
# plot vertical lines from edges to curves
vertical_lines1 <- data.frame(x = rep(f1df_int$x, each = 3),
y = rep(f1df_int$y, each = 3),
z = unlist(lapply(f1df_int$z, function(zj) c(0, zj, NA))))
vertical_lines2 <- data.frame(x = rep(f2df_int$x, each = 3),
y = rep(f2df_int$y, each = 3),
z = unlist(lapply(f2df_int$z, function(zj) c(0, zj, NA))))
vertical_lines3 <- data.frame(x = rep(f1_on_curve_smooth$x, each = 3),
y = rep(f1_on_curve_smooth$y, each = 3),
z = unlist(lapply(f1_on_curve_smooth$z, function(zj) c(0, zj, NA))))
vertical_lines4 <- data.frame(x = rep(f2_on_curve_smooth$x, each = 3),
y = rep(f2_on_curve_smooth$y, each = 3),
z = unlist(lapply(f2_on_curve_smooth$z, function(zj) c(0, zj, NA))))
vertical_lines <- rbind(vertical_lines1, vertical_lines2, vertical_lines3, vertical_lines4)
p <- plot_ly() |>
add_trace(data = rbind(curve_smooth, #smooth sin edge
data.frame(x = NA, y = NA, z = NA),
circle_curve, # smooth circle edge
data.frame(x = NA, y = NA, z = NA),
int_map, # interval for sin edge
data.frame(x = NA, y = NA, z = NA),
int_map_circle), # interval for circle edge
x = ~x, y = ~y, z = ~z,
type = "scatter3d", mode = "lines",
line = list(width = 7, color = "black"),
showlegend = FALSE) |>
add_trace(data = vertical_lines,
x = ~x, y = ~y, z = ~z,
type = "scatter3d", mode = "lines",
line = list(color = "lightgray", width = 0.5),
showlegend = FALSE) |>
add_trace(data = rbind(f1df_int,
data.frame(x = NA, y = NA, z = NA),
f2df_int,
data.frame(x = NA, y = NA, z = NA),
f1_on_curve_smooth,
data.frame(x = NA, y = NA, z = NA),
f2_on_curve_smooth),
x = ~x, y = ~y, z = ~z,
type = "scatter3d", mode = "lines",
line = list(
color = ~z, # color based on height
colorscale = "Viridis", # choose any colorscale you like
cmin = zmin,
cmax = zmax,
width = 7
),
showlegend = FALSE) |>
add_trace(data = rbind(resultee1, # mapping lines for sin
resultee2), # mapping lines for circle
x = ~x, y = ~y, z = ~z,
type = "scatter3d", mode = "lines",
line = list(
color = ~z, # color based on height
colorscale = "Viridis", # choose any colorscale you like
cmin = zmin,
cmax = zmax,
width = 1
),
showlegend = FALSE) |>
add_trace(data = vertex,
x = ~x,
y = ~y,
z = ~z,
type = "scatter3d",
mode = "markers",
marker = list(size = 5, color = "black"),
showlegend = FALSE) |>
add_trace(
type = "cone",
x = e1$x,
y = e1$y,
z = e1$z,
u = 1,
v = 0,
w = 0,
sizemode = "absolute",
sizeref = 0.6,
colorscale = list(c(0, 1), c("green", "green")),
showscale = FALSE) |>
add_trace(
type = "cone",
x = e2$x,
y = e2$y,
z = e2$z,
u = 0,
v = 1,
w = 0,
sizemode = "absolute",
sizeref = 0.6,
colorscale = list(c(0, 1), c("green", "green")),
showscale = FALSE
)
rv <- 2
p4tadpole_arclength <- p |>
config(mathjax = 'cdn') |>
layout(p,
font = list(family = "Palatino"),
margin = list(l = 0, r = 0, b = 0, t = 0),
scene = list(xaxis = list(title = list(text = "x", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(0, x_shift_for_circle +2*radius)*1.01),
yaxis = list(title = list(text = "y", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = range(int_map_circle$y)),
zaxis = list(title = list(text = "z", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(0, y_up_range+1)),
aspectratio = list(x = x_shift_for_circle +2*radius, y = L, z = 4),
camera = list(eye = list(x = 7*rv, y = -15*rv, z = 6*rv),
center = list(x = 0, y = 0, z = 0)),
annotations = list(
list(
x = zero1$x, y = zero1$y, z = zero1$z,
text = TeX("0"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = zero2$x, y = zero2$y, z = zero2$z,
text = TeX("0"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = le1$x, y = le1$y, z = le1$z,
text = TeX("\\ell_{e_1}"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = le2$x, y = le2$y, z = le2$z,
text = TeX("\\ell_{e_2}"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = v1$x, y = v1$y, z = v1$z,
text = TeX("v_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = v2$x, y = v2$y, z = v2$z,
text = TeX("v_2"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = e1$x, y = e1$y, z = e1$z,
text = TeX("e_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = e2$x, y = e2$y, z = e2$z,
text = TeX("e_2"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1))
)
)
save(p4tadpole_arclength, file = here::here("data_files/graphs6p4tadpole_arclength.Rdata"))library(plotly)
n_smooth <- 250
TT <- 3*pi
# parameter
t <- seq(0, TT, length.out = n_smooth)
# speed
speed <- sqrt(1 + cos(t)^2)
# arc-length function
s <- pracma::cumtrapz(t, speed)
# s <- cumsum(c(0, diff(t) * (head(speed,-1) + tail(speed,-1))/2))
L <- max(s)
half_L <- L / 2
half_TT <- TT / 2
dist_to_move <- abs(half_L - half_TT)
y_shift <- 4
# curve alpha(t)
x <- t + dist_to_move
y <- sin(t) + y_shift
z <- rep(0,length(t))
curve_smooth <- data.frame(x = x, y = y, z = z)
# the following lines are just to get the range of f1 on the curve, so that we can set the range so both plots are similar
f1 <- function(t) exp(t/4)
f1_on_curve <- f1(s)
y_up_range <- max(f1_on_curve)
n_map <- 50
# points where we draw connectors
idx <- seq(1, length(t), length.out = n_map)
curve_map <- data.frame(x = x[idx], y = y[idx], z = z[idx])
int_map <- data.frame(x = s[idx], y = rep(0, n_map), z = rep(0, n_map))
# Build mapping lines
rows <- lapply(1:n_map, function(i) {
list(int_map[i, ], curve_map[i, ], data.frame(x = NA, y = NA, z = NA))
})
result <- do.call(rbind, unlist(rows, recursive = FALSE))
s_circ <- L
radius <- s_circ / (2*pi)
x_shift_for_circle <- radius + TT + dist_to_move
theta <- seq(from=-pi,to=pi,length.out = n_smooth)
circle_curve <- data.frame(x = radius*cos(theta) + x_shift_for_circle,
y = radius*sin(theta) + y_shift,
z = rep(0, length(theta)))
circle_map <- circle_curve[idx, ]
dist_to_move_circle <- abs(half_L - y_shift)
int_map_circle <- data.frame(x = rep(x_shift_for_circle +2*radius, n_map), y = s[idx]-dist_to_move_circle, z = rep(0, n_map))
# Build mapping lines for circle
rows <- lapply(1:n_map, function(i) {
list(int_map_circle[i, ], circle_map[i, ], data.frame(x = NA, y = NA, z = NA))
})
result_for_circle <- do.call(rbind, unlist(rows, recursive = FALSE))
v1 <- curve_map[1, ]
v2 <- curve_map[n_map, ]
e1 <- curve_map[ceiling(n_map/2), ]
e2 <- circle_map[ceiling(n_map/2), ]
zero1 <- int_map[1, ]
le1 <- int_map[n_map, ]
zero2 <- int_map_circle[1, ]
le2 <- int_map_circle[n_map, ]
vertex <- rbind(v1, v2, zero1, zero2, le1, le2)
p <- plot_ly() |>
# smooth sin curve
add_trace(data = rbind(curve_smooth, # smooth sin curve
data.frame(x = NA, y = NA, z = NA),
circle_curve), # smooth circle curve
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(width = 7, color = "darkred"),
showlegend = FALSE
) |>
add_trace(data = rbind(int_map, # interval for sin
data.frame(x = NA, y = NA, z = NA),
int_map_circle), # interval for circle
x = ~x,
y = ~y,
z = ~z,
type = "scatter3d",
mode = "lines",
line = list(width = 7, color = "#0000C8"),
showlegend = FALSE
) |>
add_trace(data = vertex,
x = ~x,
y = ~y,
z = ~z,
type = "scatter3d",
mode = "markers",
marker = list(size = 5, color = "black"),
showlegend = FALSE
) |> add_trace(
type = "cone",
x = e1$x,
y = e1$y,
z = e1$z,
u = 1,
v = 0,
w = 0,
sizemode = "absolute",
sizeref = 0.6,
colorscale = list(c(0, 1), c("green", "green")),
showscale = FALSE
) |> add_trace(
type = "cone",
x = e2$x,
y = e2$y,
z = e2$z,
u = 0,
v = 1,
w = 0,
sizemode = "absolute",
sizeref = 0.6,
colorscale = list(c(0, 1), c("green", "green")),
showscale = FALSE
)
pal <- colorRampPalette(c(
"#0000C8", # dark navy
"#0074D9", # royalblue
"#7FDBFF", # cyan
"#2ECC40", # green
"#FFDC00", # yellow
"#FF851B", # orange
"#FF4136", # red
"darkred"
))(100)
gradient_line <- function(p0, p1, n = 20){
t <- seq(0,1,length.out = n)
x <- (1-t)*p0$x + t*p1$x
y <- (1-t)*p0$y + t*p1$y
z <- (1-t)*p0$z + t*p1$z
data.frame(x=x,y=y,z=z,t=t)
}
dx <- int_map$x - curve_map$x
dy <- int_map$y - curve_map$y
dz <- int_map$z - curve_map$z
norm <- sqrt(dx^2 + dy^2 + dz^2)
u <- dx / norm
v <- dy / norm
w <- dz / norm
dxc <- int_map_circle$x - circle_map$x
dyc <- int_map_circle$y - circle_map$y
dzc <- int_map_circle$z - circle_map$z
normc <- sqrt(dxc^2 + dyc^2 + dzc^2)
uc <- dxc / normc
vc <- dyc / normc
wc <- dzc / normc
p <- p |>
add_trace(
type = "cone",
x = int_map$x,
y = int_map$y,
z = int_map$z,
u = u,
v = v,
w = w,
sizemode = "absolute",
sizeref = 0.7,
anchor = "tip",
colorscale = list(c(0, "#0000C8"), c(1, "#0000C8")),
showscale = FALSE
) |> add_trace(
type = "cone",
x = int_map_circle$x,
y = int_map_circle$y,
z = int_map_circle$z,
u = uc,
v = vc,
w = wc,
sizemode = "absolute",
sizeref = 0.4,
anchor = "tip",
colorscale = list(c(0, "#0000C8"), c(1, "#0000C8")),
showscale = FALSE
)
for(i in 1:n_map){
g <- gradient_line(int_map[i,], curve_map[i,])
for(j in 1:(nrow(g)-1)){
seg <- g[j:(j+1),]
col <- pal[ round(seg$t[1]*(length(pal)-1))+1 ]
p <- p |> add_trace(
data = seg,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = col, width = 1),
showlegend = FALSE
)
}
}
for(i in 1:n_map){
g <- gradient_line(int_map_circle[i,], circle_map[i,])
for(j in 1:(nrow(g)-1)){
seg <- g[j:(j+1),]
col <- pal[ round(seg$t[1]*(length(pal)-1))+1 ]
p <- p |> add_trace(
data = seg,
x = ~x, y = ~y, z = ~z,
type = "scatter3d",
mode = "lines",
line = list(color = col, width = 1),
showlegend = FALSE
)
}
}
rv <- 2
p4 <- p |>
config(mathjax = 'cdn') |>
layout(p,
font = list(family = "Palatino"),
margin = list(l = 0, r = 0, b = 0, t = 0),
scene = list(xaxis = list(title = list(text = "x", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(0, x_shift_for_circle +2*radius)*1.01),
yaxis = list(title = list(text = "y", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = range(int_map_circle$y)),
zaxis = list(title = list(text = "z", font = list(color = colaxnn)), tickfont = list(color = colaxnn), range = c(0, y_up_range+1)),
aspectratio = list(x = x_shift_for_circle +2*radius, y = L, z = 4),
camera = list(eye = list(x = 7*rv, y = -15*rv, z = 6*rv),
center = list(x = 0, y = 0, z = 0)),
annotations = list(
list(
x = zero1$x, y = zero1$y, z = zero1$z,
text = TeX("0"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = zero2$x, y = zero2$y, z = zero2$z,
text = TeX("0"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = le1$x, y = le1$y, z = le1$z,
text = TeX("\\ell_{e_1}"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = le2$x, y = le2$y, z = le2$z,
text = TeX("\\ell_{e_2}"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = v1$x, y = v1$y, z = v1$z,
text = TeX("v_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = v2$x, y = v2$y, z = v2$z,
text = TeX("v_2"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = e1$x, y = e1$y, z = e1$z,
text = TeX("e_1"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1),
list(
x = e2$x, y = e2$y, z = e2$z,
text = TeX("e_2"),
textangle = 0, ax = 0, ay = -35,
font = list(color = "black", size = gfsize),
arrowcolor = "gray", arrowsize = 1, arrowwidth = 0.5, arrowhead = 1))
)
)
save(p4, file = here::here("data_files/graphs6p4.Rdata"))We used R version 4.5.2 (R Core Team 2025a) and the following R packages: cowplot v. 1.2.0 (Wilke 2025), ggmap v. 4.0.2 (Kahle and Wickham 2013), ggpubr v. 0.6.3 (Kassambara 2026), ggtext v. 0.1.2 (Wilke and Wiernik 2022), glue v. 1.8.0 (Hester and Bryan 2024), grid v. 4.5.2 (R Core Team 2025b), here v. 1.0.1 (Müller 2020), htmltools v. 0.5.8.1 (Cheng et al. 2024), INLA v. 25.11.22 (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.13.0 (Yuan et al. 2017; Bachl et al. 2019), knitr v. 1.50 (Xie 2014, 2015, 2025), latex2exp v. 0.9.8 (Meschiari 2026), Matrix v. 1.7.3 (Bates, Maechler, and Jagan 2025), MetricGraph v. 1.5.0.9000 (Bolin, Simas, and Wallin 2023a, 2023b, 2024, 2025; Bolin et al. 2024), OpenStreetMap v. 0.4.1 (Fellows and Stotz 2025), patchwork v. 1.3.1 (Pedersen 2025), plotly v. 4.11.0 (Sievert 2020), plotrix v. 3.8.14 (J 2006), pracma v. 2.4.4 (Borchers 2023), renv v. 1.1.7 (Ushey and Wickham 2026), reshape2 v. 1.4.4 (Wickham 2007), reticulate v. 1.44.1 (Ushey, Allaire, and Tang 2025), rmarkdown v. 2.30 (Xie, Allaire, and Grolemund 2018; Xie, Dervieux, and Riederer 2020; Allaire et al. 2025), rSPDE v. 2.5.2.9000 (Bolin and Kirchner 2020; Bolin and Simas 2023; Bolin, Simas, and Xiong 2024), scales v. 1.4.0 (Wickham, Pedersen, and Seidel 2025), sf v. 1.1.0 (E. Pebesma 2018; E. Pebesma and Bivand 2023), slackr v. 3.4.0 (Kaye et al. 2025), sp v. 2.2.1 (E. J. Pebesma and Bivand 2005; Bivand, Pebesma, and Gomez-Rubio 2013), tidyverse v. 2.0.0 (Wickham et al. 2019), tikzDevice v. 0.12.6 (Sharpsteen and Bracken 2023), viridis v. 0.6.5 (Garnier et al. 2024), xaringanExtra v. 0.8.0 (Aden-Buie and Warkentin 2024).