R/upload_model.R

In alex23lemm/zementisr: R client for the 'Zementis Server' API

#' Upload new PMML model
#'
#' Upload new PMML source or serialized model file to Zementis Server.
#'
#' @param file Path to a file or a \code{XMLNode} object generated by
#' \code{\link[pmml]{pmml}}. The PMML model file can end in \code{.xml},
#' \code{.pmml} or even be \code{.zip} or \code{.gzip} compressed.
#' @param applyCleanser Logical indicating if the server should perform cleansing
#'  on the PMML file. (Default: \code{TRUE})
#' @inheritParams get_models
#' @return  If a model with the same name already exists on the server or if is
#'  not valid PMML, an error.
#' Otherwise a list with the following components:
#' \itemize{
#'  \item \code{model_name} The name of the uploaded model
#'  \item \code{is_active} A logical indicating the activation status of the model
#'    which is TRUE after the initial model upload.
#'  }
#' @export
#'
#' @examples
#'  \dontrun{
#'    #Build a simple lm model
#'    iris_lm <- lm(Sepal.Length ~ ., data=iris)
#'    # Convert to pmml and save to disk
#'    iris_pmml <- pmml::pmml(iris_lm, model.name = "iris_model")
#'    saveXML(iris_pmml, "iris_pmml.xml")
#'
#'    # Upload model to server
#'    upload_model("iris_pmml.xml")
#'
#'    # Second option: Upload XMLNode object directly
#'    iris_pmml <- pmml::pmml(iris_lm, model.name = "iris_model_opt2")
#'    upload_model(iris_pmml)
#'  }
upload_model <- function(file, applyCleanser = TRUE, ...) {
  if (!class(file)[1] %in% c("XMLNode", "XMLInternalDocument") && !file.exists(file)) {
    stop("Please either provide a XMLNode object generated by pmml::pmml() or
         a valid path to a PMML file.", .call = FALSE)
  }

  if (class(file)[1] %in% c("XMLNode", "XMLInternalDocument")) {
    tmp <- tempfile(fileext = ".pmml")
    on.exit(unlink(tmp))
    XML::saveXML(file, tmp)
    file <- tmp
  }

  applyCleanser <- ifelse(applyCleanser, "true", "false")
  url <- paste(get_zementis_base_url(), "model" , sep = "/") %>%
    httr::modify_url(query = list(applyCleanser = applyCleanser))
  my_file <- httr::upload_file(file)
  response <- httr::POST(url, httr::authenticate(get_zementis_usr(),
                                                 get_zementis_pwd()),
                         httr::user_agent(get_useragent()),
                         body = list(file = my_file),
                         ...)
  if (httr::status_code(response) != 201) {
    error_message <- sprintf(
      "Zementis Server API request failed [%s]\n%s\n%s\n%s",
      httr::status_code(response),
      httr::http_status(response)$category,
      httr::http_status(response)$reason,
      httr::http_status(response)$message
    )
    if (httr::status_code(response) %in% c(400, 409)) {
      error_message <- paste(error_message,
                             httr::content(response)$errors[[1]],
                             sep = "\n")
    }
    stop(error_message, call. = FALSE)
  }
  if (httr::http_type(response) != "application/json") {
    stop("Zementis Server API did not return json", .call = FALSE)
  }
  parsed <- httr::content(response, as = "text", encoding = "UTF-8") %>%
    jsonlite::fromJSON()
  list(
    model_name = parsed[["modelName"]],
    is_active = parsed[["isActive"]]
  )
}