test-01-integration.R
In fmesher: Triangle Meshes and Related Geometry Tools

test_that("Discrete integration", {
  domain <- 2:5
  samplers <- 3:7
  ips_ <- tibble::tibble(x = 3:5, weight = rep(1, 3), .block = 1L:3L)

  ips <- fm_int(domain, samplers = samplers)
  expect_identical(ips, ips_)

  domain <- as.character(domain)
  samplers <- as.character(samplers)
  ips <- fm_int(domain, samplers)
  ips_$x <- as.character(ips_$x)
  expect_identical(ips, ips_)

  domain <- factor(domain, levels = domain)
  samplers <- factor(samplers, levels = samplers)
  ips <- fm_int(domain, samplers)
  ips_$x <- factor(ips_$x, levels = domain)
  expect_identical(ips, ips_)
})


test_that("Continuous integration", {
  domain <- fm_mesh_1d(2:5)

  samplers <- c(3, 5)
  ips_ <- tibble::tibble(
    x = c(3:5, 3.5, 4.5),
    weight = c(1 / 6, 1 / 3, 1 / 6, 2 / 3, 2 / 3),
    .block = 1L
  )
  ips_ <- ips_[order(ips_$x), ]

  ips <- fm_int(domain, samplers = samplers)
  ips <- ips[order(ips$x), ]
  expect_identical(ips, ips_)

  ips_bary_ <- ips_
  ips_bary_$x <- fm_bary(domain, ips_$x)

  ips_bary <- fm_int(domain, samplers = samplers, format = "bary")
  ips_bary_ <- ips_bary_[order(ips_bary_$x$index, ips_bary_$x$where[, 2]), ]
  ips_bary <- ips_bary[order(ips_bary$x$index, ips_bary$x$where[, 2]), ]
  expect_identical(ips_bary, ips_bary_)

  # Check blockwise integration
  samplers <- rbind(c(3, 5), c(2, 4.5))
  ips <- fm_int(domain, samplers = samplers)
  sums <- as.vector(by(ips$weight, ips$.block, sum))
  expect_equal(sums, c(2, 2.5))

  # degree = 2
  domain <- fm_mesh_1d(2:5, degree = 2)

  samplers <- c(3, 5)
  ips_ <- tibble::tibble(
    x = c(3:5, 3.5, 4.5),
    weight = c(1 / 6, 1 / 3, 1 / 6, 2 / 3, 2 / 3),
    .block = 1L
  )
  ips_ <- ips_[order(ips_$x), ]

  ips <- fm_int(domain, samplers = samplers)
  ips <- ips[order(ips$x), ]
  expect_identical(ips, ips_)

  # Check blockwise integration
  samplers <- rbind(c(3, 5), c(2, 4.5))
  ips <- fm_int(domain, samplers = samplers)
  sums <- as.vector(by(ips$weight, ips$.block, sum))
  expect_equal(sums, c(2, 2.5))
})


test_that("Tensor space integration", {
  mesh_time <- fm_mesh_1d(1:5)
  mesh_space <- fm_mesh_1d(c(0, 5, 10))
  domain <- list(space = mesh_space, time = mesh_time)
  samplers1 <- tibble::tibble(
    time = rbind(c(1, 3), c(2, 4), c(3, 5)),
    space = rbind(c(0, 10), c(0, 5), c(5, 10)),
    weight = c(1, 10, 100)
  )

  ips1 <- fm_int(domain, samplers1)

  samplers2 <- tibble::tibble(
    space = samplers1$space,
    time = samplers1$time,
    weight = samplers1$weight
  )

  ips2 <- fm_int(domain, samplers2)

  expect_equal(sort(names(ips1)), sort(names(ips2)))
  expect_equal(
    dplyr::arrange(ips1, .block, time, space),
    dplyr::arrange(ips2[names(ips1)], .block, time, space)
  )
})



test_that("Integrating a polygon on a mesh domain", {
  ips <- fm_int(fmexample$mesh, samplers = fmexample$boundary_sf[[1]])

  expect_s3_class(ips, "sf")
  expect_equal(
    sort(colnames(as.data.frame(ips))),
    sort(c("weight", ".block", "geometry"))
  )
  expect_equal(sum(ips$weight), 18.339, tolerance = lowtol)
})


test_that("Integrating a SpatialPolygon on a mesh domain", {
  skip_if_not(fm_safe_sp())
  ips <- fm_int(fmexample$mesh, samplers = fmexample_sp()$boundary_sp[[1]])

  expect_s4_class(ips, "SpatialPointsDataFrame")
  expect_equal(
    sort(colnames(as.data.frame(ips))),
    sort(c("weight", ".block", "x", "y", "z"))
  )
  expect_equal(sum(ips$weight), 18.339, tolerance = lowtol)
})

