NumPy

NumPy is available immediately. The vectorization that makes it fast in a normal Python environment carries over to the WASM build:

Try increasing n. The estimate gets more accurate but takes longer. At a million samples you’re typically accurate to 3–4 decimal places.

Matplotlib

Plots render inline. The same Monte Carlo simulation, visualized: points inside the unit circle versus outside.

Pandas

A random walk built as a pandas DataFrame, with a distance-from-origin column:

The central limit theorem in Python

The same CLT demo from the R post: exponential population, sample means converging to normal as n_obs grows. Change the value and re-run:

Installing packages with micropip

Packages not bundled with Pyodide can be installed with micropip. Pure-Python packages generally work; packages with C extensions need a WASM build:

micropip.install is asynchronous, so await is required. It downloads from PyPI and installs into the in-browser environment.

Limitations

A few things don’t work in a WASM environment:

• Threading: threading and multiprocessing are unavailable or limited.
• File I/O: no access to your local filesystem. Use io.StringIO / io.BytesIO for in-memory file handling.
• Network requests: requests won’t work. Use pyodide.http.open_url or JavaScript’s fetch via pyodide.globals.
• C-extension packages: packages that rely on compiled C extensions (like lightgbm, xgboost) only work if a WASM build exists.

For most data science and statistics work the pre-installed stack (NumPy, pandas, matplotlib, scipy, scikit-learn) covers the common cases. Scikit-learn is fully available. That’s a separate post.

What’s an MCP App?

The Model Context Protocol is an open standard for connecting AI assistants to external tools and data. MCP servers expose tools that an AI model can call: search a database, run a computation, fetch a file. MCP Apps extend this idea to include a UI. Instead of the model calling a function and getting text back, the user sees an interactive interface rendered directly in the chat.

In practice, a Shiny-style dashboard can appear inline in Claude Desktop. The user changes a dropdown, the tool fires, the output updates, all inside the conversation. No separate browser tab, no URL to share, no deployment to manage.

Quick start

Install shinymcp from GitHub:

# install.packages("pak")
pak::pak("JamesHWade/shinymcp")

An MCP App has two parts: UI components that render in the chat, and tools that run R code when inputs change. Here’s a minimal dataset explorer:

library(shinymcp)
library(bslib)

ui <- page_sidebar(
  theme = bs_theme(preset = "shiny"),
  title = "Dataset Explorer",
  sidebar = sidebar(
    shiny::selectInput("dataset", "Choose dataset", c("mtcars", "iris", "pressure"))
  ),
  card(
    card_header("Summary"),
    mcp_text("summary")
  )
)

tools <- list(
  ellmer::tool(
    fun = function(dataset = "mtcars") {
      data <- get(dataset, envir = asNamespace("datasets"))
      paste(capture.output(summary(data)), collapse = "\n")
    },
    name = "get_summary",
    description = "Get summary statistics for the selected dataset",
    arguments = list(
      dataset = ellmer::type_string("Dataset name")
    )
  )
)

app <- mcp_app(ui, tools, name = "dataset-explorer")
serve(app)

Save this as app.R, then register it in your Claude Desktop config:

{
  "mcpServers": {
    "dataset-explorer": {
      "command": "Rscript",
      "args": ["/path/to/app.R"]
    }
  }
}

Restart Claude Desktop and invoke the tool. An interactive UI appears inline in the conversation. Changing the dropdown calls the tool and updates the output without a page reload.

The core idea: flatten your reactive graph

If you’ve built Shiny apps, you think in reactive expressions: inputs feed into reactives, which feed into outputs. In an MCP App, you flatten that graph into tool functions.

Each connected group of inputs, reactives, and outputs becomes a single tool. The tool takes input values as arguments and returns a named list of outputs. Here’s what the translation looks like:

# --- Shiny server ---
server <- function(input, output, session) {
  filtered <- reactive({
    penguins[penguins$species == input$species, ]
  })
  output$scatter <- renderPlot({
    ggplot(filtered(), aes(bill_length_mm, bill_depth_mm)) + geom_point()
  })
  output$stats <- renderPrint({
    summary(filtered())
  })
}

# --- Equivalent MCP App tool ---
ellmer::tool(
  fun = function(species = "Adelie") {
    filtered <- penguins[penguins$species == species, ]

    # Render plot to base64 PNG
    p <- ggplot2::ggplot(filtered, ggplot2::aes(bill_length_mm, bill_depth_mm)) +
      ggplot2::geom_point()
    tmp <- tempfile(fileext = ".png")
    ggplot2::ggsave(tmp, p, width = 7, height = 4, dpi = 144)
    on.exit(unlink(tmp))

    list(
      scatter = base64enc::base64encode(tmp),
      stats = paste(capture.output(summary(filtered)), collapse = "\n")
    )
  },
  name = "explore",
  description = "Filter and visualize penguins",
  arguments = list(
    species = ellmer::type_string("Penguin species")
  )
)

The return keys (scatter, stats) must match the output IDs in the UI (mcp_plot("scatter"), mcp_text("stats")). The bridge routes each value to the right element.

How the bridge works

MCP Apps render inside sandboxed iframes in the AI chat interface. A lightweight JavaScript bridge (no npm dependencies) handles the communication:

1. User changes an input
2. The bridge detects which form elements are inputs (by matching tool argument names to element id attributes) and collects their values
3. Bridge sends a tools/call request to the host via postMessage
4. Host proxies the call to the MCP server (your R process)
5. R tool function runs and returns results
6. Bridge updates the output elements

The input auto-detection is the key convenience. If your selectInput has id = "species" and your tool has an argument called species, the bridge wires them together automatically. For edge cases where ids don’t match argument names, mcp_input() lets you explicitly mark an element.

Automatic conversion

If you have an existing Shiny app you want to convert, shinymcp includes a parse-analyze-generate pipeline:

convert_app("path/to/my-shiny-app")

This parses the UI and server code, maps the reactive dependency graph into tool groups, and writes a working MCP App with tools, components, and a server entrypoint. The generated tool bodies contain placeholders for the computation logic.

For complex apps with dynamic UI, modules, or file uploads, shinymcp also ships a deputy skill that guides an AI agent through the conversion process.

Output components

shinymcp provides output components that correspond to standard Shiny outputs:

For inputs, you use the standard shiny and bslib inputs you already know: selectInput, numericInput, checkboxInput, etc. The bridge auto-detects them.

Why this matters

The interesting part isn’t the technology. It’s the interaction pattern. When a Shiny app lives inside a chat, the AI can see and respond to what the user is doing in the app. The model has context about both the conversation and the interactive exploration.

I’m still early in figuring out what this enables. If you build something with it, I’d like to hear about it.

Resources

• shinymcp on GitHub
• shinymcp documentation
• ellmer, the LLM framework shinymcp builds on
• MCP specification
• bslib, Bootstrap layout and theming for the UI

The moment everything stalls

You know the scene. You’ve crafted your narrative. You’ve polished the slides. You tell the story. And then a stakeholder asks:

“That’s interesting, but what if we looked at the data this way?”

Your answer: “I’ll have to get back to you on that.”

The conversation stops. You had their attention and you couldn’t keep it, because a static slide deck can’t bend to the question.

Two traps

We don’t build more apps because we fall into one of two traps.

Trap 1: “Don’t Build.” It’s too much effort for just one meeting. The development hill looks too steep, so we default to slides.

Trap 2: “Over-Build.” If I build it, it must be production-grade. We over-engineer a complex solution for a simple, one-off need.

The consequence of both traps is the same: death by PowerPoint.

A third option

What if building an app for a single meeting was as easy as making a slide deck? That’s the disposable app.

A disposable app:

• Gets its value from immediate impact, not longevity
• Is a communication artifact, not a production system
• Is designed to be thrown away

Think of it as a whiteboard sketch, not a monument. Valuable in the moment, erasable afterward.

How to build one

The development hill isn’t steep anymore. With AI-assisted coding, you can go from a question to a working Shiny app in about fifteen minutes.

@shiny your task is to build a fun and engaging shiny app all about potty training.

- The purpose of the app is to help my wife and me know what to do next
  when it comes to potty training _twins_ (yikes!).
- We are following _Oh Crap! Potty Training_ by Jamie Glowacki.

The app should consist of:
  - a page_sidebar where the left sidebar is a shinychat that we can use
    as our Jamie Glowacki stand-in in times of need. We should use
    `claude-sonnet-4` via ellmer as our guide.
  - a main page with trackers and graphs to track pees, poops, and
    parental sanity. Remember that it matters if we made it to the potty
    or if it was an accident.
  - For bonus points, you can include a prediction for the next "event".
  - You should give this a theme suitable for the task at hand.
    Use `_brand.yml` to help you out.

It is important to remember to treat the twins separately. This should
be easy, they are boy-girl twins named Henry and Penelope.

Overcoming the objections

The mindset shift

The tools are here. The only thing left is to change how we think.

This isn’t about lowering standards. Production apps should be tested, maintained, and properly engineered. But not every app needs to be a production app. A napkin sketch isn’t a failure of architecture. It’s a different tool for a different job.

The challenge

The next time you have a presentation, I challenge you:

Open Positron before you open PowerPoint.

Ask yourself whether your audience would rather look at your data or play with it. If the answer is play, build a disposable app. It’ll take less time than you think, and the conversation it starts will be worth more than any slide deck.

And when the meeting’s over, delete it.

The opening provocation

The talk opens with two lines in large text against a dark background:

You should build more Shiny apps. And then throw them away.

The juxtaposition is deliberate. Most conference talks about Shiny apps are about building better, longer-lived, more robust ones. This one inverts that. The phrase “throw them away” is meant to sound almost irresponsible, because getting people interested in an idea often requires making them feel slightly uncomfortable first.

It landed. The room got quiet in a way that felt like engagement, and I’ll take that.

Who I am and why I can say this

I maintain a two-year-old production app with 100-plus users, tests, CI/CD, and a backlog. I know the pain of longevity. But I also build apps for single meetings — apps that live for an hour and die gracefully.

This credibility slide mattered. If I only built disposable apps, you might reasonably dismiss the argument as naivety about engineering. The production side of my work is what earns the right to advocate for the disposable side.

In hindsight, this section ran a little long. The audience doesn’t need much convincing that I’ve built software before. A single sentence would have done it.

The moment everything stalls

The scenario: you’ve crafted a narrative, polished the slides, and you’re telling the story. A stakeholder asks:

“That’s interesting, but what if we looked at the data this way?”

