R/provider-openai-compatible.R

In ellmer: Chat with Large Language Models

#' @include provider.R
#' @include content.R
#' @include turns.R
#' @include tools-def.R
NULL

#' Chat with an OpenAI-compatible model
#'
#' @description
#' This function is for use with OpenAI-compatible APIs, also known as the
#' **chat completions** API. If you want to use OpenAI itself, we recommend
#' [chat_openai()], which uses the newer **responses** API.
#'
#' Many providers offer OpenAI-compatible APIs, including:
#' * [Ollama](https://ollama.com/) for local models
#' * [vLLM](https://docs.vllm.ai/) for self-hosted models
#' * Various cloud providers with OpenAI-compatible endpoints
#'
#' @param base_url The base URL to the endpoint. This parameter is **required**
#'   since there is no default for OpenAI-compatible APIs.
#' @param name The name of the provider; this is shown in [token_usage()] and
#'   is used to compute costs.
#' @param system_prompt A system prompt to set the behavior of the assistant.
#' @param api_key `r lifecycle::badge("deprecated")` Use `credentials` instead.
#' @param credentials Credentials to use for authentication. If not provided,
#'   will attempt to use the `OPENAI_API_KEY` environment variable.
#' @param model The model to use for chat. No default; depends on your provider.
#' @param params Common model parameters, usually created by [params()].
#' @param api_args Named list of arbitrary extra arguments appended to the body
#'   of every chat API call. Combined with the body object generated by ellmer
#'   with [modifyList()].
#' @param api_headers Named character vector of arbitrary extra headers appended
#'   to every chat API call.
#' @param preserve_thinking If `TRUE`, reasoning content returned by the model
#'   is included when sending conversation history back to the API. If `FALSE`
#'   (the default), reasoning content is still captured in the turn but dropped
#'   from subsequent requests. Set to `TRUE` if your provider requires or
#'   benefits from seeing prior reasoning in multi-turn conversations.
#' @param echo One of the following options:
#'   * `none`: don't emit any output (default when running in a function).
#'   * `output`: echo text and tool-calling output as it streams in (default
#'     when running at the console).
#'   * `all`: echo all input and output.
#'
#'   Note this only affects the `chat()` method.
#' @family chatbots
#' @export
#' @returns A [Chat] object.
#' @examples
#' \dontrun{
#' # Example with Ollama (requires Ollama running locally)
#' chat <- chat_openai_compatible(
#'   base_url = "http://localhost:11434/v1",
#'   model = "llama2"
#' )
#' chat$chat("What is the difference between a tibble and a data frame?")
#' }
chat_openai_compatible <- function(
  base_url,
  name = "OpenAI-compatible",
  system_prompt = NULL,
  api_key = NULL,
  credentials = NULL,
  model = NULL,
  params = NULL,
  api_args = list(),
  api_headers = character(),
  preserve_thinking = FALSE,
  echo = c("none", "output", "all")
) {
  if (missing(base_url)) {
    cli::cli_abort(c(
      "{.arg base_url} is required for OpenAI-compatible APIs.",
      "i" = "Use {.fn chat_openai} if you want to use OpenAI's official API."
    ))
  }

  # Fall back to OPENAI_BASE_URL if it exists (for backwards compatibility)
  if (is.null(base_url) || base_url == "") {
    base_url <- Sys.getenv("OPENAI_BASE_URL", "")
    if (base_url == "") {
      cli::cli_abort("{.arg base_url} must be provided.")
    }
  }

  model <- model %||% cli::cli_abort("{.arg model} is required.")
  echo <- check_echo(echo)

  credentials <- as_credentials(
    "chat_openai_compatible",
    function() openai_key(),
    credentials = credentials,
    api_key = api_key,
    token = TRUE
  )

  provider <- ProviderOpenAICompatible(
    name = name,
    base_url = base_url,
    model = model,
    params = params %||% params(),
    extra_args = api_args,
    extra_headers = api_headers,
    credentials = credentials,
    preserve_thinking = preserve_thinking
  )
  Chat$new(provider = provider, system_prompt = system_prompt, echo = echo)
}

