tests/testthat/test-cacheGeo.R

In reproducible: Enhance Reproducibility of R Code

test_that("lightweight tests for code coverage", {
  skip_on_cran()

  testInit(
    c("sf", "terra"),
    opts = list("reproducible.overwrite" = TRUE, "reproducible.inputPaths" = NULL),
    needGoogleDriveAuth = TRUE
  )
  dPath <- checkPath(file.path(tempdir2()), create = TRUE)
  dPath2 <- checkPath(file.path(tempdir2()), create = TRUE)

  cloudFolderID <- "https://drive.google.com/drive/folders/1An8s2YLFPopQKr4BWK9o06fLSXx-Zggw"
  ## Unique per run. These files live in a Drive folder shared by every job,
  ## and the suite deletes by NAME -- so with fixed names, concurrent runs (8
  ## R-CMD-check matrix legs plus the coverage job all start together) delete
  ## each other's files mid-test. That surfaced as drive_rm() 404s: drive_ls()
  ## listed a file, another job removed it, drive_rm() then could not find it.
  rnd <- rndstr(1, 6)
  targetFile <- paste0("fireSenseParams_", rnd, ".rds")
  targetFile2 <- paste0("fireSenseParams2_", rnd, ".gpkg")
  localFileLux <- system.file("ex/lux.shp", package = "terra")

  # 1 step for each layer
  # 1st step -- get study area
  (full <- prepInputs(localFileLux, destinationPath = dPath)) |> capture.output() -> co # default is sf::st_read
  zoneA <- full[3:6, c("NAME_1", "AREA")]
  zoneB <- full[8, c("NAME_1", "AREA")] # not in A
  zoneC <- full[3, c("NAME_1", "AREA")] # yes in A
  zoneD <- full[7:8, c("NAME_1", "AREA")] # not in A, B or C
  zoneE <- full[3:5, c("NAME_1", "AREA")] # yes in A

  # This will be 1, 2 and 3 -- THIS IS THE INTERESTING ONE ... it will mean that a
  #  test below will have 2 different polygons the are "contains", so, result of
  #  Cache will be not just one polygon, but 2
  zoneF <- aggregate(
    full[, c("AREA")],
    by = list(NAME_1 = c(rep(1, 3), rep(2, NROW(full) - 3))),
    sum
  )
  zoneF <- zoneF[zoneF$NAME_1 == 1, ]

  # zoneF[, "AREA"] <- sf::st_area(zoneF)/1e6
  # 2nd step: re-write to disk as read/write is lossy; want all "from disk" for this ex.
  co <- capture.output({
    writeTo(zoneA, writeTo = "zoneA.shp", destinationPath = dPath)
    writeTo(zoneB, writeTo = "zoneB.shp", destinationPath = dPath)
    writeTo(zoneC, writeTo = "zoneC.shp", destinationPath = dPath)
    writeTo(zoneD, writeTo = "zoneD.shp", destinationPath = dPath)
    writeTo(zoneE, writeTo = "zoneE.shp", destinationPath = dPath)
    writeTo(zoneF, writeTo = "zoneF.shp", destinationPath = dPath)
    # Must re-read to get identical columns
    zoneA <- sf::st_read(file.path(dPath, "zoneA.shp"))
    zoneB <- sf::st_read(file.path(dPath, "zoneB.shp"))
    zoneC <- sf::st_read(file.path(dPath, "zoneC.shp"))
    zoneD <- sf::st_read(file.path(dPath, "zoneD.shp"))
    zoneE <- sf::st_read(file.path(dPath, "zoneE.shp"))
    zoneF <- sf::st_read(file.path(dPath, "zoneF.shp"))
  })

  # The function that is to be run. This example returns a data.frame because
  #    saving `sf` class objects with list-like columns does not work with
  #    many st_driver()
  fun <- function(domain, newField) {
    domain |>
      as.data.frame() |>
      cbind(params = I(lapply(seq_len(NROW(domain)), function(x) newField)))
  }

  # fun2 <- function(domain, newField) {
  #   domain |> as.data.frame() |>
  #     dplyr::mutate(params2 = list(list(a = seq_len(NROW(domain)),
  #                                   b = LETTERS[seq_len(NROW(domain))],
  #                                   d = TRUE)))
  # }
  fun3 <- function(domain, paramsVec) {
    cbind(domain, params = I(lapply(seq(NROW(domain)), function(x) paramsVec)))
  }

  # Run sequence -- A, B will add new entries in targetFile, C will not,
  #                 D will, E will not
  paramsVecList <- list(
    list(a = 1, b = 2, c = "D"),
    list(a = 2, b = 3, d = 4),
    list(a = 2, b = 3, e = 4),
    list(a = 2, b = 3, d = 4),
    list(a = 2, b = 3, d = 4),
    list(a = 2, b = 3, d = 4)
  )
  iter <- 0
  for (z in list(zoneA, zoneB, zoneC, zoneD, zoneE, zoneF)) {
    iter <- iter + 1
    if (identical(z, zoneA)) {
      # First iteration: targetFile doesn't exist yet, so different message
      mess <- "No remote targetFile exists"
    } else if (identical(z, zoneB) || identical(z, zoneD) || identical(z, zoneF)) {
      mess <- "Domain is not contained within the targetFile"
    }
    if (identical(z, zoneC) || identical(z, zoneE)) {
      mess <- "Spatial domain is contained within the url"
    }

    messCap <- capture_messages(
      out <- CacheGeo(
        targetFile = targetFile,
        domain = z,
        FUN = fun(domain, newField = I(list(list(a = 1, b = 1:2, c = "D")))),
        fun = fun, # pass whatever is needed into the function
        destinationPath = dPath,
        action = "update",
        verbose = 0
      )
    )
    expect_match(messCap, mess, all = FALSE)

    co <- capture.output({
      warns <- capture_warnings(expect_message(
        out2 <- CacheGeo(
          targetFile = targetFile2,
          domain = z,
          FUN = fun3(domain, paramsVec = paramsVecList[[iter]]),
          fun3 = fun3, # pass whatever is needed into the function
          paramsVecList = paramsVecList,
          iter = iter,
          destinationPath = dPath,
          action = "update"
        ),
        mess
      ))
    })

    if (NROW(warns)) {
      expect_match(warns, substr(.message$BecauseOfLossOfColumn(""), start = 1, 10), all = FALSE)
      expect_match(warns, "Dropping", all = FALSE)
    }
  }

  outSF <- sf::st_as_sf(out)

  skip_if_not_releaseVer_Linux()

  gls <- googledrive::drive_ls(cloudFolderID)
  alreadyThere <- gls$name %in% c(targetFile, targetFile2)

  if (any(alreadyThere)) {
    try(googledrive::drive_rm(gls$id[which(alreadyThere)]), silent = TRUE)
  }
  on.exit({
    ## Best-effort: a 404 here means the file is already gone, which is the
    ## desired end state, not a failure.
    try({
      gls <- googledrive::drive_ls(cloudFolderID)
      hits <- gls[gls$name %in% c(targetFile, targetFile2), ]
      if (NROW(hits)) googledrive::drive_rm(hits)
    }, silent = TRUE)
  })

  iter <- 0
  # the following will fail if not predictiveecology@gmail.com or eliotmcintire@gmail.com or the funky
  #   service account eliot-githubauthentication@genial-cycling-408722.iam.gserviceaccount.com if that
  #   has been added to the environment
  try(
    {
      for (z in list(zoneA, zoneB, zoneC, zoneD, zoneE, zoneF)) {
        iter <- iter + 1
        if (
          identical(z, zoneA) || identical(z, zoneB) || identical(z, zoneD) || identical(z, zoneF)
        ) {
          mess <- "Domain is not contained within the targetFile"
        }
        if (identical(z, zoneC) || identical(z, zoneE)) {
          mess <- "Spatial domain is contained within the url"
        }
        # With directory url

        out <- CacheGeo(
          targetFile = targetFile,
          domain = z,
          useCloud = TRUE,
          cloudFolderID = cloudFolderID,
          FUN = fun(domain, newField = I(list(list(a = 1, b = 1:2, c = "D")))),
          fun = fun, # pass whatever is needed into the function
          destinationPath = dPath2,
          action = "update",
          verbose = 0
        )

        co <- capture.output(
          warns <- capture_warnings(expect_message(
            out2 <- CacheGeo(
              targetFile = targetFile2,
              domain = z,
              useCloud = TRUE,
              cloudFolderID = cloudFolderID,
              FUN = fun3(domain, paramsVec = paramsVecList[[iter]]),
              fun3 = fun3, # pass whatever is needed into the function
              paramsVecList = paramsVecList,
              iter = iter,
              destinationPath = dPath,
              action = "update",
              verbose = 0
            ),
            mess
          ))
        )
        if (NROW(warns)) {
          expect_match(
            warns,
            substr(.message$BecauseOfLossOfColumn(""), start = 1, 10),
            all = FALSE
          )
          expect_match(warns, "Dropping", all = FALSE)
        }
      }
      outSFCloud <- sf::st_as_sf(out)
      expect_true(identical(outSFCloud, outSF))

      keeps <- sf::st_contains(outSF, outSF[1, 1], sparse = FALSE)

      polysWithParams <- outSF[keeps, ]

      expect_true(NROW(polysWithParams) == 2)

      smaller <- sf::st_as_sf(terra::buffer(terra::vect(polysWithParams[1, ]), width = -2000))

      plot(polysWithParams[2, 1], reset = FALSE)
      plot(polysWithParams[1, 1], add = TRUE, col = "red", reset = FALSE)
      smaller <- sf::st_as_sf(terra::buffer(terra::vect(polysWithParams[1, ]), width = -2000))
      plot(smaller[1, 1], add = TRUE, col = "green")

      out <- CacheGeo(
        targetFile = targetFile,
        domain = smaller,
        useCloud = TRUE,
        cloudFolderID = cloudFolderID,
        FUN = fun(domain, newField = I(list(list(a = 1, b = 1:2, c = "D")))),
        fun = fun, # pass whatever is needed into the function
        destinationPath = dPath2,
        action = "nothing"
      )
      outSFCloudSmaller <- sf::st_as_sf(out)
      expect_identical(as.data.frame(outSFCloudSmaller)[, "params"], out[, "params"])
    },
    silent = TRUE
  )
})