Your answer: “I’ll have to get back to you on that.”

The conversation stops. You had their attention and couldn’t keep it, because a static slide deck can’t bend to the question.

Most people in a data science audience have been in this room. The scenario resonated — I could see it on faces. This is the problem worth solving.

Interactive vs. passive

This was my favorite slide in the deck. A fine art gallery and a children’s museum side by side, with no explanation. Two completely different philosophies about how people should relate to what’s on display.

A slide deck is a fine art gallery. You can look at the data, but please don’t touch. A Shiny app is a children’s museum. The data is there to be played with.

The question I posed to the audience: “What do you hope to achieve with your presentation?” If the answer involves people understanding the data — not just seeing it — you probably want the children’s museum.

The images did the work here. I barely needed to speak.

The two traps

Why don’t more people build apps? Two failure modes:

Trap 1: “Don’t Build.” The development hill looks too steep for a single meeting. We default to slides because they feel like the path of least resistance.

Trap 2: “Over-Build.” If we do decide to build, engineering instincts kick in. We add a database, set up CI/CD, write tests. We engineer a production system for a problem that needed a fifteen-minute solution.

Both traps lead to the same outcome: something static when you could have had something interactive.

The punchline: “The consequence of both traps? Death by PowerPoint.” That’s a bit of a crowd-pleasing line, and it worked, but I think the “over-build” trap is the more interesting and less-discussed one. Most talks about app development implicitly encourage it.

The disposable mindset

The definition I put on screen:

• Its value is in its immediate impact, not its longevity.
• It’s a communication artifact, not a production system.
• It’s designed to be thrown away.

The analogy that holds up best: a whiteboard sketch. People gather around it, point at it, annotate it. At the end of the meeting, someone erases it. That’s not a failure — that’s what whiteboards are for. A disposable Shiny app is the same thing, with interactivity.

This section could have been shorter. The concept isn’t complicated. Say it once, cleanly, and move on.

How to build one

The practical core of the talk. I walked through building an actual app live: the Twin Potty Training Command Center. (Twin toddlers in potty training plus a four-year-old plus four cats equals a legitimately chaotic data problem that needed a Shiny solution.)

@shiny your task is to build a fun and engaging shiny app all about potty training.

- The purpose of the app is to help my wife and me know what to do next
  when it comes to potty training _twins_ (yikes!).
- We are following _Oh Crap! Potty Training_ by Jamie Glowacki.

The app should consist of:
  - a page_sidebar where the left sidebar is a shinychat that we can use
    as our Jamie Glowacki stand-in in times of need. We should use
    `claude-sonnet-4` via ellmer as our guide.
  - a main page with trackers and graphs to track pees, poops, and
    parental sanity. Remember that it matters if we made it to the potty
    or if it was an accident.
  - For bonus points, you can include a prediction for the next "event".
  - You should give this a theme suitable for the task at hand.
    Use `_brand.yml` to help you out.

It is important to remember to treat the twins separately. This should
be easy, they are boy-girl twins named Henry and Penelope.

Overcoming objections

Three objections come up reliably when I describe this approach.

“Who will support it?” Nobody. That’s the point. You don’t maintain a whiteboard drawing — you erase it. If you need the app again, you rebuild it. You probably understand the problem better now anyway, so the rebuild will be faster and better.

“Won’t this create app sprawl?” Yes, potentially. I’ve been accused of being an app hoarder, so I might be the wrong person to ask. The key distinction is communication artifacts vs. production systems. The commitment is that you delete them. If an app proves valuable enough to outlive the meeting, that’s a signal to build a proper version — with tests and CI/CD and a maintenance plan. Most apps won’t earn that.

“Isn’t this more work than slides?” The accounting:

• Slide deck: ~8 hours of work, low impact, zero interactivity.
• Disposable app: ~1 hour, high impact, full interactivity.

The ratio isn’t close. And data scientists generally find coding more enjoyable than slide alignment, which matters more than it sounds.

The challenge

The closing:

The next time you have a presentation — open Positron before you open PowerPoint.

Not every presentation needs an app. But more of them could use one than currently do. Ask the question before defaulting to slides.

And when the meeting’s over: delete it.

Base R runs immediately

The Collatz sequence converges to 1 from any positive integer. Change 27 to any other starting number:

Old Faithful has a distinctly bimodal eruption pattern. A density estimate shows the two clusters better than a histogram:

The central limit theorem, interactively

Draw n_obs samples from an exponential distribution (right-skewed, decidedly non-normal), compute the sample mean, repeat 2000 times. The orange curve is the normal approximation.

Set n_obs <- 1, then n_obs <- 5, then n_obs <- 30. The distribution of means converges to normal.

ggplot2

ggplot2 loaded in the background while you were reading. Same faithful data, with 2D density contours:

The two clusters are real. Old Faithful has two modes: short eruptions (~2 min) with short waits (~55 min), and long eruptions (~4.5 min) with long waits (~80 min).

Installing packages from CRAN

Any package with a WASM binary can be pre-loaded via the packages key in the document frontmatter. Both ggplot2 and palmerpenguins are loaded that way here, which is why this cell runs without an install.packages() call:

The WASM CRAN mirror covers most of the tidyverse and common packages. Three ways to install:

• Frontmatter packages key (used above): packages load before the first cell runs. Best for dependencies your post relies on from the start.
• webr::install("pkg") in a cell: installs at runtime inside a code cell. Works for packages you want readers to load on demand.
• install.packages(): works after calling webr::shim_install(), which patches the function to use the WASM mirror. Useful if you want familiar CRAN-style syntax.

webR can’t compile from source, so packages need a WASM binary. Check repo.r-wasm.org to see what’s available.

Where webR fits

The best case is when the code itself is what you’re teaching. Parameter exploration earns the startup time: the CLT cell above lets readers change n_obs from 1 to 30 and watch the histogram shift. That experience is the lesson in a way that a static image isn’t.

Algorithm exploration is another good fit. Code that behaves differently on different inputs — recursive sequences, graph traversals, sorting algorithms — invites readers to poke at it. The Collatz sequence starting at 27 takes 111 steps. Starting at 837799 takes 524. Readers can find out without leaving the page.

Simulation-based statistical intuition also works well. Bootstrap confidence intervals, permutation tests, birthday problem probabilities: hard to explain with formulas, obvious after running 2000 simulations. WebR is fast enough for this kind of thing that the wait doesn’t become the story.

When to skip it

WebR adds 5–10 seconds of startup and loads the full R runtime into the browser. That cost is worth it only if readers will actually interact with the code.

Skip it when the post is about results. If you’re presenting a plot and explaining what it means, render it statically. The reader gets the information faster, the page works without JavaScript, and there’s nothing to wait for.

Skip it for large data. Everything runs in the browser with no server behind it, which means everything loads into browser memory. A 50 MB CSV will be slow on a laptop and painful on mobile. If you need real data, use a small representative sample or a synthetic dataset.

Skip it for heavy computation. WebR runs in a single browser thread without the optimized BLAS/LAPACK libraries that native R uses. A simulation that takes one second in R might take ten in webR. The CLT demo above works fine. Fitting a random forest on 100,000 rows does not.

Skip it for benchmarking. WebR timing results don’t represent native R performance. If your point involves timing, either note this explicitly or skip webR for that post.

Scraping Text from R4DS

The first step is to scrape the text from the R4DS book. We’ll use the crawl() function to scrape the text from the book and store it in a data frame. The crawl() function uses the rvest package to scrape the text from the online book and {tokenizers} to split the text into chunks for subsequent processing.

The code to scrape the data is relatively simple but is unlikely to work on all sites. From some internal testing, it works quite well on {pkgdown} and similar documentation sites.

library(gpttools)
crawl("https://r4ds.hadley.nz/")

Under the hood there are a few things going on. Here is the annotated function and associated functions:

crawl <- function(url,
                  index_create = TRUE,
                  aggressive = FALSE,
                  overwrite = FALSE,
                  num_cores = parallel::detectCores() - 1) {
  local_domain <- urltools::url_parse(url)$domain
  withr::local_options(list(
    cli.progress_show_after = 0,
    cli.progress_clear = FALSE
  ))
  future::plan(future::multisession, workers = num_cores)
  scraped_data_dir <-
    file.path(tools::R_user_dir("gpttools", which = "data"), "text")
  scraped_text_file <-
    glue::glue("{scraped_data_dir}/{local_domain}.parquet")

  if (file.exists(scraped_text_file) && rlang::is_false(overwrite)) {
    cli::cli_abort(
      c(
        "!" = "Scraped data already exists for this domain.",
        "i" = "Use {.code crawl(<url>, overwrite = TRUE)} to overwrite."
      )
    )
  }

  cli_rule("Crawling {.url {url}}")
  cli_inform(c(
    "i" = "This may take a while.",
    "i" = "Gathering links to scrape"
  ))
  links <-
    recursive_hyperlinks(local_domain, url, aggressive = aggressive) |>
    unique()
  cli_inform(c("i" = "Scraping validated links"))
  scraped_data <-
    purrr::map(links, \(x) {
      if (identical(check_url(x), 200L)) {
        tibble::tibble(
          link    = x,
          text    = paste(scrape_url(x), collapse = " "),
          n_words = tokenizers::count_words(text)
        )
      } else {
        cli::cli_inform(c(
          "!" = "Skipped {url}",
          "i" = "Status code: {status}"
        ))
      }
    }) |>
    dplyr::bind_rows() |>
    dplyr::distinct()
  arrow::write_parquet(
    scraped_data,
    glue("text/{local_domain}.parquet")
  )
}

recursive_hyperlinks <- function(local_domain,
                                 url,
                                 checked_urls = NULL,
                                 aggressive = FALSE) {
  links <- url[!(url %in% checked_urls)]
  if (length(links) < 1) {
    return(checked_urls)
  }

  if (aggressive) {
    domain_pattern <- glue("^https?://(?:.*\\.)?{local_domain}/?")
  } else {
    domain_pattern <- glue("^https?://{local_domain}/?")
  }

  checked_urls <- c(checked_urls, links)
  cli::cli_inform(c("i" = "Total urls: {length(checked_urls)}"))
  links_df <- furrr::future_map(links, get_hyperlinks) |>
    dplyr::bind_rows() |>
    dplyr::filter(!stringr::str_detect(link, "^\\.$|mailto:|^\\.\\.|\\#|^\\_$"))

  new_links <-
    purrr::pmap(as.list(links_df), \(parent, link) {
      clean_link <- NULL
      if (stringr::str_detect(link, paste0("^https?://", local_domain))) {
        clean_link <- link
      } else if (stringr::str_detect(link, "^/[^/]|^/+$|^\\./|^[[:alnum:]]") &&
        !stringr::str_detect(link, "^https?://")) {
        if (stringr::str_detect(link, "^\\./")) {
          clean_link <- stringr::str_replace(link, "^\\./", "/")
        } else if (stringr::str_detect(link, "^[[:alnum:]]")) {
          clean_link <- glue::glue("/", link)
        } else {
          clean_link <- link
        }
        clean_link <- glue::glue("{parent}{clean_link}")
      }
    }) |>
    unlist()

  recursive_hyperlinks(local_domain, unique(new_links), checked_urls)
}