test_that("Conversion of whole 2D mesh to integration points", {
  ips1 <- fm_int(fmexample$mesh)
  ips <- fm_int(fmexample$mesh, format = "sf")

  expect_s3_class(ips, "sf")
  expect_equal(colnames(ips), c("weight", ".block", "geometry"))
  expect_equal(sum(ips$weight), 64.58135, tolerance = lowtol)

  skip_if_not(fm_safe_sp())

  ips <- fm_int(fmexample$mesh, format = "sp")

  expect_s4_class(ips, "SpatialPointsDataFrame")
  expect_equal(
    colnames(as.data.frame(ips)),
    c("weight", ".block", "x", "y", "z")
  )
  expect_equal(sum(ips$weight), 64.58135, tolerance = lowtol)
})


test_that("Polygon integration with holes", {
  plyA <- sf::st_sfc(sf::st_polygon(
    list(
      matrix(c(0, 3, 3, 0, 0, 0, 0, 3, 3, 0) - 1, 5, 2),
      matrix(c(1, 2, 2, 1, 1, 1, 1, 2, 2, 1) - 1, 5, 2)
    )
  ))

  bndA <- fm_as_segm(plyA)
  m <- fmexample$mesh
  ipA <- fm_int(m,
    plyA,
    int.args = list(method = "direct", nsub2 = 1)
  )

  expect_equal(
    sf::st_area(sf::st_as_sf(plyA)),
    8
  )
  expect_equal(sum(ipA$weight), 7.846134, tolerance = lowtol)
})


test_that("Integration line splitting", {
  mesh <- fmexample$mesh

  segm <- fm_segm(
    loc = rbind(c(-1, 0), c(-1, 1), c(1, 0), c(1, 1)),
    idx = rbind(c(1, 2), c(3, 4)),
    is.bnd = FALSE
  )

  expect_error(
    object = {
      sl <- fm_split_lines(mesh, segm)
    },
    NA
  )

  # Check inlabru issue #63 (problem for single line input), fixed
  segm <- fm_segm(
    loc = rbind(c(-1, 0), c(1, 0)),
    idx = 1:2,
    is.bnd = FALSE
  )
  expect_error(
    object = {
      sl <- fm_split_lines(mesh, segm)
    },
    NA
  )

  # Check if empty input is ok
  segm <- fm_segm(
    loc = NULL,
    idx = integer(0),
    is.bnd = FALSE
  )
  expect_error(
    object = {
      sl <- fm_split_lines(mesh, segm)
    },
    NA
  )
})




# Additional mesh integration tests

test_that("Flat mesh integration", {
  mesh <- fmexample$mesh

  ips0 <- fm_int(mesh, int.args = list(nsub2 = 0))
  ips9 <- fm_int(mesh, int.args = list(nsub2 = 9))

  expect_equal(sum(ips0$weight), sum(ips9$weight))
})

test_that("Sphere and globe mesh integration", {
  mesh <- fm_rcdt_2d_inla(globe = 1)

  ips0 <- fm_int(mesh, int.args = list(nsub2 = 0))
  ips9 <- fm_int(mesh, int.args = list(nsub2 = 9))

  expect_equal(sum(ips0$weight), 4 * pi)
  expect_equal(sum(ips9$weight), 4 * pi)

  mesh_ <- mesh
  mesh_$loc <- mesh_$loc * 1000

  ips0_ <- fm_int(mesh_, int.args = list(nsub2 = 0))
  ips9_ <- fm_int(mesh_, int.args = list(nsub2 = 9))

  expect_equal(sum(ips0_$weight), 4 * pi * 1e6)
  expect_equal(sum(ips9_$weight), 4 * pi * 1e6)

  mesh_2 <- fm_rcdt_2d_inla(globe = 1, crs = fm_crs("globe"))

  ips0_2 <- fm_int(mesh_2, int.args = list(nsub2 = 0))
  ips9_2 <- fm_int(mesh_2, int.args = list(nsub2 = 9))

  expect_equal(sum(ips0_2$weight), 4 * pi * 6370.997^2)
  expect_equal(sum(ips9_2$weight), 4 * pi * 6370.997^2)

  ips0_3 <- fm_int(mesh_2, int.args = list(nsub2 = 0))
  ips9_3 <- fm_int(mesh_2, int.args = list(nsub2 = 9))

  expect_equal(sum(ips0_3$weight), 4 * pi * 6370.997^2)
  expect_equal(sum(ips9_3$weight), 4 * pi * 6370.997^2)
})


