tests/testthat/test-segmentation.R

In e-sensing/sits: Satellite Image Time Series Analysis for Earth Observation Data Cubes

test_that("Segmentation", {
    # Example of classification of a data cube
    # Create a data cube from local files
    set.seed(29031956)
    data_dir <- system.file("extdata/raster/mod13q1", package = "sits")
    sinop <- sits_cube(
        source = "BDC",
        collection = "MOD13Q1-6",
        data_dir = data_dir,
        progress = FALSE
    )
    # create output dir
    output_dir <- paste0(tempdir(), "/seg")
    if (!dir.exists(output_dir)) {
        dir.create(output_dir)
    }
    # Segment the cube
    segments <- sits_segment(
        cube = sinop,
        output_dir = output_dir,
        multicores = 2,
        memsize = 24,
        progress = FALSE,
        version = "vt"
    )

    expect_s3_class(object = segments, class = "vector_cube")
    expect_true("vector_info" %in% colnames(segments))
    # Read segments as sf object
    vector_segs <- .segments_read_vec(segments)
    expect_equal(
        as.character(unique(sf::st_geometry_type(vector_segs))),
        expected = "POLYGON"
    )
    vector_obj <- .vector_open_vec(segments$vector_info[[1]]$path)

    expect_true("sf" %in% class(vector_obj))

    crs_wkt <- .vector_crs(vector_obj, wkt = TRUE)
    expect_equal(class(crs_wkt), "character")
    expect_true(grepl("PROJCRS", crs_wkt))

    crs_nowkt <- .vector_crs(vector_obj, wkt = FALSE)
    expect_equal(class(crs_nowkt), "crs")
    expect_true(grepl("PROJCRS", crs_nowkt$wkt))

    p1 <- plot(segments, band = "NDVI")
    expect_equal(p1[[1]]$shp_name, "stars_obj")
    expect_equal(p1$tm_grid$grid.projection, 4326)
    expect_equal(p1$tm_layout$legend.bg.alpha, 0.5)

    # testing resume feature
    Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE")
    expect_message({
        object <- sits_segment(
            cube = sinop,
            output_dir = output_dir,
            multicores = 1,
            memsize = 24,
            progress = FALSE,
            version = "vt"
        )
    })
    # test read vector cube
    segment_cube <- sits_cube(
        source = "BDC",
        collection = "MOD13Q1-6",
        data_dir = data_dir,
        vector_dir = output_dir,
        vector_band = "segments",
        version = "vt",
        progress = FALSE
    )
    expect_s3_class(object = segment_cube, class = "vector_cube")
    expect_true("vector_info" %in% colnames(segment_cube))

    # Train a rf model
    samples_filt <- sits_apply(samples_modis_ndvi,
                               NDVI = sits_sgolay(NDVI))

    rfor_model <- sits_train(samples_filt, sits_rfor())
    # Create a probability vector cube
    start_date <- sits_timeline(sinop)[1]
    end_date <- sits_timeline(sinop)[length(sits_timeline(sinop))]
    probs_segs <- sits_classify(
        data = segments,
        ml_model = rfor_model,
        filter_fn = sits_sgolay(),
        output_dir = output_dir,
        n_sam_pol = 20,
        multicores = 6,
        memsize = 24,
        start_date = start_date,
        end_date = end_date,
        version = "vt2"
    )
    p2 <- plot(probs_segs)
    expect_equal(p2$tm_shape$shp_name, "sf_seg")
    expect_equal(ncol(p2$tm_shape$shp), 9)

    expect_s3_class(probs_segs, class = "probs_vector_cube")
    expect_true(
        "vector_info" %in% colnames(probs_segs)
    )
    # Read segments of a probability cube
    vector_probs <- .segments_read_vec(probs_segs)
    expect_true(
        all(sits_labels(probs_segs) %in% colnames(vector_probs))
    )
    # test resume feature
    Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE")
    expect_message({
        obj <- sits_classify(
            data = segments,
            ml_model = rfor_model,
            output_dir = output_dir,
            n_sam_pol = 20,
            multicores = 6,
            memsize = 24,
            version = "vt2"
        )
    })
    # Create a classified vector cube
    class_segs <- sits_label_classification(
        cube = probs_segs,
        output_dir = output_dir,
        multicores = 2,
        memsize = 4
    )
    expect_s3_class(object = class_segs, class = "class_vector_cube")
    expect_true(
        "vector_info" %in% colnames(class_segs)
    )
    # Read segments of a classified cube
    vector_class <- .segments_read_vec(class_segs)
    expect_equal(nrow(vector_probs), nrow(vector_class))
    expect_true(all(sits_labels(rfor_model) %in% colnames(vector_probs)))
    expect_true(all(sits_labels(rfor_model) %in% colnames(vector_class)))
    expect_true(
        "class" %in% colnames(vector_class)
    )
    p3 <- plot(class_segs)
    expect_equal(p3$tm_shape$shp_name, "sf_seg")
    expect_equal(ncol(p3$tm_shape$shp), 2)
    expect_equal(p2$tm_compass$compass.show.labels, 1)

    # testing resume feature
    Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE")
    expect_message({
        obj <- sits_label_classification(
            cube = probs_segs,
            output_dir = output_dir,
            multicores = 2,
            memsize = 4
        )

    })
    uncert_vect <- sits_uncertainty(probs_segs,
                                    output_dir = output_dir)

    p4 <- plot(uncert_vect)
    expect_equal(p4$tm_shape$shp_name, "sf_seg")

    sf_uncert <- .segments_read_vec(uncert_vect)
    expect_true("entropy" %in% colnames(sf_uncert))
    expect_equal(nrow(sf_uncert), nrow(vector_class))
    expect_true(all(sits_labels(rfor_model) %in% colnames(sf_uncert)))
})
test_that("Segmentation of large files",{
    modis_cube <- .try(
        {
            sits_cube(
                source = "BDC",
                collection = "MOD13Q1-6",
                bands = c("NDVI", "EVI", "CLOUD"),
                tiles = "012010",
                start_date = "2018-09-14",
                end_date = "2019-08-29",
                progress = FALSE
            )
        },
        .default = NULL
    )
    testthat::skip_if(purrr::is_null(modis_cube),
                      message = "BDC is not accessible"
    )
    output_dir <- paste0(tempdir(), "/segs")
    if (!dir.exists(output_dir)) {
        dir.create(output_dir)
    }
    expect_warning(
        modis_cube_local <- sits_regularize(
            cube = modis_cube,
            period = "P1M",
            res = 1000,
            multicores = 6,
            output_dir = output_dir
        )
    )
    expect_true(.cube_is_regular(modis_cube_local))
    expect_true(all(sits_bands(modis_cube_local) %in% c("EVI", "NDVI")))
    segments <- sits_segment(
        cube = modis_cube_local,
        seg_fn = sits_slic(
            step = 50,
            iter = 10,
            minarea = 100
        ),
        output_dir = output_dir,
        multicores = 4,
        memsize = 16,
        progress = FALSE,
        version = "v2bands"
    )
    expect_s3_class(object = segments, class = "vector_cube")
    expect_true("vector_info" %in% colnames(segments))

    # Train a rf model
    rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor)
    probs_segs <- sits_classify(
        data = segments,
        ml_model = rfor_model,
        output_dir = output_dir,
        n_sam_pol = 10,
        multicores = 6,
        memsize = 24,
        version = "v2bands"
    )
    expect_s3_class(probs_segs, class = "probs_vector_cube")
    expect_true(
        "vector_info" %in% colnames(probs_segs)
    )
    # Read segments of a probability cube
    vector_probs <- .segments_read_vec(probs_segs)
    expect_true(
        all(sits_labels(probs_segs) %in% colnames(vector_probs))
    )
})