get_hyperlinks <- function(url) {
  rlang::check_installed("rvest")
  status <- httr::GET(url) |> httr::status_code()
  if (identical(status, 200L)) {
    tibble::tibble(
      parent = url,
      link = rvest::read_html(url) |>
        rvest::html_nodes("a[href]") |>
        rvest::html_attr("href") |>
        unique()
    )
  } else {
    cli::cli_warn(c(
      "!" = "URL not valid.",
      "i" = "Tried to scrape {url}",
      "i" = "Status code: {status}"
    ))
  }
}

scrape_url <- function(url) {
  rlang::check_installed("rvest")
  exclude_tags <- c("style", "script", "head", "meta", "link", "button")
  text <- rvest::read_html(url) |>
    rvest::html_nodes(xpath = paste("//body//*[not(self::",
      paste(exclude_tags, collapse = " or self::"),
      ")]",
      sep = ""
    )) |>
    rvest::html_text2() |>
    remove_new_lines()
  if ("You need to enable JavaScript to run this app." %in% text) {
    cli::cli_warn("Unable to parse page {url}. JavaScript is required.")
    NULL
  } else {
    text
  }
}

crawl() that takes in a single argument, url, which is a character string of the URL to be scraped. The function scrapes all hyperlinks within the same domain. The scraped text is processed into a tibble format and saved as a parquet file using the {arrow} package into a directory called “text” with a filename that includes the local domain extracted earlier.

The function begins by extracting the local domain of the input URL using the urltools::url_parse() function, which returns a parsed URL object, and then extracting the domain component of the object.

The function then calls another function called recursive_hyperlinks() to recursively extract all hyperlinks within the url and validates the links in the process by only keeping urls that return a status code of 200 (i.e., the webpage is accessible).

The function then loops through each link and scrapes the text from each webpage and creates a tibble with three columns: link, text, and n_words. The link column contains the URL, the text column contains the scraped text, and the n_words column contains the number of words in the scraped text.

Generating Embeddings

After scraping the text data from the R4DS book, the next step is to generate embeddings for each chunk of text. This can be done using the create_index() function provided by the {gpttools} package. create_index() takes in a single argument, domain, which should be a character string indicating the domain of the scraped data.

Here’s the code to generate embeddings for the R4DS text data:

# Specify the domain of the scraped data
domain <- "r4ds.hadley.nz"

# Create embeddings for each chunk of text in the scraped data
index <- create_index(domain)

create_index() function prepares the scraped data for indexing using the prepare_scraped_files() function, which splits the text into chunks and calculates the number of tokens in each chunk. It then calls add_embeddings() to generate embeddings for each chunk of text using the OpenAI API. A resulting tibble with embeddings is stored as a feather file using, again using the {arrow} package.

Here’s the code for the create_index() function and helper functions:

create_index <- function(domain, overwrite = FALSE) {
  index_dir <-
    file.path(tools::R_user_dir("gpttools", which = "data"), "index")
  index_file <-
    glue::glue("{index_dir}/{domain}.parquet")

  if (file.exists(index_file) && rlang::is_false(overwrite)) {
    cli::cli_abort(
      c(
        "!" = "Index already exists for this domain.",
        "i" = "Use {.code overwrite = TRUE} to overwrite index."
      )
    )
  }
  cli::cli_inform(c(
    "!" = "You are about to create embeddings for {domain}.",
    "i" = "This will use many tokens. Only proceed if you understand the cost.",
    "i" = "Read more about embeddings at {.url
      https://platform.openai.com/docs/guides/embeddings}."
  ))
  ask_user <- usethis::ui_yeah(
    "Would you like to continue with creating embeddings?"
  )
  if (rlang::is_true(ask_user)) {
    index <-
      prepare_scraped_files(domain = domain) |>
      add_embeddings()
    if (rlang::is_false(dir.exists(index_dir))) {
      dir.create(index_dir, recursive = TRUE)
    }
    arrow::write_parquet(
      x    = index,
      sink = index_file
    )
  } else {
    cli_inform("No index was created for {domain}")
  }
}

prepare_scraped_files <- function(domain) {
  scraped_dir <- tools::R_user_dir("gpttools", which = "data")
  arrow::read_parquet(glue("{scraped_dir}/text/{domain}.parquet")) |>
    dplyr::mutate(
      chunks = purrr::map(text, \(x) {
        chunk_with_overlap(x,
          chunk_size = 500,
          overlap_size = 50,
          doc_id = domain,
          lowercase = FALSE,
          strip_punct = FALSE,
          strip_numeric = FALSE,
          stopwords = NULL
        )
      })
    ) |>
    tidyr::unnest(chunks) |>
    tidyr::unnest(chunks) |>
    dplyr::rename(original_text = text) |>
    dplyr::mutate(n_tokens = tokenizers::count_characters(chunks) %/% 4)
}

add_embeddings <- function(index) {
  index |>
    dplyr::mutate(
      embeddings = purrr::map(
        .x = chunks,
        .f = create_openai_embedding,
        .progress = "Create Embeddings"
      )
    ) |>
    tidyr::unnest(embeddings)
}

create_openai_embedding <-
  function(input_text,
           model = "text-embedding-ada-002",
           openai_api_key = Sys.getenv("OPENAI_API_KEY")) {
    body <- list(
      model = model,
      input = input_text
    )
    embedding <- query_openai_api(body, openai_api_key, task = "embeddings")
    embedding$usage$total_tokens
    tibble::tibble(
      usage = embedding$usage$total_tokens,
      embedding = embedding$data$embedding
    )
  }

The resulting tibble contains the following columns:

• link: URL of the webpage
• original_text: scraped text
• n_words: number of words in the scraped text
• chunks: text split into chunks
• usage: number of tokens used for creating the embedding
• embeddings: embeddings for each chunk of text

Querying with Embeddings

After generating embeddings for each chunk of text, the next step is to query the embeddings to find similar chunks of text. This can be done using the query_index() function provided by the {gpttools} package. This is a bit of a complicated function, so it’s worth taking a look at the code to see how it works.

query_index <- function(index, query, history, task = "Context Only", k = 4) {
  arg_match(task, c("Context Only", "Permissive Chat"))

  query_embedding <- create_openai_embedding(input_text = query) |>
    dplyr::pull(embedding) |>
    unlist()

  full_context <- get_top_matches(index, query_embedding, k = k)

  context <-
    full_context |>
    dplyr::pull(chunks) |>
    paste(collapse = "\n\n")

  instructions <-
    switch(task,
      "Context Only" =
        list(
          list(
            role = "system",
            content =
              glue(
                "You are a helpful chat bot that answers questions based on the
                context provided by the user. If the user does not provide
                context, say \"I am not able to answer that question. Maybe
                try rephrasing your question in a different way.\"\n\n
                Context: {context}"
              )
          ),
          list(
            role = "user",
            content = glue("{query}")
          )
        ),
      "Permissive Chat" =
        list(
          list(
            role = "system",
            content =
              glue(
                "You are a helpful chat bot that answers questions based on the
                context provided by the user. If the user does not provide
                context, say \"I am not able to answer that question with the
                context you gave me, but here is my best answer. Maybe
                try rephrasing your question in a different way.\"\n\n
                Context: {context}"
              )
          ),
          list(
            role = "user",
            content = glue("{query}")
          )
        )
    )

  cli_inform("Embedding...")

  history <-
    purrr::map(history, \(x) if (x$role == "system") NULL else x) |>
    purrr::compact()

  prompt <- c(history, instructions)
  answer <- gptstudio::openai_create_chat_completion(prompt)
  list(prompt, full_context, answer)
}

get_top_matches <- function(index, query_embedding, k = 5) {
  index |>
    dplyr::mutate(similarity = purrr::map_dbl(embedding, \(x) {
      lsa::cosine(query_embedding, unlist(x))
    })) |>
    dplyr::arrange(dplyr::desc(similarity)) |>
    head(k)
}

openai_create_chat_completion <-
  function(prompt = "<|endoftext|>",
           model = "gpt-3.5-turbo",
           openai_api_key = Sys.getenv("OPENAI_API_KEY"),
           task = "chat/completions") {
    assert_that(
      is.string(model),
      is.string(openai_api_key)
    )

    if (is.string(prompt)) {
      prompt <- list(
        list(
          role    = "user",
          content = prompt
        )
      )
    }

    body <- list(
      model = model,
      messages = prompt
    )

    query_openai_api(body, openai_api_key, task = task)
  }

query_openai_api <- function(body, openai_api_key, task) {
  arg_match(task, c("completions", "chat/completions", "edits", "embeddings"))

  base_url <- glue("https://api.openai.com/v1/{task}")

  headers <- c(
    "Authorization" = glue("Bearer {openai_api_key}"),
    "Content-Type" = "application/json"
  )

  response <-
    httr::RETRY("POST",
      url = base_url,
      httr::add_headers(headers), body = body,
      encode = "json",
      quiet = TRUE
    )

  parsed <- response %>%
    httr::content(as = "text", encoding = "UTF-8") %>%
    jsonlite::fromJSON(flatten = TRUE)

  if (httr::http_error(response)) {
    cli_alert_warning(c(
      "x" = glue("OpenAI API request failed [{httr::status_code(response)}]."),
      "i" = glue("Error message: {parsed$error$message}")
    ))
  }
  parsed
}

The query_index() function takes in four arguments: index, query, task, and k.

• index: The index containing the embeddings to be queried.
• query: The query string to search for similar chunks of text.
• task: The type of task to perform based on the context of the query. {gpttools} provides a few pre-defined tasks, such as “conservative q&a” or “extract key libraries and tools”, which can be passed to this argument. These queries were taken from a repo created by OpenAI and Pinecone, which can be found here.
• k: The number of similar chunks of text to return.