chat_openai_compatible_test <- function(
  system_prompt = "Be terse.",
  ...,
  model = "gpt-4.1-nano",
  params = NULL,
  echo = "none"
) {
  params <- params %||% params()
  params$seed <- params$seed %||% 1014
  params$temperature <- params$temperature %||% 0

  chat <- chat_openai_compatible(
    # Test with real OpenAI API
    name = "OpenAI",
    base_url = "https://api.openai.com/v1",
    system_prompt = system_prompt,
    model = model,
    params = params,
    ...,
    echo = echo
  )
  chat
}

ProviderOpenAICompatible <- new_class(
  "ProviderOpenAICompatible",
  parent = Provider,
  properties = list(
    preserve_thinking = new_property(class_logical, default = FALSE)
  )
)

openai_key_exists <- function() {
  key_exists("OPENAI_API_KEY")
}

openai_key <- function() {
  key_get("OPENAI_API_KEY")
}

# Base request -----------------------------------------------------------------

method(base_request, ProviderOpenAICompatible) <- function(provider) {
  req <- request(provider@base_url)
  req <- ellmer_req_credentials(req, provider@credentials(), "Authorization")
  req <- ellmer_req_robustify(req)
  req <- ellmer_req_user_agent(req)
  req <- base_request_error(provider, req)
  req
}

method(base_request_error, ProviderOpenAICompatible) <- function(
  provider,
  req
) {
  req_error(req, body = function(resp) {
    if (resp_content_type(resp) == "application/json") {
      error <- resp_body_json(resp)$error
      if (is_string(error)) {
        error
      } else if (is.list(error)) {
        error$message
      } else {
        prettify(resp_body_string(resp))
      }
    } else if (resp_content_type(resp) == "text/plain") {
      resp_body_string(resp)
    }
  })
}

# Chat endpoint ----------------------------------------------------------------

method(chat_path, ProviderOpenAICompatible) <- function(provider) {
  "/chat/completions"
}

# https://platform.openai.com/docs/api-reference/chat/create
method(chat_body, ProviderOpenAICompatible) <- function(
  provider,
  stream = TRUE,
  turns = list(),
  tools = list(),
  type = NULL
) {
  messages <- compact(unlist(as_json(provider, turns), recursive = FALSE))
  tools <- as_json(provider, unname(tools))

  if (!is.null(type)) {
    response_format <- list(
      type = "json_schema",
      json_schema = list(
        name = "structured_data",
        schema = as_json(provider, type),
        strict = TRUE
      )
    )
  } else {
    response_format <- NULL
  }

  params <- chat_params(provider, provider@params)

  compact(list2(
    messages = messages,
    model = provider@model,
    !!!params,
    stream = stream,
    stream_options = if (stream) list(include_usage = TRUE),
    tools = tools,
    response_format = response_format
  ))
}


method(chat_params, ProviderOpenAICompatible) <- function(provider, params) {
  standardise_params(
    params,
    c(
      frequency_penalty = "frequency_penalty",
      logprobs = "log_probs",
      max_completion_tokens = "max_tokens",
      presence_penalty = "presence_penalty",
      seed = "seed",
      stop = "stop_sequences",
      temperature = "temperature",
      top_logprobs = "top_k",
      top_p = "top_p"
    )
  )
}

# OpenAI -> ellmer --------------------------------------------------------------

method(stream_parse, ProviderOpenAICompatible) <- function(provider, event) {
  if (is.null(event) || identical(event$data, "[DONE]")) {
    return(NULL)
  }

  jsonlite::parse_json(event$data)
}
method(stream_content, ProviderOpenAICompatible) <- function(provider, event) {
  if (length(event$choices) == 0) {
    return(NULL)
  }
  delta <- event$choices[[1]]$delta

  reasoning <- delta[["reasoning"]] %||% delta[["reasoning_content"]]
  if (!is.null(reasoning)) {
    return(ContentThinking(reasoning))
  }

  text <- delta[["content"]]
  if (is.null(text)) {
    return(NULL)
  }
  ContentText(text)
}
method(stream_merge_chunks, ProviderOpenAICompatible) <- function(
  provider,
  result,
  chunk
) {
  if (is.null(result)) {
    chunk
  } else {
    merge_dicts(result, chunk)
  }
}

