tests/testthat/test-pin-read-write.R

In tidymodels/vetiver: Version, Share, Deploy, and Monitor Models

skip_if_not_installed("mockery")

test_that("can pin a model", {
    b <- board_temp()
    v <- vetiver_model(cars_lm, "cars1")
    expect_snapshot(v)
    vetiver_pin_write(b, v)
    expect_equal(
        pin_read(b, "cars1"),
        list(
            model = butcher::butcher(cars_lm),
            prototype = vctrs::vec_slice(tibble::as_tibble(mtcars[,2:3]), 0)
        )
    )
})

test_that("can pin a model with no prototype", {
    b <- board_temp()
    expect_snapshot_warning(
        v <- vetiver_model(cars_lm, "cars_null", save_ptype = FALSE)
    )
    v <- vetiver_model(cars_lm, "cars_null", save_prototype = FALSE)
    vetiver_pin_write(b, v)
    expect_equal(
        pin_read(b, "cars_null"),
        list(
            model = butcher::butcher(cars_lm),
            prototype = NULL
        )
    )
})

test_that("can pin a model with custom prototype", {
    b <- board_temp()
    v <- vetiver_model(cars_lm, "cars_custom", save_prototype = mtcars[3:10, 2:3])
    vetiver_pin_write(b, v)
    expect_equal(
        pin_read(b, "cars_custom"),
        list(
            model = butcher::butcher(cars_lm),
            prototype = mtcars[3:10, 2:3]
        )
    )
})

test_that("default metadata for model", {
    b <- board_temp()
    v <- vetiver_model(cars_lm, "cars2")
    vetiver_pin_write(b, v)
    meta <- pin_meta(b, "cars2")
    expect_equal(meta$user, list(required_pkgs = NULL, renv_lock = NULL))
    expect_equal(meta$description, "An OLS linear regression model")
})

test_that("user can supply metadata for model", {
    b <- board_temp()
    v <- vetiver_model(cars_lm, "cars3",
                       description = "lm model for mtcars",
                       metadata = list(metrics = 1:10))
    vetiver_pin_write(b, v)
    meta <- pin_meta(b, "cars3")
    expect_equal(meta$user$metrics, 1:10)
    expect_equal(meta$description, "lm model for mtcars")
})

test_that("can read a pinned model", {
    b <- board_temp()
    cars_lm <- lm(mpg ~ cyl + disp, data = mtcars)
    v <- vetiver_model(cars_lm, "cars1")
    vetiver_pin_write(b, v)
    v1 <- vetiver_pin_read(b, "cars1")
    meta <- pin_meta(b, "cars1")
    expect_equal(v1$model, v$model)
    expect_equal(v1$model_name, v$model_name)
    expect_equal(v1$board, v$board)
    expect_equal(v1$description, v$description)
    expect_equal(
        v1$metadata,
        list(user = v$metadata$user,
             version = meta$local$version,
             url = meta$local$url,
             required_pkgs = v$metadata$required_pkgs)
    )
    expect_equal(v1$prototype, v$prototype)
    expect_equal(v1$versioned, FALSE)
})

test_that("can read an old pinned model with `required_pkgs` in blob", {
    b <- board_temp()
    pins::pin_write(
        board = b,
        x = list(
            model = v$model,
            ptype = v$ptype,
            required_pkgs = c("janeaustenr", "beepr")
        ),
        name = "cars-plus-pkgs",
        type = "rds",
        description = v$description,
        metadata = v$metadata$user,
        versioned = v$versioned
    )
    v2 <- vetiver_pin_read(b, "cars-plus-pkgs")
    expect_equal(v2$metadata$required_pkgs, c("janeaustenr", "beepr"))
})

test_that("can read a versioned model with metadata", {
    b <- board_temp(versioned = TRUE)
    cars_lm <- lm(mpg ~ cyl + disp, data = mtcars)
    v <- vetiver_model(cars_lm, "cars4",
                       description = "lm model for mtcars",
                       metadata = list(metrics = 1:10))
    vetiver_pin_write(b, v)
    v4 <- vetiver_pin_read(b, "cars4")
    meta <- pin_meta(b, "cars4")
    expect_equal(v4$model, v$model)
    expect_equal(v4$model_name, v$model_name)
    expect_equal(v4$board, v$board)
    expect_equal(v4$description, v$description)
    expect_equal(
        v4$metadata,
        list(user = v$metadata$user,
             version = meta$local$version,
             url = meta$local$url,
             required_pkgs = v$metadata$required_pkgs)
    )
    expect_equal(v4$prototype, v$prototype)
    expect_equal(v4$versioned, TRUE)
})

test_that("right message for reading with `check_renv`", {
    skip_on_cran()

    b <- board_temp(versioned = TRUE)
    mock_version_name <- mockery::mock(
        "20130104T050607Z-xxxxx",
        "20130204T050607Z-yyyyy",
        "20130304T050607Z-zzzzz",
    )
    local_mocked_bindings(version_name = mock_version_name, .package = "pins")
    v <- vetiver_model(cars_lm, "cars5")
    v$metadata$required_pkgs <- "ranger"
    vetiver_pin_write(b, v)
    expect_snapshot_warning(vetiver_pin_read(b, "cars5", check_renv = TRUE))

    vetiver_pin_write(b, v, check_renv = TRUE)
    v1 <- vetiver_pin_read(b, "cars5")
    expect_silent(v2 <- vetiver_pin_read(b, "cars5", check_renv = TRUE))
    expect_equal(v1, v2)

    new_lock <- renv$renv_lockfile_init(project = NULL)
    pins::pin_write(
        board = b,
        x = list(
            model = v$model,
            ptype = v$ptype,
            required_pkgs = v$metadata$required_pkgs
        ),
        name = v$model_name,
        type = "rds",
        description = v$description,
        metadata = list_modify(v$metadata$user, renv_lockfile = new_lock),
        versioned = v$versioned
    )

    expect_message(
        vetiver_pin_read(b, "cars5", check_renv = TRUE),
        regexp = "do not match your model"
    )

})