The function generates an embedding for the query string with create_openai_embedding(). It then uses the get_top_matches() to find the most similar chunks of text in the index using cosine similarity returning the top k matches.

The next step is to formats the instructions based on the task argument as well as the query and context. For example, if the task is “conservative q&a”, the function will return a string asking the model to answer a question based on the context of the returned chunks of text. If the task is “extract key libraries and tools”, the function will return a string listing the libraries and tools present in the returned chunks of text.

The prompt is passed to OpenAI’s GPT-3.5 gpt-3.5-turbo (i.e., ChatGPT) to generate a response based on the formatted output. The response is returned as a list containing the instructions, the top k matches, and the response from ChatGPT.

Analysis of Embeddings with tidymodels and UMAP

The next step is to perform dimension reduction with UMAP as naive exploration of the embeddings. The embeddings column in the index contains a list of 1536-dimensional vectors. We can use the recipes package to normalize the vectors and then use the step_umap() function to reduce the dimensionality to 2. We can then plot the results.

library(recipes)
library(ggplot2)
library(purrr)
library(tidyr)
library(embed)

index_wide <-  
  index |>
  mutate(embedding = map(embedding, \(x) as.data.frame(t(x)))) |>
  unnest(embedding)

set.seed(123)

umap_spec <- recipe(~ ., data = index_wide) |>
  step_normalize(starts_with("V")) |>
  step_umap(starts_with("V"), num_comp = 2)

umap_estimates <- prep(umap_spec, training = index_wide)
umap_data <- bake(umap_estimates, new_data = NULL)

umap_data |> 
  ggplot() +
  geom_point(aes(x = UMAP1, y = UMAP2, color = link),
             alpha = 0.5, size = 2, show.legend = FALSE) +
  labs(title = "Dimensionality Reduction with UMAP",
       subtitle = "UMAP of 1536-dimensional vectors | Colored by Source Text") +
  theme_minimal()

Retreiver Plugin as a Shiny App

To use the index, {gpttools} now as a shiny app that you can run as a plugin in RStudio. To use it, open the command palette (Cmd/Ctrl + Shift + P) and type “gpttools”. You can then select the “gpttools: ChatGPT with Retrieval” option. This will open a shiny app in your viewer pane. If you have multiple indices, you can select which one to use in the dropdown menu. You can also specify if you want answers that only use the context of index (“Context Only”) or if you want answers that use the context of the index and full ChatGPT model (“Permissive Chat”). “Context Only” answers are much less likely to “hallucinate.” “Permissive Chat” answers are more likely to hallucinate, but they are also more likely choice if the index lacks relevant information.

Photo Credit

Thumbnail Photo by Richard Burlton on Unsplash

Creating dm from Dataframes

In this tutorial, we will use the {alone} package, part of week for of #TidyTuesday. Our first step is to convert data in the {alone} package into a dm object.

library(dm)

Attaching package: 'dm'

The following object is masked from 'package:stats':

    filter

library(alone)

alone_no_keys <- dm(episodes, loadouts, seasons, survivalists)
alone_no_keys

── Metadata ────────────────────────────────────────────────────────────────────
Tables: `episodes`, `loadouts`, `seasons`, `survivalists`
Columns: 41
Primary keys: 0
Foreign keys: 0

Primary Keys

In practice, we should always inspect our data to ensure we are joining data in a sensible manner, but dm_enum_pk_candidates() can suggest a primary key for us.

dm_enum_pk_candidates(
  dm = alone_no_keys,
  table = episodes
)

# A tibble: 11 × 3
   columns                candidate why                                         
   <keys>                 <lgl>     <chr>                                       
 1 episode_number_overall TRUE      ""                                          
 2 title                  TRUE      ""                                          
 3 version                FALSE     "has duplicate values: US (98)"             
 4 season                 FALSE     "has duplicate values: 2 (13), 1 (11), 6 (1…
 5 episode                FALSE     "has duplicate values: 1 (9), 2 (9), 3 (9),…
 6 air_date               FALSE     "has duplicate values: 2016-07-14 (2)"      
 7 viewers                FALSE     "has 15 missing values, and duplicate value…
 8 quote                  FALSE     "has duplicate values: In nature there are …
 9 author                 FALSE     "has duplicate values: John Muir (4), Ameli…
10 imdb_rating            FALSE     "has duplicate values: 7.7 (16), 7.6 (9), 7…
11 n_ratings              FALSE     "has 5 missing values, and duplicate values…

episode_number and title are the two candidates for primary keys. We can look at the other tables, as well.

dm_enum_pk_candidates(
  dm = alone_no_keys,
  table = loadouts
)

# A tibble: 6 × 3
  columns       candidate why                                                   
  <keys>        <lgl>     <chr>                                                 