test_that("Globe polygon integration", {
  mesh <- fm_rcdt_2d_inla(globe = 1, crs = fm_crs("globe"))

  poly <- sf::st_sfc(
    sf::st_polygon(
      list(rbind(
        c(-45, -45), c(-45, 45), c(45, 45), c(45, -45), c(-45, -45)
      ))
    ),
    crs = fm_crs("longlat_globe")
  )

  ips1 <- fm_int(mesh, samplers = poly, int.args = list(nsub = 2))

  expect_equal(
    nrow(ips1),
    9
  )
})


test_that("fm_int for linestring coinciding with mesh edges", {
  sc <- 1
  bnd <- fm_segm(
    rbind(
      c(0, 0 * sc),
      c(1, 0 * sc),
      c(1, 1 * sc),
      c(0, 1 * sc)
    ),
    idx = rbind(
      c(1, 2),
      c(2, 3),
      c(3, 4),
      c(4, 1)
    ),
    is.bnd = c(TRUE, TRUE, TRUE, TRUE)
  )
  mesh <- fm_rcdt_2d(boundary = bnd)
  # mesh_sizes <- c(1, 2, 3, 5, 7, 9)
  mesh_sizes <- c(1, 3, 5)
  names(mesh_sizes) <- paste0("mesh", mesh_sizes)
  meshes <- c(
    list(mesh0 = mesh),
    lapply(mesh_sizes, function(n) fm_subdivide(mesh, n = n))
  )

  int_line <- fm_segm(
    rbind(
      c(0.1, 0.1 * sc),
      c(0.95, 0.95 * sc)
    ),
    is.bnd = FALSE
  )

  #  x <- sf::st_linestring(int_line$loc + c(0.01, -0.01, 0.02, -0.03, 0, 0))
  x <- sf::st_linestring(int_line$loc)
  x <- sf::st_as_sf(sf::st_geometry(x))

  int.args <- list(nsub1 = 100)
  ips <- lapply(meshes, fm_int, samplers = x, int.args = int.args)
  (w <- vapply(
    ips,
    function(x) sum(x$weight),
    numeric(1)
  ))
  expect_equal(as.vector(w),
    rep((0.95 - 0.1) * sqrt(1 + sc^2), length(w)),
    tolerance = lowtol
  )

  # ips <- lapply(ips, function(x) x[x$weight > 1e-14, ])
  # (w <- vapply(
  #   ips,
  #   function(x) sum(x$weight),
  #   numeric(1)
  # ))
  # diff(range(w))
  #
  # library(ggplot2)
  # ggplot(
  #   do.call(dplyr::bind_rows,
  #           lapply(c(0, 1, 2, 3, 5, 7, 9, 15),
  #                  function(n) cbind(ips[[paste0("mesh", n)]], n = n)))) +
  #   geom_fm(data = meshes[["mesh3"]]) +
  #   geom_sf(aes(size = weight)) +
  #   scale_size_area() +
  #   geom_sf(data = x, alpha = 0.2, col = "red") +
  #   facet_wrap(~n, nrow = 2)
})

test_that("fm_int for linestring", {
  mesh <- fmexample$mesh
  # mesh_sizes <- c(1, 2, 3, 5, 7, 9)
  mesh_sizes <- c(1, 3)
  names(mesh_sizes) <- paste0("mesh", mesh_sizes)
  meshes <- c(
    list(mesh0 = mesh),
    lapply(mesh_sizes, function(n) fm_subdivide(mesh, n = n))
  )

  x <- sf::st_linestring(fm_as_segm(fmexample$boundary_sf[[1]])$loc)
  x <- sf::st_as_sf(sf::st_geometry(x))

  ips <- lapply(meshes, fm_int, samplers = x)
  (w <- vapply(
    ips,
    function(x) sum(x$weight),
    numeric(1)
  ))
  expect_equal(as.vector(w),
    rep(16.3259194526, length(w)),
    tolerance = lowtol
  )

  # ips <- lapply(ips, function(x) x[x$weight > 1e-14, ])
  # (w <- vapply(
  #   ips,
  #   function(x) sum(x$weight),
  #   numeric(1)
  # ))
  # diff(range(w))
  #
  # library(ggplot2)
  # ggplot(
  #   do.call(dplyr::bind_rows,
  #           lapply(c(0, 1, 2, 3, 5, 7, 9, 15),
  #                  function(n) cbind(ips[[paste0("mesh", n)]], n = n)))) +
  #   geom_fm(data = meshes[["mesh3"]]) +
  #   geom_sf(aes(size = weight)) +
  #   geom_sf(data = fmexample$boundary_sf[[1]], alpha = 0.2) +
  #   scale_size_area() +
  #   facet_wrap(~n, nrow = 2) +
  #   xlim(c(-1.8, -1.4)) +
  #   ylim(c(-1.6, -1.2))
})