method(value_tokens, ProviderOpenAICompatible) <- function(provider, json) {
  usage <- json$usage
  cached_tokens <- usage$prompt_tokens_details$cached_tokens %||% 0

  tokens(
    input = (usage$prompt_tokens %||% 0) - cached_tokens,
    output = usage$completion_tokens %||% 0,
    cached_input = cached_tokens
  )
}

# https://platform.openai.com/docs/api-reference/chat/create
method(value_finish_reason, ProviderOpenAICompatible) <- function(
  provider,
  result
) {
  reason <- result$choices[[1]]$finish_reason
  if (is.null(reason)) {
    return(NA_character_)
  }
  switch(
    reason,
    stop = "success",
    tool_calls = "tool_use",
    length = "max_tokens",
    content_filter = "content_filter",
    I(reason)
  )
}

method(value_turn, ProviderOpenAICompatible) <- function(
  provider,
  result,
  has_type = FALSE
) {
  if (has_name(result$choices[[1]], "delta")) {
    # streaming
    message <- result$choices[[1]]$delta
  } else {
    message <- result$choices[[1]]$message
  }

  thinking <- list()
  reasoning <- message$reasoning %||% message$reasoning_content
  if (is_string(reasoning) && nzchar(reasoning)) {
    thinking <- list(ContentThinking(reasoning))
  }

  if (has_type) {
    if (is_string(message$content)) {
      content <- list(ContentJson(string = message$content[[1]]))
    } else {
      content <- list(ContentJson(data = message$content))
    }
  } else {
    # Some providers (e.g. Databricks) return content: "" instead of
    # content: null for tool-only turns; treat empty strings as null
    if (is_string(message$content) && !nzchar(message$content)) {
      content <- list()
    } else {
      content <- lapply(message$content, as_content)
    }
  }
  if (has_name(message, "tool_calls")) {
    calls <- lapply(message$tool_calls, function(call) {
      name <- call$`function`$name
      # TODO: record parsing error
      args <- tryCatch(
        jsonlite::parse_json(call$`function`$arguments),
        error = function(cnd) list()
      )
      ContentToolRequest(
        name = name,
        arguments = args %||% list(),
        id = call$id
      )
    })
    content <- c(content, calls)
  }

  content <- c(thinking, content)

  tokens <- value_tokens(provider, result)
  cost <- get_token_cost(provider, tokens)

  AssistantTurn(
    content,
    json = result,
    tokens = unlist(tokens),
    cost = cost,
    finish_reason = value_finish_reason(provider, result)
  )
}

# ellmer -> OpenAI --------------------------------------------------------------

# Most providers use "reasoning" but a subset use "reasoning_content" (#1004)
reasoning_content_field <- function(provider) {
  if (
    S7_inherits(provider, ProviderLMStudio) ||
      S7_inherits(provider, ProviderDeepSeek)
  ) {
    "reasoning_content"
  } else {
    "reasoning"
  }
}