1 version       FALSE     has duplicate values: US (940)                        
2 season        FALSE     has duplicate values: 4 (140), 1 (100), 2 (100), 3 (1…
3 name          FALSE     has duplicate values: Brad Richardson (20), Britt Aha…
4 item_number   FALSE     has duplicate values: 1 (94), 2 (94), 3 (94), 4 (94),…
5 item_detailed FALSE     has duplicate values: Ferro rod (66), Sleeping bag (6…
6 item          FALSE     has duplicate values: Pot (92), Fishing gear (90), Sl…

dm_enum_pk_candidates(
  dm = alone_no_keys,
  table = seasons
)

# A tibble: 8 × 3
  columns       candidate why                                                   
  <keys>        <lgl>     <chr>                                                 
1 season        TRUE      ""                                                    
2 version       FALSE     "has duplicate values: US (9)"                        
3 location      FALSE     "has duplicate values: Quatsino (3), Great Slave Lake…
4 country       FALSE     "has duplicate values: Canada (7)"                    
5 n_survivors   FALSE     "has duplicate values: 10 (8)"                        
6 lat           FALSE     "has duplicate values: 50.72444 (3), 61.50028 (2)"    
7 lon           FALSE     "has duplicate values: -127.4981 (3), -114.0011 (2)"  
8 date_drop_off FALSE     "has 6 missing values"                                

dm_enum_pk_candidates(
  dm = alone_no_keys,
  table = survivalists
)

# A tibble: 16 × 3
   columns             candidate why                                            
   <keys>              <lgl>     <chr>                                          
 1 season              FALSE     has duplicate values: 4 (14), 1 (10), 2 (10), …
 2 name                FALSE     has duplicate values: Brad Richardson (2), Bri…
 3 age                 FALSE     has duplicate values: 31 (7), 40 (6), 44 (6), …
 4 gender              FALSE     has duplicate values: Male (74), Female (20)   
 5 city                FALSE     has duplicate values: Fox (3), Fox Lake (3), S…
 6 state               FALSE     has duplicate values: Alaska (11), Maine (6), …
 7 country             FALSE     has duplicate values: United States (79), Cana…
 8 result              FALSE     has duplicate values: 1 (10), 2 (10), 3 (10), …
 9 days_lasted         FALSE     has duplicate values: 8 (4), 1 (3), 2 (3), 4 (…
10 medically_evacuated FALSE     has duplicate values: FALSE (69), TRUE (25)    
11 reason_tapped_out   FALSE     has 10 missing values, and duplicate values: S…
12 reason_category     FALSE     has 10 missing values, and duplicate values: M…
13 team                FALSE     has 80 missing values, and duplicate values: B…
14 day_linked_up       FALSE     has 86 missing values, and duplicate values: 9…
15 profession          FALSE     has duplicate values: Carpenter (4), Blacksmit…
16 url                 FALSE     has duplicate values: alex-and-logan-ribar (2)…

{loadouts} and {survivalists} lack a single column that serves as a primary key, but we can use a column tuple (i.e., multiple columns) to make a primary key.

alone_only_pks <-
  alone_no_keys %>%
  dm_add_pk(table = episodes, columns = episode_number_overall) %>%
  dm_add_pk(loadouts, c(version, season, name, item_number)) %>%
  dm_add_pk(seasons, season) %>%
  dm_add_pk(survivalists, c(season, name))

alone_only_pks

── Metadata ────────────────────────────────────────────────────────────────────
Tables: `episodes`, `loadouts`, `seasons`, `survivalists`
Columns: 41
Primary keys: 4
Foreign keys: 0

Foreign Keys

To create the relationships between tables, we need to identify foreign keys. We can use the same approach as we did with primary keys, this time with dm_enum_fk_candidates().

dm_enum_fk_candidates(
  dm = alone_only_pks,
  table = episodes,
  ref_table = seasons
)

# A tibble: 11 × 3
   columns                candidate why                                         
   <keys>                 <lgl>     <chr>                                       
 1 season                 TRUE      ""                                          
 2 version                FALSE     "Can't combine `value1` <character> and `va…
 3 episode_number_overall FALSE     "values of `episodes$episode_number_overall…
 4 episode                FALSE     "values of `episodes$episode` not in `seaso…
 5 title                  FALSE     "Can't combine `value1` <character> and `va…
 6 air_date               FALSE     "Can't combine `value1` <character> and `va…
 7 viewers                FALSE     "values of `episodes$viewers` not in `seaso…
 8 quote                  FALSE     "Can't combine `value1` <character> and `va…
 9 author                 FALSE     "Can't combine `value1` <character> and `va…
10 imdb_rating            FALSE     "values of `episodes$imdb_rating` not in `s…
11 n_ratings              FALSE     "values of `episodes$n_ratings` not in `sea…

dm_add_fk() is the same as dm_add_pk() except for foreign keys.

alone_with_keys <-
  alone_only_pks |>
  dm_add_fk(table = episodes, columns = season, ref_table = seasons) |>
  dm_add_fk(loadouts, c(name, season), survivalists) |>
  dm_add_fk(loadouts, season, seasons) |>
  dm_add_fk(survivalists, season, seasons)

alone_with_keys

── Metadata ────────────────────────────────────────────────────────────────────
Tables: `episodes`, `loadouts`, `seasons`, `survivalists`
Columns: 41
Primary keys: 4
Foreign keys: 4

Visualizing Relationships

Two powerful features included with {dm} are relational table visualization and integrity checks. dm_draw() gives us a visualization to inspect the relationships between tables and the keys used to do so.

rlang::check_installed("DiagrammeR")
dm_draw(alone_with_keys)

Integrity Checks

dm_examine_constraints(alone_no_keys)

ℹ No constraints defined.

dm_examine_constraints(alone_only_pks)

ℹ All constraints satisfied.

dm_examine_constraints(alone_with_keys)

! Unsatisfied constraints:

• Table `loadouts`: foreign key `name`, `season` into table `survivalists`: Can't combine `value1` <character> and `value1` <double>.

We can see that there is an issue with constraints for joining loadouts and survivalists.

Table Flattening

In my own projects, the power of a well organized tidy data structure is most evident when I join tidy tables to answer a particular question about the project. The joined table can sometimes be the most valuable step in the product. From these joins, I can usually build visuals and summaries that becomes the most visible artifact of the product.

dm_flatten_to_tbl() uses a table of our choosing as starting point and produces a wide table that brings in information from our other tables. Importantly, columns with the same name but no relationship (i.e., they are not primary <-> foreign keys) are disambiguated. This seems like it could explode for more complicated data structures, but four tables seems manageable.

flat_survivors <- dm_flatten_to_tbl(alone_with_keys, .start = survivalists)

Renaming ambiguous columns: %>%
  dm_rename(survivalists, country.survivalists = country) %>%
  dm_rename(seasons, country.seasons = country)

flat_survivors

# A tibble: 94 × 23
   season name     age gender city  state count…¹ result days_…² medic…³ reaso…⁴
    <dbl> <chr>  <dbl> <chr>  <chr> <chr> <chr>    <dbl>   <dbl> <lgl>   <chr>  
 1      1 Alan …    40 Male   Blai… Geor… United…      1      56 FALSE   <NA>   
 2      1 Sam L…    22 Male   Linc… Nebr… United…      2      55 FALSE   Lost t…
 3      1 Mitch…    34 Male   Bell… Mass… United…      3      43 FALSE   Realiz…
 4      1 Lucas…    32 Male   Quas… Iowa  United…      4      39 FALSE   Felt c…
 5      1 Dusti…    37 Male   Pitt… Penn… United…      5       8 FALSE   Fear o…
 6      1 Brant…    44 Male   Albe… Nort… United…      6       6 FALSE   Consum…
 7      1 Wayne…    46 Male   Sain… New … Canada       7       4 FALSE   Fear o…
 8      1 Joe R…    24 Male   Wind… Onta… Canada       8       4 FALSE   Loss o…
 9      1 Chris…    41 Male   Umat… Flor… United…      9       1 FALSE   Fear o…
10      1 Josh …    31 Male   Jack… Ohio  United…     10       0 FALSE   Fear o…
# … with 84 more rows, 12 more variables: reason_category <chr>, team <chr>,
#   day_linked_up <dbl>, profession <chr>, url <chr>, version <chr>,
#   location <chr>, country.seasons <chr>, n_survivors <dbl>, lat <dbl>,
#   lon <dbl>, date_drop_off <chr>, and abbreviated variable names
#   ¹​country.survivalists, ²​days_lasted, ³​medically_evacuated,
#   ⁴​reason_tapped_out

The renaming of ambiguous columns is important in this case since seasons$country refers the location of the show and survivalists$country refers to the nationality of the survivalist.

A simple plot

Usign flattened data, we can make a simple plot of days lasted versus age colored by country.

library(ggplot2)
flat_survivors |>
  ggplot(aes(x = age, y = days_lasted, color = country.survivalists)) +
  geom_point(size = 2, alpha = 0.7) +
  theme_minimal() +
  labs(
    x = "Survivalist Age", y = "Days Alone", color = "Nationality",
    title = "Days on Alone vs Survivalist Age",
    subtitle = "Color Indicates Nationality"
  ) +
  theme(plot.title.position = "plot")

In a future post, I’d like to explore going from files to dm to a database.

Model Building

We covered model builidng in part one, but here is the code from there to save time searching around for it.

library(tidyverse)
library(gt)
library(tidymodels)
library(pins)
library(vetiver)
library(palmerpenguins)
library(plumber)
library(conflicted)
tidymodels_prefer()
conflict_prefer("penguins", "palmerpenguins")
penguins_df <-
  penguins |>
  drop_na(sex) |>
  select(-year, -island)

set.seed(1234)
penguin_split <- initial_split(penguins_df, strata = sex)
penguin_train <- training(penguin_split)
penguin_test <- testing(penguin_split)

penguin_rec <-
  recipe(sex ~ ., data = penguin_train) |>
  step_YeoJohnson(all_numeric_predictors()) |>
  step_normalize(all_numeric_predictors()) |>
  step_dummy(species)

glm_spec <-
  logistic_reg() |>
  set_engine("glm")

tree_spec <-
  rand_forest(min_n = tune()) |>
  set_engine("ranger") |>
  set_mode("classification")

mlp_brulee_spec <-
  mlp(
    hidden_units = tune(), epochs = tune(),
    penalty = tune(), learn_rate = tune()
  ) %>%
  set_engine("brulee") %>%
  set_mode("classification")

set.seed(1234)
penguin_folds <- vfold_cv(penguin_train)

bayes_control <-
  control_bayes(no_improve = 10L, time_limit = 20, save_pred = TRUE)

set.seed(1234)
workflow_set <-
  workflow_set(
    preproc = list(penguin_rec),
    models = list(
      glm = glm_spec,
      tree = tree_spec,
      torch = mlp_brulee_spec
    )
  ) |>
  workflow_map("tune_bayes",
    iter = 50L,
    resamples = penguin_folds,
    control = bayes_control
  )

Model Deployment on Azure

The {vetiver} package is provides a set of tools for building, deploying, and managing machine learning models in production. It allows users to easily create, version, and deploy machine learning models to various hosting platforms, such as Posit Connect or a cloud hosting service like Azure. Part one showed a Connect deployment, and this one will use an Azure storage container as the board.

The vetiver_model() function is used to create an object that stores a machine learning model and its associated metadata, such as the model’s name, type, and parameters. vetiver_pin_write() and vetiver_pin_read() functions are used to write and read vetiver_model objects to and from a server.

library(AzureStor)
library(pins)

container <-
  storage_container(
    endpoint = Sys.getenv("AZURE_CONTAINER_ENDPOINT"),
    sas = Sys.getenv("AZURE_SAS_KEY")
  )

model_board <- pins::board_azure(container)

library(tidymodels)

best_model_id <- "recipe_glm"

best_fit <-
  workflow_set |>
  extract_workflow_set_result(best_model_id) |>
  select_best(metric = "accuracy")

final_fit_to_deploy <-
  workflow_set |>
  extract_workflow(best_model_id) |>
  finalize_workflow(best_fit) |>
  last_fit(penguin_split) |>
  extract_workflow()

library(vetiver)
v <- vetiver_model(final_fit_to_deploy, model_name = "penguins_model")

v

── penguins_model ─ <bundled_workflow> model for deployment 
A glm classification modeling workflow using 5 features

model_board |> vetiver_pin_write(v)

Creating new version '20230122T144640Z-a875f'
Writing to pin 'penguins_model'

Create a Model Card for your published model
• Model Cards provide a framework for transparent, responsible reporting
• Use the vetiver `.Rmd` template as a place to start

model_board |> vetiver_pin_read("penguins_model")

── penguins_model ─ <bundled_workflow> model for deployment 
A glm classification modeling workflow using 5 features

library(plumber)
pr() |>
  vetiver_api(v)

# Plumber router with 2 endpoints, 4 filters, and 1 sub-router.
# Use `pr_run()` on this object to start the API.
├──[queryString]
├──[body]
├──[cookieParser]
├──[sharedSecret]
├──/logo
│  │ # Plumber static router serving from directory: /Library/Frameworks/R.framework/Versions/4.2/Resources/library/vetiver
├──/ping (GET)
└──/predict (POST)

vetiver_write_plumber(
  board = model_board,
  name = "penguins_model",
  file = "azure_plumber.R"
)

# Generated by the vetiver package; edit with care

library(pins)
library(plumber)
library(rapidoc)
library(vetiver)

# Packages needed to generate model predictions
if (FALSE) {
  library(parsnip)
  library(recipes)
  library(stats)
  library(workflows)
}
b <- board_azure(AzureStor::storage_container("https://penguinstore.blob.core.windows.net/penguincontainer"), path = "")
v <- vetiver_pin_read(b, "penguins_model", version = "20221222T172651Z-50d8c")

#* @plumber
function(pr) {
  pr %>% vetiver_api(v)
}

vetiver_write_docker(
  vetiver_model = v,
  path = "azure",
  lockfile = "azure/vetiver_renv.lock"
)

# Generated by the vetiver package; edit with care

FROM rocker/r-ver:4.2.2
ENV RENV_CONFIG_REPOS_OVERRIDE packagemanager.rstudio.com/cran/latest

RUN apt-get update -qq && apt-get install -y --no-install-recommends \
  libcurl4-openssl-dev \
  libicu-dev \
  libsodium-dev \
  libssl-dev \
  make \
  zlib1g-dev \
  && apt-get clean

COPY azure/vetiver_renv.lock renv.lock
RUN Rscript -e "install.packages('renv')"
RUN Rscript -e "renv::restore()"
COPY plumber.R /opt/ml/plumber.R
EXPOSE 8000
ENTRYPOINT ["R", "-e", "pr <- plumber::plumb('/opt/ml/plumber.R'); pr$run(host = '0.0.0.0', port = 8000)"]

Terminal

docker build -t penguin-image .

Terminal

az acr login --name vetiverdeploy
docker tag penguin-image:latest vetiverdeploy.azurecr.io/penguin-image
docker push vetiverdeploy.azurecr.io/penguin-image

endpoint <-
  vetiver_endpoint("http://penguin.eastus.azurecontainer.io:8000/predict")
endpoint

── A model API endpoint for prediction: 
http://penguin.eastus.azurecontainer.io:8000/predict

new_data <- tibble(
  species = "Adelie",
  bill_length_mm = 40.5,
  bill_depth_mm = 18.9,
  flipper_length_mm = 180,
  body_mass_g = 3950
)

predict(endpoint, new_data)

# A tibble: 1 × 1
  .pred_class
  <chr>      
1 male       

library(httr)
url <- "http://penguin.eastus.azurecontainer.io:8000/predict"
json_data <- jsonlite::toJSON(new_data)
response <- POST(url, body = json_data)
response

Response [http://penguin.eastus.azurecontainer.io:8000/predict]
  Date: 2023-01-22 14:46
  Status: 200
  Content-Type: application/json
  Size: 24 B

content(response)

[[1]]
[[1]]$.pred_class
[1] "male"

Terminal

curl -X POST "http://penguin.eastus.azurecontainer.io:8000/predict" \
-H "Accept: application/json" \
-H "Content-Type: application/json" \
-d '[{"species":"Adelie","bill_length_mm":0.5,"bill_depth_mm":0.5,"flipper_length_mm":0,"body_mass_g":0}]' \

Model Monitoring

After deployment, we need to monitor model performance. The MLOps with vetiver monitoring page describes this well:

Machine learning can break quietly; a model can continue returning predictions without error, even if it is performing poorly. Often these quiet performance problems are discussed as types of model drift; data drift can occur when the statistical distribution of an input feature changes, or concept drift occurs when there is change in the relationship between the input features and the outcome.

Without monitoring for degradation, this silent failure can continue undiagnosed. The vetiver framework offers functions to fluently compute, store, and plot model metrics. These functions are particularly suited to monitoring your model using multiple performance metrics over time. Effective model monitoring is not “one size fits all”, but instead depends on choosing appropriate metrics and time aggregation for a given application.

As a baseline for model performance, we can start by using our training set to create original metrics for the model. We also simulate a date_obs column. In a real example, you should use the date the data was collected.

set.seed(1234)
penguin_train_by_date <-
  training(penguin_split) |>
  rowwise() |>
  mutate(date_obs = Sys.Date() - sample(4:10, 1)) |>
  ungroup() |>
  arrange(date_obs)

original_metrics <-
  augment(v, penguin_train_by_date) |>
  vetiver_compute_metrics(
    date_var = date_obs,
    period = "day",
    truth = "sex",
    estimate = ".pred_class"
  )

vetiver_plot_metrics(original_metrics)

We can pin the model performance metrics, just as we did with the model.

model_board %>%
  pin_write(original_metrics, "penguin_metrics")

Guessing `type = 'rds'`
Creating new version '20230122T144645Z-dd69c'
Writing to pin 'penguin_metrics'

penguin_test_by_date <-
  testing(penguin_split) |>
  rowwise() |>
  mutate(date_obs = Sys.Date() - sample(1:3, 1)) |>
  ungroup() |>
  arrange(date_obs)

v <-
  model_board |>
  vetiver_pin_read("penguins_model")

new_metrics <-
  augment(v, penguin_test_by_date) |>
  vetiver_compute_metrics(
    date_var = date_obs,
    period = "day",
    truth = "sex",
    estimate = ".pred_class"
  )

model_board |>
  vetiver_pin_metrics(new_metrics, "penguin_metrics")

Creating new version '20230122T144648Z-4f9b0'
Writing to pin 'penguin_metrics'

# A tibble: 20 × 5
   .index        .n .metric  .estimator .estimate
   <date>     <int> <chr>    <chr>          <dbl>
 1 2023-01-12    32 accuracy binary         0.844
 2 2023-01-12    32 kap      binary         0.688
 3 2023-01-13    45 accuracy binary         0.911
 4 2023-01-13    45 kap      binary         0.82 
 5 2023-01-14    29 accuracy binary         0.966
 6 2023-01-14    29 kap      binary         0.931
 7 2023-01-15    34 accuracy binary         0.912
 8 2023-01-15    34 kap      binary         0.820
 9 2023-01-16    44 accuracy binary         0.886
10 2023-01-16    44 kap      binary         0.759
11 2023-01-17    31 accuracy binary         0.903
12 2023-01-17    31 kap      binary         0.807
13 2023-01-18    34 accuracy binary         0.941
14 2023-01-18    34 kap      binary         0.881
15 2023-01-19    25 accuracy binary         0.92 
16 2023-01-19    25 kap      binary         0.840
17 2023-01-20    31 accuracy binary         0.839
18 2023-01-20    31 kap      binary         0.686
19 2023-01-21    28 accuracy binary         0.964
20 2023-01-21    28 kap      binary         0.924

monitoring_metrics <-
  model_board |> pin_read("penguin_metrics")
vetiver_plot_metrics(monitoring_metrics)

The Data

The {modeldata} package has a number of datasets that are useful for modeling. We’ll use the ad_data dataset, which is a clinical study of a few hundred patients with cognitive impairment. The goal of the study was to predict if early stages of cognitive impairment could be distinguished from normal cognition. We can look at the data documentation with ?modeldata::ad_data.

#' Capture help documents contents
#'
#' Allows you to capture the contents of a help file to print to the console or
#' include in a Quarto / RMarkdown document.
#'
#' based on code by Noam Ross
#'  http://www.noamross.net/archives/2013-06-18-helpconsoleexample/
#' Stéphane Laurent
#'  https://stackoverflow.com/questions/60468080/
#'   print-an-r-help-file-vignette-as-output-into-an-r-html-notebook
#' Michael Sumner (mdsumner)
#'  https://stackoverflow.com/questions/7495685/
#'   how-to-access-the-help-documentation-rd-source-files-in-r
#' and David Fong
#'  https://stackoverflow.com/questions/60468080/print-an-r-help-file-vignette-
#'  as-output-into-an-r-html-notebook/62241456#62241456
#'
#' @param topic - the command for which help is required
#' @param package - the package name with the required topic
#' @param format - output format
#' @param before - place code before the output e.g. "<blockquote>"
#' @param after - place code after the output e.g. "</blockquote>"
help_console <- function(topic, package,
                         format = c("text", "html", "latex", "Rd"),
                         before = NULL, after = NULL) {
  format <- match.arg(format)
  if (!is.character(topic)) topic <- deparse(substitute(topic))
  db <- tools::Rd_db(package)
  helpfile <- db[paste0(topic, ".Rd")][[1]]
  hs <- capture.output(
    switch(format,
      text = tools::Rd2txt(helpfile,
        stages = "render",
        outputEncoding = "UTF-8"
      ),
      html = tools::Rd2HTML(helpfile, package = "", stages = "render"),
      latex = tools::Rd2latex(helpfile),
      Rd = tools:::prepare_Rd(helpfile)
    )
  )
  if (format == "html") {
    i <- grep("<body>", hs)
    j <- grep("</body>", hs)
    hs <- hs[(i + 1):(j - 1)]
  }
  hs <- c(before, hs, after)
  hs <- cat(hs, sep = "\n")
  invisible(hs)
}
help_console("ad_data", format = "text", package = "modeldata")

_A_l_z_h_e_i_m_e_r'_s _d_i_s_e_a_s_e _d_a_t_a

_D_e_s_c_r_i_p_t_i_o_n:

     Alzheimer's disease data

_D_e_t_a_i_l_s:

     Craig-Schapiro et al. (2011) describe a clinical study of 333
     patients, including some with mild (but well-characterized)
     cognitive impairment as well as healthy individuals. CSF samples
     were taken from all subjects. The goal of the study was to
     determine if subjects in the early states of impairment could be
     differentiated from cognitively healthy individuals. Data
     collected on each subject included:

        • Demographic characteristics such as age and gender

        • Apolipoprotein E genotype

        • Protein measurements of Abeta, Tau, and a phosphorylated
          version of Tau (called pTau)

        • Proteinmeasurements of 124 exploratory biomarkers, and

        • Clinical dementia scores

     For these analyses, we have converted the scores to two classes:
     impaired and healthy. The goal of this analysis is to create
     classification models using the demographic and assay data to
     predict which patients have early stages of disease.

_V_a_l_u_e:

 ad_data: a tibble

_S_o_u_r_c_e:

     Kuhn, M., Johnson, K. (2013) _Applied Predictive Modeling_,
     Springer.

     Craig-Schapiro R, Kuhn M, Xiong C, Pickering EH, Liu J, Misko TP,
     et al. (2011) Multiplexed Immunoassay Panel Identifies Novel CSF
     Biomarkers for Alzheimer's Disease Diagnosis and Prognosis. PLoS
     ONE 6(4): e18850.

_E_x_a_m_p_l_e_s:

     data(ad_data)
     str(ad_data)
     

skim(ad_data) |> summary()

Initial Split

ad_split <- initial_split(ad_data, strata = Class)
ad_train <- training(ad_split)
ad_test <- testing(ad_split)

Cross Validation

ad_folds <- vfold_cv(ad_train, v = 3, strata = Class)

Build the Model

Specify Recipe

ad_rec <-
  recipe(Class ~ ., data = ad_train) |>
  step_YeoJohnson(all_numeric_predictors()) |>
  step_normalize(all_numeric_predictors()) |>
  step_dummy(all_nominal_predictors()) |>
  step_nzv(all_numeric_predictors())

Specify Models

logistic_reg_brulee_spec <-
  logistic_reg(
    penalty = tune()
  ) |>
  set_engine("brulee")

mlp_brulee_spec <-
  mlp(
    hidden_units = 10,
    dropout      = tune(),
    epochs       = tune(),
    learn_rate   = tune(),
    activation   = "elu"
  ) |>
  set_engine("brulee") |>
  set_mode("classification")

Tuning Control Settings

bayes_control <-
  control_bayes(
    no_improve    = 30L,
    time_limit    = 20,
    verbose_iter  = TRUE,
    save_pred     = TRUE,
    save_workflow = TRUE
  )

grid_control <-
  control_grid(
    allow_par     = TRUE,
    save_pred     = TRUE,
    save_workflow = TRUE,
    parallel_over = NULL
  )

dials::penalty()

Amount of Regularization (quantitative)
Transformer: log-10 [1e-100, Inf]
Range (transformed scale): [-10, 0]

dials::activation()

Activation Function  (qualitative)
5 possible value include:
'linear', 'softmax', 'relu', 'elu' and 'tanh' 

dials::epochs()

# Epochs (quantitative)
Range: [10, 1000]

dials::dropout()

Dropout Rate (quantitative)
Range: [0, 1)

dials::hidden_units()

# Hidden Units (quantitative)
Range: [1, 10]

mlp_brulee_params <-
  mlp_brulee_spec |>
  extract_parameter_set_dials() |>
  update(
    epochs  = epochs(c(10, 200)),
    dropout = dropout(c(0.1, 0.9))
  )

mlp_brulee_start <-
  mlp_brulee_params |>
  grid_regular(levels = 3)

Model Workflow

The {workflows} package creates a workflow for each model. The workflow will include the recipe, the model specification, and the cross validation folds. We’ll use the workflow() function to create the workflow. The tune_bayes() function will then be used to tune the model with with splits and control parameters we created above.

Create Logistic Regression Workflow

logistic_reg_brulee_wf <-
  workflow() |>
  add_recipe(ad_rec) |>
  add_model(logistic_reg_brulee_spec) |>
  tune_grid(
    resamples = ad_folds,
    control   = grid_control
  )

autoplot(logistic_reg_brulee_wf)

collect_metrics(logistic_reg_brulee_wf, summarize = TRUE)

# A tibble: 20 × 7
    penalty .metric  .estimator  mean     n std_err .config              
      <dbl> <chr>    <chr>      <dbl> <int>   <dbl> <chr>                
 1 1.11e- 2 accuracy binary     0.831     3 0.0257  Preprocessor1_Model01
 2 1.11e- 2 roc_auc  binary     0.880     3 0.00871 Preprocessor1_Model01
 3 4.58e- 8 accuracy binary     0.835     3 0.00419 Preprocessor1_Model02
 4 4.58e- 8 roc_auc  binary     0.878     3 0.00766 Preprocessor1_Model02
 5 7.60e- 9 accuracy binary     0.843     3 0.0121  Preprocessor1_Model03
 6 7.60e- 9 roc_auc  binary     0.874     3 0.00235 Preprocessor1_Model03
 7 3.85e- 3 accuracy binary     0.855     3 0.0183  Preprocessor1_Model04
 8 3.85e- 3 roc_auc  binary     0.895     3 0.00220 Preprocessor1_Model04
 9 1.76e- 5 accuracy binary     0.839     3 0.0115  Preprocessor1_Model05
10 1.76e- 5 roc_auc  binary     0.891     3 0.00872 Preprocessor1_Model05
11 6.88e- 7 accuracy binary     0.827     3 0.0187  Preprocessor1_Model06
12 6.88e- 7 roc_auc  binary     0.877     3 0.0192  Preprocessor1_Model06
13 3.57e- 6 accuracy binary     0.868     3 0.0182  Preprocessor1_Model07
14 3.57e- 6 roc_auc  binary     0.877     3 0.00511 Preprocessor1_Model07
15 2.11e-10 accuracy binary     0.831     3 0.0130  Preprocessor1_Model08
16 2.11e-10 roc_auc  binary     0.880     3 0.00217 Preprocessor1_Model08
17 8.03e- 1 accuracy binary     0.827     3 0.00706 Preprocessor1_Model09
18 8.03e- 1 roc_auc  binary     0.877     3 0.0115  Preprocessor1_Model09
19 9.42e- 4 accuracy binary     0.823     3 0.0250  Preprocessor1_Model10
20 9.42e- 4 roc_auc  binary     0.882     3 0.00516 Preprocessor1_Model10

Select Best Logistic Regression Model and Evaluate

# select the best model from the workflow
best_logistic_reg_id <-
  logistic_reg_brulee_wf |>
  select_best(metric = "roc_auc")

# extract the best model from the workflow
best_logistic_reg <-
  logistic_reg_brulee_wf |>
  extract_workflow() |>
  finalize_workflow(best_logistic_reg_id) |>
  last_fit(ad_split)

# collect the metrics for the best model
best_logistic_reg |>
  collect_metrics()

# A tibble: 2 × 4
  .metric  .estimator .estimate .config             
  <chr>    <chr>          <dbl> <chr>               
1 accuracy binary         0.833 Preprocessor1_Model1
2 roc_auc  binary         0.865 Preprocessor1_Model1

# plot results of test set fit
best_logistic_reg |>
  collect_predictions() |>
  roc_curve(Class, .pred_Impaired) |>
  autoplot()

Create MLP Workflow and Perform Grid Tuning

mlp_brulee_wf <-
  workflow() |>
  add_recipe(ad_rec) |>
  add_model(mlp_brulee_spec)

mlp_brulee_tune_grid <-
  mlp_brulee_wf |>
  tune_grid(
    resamples = ad_folds,
    grid      = mlp_brulee_start,
    control   = grid_control
  )

autoplot(mlp_brulee_tune_grid)

Visualize and Evaluate Initial Tuning

best_mlp_id_no_bayes <-
  mlp_brulee_tune_grid |>
  select_best(metric = "roc_auc")

# extract the best model from the workflow
best_mlp_no_bayes <-
  mlp_brulee_tune_grid |>
  extract_workflow() |>
  finalize_workflow(best_mlp_id_no_bayes) |>
  last_fit(ad_split)

# collect the metrics for the best model
best_mlp_no_bayes |>
  collect_metrics()

# A tibble: 2 × 4
  .metric  .estimator .estimate .config             
  <chr>    <chr>          <dbl> <chr>               
1 accuracy binary         0.833 Preprocessor1_Model1
2 roc_auc  binary         0.852 Preprocessor1_Model1

# plot results of test set fit
best_mlp_no_bayes |>
  collect_predictions() |>
  roc_curve(Class, .pred_Impaired) |>
  autoplot()

Bayesian Optimization of MLP

mlp_brulee_bo <-
  mlp_brulee_wf |>
  tune_bayes(
    resamples = ad_folds,
    iter      = 100L,
    control   = bayes_control,
    initial   = mlp_brulee_tune_grid
  )

Optimizing roc_auc using the expected improvement

! No improvement for 30 iterations; returning current results.

autoplot(mlp_brulee_bo)

collect_metrics(mlp_brulee_bo, summarize = TRUE)

# A tibble: 142 × 10
   dropout epochs learn_rate .metric  .estim…¹  mean     n std_err .config .iter
     <dbl>  <int>      <dbl> <chr>    <chr>    <dbl> <int>   <dbl> <chr>   <int>
 1     0.1     10      0.001 accuracy binary   0.426     3  0.0897 Prepro…     0
 2     0.1     10      0.001 roc_auc  binary   0.491     3  0.0212 Prepro…     0
 3     0.5     10      0.001 accuracy binary   0.563     3  0.111  Prepro…     0
 4     0.5     10      0.001 roc_auc  binary   0.542     3  0.0360 Prepro…     0
 5     0.9     10      0.001 accuracy binary   0.466     3  0.0362 Prepro…     0
 6     0.9     10      0.001 roc_auc  binary   0.554     3  0.0576 Prepro…     0
 7     0.1    105      0.001 accuracy binary   0.357     3  0.0274 Prepro…     0
 8     0.1    105      0.001 roc_auc  binary   0.459     3  0.0476 Prepro…     0
 9     0.5    105      0.001 accuracy binary   0.610     3  0.0619 Prepro…     0
10     0.5    105      0.001 roc_auc  binary   0.550     3  0.0707 Prepro…     0
# … with 132 more rows, and abbreviated variable name ¹​.estimator

Finalize Model and Evaluate

best_mlp_id <-
  mlp_brulee_bo |>
  select_best(metric = "roc_auc")

# extract the best model from the workflow
best_mlp <-
  mlp_brulee_bo |>
  extract_workflow() |>
  finalize_workflow(best_mlp_id) |>
  last_fit(ad_split)

# collect the metrics for the best model
best_mlp |>
  collect_metrics()

# A tibble: 2 × 4
  .metric  .estimator .estimate .config             
  <chr>    <chr>          <dbl> <chr>               
1 accuracy binary         0.893 Preprocessor1_Model1
2 roc_auc  binary         0.890 Preprocessor1_Model1

# plot results of test set fit
best_mlp |>
  collect_predictions() |>
  roc_curve(Class, .pred_Impaired) |>
  autoplot()

Model Building

library(tidyverse)
library(tidymodels)
library(pins)
library(vetiver)
library(plumber)
library(palmerpenguins)
library(gt)
library(conflicted)
tidymodels_prefer()
conflict_prefer("penguins", "palmerpenguins")
theme_set(theme_bw())
options(tidymodels.dark = TRUE)

penguins |>
  head(4) |>
  glimpse()

Rows: 4
Columns: 8
$ species           <fct> Adelie, Adelie, Adelie, Adelie
$ island            <fct> Torgersen, Torgersen, Torgersen, Torgersen
$ bill_length_mm    <dbl> 39.1, 39.5, 40.3, NA
$ bill_depth_mm     <dbl> 18.7, 17.4, 18.0, NA
$ flipper_length_mm <int> 181, 186, 195, NA
$ body_mass_g       <int> 3750, 3800, 3250, NA
$ sex               <fct> male, female, female, NA
$ year              <int> 2007, 2007, 2007, 2007

penguins %>%
  filter(!is.na(sex)) %>%
  ggplot(aes(
    x = flipper_length_mm,
    y = bill_length_mm,
    color = sex,
    size = body_mass_g
  )) +
  geom_point(alpha = 0.5) +
  facet_wrap(~species)

penguins_df <-
  penguins |>
  drop_na(sex) |>
  select(-year, -island)

set.seed(1234)
penguin_split <- initial_split(penguins_df, strata = sex)
penguin_train <- training(penguin_split)
penguin_test <- testing(penguin_split)

penguin_rec <-
  recipe(sex ~ ., data = penguin_train) |>
  step_YeoJohnson(all_numeric_predictors()) |>
  step_normalize(all_numeric_predictors()) |>
  step_dummy(species)

glm_spec <-
  logistic_reg() |>
  set_engine("glm")

tree_spec <-
  rand_forest(min_n = tune()) |>
  set_engine("ranger") |>
  set_mode("classification")

mlp_brulee_spec <-
  mlp(
    hidden_units = tune(), epochs = tune(),
    penalty = tune(), learn_rate = tune()
  ) %>%
  set_engine("brulee") %>%
  set_mode("classification")

set.seed(1234)
penguin_folds <- vfold_cv(penguin_train)

bayes_control <-
  control_bayes(no_improve = 10L, time_limit = 20, save_pred = TRUE)

workflow_set <-
  workflow_set(
    preproc = list(penguin_rec),
    models = list(
      glm = glm_spec,
      tree = tree_spec,
      torch = mlp_brulee_spec
    )
  ) |>
  workflow_map("tune_bayes",
    iter = 50L,
    resamples = penguin_folds,
    control = bayes_control
  )

rank_results(workflow_set,
  rank_metric = "roc_auc",
  select_best = TRUE
) |>
  gt()

workflow_set |> autoplot()

best_model_id <- "recipe_glm"

best_fit <-
  workflow_set |>
  extract_workflow_set_result(best_model_id) |>
  select_best(metric = "accuracy")

final_workflow <-
  workflow_set |>
  extract_workflow(best_model_id) |>
  finalize_workflow(best_fit)

final_fit <-
  final_workflow |>
  last_fit(penguin_split)

final_fit |>
  collect_metrics() |>
  gt()

final_fit |>
  collect_predictions() |>
  roc_curve(sex, .pred_female) |>
  autoplot()

Model Deployment

The {vetiver} package provides a set of tools for building, deploying, and managing machine learning models in production. It allows users to easily create, version, and deploy machine learning models to various hosting platforms, such as Posit Connect or a cloud hosting service like Azure.

The vetiver_model() function is used to create an object that stores a machine learning model and its associated metadata, such as the model’s name, type, and parameters. vetiver_pin_write() and vetiver_pin_read() functions are used to write and read vetiver_model objects to and from a server.

final_fit_to_deploy <- final_fit |> extract_workflow()

v <- vetiver_model(final_fit_to_deploy, model_name = "penguins_model")

v

── penguins_model ─ <bundled_workflow> model for deployment 
A glm classification modeling workflow using 5 features

model_board <- board_local(versioned = TRUE)
model_board |> vetiver_pin_write(v)

Creating new version '20221228T000205Z-9c561'
Writing to pin 'penguins_model'

Create a Model Card for your published model
• Model Cards provide a framework for transparent, responsible reporting
• Use the vetiver `.Rmd` template as a place to start

model_board |> vetiver_pin_read("penguins_model")

── penguins_model ─ <bundled_workflow> model for deployment 
A glm classification modeling workflow using 5 features

model_board <- board_rsconnect(versioned = TRUE)
model_board |> vetiver_pin_write(v)
model_board |> vetiver_pin_read("penguins_model")

pr() |>
  vetiver_api(v)

# Plumber router with 2 endpoints, 4 filters, and 1 sub-router.
# Use `pr_run()` on this object to start the API.
├──[queryString]
├──[body]
├──[cookieParser]
├──[sharedSecret]
├──/logo
│  │ # Plumber static router serving from directory: /Library/Frameworks/R.framework/Versions/4.2/Resources/library/vetiver
├──/ping (GET)
└──/predict (POST)

vetiver_write_plumber(model_board, "penguins_model")

# Generated by the vetiver package; edit with care

library(pins)
library(plumber)
library(rapidoc)
library(vetiver)

# Packages needed to generate model predictions
if (FALSE) {
  library(parsnip)
  library(recipes)
  library(stats)
  library(workflows)
}
b <- board_rsconnect("envvar", server = "https://connect.mycompany.com")
v <- vetiver_pin_read(b, "penguins_model", version = "6926")

#* @plumber
function(pr) {
  pr %>% vetiver_api(v)
}

vetiver_deploy_rsconnect(
  board = model_board,
  name = "penguins_model",
  account = "james"
)

vetiver_write_docker(v)

# Generated by the vetiver package; edit with care

FROM rocker/r-ver:4.2.1
ENV RENV_CONFIG_REPOS_OVERRIDE https://packagemanager.rstudio.com/cran/latest

RUN apt-get update -qq && apt-get install -y --no-install-recommends \
libcurl4-openssl-dev \
libicu-dev \
libsodium-dev \
libssl-dev \
make \
zlib1g-dev \
&& apt-get clean

COPY vetiver_renv.lock renv.lock
RUN Rscript -e "install.packages('renv')"
RUN Rscript -e "renv::restore()"
COPY plumber.R /opt/ml/plumber.R
EXPOSE 8000
ENTRYPOINT ["R", "-e", "pr <- plumber::plumb('/opt/ml/plumber.R'); pr$run(host = '0.0.0.0', port = 8000)"]

endpoint <-
  vetiver_endpoint("https://connect.mycompany.com/penguins/predict")

new_data <- tibble(
  species = "Adelie",
  bill_length_mm = 40.5,
  bill_depth_mm = 18.9,
  flipper_length_mm = 180,
  body_mass_g = 3950
)

predict(endpoint, new_data)

library(httr)
url <- "https://connect.mycompany.com/penguins/predict"
json_data <- jsonlite::toJSON(new_data)
response <- POST(url, body = json_data)
response
content(response)

Terminal

#| file
curl -X POST "https://connect.mycompany.com/penguins/predict" \
 -H "Accept: application/json" \
 -H "Content-Type: application/json" \
 -d '[{"species":"Adelie","bill_length_mm":0.5,"bill_depth_mm":0.5,"flipper_length_mm":0,"body_mass_g":0}]' \

Model Monitoring

After deployment, we need to monitor model performance. The MLOps with vetiver monitoring page describes this well:

Machine learning can break quietly; a model can continue returning predictions without error, even if it is performing poorly. Often these quiet performance problems are discussed as types of model drift; data drift can occur when the statistical distribution of an input feature changes, or concept drift occurs when there is change in the relationship between the input features and the outcome.

Without monitoring for degradation, this silent failure can continue undiagnosed. The vetiver framework offers functions to fluently compute, store, and plot model metrics. These functions are particularly suited to monitoring your model using multiple performance metrics over time. Effective model monitoring is not “one size fits all”, but instead depends on choosing appropriate metrics and time aggregation for a given application.

As a baseline for model performance, we can start by using our training set to create original metrics for the model. We also simulate a date_obs column. In a real example, we should use the date the data was collected.

set.seed(1234)
penguin_train_by_date <-
  penguin_train |>
  rowwise() |>
  mutate(date_obs = Sys.Date() - sample(4:10, 1)) |>
  ungroup() |>
  arrange(date_obs)

original_metrics <-
  augment(v, penguin_train_by_date) |>
  vetiver_compute_metrics(
    date_var = date_obs,
    period = "day",
    truth = "sex",
    estimate = ".pred_class"
  )

vetiver_plot_metrics(original_metrics)

We can pin the model performance metrics, just as we did with the model.

model_board %>%
  pin_write(original_metrics, "penguin_metrics")

Guessing `type = 'rds'`
Creating new version '20221228T000206Z-3e18d'
Writing to pin 'penguin_metrics'

To simulate the model going “live”, let’s use the test set to add more predictions.

set.seed(1234)
penguin_test_by_date <-
  penguin_test |>
  rowwise() |>
  mutate(date_obs = Sys.Date() - sample(1:3, 1)) |>
  ungroup() |>
  arrange(date_obs)

v <-
  model_board |>
  vetiver_pin_read("penguins_model")

new_metrics <-
  augment(v, penguin_test_by_date) |>
  vetiver_compute_metrics(
    date_var = date_obs,
    period = "day",
    truth = "sex",
    estimate = ".pred_class"
  )

model_board |>
  vetiver_pin_metrics(new_metrics, "penguin_metrics")

Creating new version '20221228T000206Z-7c132'
Writing to pin 'penguin_metrics'

# A tibble: 20 × 5
   .index        .n .metric  .estimator .estimate
   <date>     <int> <chr>    <chr>          <dbl>
 1 2022-12-17    32 accuracy binary         0.844
 2 2022-12-17    32 kap      binary         0.688
 3 2022-12-18    45 accuracy binary         0.911
 4 2022-12-18    45 kap      binary         0.82 
 5 2022-12-19    29 accuracy binary         0.966
 6 2022-12-19    29 kap      binary         0.931
 7 2022-12-20    34 accuracy binary         0.912
 8 2022-12-20    34 kap      binary         0.820
 9 2022-12-21    44 accuracy binary         0.886
10 2022-12-21    44 kap      binary         0.759
11 2022-12-22    31 accuracy binary         0.903
12 2022-12-22    31 kap      binary         0.807
13 2022-12-23    34 accuracy binary         0.941
14 2022-12-23    34 kap      binary         0.881
15 2022-12-24    30 accuracy binary         0.867
16 2022-12-24    30 kap      binary         0.724
17 2022-12-25    30 accuracy binary         0.933
18 2022-12-25    30 kap      binary         0.867
19 2022-12-26    24 accuracy binary         0.917
20 2022-12-26    24 kap      binary         0.833

Now that we’ve updated the model metrics, we can plot model performance over time , again using the vetiver_plot_metrics() function.

monitoring_metrics <-
  model_board |> pin_read("penguin_metrics")
vetiver_plot_metrics(monitoring_metrics)

Lesson 1: Design Curriculum for Learning Stages

There are three stages of learners: novices, competents, and experts. The curriculum and teaching styles should be distinct for each learning stage.

Lesson 2: A Lesson is a User Interface for Knowledge

Much like designing a new user interface, your first step in to creating learning content is to create personas of learners. These are fictional characters to capture key properties of your target audience. A persona consists of:

1. General background: Who are they? What do they do when not learning?
2. Relevant experience: What have they done before? This is better than a list of prerequisites.
3. Perceived needs: What do they think they want to learn?
4. Special considerations: How are they different from you as the instructor? What constraints do they have on learning

Lesson 3: Use Formative Assessments as Unit Tests for Learning

A formative assessment checks for retention of key learning concepts. If the learner gets the assessment wrong, you gain insight into the learners mental model. Your assessment must have diagnostic power. Build formative assessments before you create your curriculum. You need to understand the mental model of your learners. If you do this well, you can dynamically adjust the lessons based on the prior knowledge of the learner.

Lesson 4: Manage Cognitive Load

Do not overload your students with too much information at once. This does not mean that you cannot convey complex ideas or use complex figures. You must introduce components of a complex idea or image gradually. A practical example of this is to use slide builds. You want new linguistic and audio information at the same time. This is one reason why books do not work.

Short term memory is the bottleneck of learning. We often overestimate our short term memory capacity. Modern estimates of short term memory are 4 +/- 1 chunks for knowledge. Short term memory capacity determines how you convert concept maps to lessons. Only once a concept map is decomposed into digestible chunks can you create the lesson. Count the concepts. Remember to not spoon feeding learners. Use your personas and learning stages to guide you.

Lesson 5: Active Learning Beats Passive Learning Every Time

Active learning results in better learning outcomes. However, most learners will prefer passive learning as that is how most were taught throughout their childhood education. For strategies on how to incorporate active learning into your lessons, explore The Learning Scientists.

Lesson 6: Learner are Not Robots

For most learners, the most important factor for success is intrinsic motivation. “I’m learning this because I want to.” You can increase intrinsic motivation of your students by increasing self-efficacy, utility, and community. Formative assessments increase self-efficacy by giving some control over the pace learning to learners. Utility requires that learners can apply new concepts soon after learning. A community of learners that want to learn will build upon each other. Demotivators a are unpredictability, unfairness, and indifference. Being an ally to your learners can make a big difference in student motivation. Valerie Aurora covers how to be a good ally.

Miscellaneous Tips and Tricks