# demo

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.