method(as_json, list(ProviderOpenAICompatible, Turn)) <- function(
  provider,
  x,
  ...
) {
  if (is_system_turn(x)) {
    list(
      list(role = "system", content = x@contents[[1]]@text)
    )
  } else if (is_user_turn(x)) {
    # Tool results come out of content and go into own element
    x <- turn_contents_expand(x)
    data <- turn_split_tool_results(x)

    if (length(data$contents) > 0) {
      content <- as_json(provider, data$contents, ...)
      user <- list(list(role = "user", content = content))
    } else {
      user <- list()
    }

    tools <- lapply(data$tool_results, function(tool) {
      list(
        role = "tool",
        content = tool_string(tool),
        tool_call_id = tool@request@id
      )
    })

    c(tools, user)
  } else if (is_assistant_turn(x)) {
    # Drop empty ContentText to avoid API errors from providers that reject
    # empty text content blocks (e.g. Databricks returns content: "" for
    # tool-only turns, then rejects it on replay)
    is_empty_text <- map_lgl(x@contents, function(c) {
      S7_inherits(c, ContentText) && !nzchar(c@text)
    })
    contents <- x@contents[!is_empty_text]
    if (length(contents) == 0) {
      return(NULL)
    }
    # Thinking and tool requests come out of content
    is_thinking <- map_lgl(contents, S7_inherits, ContentThinking)
    is_tool <- map_lgl(contents, is_tool_request)
    other <- contents[!is_thinking & !is_tool]
    content <- as_json(provider, other, ...)
    tool_calls <- as_json(provider, contents[is_tool], ...)

    reasoning_content <- NULL
    if (provider@preserve_thinking) {
      thinking_texts <- map_chr(contents[is_thinking], function(c) c@thinking)
      if (length(thinking_texts) > 0) {
        reasoning_content <- paste0(thinking_texts, collapse = "")
      }
    }

    result <- compact(list(
      role = "assistant",
      content = content,
      tool_calls = tool_calls
    ))
    result[[reasoning_content_field(provider)]] <- reasoning_content
    list(result)
  } else {
    cli::cli_abort("Unknown role {x@role}", .internal = TRUE)
  }
}

method(as_json, list(ProviderOpenAICompatible, ContentText)) <- function(
  provider,
  x,
  ...
) {
  list(type = "text", text = x@text)
}

method(as_json, list(ProviderOpenAICompatible, ContentImageRemote)) <- function(
  provider,
  x,
  ...
) {
  list(type = "image_url", image_url = list(url = x@url))
}

method(as_json, list(ProviderOpenAICompatible, ContentImageInline)) <- function(
  provider,
  x,
  ...
) {
  list(
    type = "image_url",
    image_url = list(
      url = paste0("data:", x@type, ";base64,", x@data)
    )
  )
}

method(as_json, list(ProviderOpenAICompatible, ContentPDF)) <- function(
  provider,
  x,
  ...
) {
  list(
    type = "file",
    file = list(
      filename = x@filename,
      file_data = paste0("data:application/pdf;base64,", x@data)
    )
  )
}

method(as_json, list(ProviderOpenAICompatible, ContentToolRequest)) <- function(
  provider,
  x,
  ...
) {
  json_args <- to_json(x@arguments)
  list(
    id = x@id,
    `function` = list(name = x@name, arguments = json_args),
    type = "function"
  )
}

method(as_json, list(ProviderOpenAICompatible, ToolDef)) <- function(
  provider,
  x,
  ...
) {
  list(
    type = "function",
    "function" = compact(list(
      name = x@name,
      description = x@description,
      strict = TRUE,
      parameters = as_json(provider, x@arguments, ...)
    ))
  )
}


method(as_json, list(ProviderOpenAICompatible, TypeObject)) <- function(
  provider,
  x,
  ...
) {
  if (x@additional_properties) {
    cli::cli_abort("{.arg .additional_properties} not supported for OpenAI.")
  }

  names <- names2(x@properties)
  properties <- lapply(x@properties, function(x) {
    out <- as_json(provider, x, ...)
    if (!x@required) {
      out$type <- c(out$type, "null")
    }
    out
  })

  names(properties) <- names

  list(
    type = "object",
    description = x@description %||% "",
    properties = properties,
    required = as.list(names),
    additionalProperties = FALSE
  )
}


# Models -----------------------------------------------------------------------

method(models_list, ProviderOpenAICompatible) <- function(provider) {
  req <- base_request(provider)
  req <- req_url_path_append(req, "/models")
  resp <- req_perform(req)

  json <- resp_body_json(resp)

  id <- map_chr(json$data, "[[", "id")
  created <- as.Date(.POSIXct(map_dbl(json$data, "[[", "created")))
  owned_by <- map_chr(json$data, "[[", "owned_by")

  df <- data.frame(
    id = id,
    created_at = created,
    owned_by = owned_by
  )
  df <- cbind(df, match_prices(provider@name, df$id))
  df[order(-xtfrm(df$created_at)), ]
}

# Batched requests -------------------------------------------------------------

method(has_batch_support, ProviderOpenAICompatible) <- function(provider) {
  FALSE
}