This is a demonstration of the SparseVFC algorithm. This demonstration was adapted from the script in https://github.com/jiayi-ma/VFC.
Import related packages.
library(SparseVFC)
library(ggplot2)
library(dplyr)
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
library(tibble)Load and normalize the data.
data(church)
X <- church$X
Y <- church$Y
CorrectIndex <- church$CorrectIndex
nX <- norm_vecs(X)
nY <- norm_vecs(Y)SparseVFC.
set.seed(1614)
VecFld <- SparseVFC(nX, nY - nX, silent = FALSE)
#> Start mismatch removal...
#> iterate: 1th, gamma: 0.900000, the energy change rate: 0.924937, sigma2=0.578028
#> iterate: 2th, gamma: 0.809524, the energy change rate: 1.234984, sigma2=0.264078
#> iterate: 3th, gamma: 0.753968, the energy change rate: 0.304775, sigma2=0.186379
#> iterate: 4th, gamma: 0.706349, the energy change rate: 0.149332, sigma2=0.147645
#> iterate: 5th, gamma: 0.674603, the energy change rate: 0.099174, sigma2=0.122940
#> iterate: 6th, gamma: 0.658730, the energy change rate: 0.078741, sigma2=0.104899
#> iterate: 7th, gamma: 0.658730, the energy change rate: 0.080516, sigma2=0.090414
#> iterate: 8th, gamma: 0.642857, the energy change rate: 0.087067, sigma2=0.075050
#> iterate: 9th, gamma: 0.634921, the energy change rate: 0.073867, sigma2=0.061626
#> iterate: 10th, gamma: 0.611111, the energy change rate: 0.095015, sigma2=0.050427
#> iterate: 11th, gamma: 0.611111, the energy change rate: 0.099653, sigma2=0.038044
#> iterate: 12th, gamma: 0.587302, the energy change rate: 0.073018, sigma2=0.028603
#> iterate: 13th, gamma: 0.555556, the energy change rate: 0.063893, sigma2=0.021995
#> iterate: 14th, gamma: 0.507937, the energy change rate: 0.114747, sigma2=0.015971
#> iterate: 15th, gamma: 0.515873, the energy change rate: 0.200772, sigma2=0.005778
#> iterate: 16th, gamma: 0.507937, the energy change rate: 0.190363, sigma2=0.001516
#> iterate: 17th, gamma: 0.492063, the energy change rate: 0.092108, sigma2=0.000699
#> iterate: 18th, gamma: 0.492063, the energy change rate: 0.032097, sigma2=0.000440
#> iterate: 19th, gamma: 0.476190, the energy change rate: 0.008552, sigma2=0.000389
#> iterate: 20th, gamma: 0.476190, the energy change rate: 0.004999, sigma2=0.000354
#> iterate: 21th, gamma: 0.476190, the energy change rate: 0.003603, sigma2=0.000328
#> iterate: 22th, gamma: 0.476190, the energy change rate: 0.001645, sigma2=0.000317
#> iterate: 23th, gamma: 0.476190, the energy change rate: 0.000560, sigma2=0.000315
#> iterate: 24th, gamma: 0.476190, the energy change rate: 0.000117, sigma2=0.000315
#> iterate: 25th, gamma: 0.476190, the energy change rate: 0.000035, sigma2=0.000315
#> iterate: 26th, gamma: 0.476190, the energy change rate: 0.000001, sigma2=0.000315
#> Removing outliers succesfully completed.Make some samples for drawing the victor field.
vec <- expand.grid(x = seq(-1.2, 1.2, 0.2), y = seq(-1.2, 1.2, 0.2))
vec <- vec %>%
rowwise() %>%
mutate(v = list(predict(VecFld, c(x, y)))) %>%
mutate(
vx = v[1],
vy = v[2]
)The accuracy for the algorithm.
tibble(
correct = 1:126 %in% CorrectIndex,
VFC = 1:126 %in% VecFld$VFCIndex
) %>% table()
#> VFC
#> correct FALSE TRUE
#> FALSE 56 1
#> TRUE 10 59(Recall: \(59/(59+1) = 0.9833\); precision: \(59/(59+10) = 0.8551\). Those two performance measures are the same as reported in Zhao et al., 2011 https://doi.org/10.1109/CVPR.2011.5995336, indicating a correct replication.)
Plot the output vector field. (red arrows: correct arrows in the original data; black arrows: incorrect vectors in the original data; gray arrows: learned vector field.)
library(grid)
ggplot(vec, aes(x = x, y = y)) +
geom_segment(aes(xend = x + vx, yend = y + vy),
arrow = arrow(length = unit(0.1, "cm")), linewidth = 0.25, alpha = 0.2
) +
geom_segment(
data = cbind(nX, nY - nX) %>% as.data.frame() %>% `colnames<-`(c("x", "y", "vx", "vy")),
aes(xend = x + vx, yend = y + vy),
arrow = arrow(length = unit(0.1, "cm")), linewidth = 0.25
) +
geom_segment(
data = cbind(nX, nY - nX) %>% as.data.frame() %>% `colnames<-`(c("x", "y", "vx", "vy")) %>% slice(CorrectIndex),
aes(xend = x + vx, yend = y + vy),
arrow = arrow(length = unit(0.1, "cm")), linewidth = 0.25, color = "red"
)
#> Warning: Slicing with a 1-column matrix was deprecated in dplyr 1.1.0.
#> This warning is displayed once every 8 hours.
#> Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
#> generated.