receptiviti coverage - 85.84%

Files
Source

#' View or Establish Custom Norming Contexts
#'
#' Custom norming contexts can be used to process later texts by specifying the
#' \code{custom_context} API argument in the \code{receptiviti} function (e.g.,
#' \code{receptiviti("text to score", version = "v2",
#' options = list(custom_context = "norm_name"))},
#' where \code{norm_name} is the name you set here).
#'
#' @param name Name of a new norming context, to be established from the provided \code{text}.
#' Not providing a name will list the previously created contexts.
#' @param text Text to be processed and used as the custom norming context.
#' Not providing text will return the status of the named norming context.
#' @param options Options to set for the norming context (e.g.,
#' \code{list(min_word_count = 350,} \code{max_punctuation = .25)}).
#' @param delete Logical; If \code{TRUE}, will request to remove the \code{name} context.
#' @param name_only Logical; If \code{TRUE}, will return a character vector of names
#' only, including those of build-in contexts.
#' @param id,text_column,id_column,files,dir,file_type,collapse_lines,encoding Additional
#' arguments used to handle \code{text}; same as those in \code{\link{receptiviti}}.
#' @param bundle_size,bundle_byte_limit,retry_limit,clear_scratch_cache,use_future,in_memory
#' Additional arguments used to manage the requests; same as those in
#' \code{\link{receptiviti}}.
#' @param key,secret,url Request arguments; same as those in \code{\link{receptiviti}}.
#' @param verbose Logical; if \code{TRUE}, will show status messages.
#' @returns Nothing if \code{delete} if \code{TRUE}.
#' Otherwise, if \code{name} is not specified, a character vector containing names of each
#' available norming context (built-in and custom).
#' If \code{text} is not specified, the status of the
#' named context in a \code{list}. If \code{text}s are provided, a \code{list}:
#' \itemize{
#'    \item \code{initial_status}: Initial status of the context.
#'    \item \code{first_pass}: Response after texts are sent the first time, or
#'      \code{NULL} if the initial status is \code{pass_two}.
#'    \item \code{second_pass}: Response after texts are sent the second time.
#' }
#' @examples
#' \dontrun{
#'
#' # get status of all existing custom norming contexts
#' contexts <- receptiviti_norming(name_only = TRUE)
#'
#' # create or get the status of a single custom norming context
#' status <- receptiviti_norming("new_context")
#'
#' # send texts to establish the context
#'
#' ## these texts can be specified just like
#' ## texts in the main receptiviti function
#'
#' ## such as directly
#' full_status <- receptiviti_norming("new_context", c(
#'   "a text to set the norm",
#'   "another text part of the new context"
#' ))
#'
#' ## or from a file
#' full_status <- receptiviti_norming(
#'   "new_context", "./path/to/text.csv",
#'   text_column = "texts"
#' )
#'
#' ## or from multiple files in a directory
#' full_status <- receptiviti_norming(
#'   "new_context",
#'   dir = "./path/to/txt_files"
#' )
#' }
#' @export

receptiviti_norming <- function(
  name = NULL,
  text = NULL,
  options = list(),
  delete = FALSE,
  name_only = FALSE,
  id = NULL,
  text_column = NULL,
  id_column = NULL,
  files = NULL,
  dir = NULL,
  file_type = "txt",
  collapse_lines = FALSE,
  encoding = NULL,
  bundle_size = 1000,
  bundle_byte_limit = 75e5,
  retry_limit = 50,
  clear_scratch_cache = TRUE,
  use_future = FALSE,
  in_memory = TRUE,
  url = Sys.getenv("RECEPTIVITI_URL"),
  key = Sys.getenv("RECEPTIVITI_KEY"),
  secret = Sys.getenv("RECEPTIVITI_SECRET"),
  verbose = TRUE
) {
  params <- handle_request_params(url, key, secret)
  if (name_only) {
    req <- curl::curl_fetch_memory(
      paste0(params$url, "/v2/norming"),
      params$handler
    )
    if (req$status_code != 200) {
      stop(
        "failed to make norming list request: ",
        req$status_code,
        call. = FALSE
      )
    }
    norms <- jsonlite::fromJSON(rawToChar(req$content))
    if (verbose) {
      if (length(norms)) {
        message(
          "available norming context(s): ",
          paste(sub("custom/", "", norms, fixed = TRUE), collapse = ", ")
        )
      } else {
        message("no custom norming contexts found")
      }
    }
    return(norms)
  }

  baseurl <- paste0(params$url, "/v2/norming/custom/")
  if (!is.null(name) && grepl("[^a-z0-9_.-]", name)) {
    stop(
      "`name` can only include lowercase letters, numbers, hyphens, underscores, or periods",
      call. = FALSE
    )
  }

  # list current contexts
  req <- curl::curl_fetch_memory(baseurl, params$handler)
  if (req$status_code != 200) {
    stop(
      "failed to make norming list request: ",
      req$status_code,
      call. = FALSE
    )
  }
  norms <- jsonlite::fromJSON(rawToChar(req$content))
  if (length(norms)) {
    if (verbose && is.null(name)) {
      message(
        "custom norming context(s) found: ",
        paste(sub("custom/", "", norms$name, fixed = TRUE), collapse = ", ")
      )
    }
  } else {
    if (verbose && is.null(name)) message("no custom norming contexts found")
    norms <- NULL
  }
  if (is.null(name)) {
    return(norms)
  }

  context_id <- paste0("custom/", name)
  if (context_id %in% norms$name) {
    if (delete) {
      curl::handle_setopt(params$handler, customrequest = "DELETE")
      req <- curl::curl_fetch_memory(paste0(baseurl, name), params$handler)
      if (req$status_code != 200) {
        message <- list(error = rawToChar(req$content))
        if (substr(message$error, 1, 1) == "{")
          message$error <- jsonlite::fromJSON(message$error)
        stop(
          "failed to delete custom norming context: ",
          message$error,
          call. = FALSE
        )
      }
      return(invisible(NULL))
    }
    status <- as.list(norms[norms$name == context_id, ])
    if (length(options)) {
      warning(
        "context ",
        name,
        " already exists, so options do not apply",
        call. = FALSE
      )
    }
  } else if (!delete) {
    # establish a new context if needed
    if (verbose) message("requesting creation of custom context ", name)
    curl::handle_setopt(
      params$handler,
      copypostfields = jsonlite::toJSON(
        c(name = name, options),
        auto_unbox = TRUE
      )
    )
    req <- curl::curl_fetch_memory(baseurl, params$handler)
    if (req$status_code != 200) {
      message <- list(error = rawToChar(req$content))
      if (substr(message$error, 1, 1) == "{")
        message$error <- jsonlite::fromJSON(message$error)
      stop(
        "failed to make norming creation request: ",
        message$error,
        call. = FALSE
      )
    }
    status <- jsonlite::fromJSON(rawToChar(req$content))
    for (option in names(options)) {
      if (!is.null(status[[option]]) && status[[option]] != options[[option]]) {
        warning(
          "set option ",
          option,
          " does not match the requested value",
          call. = FALSE
        )
      }
    }
  }
  if (delete) {
    message("context ", name, " does not exist")
    return(invisible(NULL))
  }
  if (verbose) {
    message(
      "status of ",
      name,
      ": ",
      jsonlite::toJSON(status, pretty = TRUE, auto_unbox = TRUE)
    )
  }
  if (is.null(text)) {
    return(status)
  }
  if (status$status != "created") {
    warning("status is not `created`, so cannot send text", call. = FALSE)
    return(invisible(list(
      initial_status = status,
      first_pass = NULL,
      second_pass = NULL
    )))
  }
  if (verbose) message("sending first-pass samples for ", name)
  first_pass <- manage_request(
    text,
    id = id,
    text_column = text_column,
    id_column = id_column,
    files = files,
    dir = dir,
    file_type = file_type,
    collapse_lines = collapse_lines,
    encoding = encoding,
    bundle_size = bundle_size,
    bundle_byte_limit = bundle_byte_limit,
    retry_limit = retry_limit,
    clear_scratch_cache = clear_scratch_cache,
    cores = 1,
    use_future = use_future,
    in_memory = in_memory,
    url = paste0(baseurl, name, "/one"),
    key = key,
    secret = secret,
    verbose = verbose,
    to_norming = TRUE
  )$final_res
  second_pass <- NULL
  if (
    !is.null(first_pass$analyzed_samples) &&
      all(first_pass$analyzed_samples == 0)
  ) {
    warning(
      "no texts were successfully analyzed in the first pass, so second pass was skipped",
      call. = FALSE
    )
  } else {
    if (verbose) message("sending second-pass samples for ", name)
    second_pass <- manage_request(
      text,
      id = id,
      text_column = text_column,
      id_column = id_column,
      files = files,
      dir = dir,
      file_type = file_type,
      collapse_lines = collapse_lines,
      encoding = encoding,
      bundle_size = bundle_size,
      bundle_byte_limit = bundle_byte_limit,
      retry_limit = retry_limit,
      clear_scratch_cache = clear_scratch_cache,
      cores = 1,
      use_future = use_future,
      in_memory = in_memory,
      url = paste0(baseurl, name, "/two"),
      key = key,
      secret = secret,
      verbose = verbose,
      to_norming = TRUE
    )$final_res
  }
  if (
    !is.null(second_pass$analyzed_samples) &&
      all(second_pass$analyzed_samples == 0)
  ) {
    warning(
      "no texts were successfully analyzed in the second pass",
      call. = FALSE
    )
  }
  invisible(list(
    initial_status = status,
    first_pass = first_pass,
    second_pass = second_pass
  ))
}

#' @rdname receptiviti
#' @export

receptiviti_status <- function(
  url = Sys.getenv("RECEPTIVITI_URL"),
  key = Sys.getenv("RECEPTIVITI_KEY"),
  secret = Sys.getenv("RECEPTIVITI_SECRET"),
  version = Sys.getenv("RECEPTIVITI_VERSION"),
  verbose = TRUE,
  include_headers = FALSE
) {
  params <- handle_request_params(url, key, secret)
  url_parts <- parse_url(url, version)
  ping <- tryCatch(
    curl_fetch_memory(
      paste0(params$url, "/", url_parts$version, "/ping"),
      params$handler
    ),
    error = function(e) NULL
  )
  if (is.null(ping)) {
    if (verbose) message("Status: ERROR\nMessage: URL is unreachable")
    invisible(return())
  }
  ping$content <- list(message = rawToChar(ping$content))
  if (substr(ping$content, 1, 1) == "{")
    ping$content <- fromJSON(ping$content$message)
  ok <- ping$status_code == 200 && !length(ping$content$code)
  ping$status_message <- if (ok) {
    ping$content$pong
  } else {
    paste0(
      if (length(ping$content$code))
        paste0(ping$status_code, " (", ping$content$code, "): "),
      if (
        nchar(ping$content$message) > 500 ||
          grepl("<", ping$content$message, fixed = TRUE)
      ) {
        ping$status_code
      } else {
        ping$content$message
      }
    )
  }
  if (verbose) {
    message(
      "Status: ",
      if (ok) "OK" else "ERROR",
      "\nMessage: ",
      ping$status_message
    )
    if (include_headers) {
      ping$headers <- strsplit(
        rawToChar(ping$headers),
        "[\r\n]+",
        perl = TRUE
      )[[1]]
      json <- regexec("\\{.+\\}", ping$headers)
      for (i in seq_along(json)) {
        if (json[[i]] != -1) {
          regmatches(ping$headers[[i]], json[[i]]) <- paste(
            " ",
            strsplit(
              toJSON(
                fromJSON(regmatches(ping$headers[[i]], json[[i]])),
                auto_unbox = TRUE,
                pretty = TRUE
              ),
              "\n"
            )[[1]],
            collapse = "\n"
          )
        }
      }
      message(paste0("\n", paste(" ", ping$headers, collapse = "\n")))
    }
  }
  invisible(ping)
}

handle_request_params <- function(url, key, secret) {
  if (key == "") {
    stop(
      "specify your key, or set it to the RECEPTIVITI_KEY environment variable",
      call. = FALSE
    )
  }
  if (secret == "") {
    stop(
      "specify your secret, or set it to the RECEPTIVITI_SECRET environment variable",
      call. = FALSE
    )
  }
  url <- paste0(
    if (!grepl("http", tolower(url), fixed = TRUE)) "https://",
    sub("/+[Vv]\\d+(?:/.*)?$|/+$", "", url)
  )
  if (!grepl("^https?://[^.]+[.:][^.]", url, TRUE)) {
    stop(
      "url does not appear to be valid: ",
      url,
      call. = FALSE
    )
  }
  list(
    url = url,
    handler = new_handle(httpauth = 1, userpwd = paste0(key, ":", secret))
  )
}

parse_url <- function(url, version = "", endpoint = "") {
  url_parts <- unlist(strsplit(
    regmatches(
      url,
      gregexpr("/[Vv]\\d+(?:/[^/]+)?", url)
    )[[1]],
    "/",
    fixed = TRUE
  ))
  if (version == "")
    version <- if (length(url_parts) > 1) url_parts[[2]] else "v1"
  version <- tolower(version)
  if (version == "" || !grepl("^v\\d+$", version)) {
    stop("invalid version: ", version, call. = FALSE)
  }
  if (endpoint == "") {
    endpoint <- if (length(url_parts) > 2) {
      url_parts[[3]]
    } else {
      if (tolower(version) == "v1") "framework" else "analyze"
    }
  }
  endpoint <- sub("^.*/", "", tolower(endpoint))
  if (endpoint == "" || grepl("[^a-z]", endpoint)) {
    stop("invalid endpoint: ", endpoint, call. = FALSE)
  }
  list(
    url = sub("/+[Vv]\\d+(/.*)?$|/+$", "", url),
    version = version,
    endpoint = endpoint
  )
}

manage_request <- function(
  text = NULL,
  id = NULL,
  text_column = NULL,
  id_column = NULL,
  files = NULL,
  dir = NULL,
  file_type = "txt",
  encoding = NULL,
  context = "written",
  api_args = getOption("receptiviti.api_args", list()),
  bundle_size = 1000,
  bundle_byte_limit = 75e5,
  collapse_lines = FALSE,
  retry_limit = 50,
  clear_scratch_cache = TRUE,
  request_cache = TRUE,
  cores = detectCores() - 1,
  collect_results = TRUE,
  use_future = FALSE,
  in_memory = TRUE,
  verbose = FALSE,
  make_request = TRUE,
  text_as_paths = FALSE,
  cache = Sys.getenv("RECEPTIVITI_CACHE"),
  cache_overwrite = FALSE,
  cache_format = Sys.getenv("RECEPTIVITI_CACHE_FORMAT", "parquet"),
  key = Sys.getenv("RECEPTIVITI_KEY"),
  secret = Sys.getenv("RECEPTIVITI_SECRET"),
  url = Sys.getenv("RECEPTIVITI_URL"),
  version = Sys.getenv("RECEPTIVITI_VERSION"),
  endpoint = Sys.getenv("RECEPTIVITI_ENDPOINT"),
  to_norming = FALSE
) {
  # check input
  if (use_future && !requireNamespace("future.apply", quietly = TRUE)) {
    stop("install the `future.apply` package to use future", call. = FALSE)
  }
  st <- proc.time()[[3]]
  text_as_dir <- FALSE
  if (is.null(text)) {
    if (!is.null(dir)) {
      if (!dir.exists(dir)) stop("entered dir does not exist", call. = FALSE)
      text <- dir
      text_as_dir <- TRUE
    } else if (!is.null(files)) {
      text <- files
      text_as_paths <- TRUE
    } else {
      stop(
        "enter text as the first argument, or use files or dir",
        call. = FALSE
      )
    }
  }
  if (text_as_paths) {
    if (anyNA(text))
      stop(
        "NAs are not allowed in text when being treated as file paths",
        call. = FALSE
      )
    if (!all(file.exists(text)))
      stop("not all of the files in text exist", call. = FALSE)
  }
  read_in <- FALSE
  handle_encoding <- function(file) {
    if (is.null(encoding)) {
      con <- gzfile(file, "rb")
      on.exit(close(con))
      unlist(stringi::stri_enc_detect(readBin(con, "raw", file.size(file)))[[
        1
      ]])[[1]]
    } else {
      encoding
    }
  }
  if (
    text_as_dir ||
      text_as_paths ||
      (is.character(text) && !anyNA(text) && all(nchar(text) < 500))
  ) {
    if (text_as_dir || length(text) == 1 && dir.exists(text)) {
      if (verbose)
        message(
          "reading in texts from directory: ",
          text,
          " (",
          round(proc.time()[[3]] - st, 4),
          ")"
        )
      text_as_paths <- TRUE
      text <- normalizePath(
        list.files(text, file_type, full.names = TRUE),
        "/",
        FALSE
      )
    }
    if (text_as_paths || all(file.exists(text))) {
      text_as_paths <- collapse_lines
      if (!collapse_lines) {
        if (verbose)
          message(
            "reading in texts from file list (",
            round(proc.time()[[3]] - st, 4),
            ")"
          )
        if (is.null(id_column))
          names(text) <- if (length(id) != length(text)) text else id
        if (all(grepl("\\.csv", text, TRUE))) {
          if (is.null(text_column))
            stop(
              "text appears to point to csv files, but text_column was not specified",
              call. = FALSE
            )
          read_in <- TRUE
          text <- unlist(lapply(text, function(f) {
            d <- tryCatch(
              {
                enc <- handle_encoding(f)
                con <- gzfile(f, encoding = enc)
                arrow::read_csv_arrow(
                  con,
                  read_options = arrow::CsvReadOptions$create(
                    encoding = enc
                  ),
                  col_select = c(text_column, id_column)
                )
              },
              error = function(e) NULL
            )
            if (is.null(d)) stop("failed to read in file ", f, call. = FALSE)
            if (!is.null(id_column) && id_column %in% colnames(d)) {
              structure(
                d[, text_column, drop = TRUE],
                names = d[, id_column, drop = TRUE]
              )
            } else {
              d[, text_column, drop = TRUE]
            }
          }))
        } else {
          text <- unlist(lapply(text, function(f) {
            tryCatch(
              {
                con <- gzfile(f, encoding = handle_encoding(f))
                on.exit(close(con))
                d <- readLines(con, warn = FALSE, skipNul = TRUE)
                d[d != ""]
              },
              error = function(e)
                stop("failed to read in file ", f, call. = FALSE)
            )
          }))
        }
        id <- names(text)
      }
    } else if (
      length(text) == 1 &&
        dirname(text) != "." &&
        dir.exists(dirname(dirname(text)))
    ) {
      stop("text appears to be a directory, but it does not exist")
    }
    if (text_as_paths && is.null(id)) {
      id <- text
      if (anyDuplicated(id))
        id <- names(unlist(lapply(
          split(id, factor(id, unique(id))),
          seq_along
        )))
    }
  }
  if (is.null(dim(text))) {
    if (!read_in) {
      if (!text_as_paths && !is.null(text_column))
        stop("text_column is specified, but text has no columns", call. = FALSE)
      if (!is.null(id_column))
        stop("id_column is specified, but text has no columns", call. = FALSE)
    }
  } else {
    if (length(id) == 1 && id %in% colnames(text)) id_column <- id
    if (!is.null(id_column)) {
      if (id_column %in% colnames(text)) {
        id <- text[, id_column, drop = TRUE]
      } else {
        stop("id_column not found in text", call. = FALSE)
      }
    }
    if (!is.null(text_column)) {
      if (text_column %in% colnames(text)) {
        text <- text[, text_column, drop = TRUE]
      } else {
        if (!text_as_paths) stop("text_column not found in text", call. = FALSE)
      }
    }
    if (!is.null(dim(text))) {
      if (ncol(text) == 1) {
        text <- text[, 1, drop = TRUE]
      } else {
        stop("text has dimensions, but no text_column column", call. = FALSE)
      }
    }
  }
  if (!is.character(text)) text <- as.character(text)
  if (!length(text))
    stop("no texts were found after resolving the text argument")
  if (length(id) && !is.character(id)) id <- as.character(id)
  provided_id <- FALSE
  if (length(id)) {
    if (length(id) != length(text))
      stop("id is not the same length as text", call. = FALSE)
    if (anyDuplicated(id)) stop("id contains duplicate values", call. = FALSE)
    provided_id <- TRUE
  } else {
    id <- paste0("t", seq_along(text))
  }
  if (!is.numeric(retry_limit)) retry_limit <- 0
  if (to_norming) {
    version <- "v2"
    endpoint <- "norming"
    full_url <- url
    request_cache <- FALSE
  } else {
    parsed_url <- parse_url(url, version, endpoint)
    url <- parsed_url$url
    version <- parsed_url$version
    endpoint <- parsed_url$endpoint
    full_url <- paste0(
      url,
      "/",
      version,
      "/",
      endpoint,
      if (version == "v1") "/bulk" else paste0("/", context)
    )
    if (!is.list(api_args)) api_args <- as.list(api_args)
    if (
      version != "v1" &&
        "context" %in% api_args &&
        "custom_context" %in% api_args
    ) {
      stop(
        "only one of `context` or `custom_context may be specified",
        call. = FALSE
      )
    }
    if (version != "v1" && length(api_args)) {
      full_url <- paste0(
        full_url,
        "?",
        paste0(names(api_args), "=", unlist(api_args), collapse = "&")
      )
    }
  }
  args_hash <- digest::digest(
    jsonlite::toJSON(
      c(
        api_args,
        url = full_url,
        key = key,
        secret = secret
      ),
      auto_unbox = TRUE
    ),
    serialize = FALSE
  )

  # ping API
  if (make_request) {
    if (verbose) message("pinging API (", round(proc.time()[[3]] - st, 4), ")")
    ping <- receptiviti_status(
      url,
      key,
      secret,
      version,
      verbose = FALSE
    )
    if (is.null(ping)) stop("URL is unreachable", call. = FALSE)
    if (ping$status_code != 200) stop(ping$status_message, call. = FALSE)
  }

  # prepare text
  if (verbose) message("preparing text (", round(proc.time()[[3]] - st, 4), ")")
  data <- data.frame(text = text, id = id, stringsAsFactors = FALSE)
  text <- data[!is.na(data$text) & data$text != "" & !duplicated(data$text), ]
  if (!nrow(text)) stop("no valid texts to process", call. = FALSE)
  if (!is.numeric(bundle_size)) bundle_size <- 1000
  n_texts <- nrow(text)
  n <- ceiling(n_texts / min(1000, max(1, bundle_size)))
  bundles <- split(text, sort(rep_len(seq_len(n), nrow(text))))
  size_fun <- if (text_as_paths) function(b) sum(file.size(b$text)) else
    object.size
  for (i in rev(seq_along(bundles))) {
    size <- size_fun(bundles[[i]])
    if (size > bundle_byte_limit) {
      sizes <- vapply(
        seq_len(nrow(bundles[[i]])),
        function(r) as.numeric(size_fun(bundles[[i]][r, ])),
        0
      )
      if (any(sizes > bundle_byte_limit)) {
        stop(
          "one of your texts is over the individual size limit (",
          bundle_byte_limit / 1024e3,
          " MB)",
          call. = FALSE
        )
      }
      bins <- rep(1, length(sizes))
      bin_size <- 0
      bi <- 1
      for (ti in seq_along(bins)) {
        bin_size <- bin_size + sizes[ti]
        if (bin_size > bundle_byte_limit) {
          bin_size <- sizes[ti]
          bi <- bi + 1
        }
        bins[ti] <- bi
      }
      bundles <- c(
        bundles[-i],
        unname(split(bundles[[i]], paste0(i, ".", bins)))
      )
    }
  }
  n_bundles <- length(bundles)
  bundle_ref <- if (n_bundles == 1) "bundle" else "bundles"
  if (verbose)
    message(
      "prepared text in ",
      n_bundles,
      " ",
      bundle_ref,
      " (",
      round(proc.time()[[3]] - st, 4),
      ")"
    )

  auth <- paste0(key, ":", secret)
  if (is.null(in_memory) && (use_future || cores > 1) && n_bundles > cores)
    in_memory <- FALSE
  request_scratch <- NULL
  if (!in_memory) {
    if (verbose)
      message(
        "writing ",
        bundle_ref,
        " to disc (",
        round(proc.time()[[3]] - st, 4),
        ")"
      )
    request_scratch <- paste0(tempdir(), "/receptiviti_request_scratch/")
    dir.create(request_scratch, FALSE)
    if (clear_scratch_cache) on.exit(unlink(request_scratch, recursive = TRUE))
    bundles <- vapply(
      bundles,
      function(b) {
        scratch_bundle <- paste0(request_scratch, digest::digest(b), ".rds")
        if (!file.exists(scratch_bundle))
          saveRDS(b, scratch_bundle, compress = FALSE)
        scratch_bundle
      },
      "",
      USE.NAMES = FALSE
    )
  }

  doprocess <- function(bundles, cores, future) {
    env <- parent.frame()
    if (future) {
      eval(
        expression(future.apply::future_lapply(bundles, process)),
        envir = env
      )
    } else {
      cl <- parallel::makeCluster(cores)
      parallel::clusterExport(cl, ls(envir = env), env)
      on.exit(parallel::stopCluster(cl))
      (if (length(bundles) > cores * 2) parallel::parLapplyLB else
        parallel::parLapply)(cl, bundles, process)
    }
  }

  request <- function(body, body_hash, bin, ids, attempt = retry_limit) {
    temp_file <- paste0(tempdir(), "/", body_hash, ".json")
    if (!request_cache) unlink(temp_file)
    res <- NULL
    if (!file.exists(temp_file)) {
      if (make_request) {
        handler <- tryCatch(
          curl::new_handle(httpauth = 1, userpwd = auth, copypostfields = body),
          error = function(e) e$message
        )
        if (is.character(handler)) {
          stop(
            if (grepl("libcurl", handler, fixed = TRUE)) {
              "libcurl encountered an error; try setting the bundle_byte_limit argument to a smaller value"
            } else {
              paste("failed to create handler:", handler)
            },
            call. = FALSE
          )
        }
        if (to_norming) curl::handle_setopt(handler, customrequest = "PATCH")
        res <- curl::curl_fetch_disk(full_url, temp_file, handler)
      } else {
        stop(
          "make_request is FALSE, but there are texts with no cached results",
          call. = FALSE
        )
      }
    }
    result <- if (file.exists(temp_file)) {
      if (
        is.null(res$type) || grepl("application/json", res$type, fixed = TRUE)
      ) {
        tryCatch(
          jsonlite::read_json(temp_file, simplifyVector = TRUE),
          error = function(e) list(message = "invalid response format")
        )
      } else {
        list(message = "invalid response format")
      }
    } else {
      list(message = rawToChar(res$content))
    }
    valid_result <- if (to_norming) {
      !is.null(result$submitted)
    } else {
      !is.null(result$results) || is.null(result$message)
    }
    if (valid_result) {
      if (!is.null(result$results)) result <- result$results
      if ("error" %in% names(result)) {
        if (!is.list(result$error)) {
          warning("bundle ", body_hash, " failed: ", result$error)
        } else if (is.list(result$error)) {
          warning(
            "bundle ",
            body_hash,
            " failed: ",
            if (!is.null(result$error$code))
              paste0("(", result$error$code, ") ") else NULL,
            result$error$message
          )
        } else {
          if (is.data.frame(result)) {
            warning(
              "text-level errors present: ",
              jsonlite::toJSON(result$error, pretty = TRUE)
            )
          } else {
            errors <- result$error
            su <- !is.na(result$error$code)
            warning(
              if (sum(su) > 1) "some texts were invalid: " else
                "a text was invalid: ",
              paste(
                do.call(
                  paste0,
                  data.frame(
                    "(",
                    errors$code,
                    ") ",
                    errors$message,
                    stringsAsFactors = FALSE
                  )
                ),
                collapse = "; "
              ),
              call. = FALSE
            )
          }
        }
      }
      if (to_norming) {
        cbind(body_hash = body_hash, as.data.frame(result))
      } else {
        unpack <- function(d) {
          if (is.list(d)) as.data.frame(lapply(d, unpack), optional = TRUE) else
            d
        }
        result <- unpack(result[
          !names(result) %in% c("response_id", "language", "version", "error")
        ])
        if (!is.null(result) && nrow(result)) {
          if (colnames(result)[[1]] == "request_id") {
            colnames(result)[[1]] <- "text_hash"
          }
          cbind(id = ids, bin = bin, result)
        }
      }
    } else {
      unlink(temp_file)
      if (length(result$message) == 1 && substr(result$message, 1, 1) == "{") {
        result <- jsonlite::fromJSON(result$message)
      }
      if (
        attempt > 0 &&
          (length(result$code) == 1 && result$code == 1420) ||
          (length(result$message) == 1 &&
            result$message == "invalid response format")
      ) {
        wait_time <- as.numeric(regmatches(
          result$message,
          regexec("[0-9]+(?:\\.[0-9]+)?", result$message)
        ))
        Sys.sleep(if (is.na(wait_time)) 1 else wait_time / 1e3)
        request(body, body_hash, bin, ids, attempt - 1)
      } else {
        message <- if (is.null(res$status_code)) 200 else res$status_code
        if (length(result$code))
          message <- paste0(message, " (", result$code, "): ", result$message)
        if (length(result$error)) message <- paste0(message, ": ", result$error)
        stop(message, call. = FALSE)
      }
    }
  }

  process <- function(bundle) {
    opts <- getOption("stringsAsFactors")
    options("stringsAsFactors" = FALSE)
    on.exit(options("stringsAsFactors" = opts))
    if (is.character(bundle)) bundle <- readRDS(bundle)
    text <- bundle$text
    bin <- NULL
    if (text_as_paths) {
      if (all(grepl("\\.csv", text, TRUE))) {
        if (is.null(text_column))
          stop(
            "files appear to be csv, but no text_column was specified",
            call. = FALSE
          )
        text <- vapply(
          text,
          function(f) {
            tryCatch(
              paste(
                arrow::read_csv_arrow(
                  f,
                  read_options = arrow::CsvReadOptions$create(
                    encoding = handle_encoding(f)
                  ),
                  col_select = dplyr::all_of(text_column)
                )[[1]],
                collapse = " "
              ),
              error = function(e)
                stop("failed to read in file ", f, call. = FALSE)
            )
          },
          ""
        )
      } else {
        text <- vapply(
          text,
          function(f) {
            tryCatch(
              {
                con <- file(f, encoding = handle_encoding(f))
                on.exit(close(con))
                paste(
                  readLines(con, warn = FALSE, skipNul = TRUE),
                  collapse = " "
                )
              },
              error = function(e)
                stop("failed to read in file ", f, call. = FALSE)
            )
          },
          ""
        )
      }
    }
    bundle$hashes <- paste0(vapply(
      paste0(args_hash, text),
      digest::digest,
      "",
      serialize = FALSE
    ))
    if (to_norming) {
      body <- jsonlite::toJSON(
        lapply(
          seq_along(text),
          function(i) list(text = text[[i]], request_id = bundle$hashes[[i]])
        ),
        auto_unbox = TRUE
      )
      res <- request(
        body,
        digest::digest(body, serialize = FALSE),
        initial,
        bundle$id
      )
      prog(amount = nrow(bundle))
    } else {
      initial <- paste0("h", substr(bundle$hashes, 1, 1))
      set <- !is.na(text) &
        text != "" &
        text != "logical(0)" &
        !duplicated(bundle$hashes)
      res_cached <- cached_cols <- res_fresh <- NULL
      nres <- ncached <- 0
      check_cache <- !cache_overwrite &&
        (cache != "" && length(list.dirs(cache)))
      if (check_cache) {
        db <- arrow::open_dataset(
          cache,
          partitioning = arrow::schema(bin = arrow::string()),
          format = cache_format
        )
        cached_cols <- colnames(db)
        cached <- if (!is.null(db$schema$GetFieldByName("text_hash"))) {
          text_hash <- NULL
          su <- dplyr::filter(
            db,
            bin %in% unique(initial),
            text_hash %in% bundle$hashes
          )
          tryCatch(
            dplyr::compute(
              if (collect_results) su else dplyr::select(su, text_hash)
            ),
            error = function(e) matrix(integer(), 0)
          )
        } else {
          matrix(integer(), 0)
        }
        ncached <- nrow(cached)
        if (ncached) {
          cached <- as.data.frame(cached$to_data_frame())
          if (anyDuplicated(cached$text_hash))
            cached <- cached[!duplicated(cached$text_hash), ]
          rownames(cached) <- cached$text_hash
          cached_set <- which(bundle$hashes %in% cached$text_hash)
          set[cached_set] <- FALSE
          if (collect_results) {
            res_cached <- cbind(
              id = bundle$id[cached_set],
              cached[bundle$hashes[cached_set], ]
            )
          }
        }
      }
      valid_options <- names(api_args)
      if (any(set)) {
        set <- which(set)
        make_bundle <- if (version == "v1") {
          function(i) {
            c(
              api_args,
              list(content = text[[i]], request_id = bundle$hashes[[i]])
            )
          }
        } else {
          function(i) {
            list(text = text[[i]], request_id = bundle$hashes[[i]])
          }
        }
        body <- jsonlite::toJSON(
          unname(lapply(set, make_bundle)),
          auto_unbox = TRUE
        )
        body_hash <- digest::digest(body, serialize = FALSE)
        res_fresh <- request(body, body_hash, initial[set], bundle$id[set])
        valid_options <- valid_options[valid_options %in% colnames(res_fresh)]
        if (length(valid_options)) {
          res_fresh <- res_fresh[,
            !colnames(res_fresh) %in% valid_options,
            drop = FALSE
          ]
        }
        if (ncached && !all(cached_cols %in% colnames(res_fresh))) {
          res_cached <- NULL
          ncached <- 0
          body <- jsonlite::toJSON(
            lapply(cached_set, make_bundle),
            auto_unbox = TRUE
          )
          res_fresh <- rbind(
            res_fresh,
            request(
              body,
              digest::digest(body, serialize = FALSE),
              initial[cached_set],
              bundle$id[cached_set]
            )
          )
        }
        nres <- nrow(res_fresh)
        if (cache != "" && nres) {
          writer <- if (cache_format == "parquet") arrow::write_parquet else
            arrow::write_feather
          cols <- vapply(
            res_fresh[,
              !(colnames(res_fresh) %in% c("id", "bin", names(api_args)))
            ],
            is.character,
            TRUE
          )
          schema <- list()
          for (v in names(cols)) {
            schema[[v]] <- if (cols[[v]]) {
              arrow::string()
            } else if (
              v %in% c("summary.word_count", "summary.sentence_count")
            ) {
              if (anyNA(res_fresh[[v]]))
                res_fresh[[v]][is.na(res_fresh[[v]])] <- NA_integer_
              arrow::int32()
            } else {
              if (anyNA(res_fresh[[v]]))
                res_fresh[[v]][is.na(res_fresh[[v]])] <- NA_real_
              arrow::float64()
            }
          }
          schema <- arrow::schema(schema)
          for (part_bin in unique(res_fresh$bin)) {
            part <- res_fresh[res_fresh$bin == part_bin, ]
            part$id <- NULL
            part$bin <- NULL
            bin_dir <- paste0(cache, "/bin=", part_bin, "/")
            dir.create(bin_dir, FALSE, TRUE)
            writer(
              arrow::as_arrow_table(part, schema = schema),
              paste0(bin_dir, "fragment-", body_hash, "-0.", cache_format)
            )
          }
        }
      }
      if (collect_results) {
        res <- rbind(res_cached, res_fresh)
        if (length(valid_options))
          for (n in valid_options) res[[n]] <- api_args[[n]]
        missing_ids <- !bundle$id %in% res$id
        if (any(missing_ids)) {
          varnames <- colnames(res)[colnames(res) != "id"]
          res <- rbind(
            res,
            cbind(
              id = bundle$id[missing_ids],
              as.data.frame(matrix(
                NA,
                sum(missing_ids),
                length(varnames),
                dimnames = list(NULL, varnames)
              ))
            )
          )
          res$text_hash <- structure(bundle$hashes, names = bundle$id)[res$id]
        }
      }
      prog(amount = nres + ncached)
    }
    if (collect_results) res else NULL
  }

  # make request(s)
  cores <- if (is.numeric(cores)) max(1, min(n_bundles, cores)) else 1
  prog <- progressor(n_texts)
  results <- if (use_future || cores > 1) {
    call_env <- new.env(parent = globalenv())
    environment(doprocess) <- call_env
    environment(request) <- call_env
    environment(process) <- call_env
    for (name in c(
      "doprocess",
      "request",
      "process",
      "text_column",
      "prog",
      "make_request",
      "full_url",
      "cache",
      "cache_overwrite",
      "use_future",
      "cores",
      "bundles",
      "cache_format",
      "request_cache",
      "auth",
      "version",
      "to_norming",
      "text_as_paths",
      "retry_limit",
      "api_args",
      "args_hash",
      "encoding",
      "handle_encoding",
      "collect_results"
    )) {
      call_env[[name]] <- get(name)
    }
    if (verbose) {
      message(
        "processing ",
        bundle_ref,
        " using ",
        if (use_future) "future backend" else paste(cores, "cores"),
        " (",
        round(proc.time()[[3]] - st, 4),
        ")"
      )
    }
    eval(expression(doprocess(bundles, cores, use_future)), envir = call_env)
  } else {
    if (verbose)
      message(
        "processing ",
        bundle_ref,
        " sequentially (",
        round(proc.time()[[3]] - st, 4),
        ")"
      )
    lapply(bundles, process)
  }
  if (verbose)
    message("done retrieving (", round(proc.time()[[3]] - st, 4), ")")
  if (collect_results) {
    final_res <- do.call(rbind, results)
    list(data = data, final_res = final_res, provided_id = provided_id)
  } else {
    NULL
  }
}

.onLoad <- function(lib, pkg) {
  if (Sys.getenv("RECEPTIVITI_URL") == "")
    Sys.setenv(RECEPTIVITI_URL = "https://api.receptiviti.com/")
}

#' Receptiviti API
#'
#' The main function to access the \href{https://www.receptiviti.com}{Receptiviti} API.
#'
#' @param text A character vector with text to be processed, path to a directory containing files, or a vector of file paths.
#' If a single path to a directory, each file is collapsed to a single text. If a path to a file or files,
#' each line or row is treated as a separate text, unless \code{collapse_lines} is \code{TRUE} (in which case,
#' files will be read in as part of bundles at processing time, as is always the case when a directory).
#' Use \code{files} to more reliably enter files, or \code{dir} to more reliably specify a directory.
#' @param output Path to a \code{.csv} file to write results to. If this already exists, set \code{overwrite} to \code{TRUE}
#' to overwrite it.
#' @param id Vector of unique IDs the same length as \code{text}, to be included in the results.
#' @param text_column,id_column Column name of text/id, if \code{text} is a matrix-like object, or a path to a csv file.
#' @param files A list of file paths, as alternate entry to \code{text}.
#' @param dir A directory to search for files in, as alternate entry to \code{text}.
#' @param file_type File extension to search for, if \code{text} is the path to a directory containing files to be read in.
#' @param encoding Encoding of file(s) to be read in. If not specified, this will be detected, which can fail,
#' resulting in mis-encoded characters; for best (and fasted) results, specify encoding.
#' @param return_text Logical; if \code{TRUE}, \code{text} is included as the first column of the result.
#' @param context Name of the analysis context.
#' @param custom_context Name of a custom context (as listed by \code{\link{receptiviti_norming}}),
#' or \code{TRUE} if \code{context} is the name of a custom context.
#' @param api_args A list of additional arguments to pass to the API (e.g., \code{list(sallee_mode = "sparse")}). Defaults to the
#' \code{receptiviti.api_args} option. Custom norming contexts can be established with the \code{\link{receptiviti_norming}}
#' function, then referred to here with the \code{custom_context} argument (only available in API V2).
#' @param frameworks A vector of frameworks to include results from. Texts are always scored with all available framework --
#' this just specifies what to return. Defaults to \code{all}, to return all scored frameworks. Can be set by the
#' \code{receptiviti.frameworks} option (e.g., \code{options(receptiviti.frameworks = c("liwc", "sallee"))}).
#' @param framework_prefix Logical; if \code{FALSE}, will remove the framework prefix from column names, which may result in duplicates.
#' If this is not specified, and 1 framework is selected, or \code{as_list} is \code{TRUE}, will default to remove prefixes.
#' @param as_list Logical; if \code{TRUE}, returns a list with frameworks in separate entries.
#' @param bundle_size Number of texts to include in each request; between 1 and 1,000.
#' @param bundle_byte_limit Memory limit (in bytes) of each bundle, under \code{1e7} (10 MB, which is the API's limit).
#' May need to be lower than the API's limit, depending on the system's requesting library.
#' @param collapse_lines Logical; if \code{TRUE}, and \code{text} contains paths to files, each file is treated as a single text.
#' @param retry_limit Maximum number of times each request can be retried after hitting a rate limit.
#' @param overwrite Logical; if \code{TRUE}, will overwrite an existing \code{output} file.
#' @param compress Logical; if \code{TRUE}, will save as an \code{xz}-compressed file.
#' @param make_request Logical; if \code{FALSE}, a request is not made. This could be useful if you want to be sure and
#' load from one of the caches, but aren't sure that all results exist there; it will error out if it encounters
#' texts it has no other source for.
#' @param text_as_paths Logical; if \code{TRUE}, ensures \code{text} is treated as a vector of file paths. Otherwise, this will be
#' determined if there are no \code{NA}s in \code{text} and every entry is under 500 characters long.
#' @param cache Path to a directory in which to save unique results for reuse; defaults to
#' \code{Sys.getenv(}\code{"RECEPTIVITI_CACHE")}. See the Cache section for details.
#' @param cache_overwrite Logical; if \code{TRUE}, will write results to the cache without reading from it. This could be used
#' if you want fresh results to be cached without clearing the cache.
#' @param cache_format Format of the cache database; see \code{\link[arrow]{FileFormat}}.
#' Defaults to \code{Sys.getenv(}\code{"RECEPTIVITI_CACHE_FORMAT")}.
#' @param clear_cache Logical; if \code{TRUE}, will clear any existing files in the cache. Use \code{cache_overwrite} if
#' you want fresh results without clearing or disabling the cache. Use \code{cache = FALSE} to disable the cache.
#' @param request_cache Logical; if \code{FALSE}, will always make a fresh request, rather than using the response
#' from a previous identical request.
#' @param cores Number of CPU cores to split bundles across, if there are multiple bundles. See the Parallelization section.
#' @param collect_results Logical; if \code{FALSE}, will not retain bundle results in memory for return.
#' @param use_future Logical; if \code{TRUE}, uses a \code{future} back-end to process bundles, in which case,
#' parallelization can be controlled with the \code{\link[future]{plan}} function (e.g., \code{plan("multisession")}
#' to use multiple cores); this is required to see progress bars when using multiple cores. See the Parallelization section.
#' @param in_memory Logical; if \code{FALSE}, will write bundles to temporary files, and only load them as they are being requested.
#' @param clear_scratch_cache Logical; if \code{FALSE}, will preserve the bundles written when \code{in_memory} is \code{TRUE}, after
#' the request has been made.
#' @param verbose Logical; if \code{TRUE}, will show status messages.
#' @param key API Key; defaults to \code{Sys.getenv("RECEPTIVITI_KEY")}.
#' @param secret API Secret; defaults to \code{Sys.getenv("RECEPTIVITI_SECRET")}.
#' @param url API URL; defaults to \code{Sys.getenv("RECEPTIVITI_URL")}, which defaults to
#' \code{"https://api.receptiviti.com/"}.
#' @param version API version; defaults to \code{Sys.getenv("RECEPTIVITI_VERSION")}, which defaults to
#' \code{"v1"}.
#' @param endpoint API endpoint (path name after the version); defaults to \code{Sys.getenv("RECEPTIVITI_ENDPOINT")},
#' which defaults to \code{"framework"}.
#' @param include_headers Logical; if \code{TRUE}, \code{receptiviti_status}'s verbose message will include
#' the HTTP headers.
#'
#' @returns Nothing if \code{collect_results} is \code{FALSE}.
#' Otherwise, a \code{data.frame} with columns for \code{text} (if \code{return_text} is \code{TRUE}; the originally entered text),
#' \code{id} (if one was provided), \code{text_hash} (the MD5 hash of the text), a column each for relevant entries in \code{api_args},
#' and scores from each included framework (e.g., \code{summary.word_count} and \code{liwc.i}). If \code{as_list} is \code{TRUE},
#' returns a list with a named entry containing such a \code{data.frame} for each framework.
#'
#' @section Request Process:
#' This function (along with the internal \code{manage_request} function) handles texts and results in several steps:
#' \enumerate{
#'   \item Prepare bundles (split \code{text} into <= \code{bundle_size} and <= \code{bundle_byte_limit} bundles).
#'   \enumerate{
#'     \item If \code{text} points to a directory or list of files, these will be read in later.
#'     \item If \code{in_memory} is \code{FALSE}, bundles are written to a temporary location,
#'           and read back in when the request is made.
#'   }
#'   \item Get scores for texts within each bundle.
#'   \enumerate{
#'     \item If texts are paths, or \code{in_memory} is \code{FALSE}, will load texts.
#'     \item If \code{cache} is set, will skip any texts with cached scores.
#'     \item If \code{request_cache} is \code{TRUE}, will check for a cached request.
#'     \item If any texts need scoring and \code{make_request} is \code{TRUE}, will send unscored texts to the API.
#'   }
#'   \item If a request was made and \code{request_cache} is set, will cache the response.
#'   \item If \code{cache} is set, will write bundle scores to the cache.
#'   \item After requests are made, if \code{cache} is set, will defragment the cache
#'         (combine bundle results within partitions).
#'   \item If \code{collect_results} is \code{TRUE}, will prepare results:
#'   \enumerate{
#'     \item Will realign results with \code{text} (and \code{id} if provided).
#'     \item If \code{output} is specified, will write realigned results to it.
#'     \item Will drop additional columns (such as \code{custom} and \code{id} if not provided).
#'     \item If \code{framework} is specified, will use it to select columns of the results.
#'     \item Returns results.
#'   }
#' }
#'
#' @section Cache:
#' If the \code{cache} argument is specified, results for unique texts are saved in an
#' \href{https://arrow.apache.org}{Arrow} database in the cache location
#' (\code{Sys.getenv(}\code{"RECEPTIVITI_CACHE")}), and are retrieved with subsequent requests.
#' This ensures that the exact same texts are not re-sent to the API.
#' This does, however, add some processing time and disc space usage.
#'
#' If \code{cache} is \code{TRUE}, a default directory (\code{receptiviti_cache}) will be looked for
#' in the system's temporary directory (which is usually the parent of \code{tempdir()}).
#' If this does not exist, you will be asked if it should be created.
#'
#' The primary cache is checked when each bundle is processed, and existing results are loaded at
#' that time. When processing many bundles in parallel, and many results have been cached,
#' this can cause the system to freeze and potentially crash.
#' To avoid this, limit the number of cores, or disable parallel processing.
#'
#' The \code{cache_format} arguments (or the \code{RECEPTIVITI_CACHE_FORMAT} environment variable) can be used to adjust the format of the cache.
#'
#' You can use the cache independently with \code{open_database(Sys.getenv("RECEPTIVITI_CACHE"))}.
#'
#' You can also set the \code{clear_cache} argument to \code{TRUE} to clear the cache before it is used again, which may be useful
#' if the cache has gotten big, or you know new results will be returned. Even if a cached result exists, it will be
#' reprocessed if it does not have all of the variables of new results, but this depends on there being at least 1 uncached
#' result. If, for instance, you add a framework to your account and want to reprocess a previously processed set of texts,
#' you would need to first clear the cache.
#'
#' Either way, duplicated texts within the same call will only be sent once.
#'
#' The \code{request_cache} argument controls a more temporary cache of each bundle request. This is cleared when the
#' R session ends. You might want to set this to \code{FALSE} if a new framework becomes available on your account
#' and you want to process a set of text you already processed in the current R session without restarting.
#'
#' Another temporary cache is made when \code{in_memory} is \code{FALSE}, which is the default when processing
#' in parallel (when \code{cores} is over \code{1} or \code{use_future} is \code{TRUE}). This contains
#' a file for each unique bundle, which is read in as needed by the parallel workers.
#'
#' @section Parallelization:
#' \code{text}s are split into bundles based on the \code{bundle_size} argument. Each bundle represents
#' a single request to the API, which is why they are limited to 1000 texts and a total size of 10 MB.
#' When there is more than one bundle and either \code{cores} is greater than 1 or \code{use_future} is \code{TRUE} (and you've
#' externally specified a \code{\link[future]{plan}}), bundles are processed by multiple cores.
#'
#' If you have texts spread across multiple files, they can be most efficiently processed in parallel
#' if each file contains a single text (potentially collapsed from multiple lines). If files contain
#' multiple texts (i.e., \code{collapse_lines = FALSE}), then texts need to be read in before bundling
#' in order to ensure bundles are under the length limit.
#'
#' Whether processing in serial or parallel, progress bars can be specified externally with
#' \code{\link[progressr]{handlers}}; see examples.
#' @examples
#' \dontrun{
#'
#' # check that the API is available, and your credentials work
#' receptiviti_status()
#'
#' # score a single text
#' single <- receptiviti("a text to score")
#'
#' # score multiple texts, and write results to a file
#' multi <- receptiviti(c("first text to score", "second text"), "filename.csv")
#'
#' # score many texts in separate files
#' ## defaults to look for .txt files
#' file_results <- receptiviti(dir = "./path/to/txt_folder")
#'
#' ## could be .csv
#' file_results <- receptiviti(
#'   dir = "./path/to/csv_folder",
#'   text_column = "text", file_type = "csv"
#' )
#'
#' # score many texts from a file, with a progress bar
#' ## set up cores and progress bar
#' ## (only necessary if you want the progress bar)
#' future::plan("multisession")
#' progressr::handlers(global = TRUE)
#' progressr::handlers("progress")
#'
#' ## make request
#' results <- receptiviti(
#'   "./path/to/largefile.csv",
#'   text_column = "text", use_future = TRUE
#' )
#' }
#' @importFrom curl new_handle curl_fetch_memory curl_fetch_disk handle_setopt
#' @importFrom jsonlite toJSON fromJSON read_json
#' @importFrom utils object.size
#' @importFrom digest digest
#' @importFrom parallel detectCores makeCluster clusterExport parLapplyLB parLapply stopCluster
#' @importFrom progressr progressor
#' @importFrom stringi stri_enc_detect
#' @export

receptiviti <- function(
  text = NULL,
  output = NULL,
  id = NULL,
  text_column = NULL,
  id_column = NULL,
  files = NULL,
  dir = NULL,
  file_type = "txt",
  encoding = NULL,
  return_text = FALSE,
  context = "written",
  custom_context = FALSE,
  api_args = getOption("receptiviti.api_args", list()),
  frameworks = getOption("receptiviti.frameworks", "all"),
  framework_prefix = TRUE,
  as_list = FALSE,
  bundle_size = 1000,
  bundle_byte_limit = 75e5,
  collapse_lines = FALSE,
  retry_limit = 50,
  clear_cache = FALSE,
  clear_scratch_cache = TRUE,
  request_cache = TRUE,
  cores = detectCores() - 1,
  collect_results = TRUE,
  use_future = FALSE,
  in_memory = TRUE,
  verbose = FALSE,
  overwrite = FALSE,
  compress = FALSE,
  make_request = TRUE,
  text_as_paths = FALSE,
  cache = Sys.getenv("RECEPTIVITI_CACHE"),
  cache_overwrite = FALSE,
  cache_format = Sys.getenv("RECEPTIVITI_CACHE_FORMAT", "parquet"),
  key = Sys.getenv("RECEPTIVITI_KEY"),
  secret = Sys.getenv("RECEPTIVITI_SECRET"),
  url = Sys.getenv("RECEPTIVITI_URL"),
  version = Sys.getenv("RECEPTIVITI_VERSION"),
  endpoint = Sys.getenv("RECEPTIVITI_ENDPOINT")
) {
  # check input
  if (!is.null(output)) {
    if (!file.exists(output) && file.exists(paste0(output, ".xz")))
      output <- paste0(output, ".xz")
    if (!overwrite && file.exists(output))
      stop(
        "output file already exists; use overwrite = TRUE to overwrite it",
        call. = FALSE
      )
  }
  if (isTRUE(cache)) {
    temp <- dirname(tempdir())
    if (basename(temp) == "working_dir") temp <- dirname(dirname(temp))
    cache <- paste0(temp, "/receptiviti_cache")
    if (!dir.exists(cache)) {
      if (
        interactive() &&
          !isFALSE(getOption("receptiviti.cache_prompt")) &&
          grepl(
            "^(?:[Yy1]|$)",
            readline("Do you want to establish a default cache? [Y/n] ")
          )
      ) {
      } else {
        options(receptiviti.cache_prompt = FALSE)
        cache <- ""
      }
    }
  }
  if (!is.character(cache)) cache <- ""
  if (cache != "") {
    if (!requireNamespace("arrow", quietly = TRUE)) {
      stop("install the `arrow` package to enable the cache", call. = FALSE)
    }
    if (!(cache_format %in% c("parquet", "feather"))) {
      stop("cache format can only be `parquet` or `feather`", call. = FALSE)
    }
    if (clear_cache) unlink(cache, TRUE)
    dir.create(cache, FALSE, TRUE)
    cached_parts <- list.files(
      cache,
      cache_format,
      recursive = TRUE,
      full.names = TRUE
    )
  }
  st <- proc.time()[[3]]
  if (is.character(custom_context)) {
    context <- custom_context
    custom_context <- TRUE
  }
  if (context != "written") {
    norming_status <- receptiviti_norming(
      name_only = TRUE,
      url = url,
      key = key,
      secret = secret,
      verbose = FALSE
    )
    if (verbose) {
      message(
        "retrieved custom norming context list (",
        round(proc.time()[[3]] - st, 4),
        ")"
      )
    }
    context_id <- if (custom_context) paste0("custom/", context) else context
    if (!length(norming_status) || !(context_id %in% norming_status)) {
      stop(
        "custom norming context ",
        context,
        " is not on record or is not complete",
        call. = FALSE
      )
    }
  }
  if (
    length(frameworks) &&
      !("all" %in% frameworks) &&
      grepl("2", version, fixed = TRUE)
  ) {
    api_args$frameworks <- paste0(
      frameworks[frameworks != "summary"],
      collapse = ","
    )
  }
  if (!is.null(api_args$frameworks)) {
    available_frameworks <- c(
      "summary",
      receptiviti_frameworks(url, key, secret)
    )
    if (verbose)
      message(
        "retrived frameworks list (",
        round(proc.time()[[3]] - st, 4),
        ")"
      )
    arg_frameworks <- unlist(strsplit(api_args$frameworks, ",", fixed = TRUE))
    su <- !(arg_frameworks %in% available_frameworks)
    if (any(su)) {
      stop(
        "requested framework(s) are not available to your account: ",
        paste(arg_frameworks[su], collapse = ", "),
        call. = FALSE
      )
    }
  }
  res <- manage_request(
    text,
    id = id,
    text_column = text_column,
    id_column = id_column,
    files = files,
    dir = dir,
    file_type = file_type,
    encoding = encoding,
    context = if (custom_context) paste0("custom/", context) else context,
    api_args = api_args,
    bundle_size = bundle_size,
    bundle_byte_limit = bundle_byte_limit,
    collapse_lines = collapse_lines,
    retry_limit = retry_limit,
    clear_scratch_cache = clear_scratch_cache,
    request_cache = request_cache,
    cores = cores,
    use_future = use_future,
    in_memory = in_memory,
    verbose = verbose,
    make_request = make_request,
    text_as_paths = text_as_paths,
    cache = cache,
    cache_overwrite = cache_overwrite,
    cache_format = cache_format,
    key = key,
    secret = secret,
    url = url,
    version = version,
    endpoint = endpoint
  )
  data <- res$data
  final_res <- res$final_res

  # defragment cache
  if (cache != "") {
    cache <- normalizePath(cache, "/", FALSE)
    exclude <- c("id", "bin", names(api_args))
    bin_dirs <- list.dirs(cache)
    if (length(bin_dirs) > 1) {
      if (verbose)
        message("defragmenting cache (", round(proc.time()[[3]] - st, 4), ")")
      write_time <- as.numeric(Sys.time())
      for (bin_dir in bin_dirs[-1]) {
        files <- list.files(bin_dir, cache_format, full.names = TRUE)
        if (length(files) > 1) {
          previous <- files[!(files %in% cached_parts)]
          if (collect_results && length(previous)) {
            existing_cols <- unique(c(
              "id",
              "bin",
              names(arrow::schema(arrow::open_dataset(
                previous[[1]],
                format = cache_format
              )))
            ))
            if (
              length(existing_cols) != ncol(final_res) ||
                !all(existing_cols %in% colnames(final_res))
            ) {
              if (verbose)
                message("  clearing existing cache since columns did not align")
              unlink(previous)
            }
          }
          bin_content <- dplyr::compute(arrow::open_dataset(
            bin_dir,
            format = cache_format
          ))
          su <- !duplicated(as.character(bin_content$text_hash))
          if (!all(su)) bin_content <- bin_content[su, ]
          writer <- if (cache_format == "parquet") arrow::write_parquet else
            arrow::write_feather
          all_rows <- nrow(bin_content)
          for (i in seq_len(ceiling(all_rows / 1e9))) {
            writer(
              bin_content[seq((i - 1) * 1e9 + 1, min(all_rows, i * 1e9)), ],
              paste0(bin_dir, "/part-", write_time, "-", i, ".", cache_format)
            )
          }
          unlink(files)
        }
      }
    }
  }

  if (!collect_results) {
    if (verbose) message("done (", round(proc.time()[[3]] - st, 4), ")")
    return(invisible(NULL))
  }

  # prepare final results
  if (verbose)
    message("preparing output (", round(proc.time()[[3]] - st, 4), ")")
  rownames(final_res) <- final_res$id
  rownames(data) <- data$id
  data$text_hash <- structure(
    final_res$text_hash,
    names = data[final_res$id, "text"]
  )[data$text]
  final_res <- cbind(
    data[,
      c(if (return_text) "text", if (res$provided_id) "id", "text_hash"),
      drop = FALSE
    ],
    final_res[
      structure(final_res$id, names = final_res$text_hash)[data$text_hash],
      !colnames(final_res) %in% c("id", "bin", "text_hash", "custom"),
      drop = FALSE
    ]
  )
  row.names(final_res) <- NULL
  if (!is.null(output)) {
    if (!grepl("\\.csv", output, TRUE)) output <- paste0(output, ".csv")
    if (compress && !grepl(".xz", output, fixed = TRUE))
      output <- paste0(output, ".xz")
    if (grepl(".xz", output, fixed = TRUE)) compress <- TRUE
    if (verbose)
      message(
        "writing results to file: ",
        output,
        " (",
        round(proc.time()[[3]] - st, 4),
        ")"
      )
    dir.create(dirname(output), FALSE, TRUE)
    if (overwrite) unlink(output)
    if (compress) output <- xzfile(output)
    arrow::write_csv_arrow(final_res, file = output)
  }

  if (is.character(frameworks) && frameworks[1] != "all") {
    if (verbose)
      message("selecting frameworks (", round(proc.time()[[3]] - st, 4), ")")
    vars <- colnames(final_res)
    sel <- grepl(
      paste0("^(?:", paste(tolower(frameworks), collapse = "|"), ")"),
      vars
    )
    if (any(sel)) {
      if (
        missing(framework_prefix) &&
          (length(frameworks) == 1 && frameworks != "all")
      )
        framework_prefix <- FALSE
      sel <- unique(c("text", "id", "text_hash", names(api_args), vars[sel]))
      sel <- sel[sel %in% vars]
      final_res <- final_res[, sel]
    } else {
      warning(
        "frameworks did not match any columns -- returning all",
        call. = FALSE
      )
    }
  }
  if (as_list) {
    if (missing(framework_prefix)) framework_prefix <- FALSE
    inall <- c("text", "id", "text_hash", names(api_args))
    cols <- colnames(final_res)
    inall <- inall[inall %in% cols]
    pre <- sub("\\..*$", "", cols)
    pre <- unique(pre[!pre %in% inall])
    final_res <- lapply(structure(pre, names = pre), function(f) {
      res <- final_res[, c(inall, grep(paste0("^", f), cols, value = TRUE))]
      if (!framework_prefix) colnames(res) <- sub("^.+\\.", "", colnames(res))
      res
    })
  } else if (!framework_prefix)
    colnames(final_res) <- sub("^.+\\.", "", colnames(final_res))
  if (verbose) message("done (", round(proc.time()[[3]] - st, 4), ")")
  invisible(final_res)
}

#' List Available Frameworks
#'
#' Retrieve the list of frameworks available to your account.
#' @param url,key,secret Request arguments; same as those in \code{\link{receptiviti}}.
#' @returns A character vector containing the names of frameworks available to your account.
#' @examples
#' \dontrun{
#'
#' # see which frameworks are available to your account
#' frameworks <- receptiviti_frameworks()
#' }
#' @export

receptiviti_frameworks <- function(
  url = Sys.getenv("RECEPTIVITI_URL"),
  key = Sys.getenv("RECEPTIVITI_KEY"),
  secret = Sys.getenv("RECEPTIVITI_SECRET")
) {
  params <- handle_request_params(url, key, secret)
  req <- curl::curl_fetch_memory(
    paste0(params$url, "/v2/frameworks"),
    params$handler
  )
  if (req$status_code == 200) {
    return(jsonlite::fromJSON(rawToChar(req$content)))
  }
  content <- list(message = rawToChar(req$content))
  if (substr(content$message, 1, 1) == "{")
    content <- jsonlite::fromJSON(content$message)
  stop("failed to retrieve frameworks list: ", content$message, call. = FALSE)
}

1		#' @rdname receptiviti
2		#' @export
3
4		receptiviti_status <- function(
5		url = Sys.getenv("RECEPTIVITI_URL"),
6		key = Sys.getenv("RECEPTIVITI_KEY"),
7		secret = Sys.getenv("RECEPTIVITI_SECRET"),
8		version = Sys.getenv("RECEPTIVITI_VERSION"),
9		verbose = TRUE,
10		include_headers = FALSE
11		) {
12	61x	params <- handle_request_params(url, key, secret)
13	56x	url_parts <- parse_url(url, version)
14	56x	ping <- tryCatch(
15	56x	curl_fetch_memory(
16	56x	paste0(params$url, "/", url_parts$version, "/ping"),
17	56x	params$handler
18		),
19	56x	error = function(e) NULL
20		)
21	56x	if (is.null(ping)) {
22	1x	if (verbose) message("Status: ERROR\nMessage: URL is unreachable")
23	2x	invisible(return())
24		}
25	54x	ping$content <- list(message = rawToChar(ping$content))
26	54x	if (substr(ping$content, 1, 1) == "{")
27	53x	ping$content <- fromJSON(ping$content$message)
28	54x	ok <- ping$status_code == 200 && !length(ping$content$code)
29	54x	ping$status_message <- if (ok) {
30	50x	ping$content$pong
31		} else {
32	4x	paste0(
33	4x	if (length(ping$content$code))
34	4x	paste0(ping$status_code, " (", ping$content$code, "): "),
35	4x	if (
36	4x	nchar(ping$content$message) > 500 \|\|
37	4x	grepl("<", ping$content$message, fixed = TRUE)
38		) {
39	1x	ping$status_code
40		} else {
41	3x	ping$content$message
42		}
43		)
44		}
45	54x	if (verbose) {
46	4x	message(
47	4x	"Status: ",
48	4x	if (ok) "OK" else "ERROR",
49	4x	"\nMessage: ",
50	4x	ping$status_message
51		)
52	4x	if (include_headers) {
53	1x	ping$headers <- strsplit(
54	1x	rawToChar(ping$headers),
55	1x	"[\r\n]+",
56	1x	perl = TRUE
57	1x	)[[1]]
58	1x	json <- regexec("\\{.+\\}", ping$headers)
59	1x	for (i in seq_along(json)) {
60	9x	if (json[[i]] != -1) {
61	2x	regmatches(ping$headers[[i]], json[[i]]) <- paste(
62		" ",
63	2x	strsplit(
64	2x	toJSON(
65	2x	fromJSON(regmatches(ping$headers[[i]], json[[i]])),
66	2x	auto_unbox = TRUE,
67	2x	pretty = TRUE
68		),
69	2x	"\n"
70	2x	)[[1]],
71	2x	collapse = "\n"
72		)
73		}
74		}
75	1x	message(paste0("\n", paste(" ", ping$headers, collapse = "\n")))
76		}
77		}
78	54x	invisible(ping)
79		}
80
81		handle_request_params <- function(url, key, secret) {
82	76x	if (key == "") {
83	2x	stop(
84	2x	"specify your key, or set it to the RECEPTIVITI_KEY environment variable",
85	2x	call. = FALSE
86		)
87		}
88	74x	if (secret == "") {
89	2x	stop(
90	2x	"specify your secret, or set it to the RECEPTIVITI_SECRET environment variable",
91	2x	call. = FALSE
92		)
93		}
94	72x	url <- paste0(
95	72x	if (!grepl("http", tolower(url), fixed = TRUE)) "https://",
96	72x	sub("/+[Vv]\\d+(?:/.*)?$\|/+$", "", url)
97		)
98	72x	if (!grepl("^https?://[^.]+[.:][^.]", url, TRUE)) {
99	2x	stop(
100	2x	"url does not appear to be valid: ",
101	2x	url,
102	2x	call. = FALSE
103		)
104		}
105	70x	list(
106	70x	url = url,
107	70x	handler = new_handle(httpauth = 1, userpwd = paste0(key, ":", secret))
108		)
109		}
110
111		parse_url <- function(url, version = "", endpoint = "") {
112	112x	url_parts <- unlist(strsplit(
113	112x	regmatches(
114	112x	url,
115	112x	gregexpr("/[Vv]\\d+(?:/[^/]+)?", url)
116	112x	)[[1]],
117		"/",
118	112x	fixed = TRUE
119		))
120	112x	if (version == "")
121	56x	version <- if (length(url_parts) > 1) url_parts[[2]] else "v1"
122	112x	version <- tolower(version)
123	112x	if (version == "" \|\| !grepl("^v\\d+$", version)) {
124	1x	stop("invalid version: ", version, call. = FALSE)
125		}
126	111x	if (endpoint == "") {
127	110x	endpoint <- if (length(url_parts) > 2) {
128	3x	url_parts[[3]]
129		} else {
130	9x	if (tolower(version) == "v1") "framework" else "analyze"
131		}
132		}
133	111x	endpoint <- sub("^.*/", "", tolower(endpoint))
134	111x	if (endpoint == "" \|\| grepl("[^a-z]", endpoint)) {
135	1x	stop("invalid endpoint: ", endpoint, call. = FALSE)
136		}
137	110x	list(
138	110x	url = sub("/+[Vv]\\d+(/.*)?$\|/+$", "", url),
139	110x	version = version,
140	110x	endpoint = endpoint
141		)
142		}

1		#' View or Establish Custom Norming Contexts
2		#'
3		#' Custom norming contexts can be used to process later texts by specifying the
4		#' \code{custom_context} API argument in the \code{receptiviti} function (e.g.,
5		#' \code{receptiviti("text to score", version = "v2",
6		#' options = list(custom_context = "norm_name"))},
7		#' where \code{norm_name} is the name you set here).
8		#'
9		#' @param name Name of a new norming context, to be established from the provided \code{text}.
10		#' Not providing a name will list the previously created contexts.
11		#' @param text Text to be processed and used as the custom norming context.
12		#' Not providing text will return the status of the named norming context.
13		#' @param options Options to set for the norming context (e.g.,
14		#' \code{list(min_word_count = 350,} \code{max_punctuation = .25)}).
15		#' @param delete Logical; If \code{TRUE}, will request to remove the \code{name} context.
16		#' @param name_only Logical; If \code{TRUE}, will return a character vector of names
17		#' only, including those of build-in contexts.
18		#' @param id,text_column,id_column,files,dir,file_type,collapse_lines,encoding Additional
19		#' arguments used to handle \code{text}; same as those in \code{\link{receptiviti}}.
20		#' @param bundle_size,bundle_byte_limit,retry_limit,clear_scratch_cache,use_future,in_memory
21		#' Additional arguments used to manage the requests; same as those in
22		#' \code{\link{receptiviti}}.
23		#' @param key,secret,url Request arguments; same as those in \code{\link{receptiviti}}.
24		#' @param verbose Logical; if \code{TRUE}, will show status messages.
25		#' @returns Nothing if \code{delete} if \code{TRUE}.
26		#' Otherwise, if \code{name} is not specified, a character vector containing names of each
27		#' available norming context (built-in and custom).
28		#' If \code{text} is not specified, the status of the
29		#' named context in a \code{list}. If \code{text}s are provided, a \code{list}:
30		#' \itemize{
31		#' \item \code{initial_status}: Initial status of the context.
32		#' \item \code{first_pass}: Response after texts are sent the first time, or
33		#' \code{NULL} if the initial status is \code{pass_two}.
34		#' \item \code{second_pass}: Response after texts are sent the second time.
35		#' }
36		#' @examples
37		#' \dontrun{
38		#'
39		#' # get status of all existing custom norming contexts
40		#' contexts <- receptiviti_norming(name_only = TRUE)
41		#'
42		#' # create or get the status of a single custom norming context
43		#' status <- receptiviti_norming("new_context")
44		#'
45		#' # send texts to establish the context
46		#'
47		#' ## these texts can be specified just like
48		#' ## texts in the main receptiviti function
49		#'
50		#' ## such as directly
51		#' full_status <- receptiviti_norming("new_context", c(
52		#' "a text to set the norm",
53		#' "another text part of the new context"
54		#' ))
55		#'
56		#' ## or from a file
57		#' full_status <- receptiviti_norming(
58		#' "new_context", "./path/to/text.csv",
59		#' text_column = "texts"
60		#' )
61		#'
62		#' ## or from multiple files in a directory
63		#' full_status <- receptiviti_norming(
64		#' "new_context",
65		#' dir = "./path/to/txt_files"
66		#' )
67		#' }
68		#' @export
69
70		receptiviti_norming <- function(
71		name = NULL,
72		text = NULL,
73		options = list(),
74		delete = FALSE,
75		name_only = FALSE,
76		id = NULL,
77		text_column = NULL,
78		id_column = NULL,
79		files = NULL,
80		dir = NULL,
81		file_type = "txt",
82		collapse_lines = FALSE,
83		encoding = NULL,
84		bundle_size = 1000,
85		bundle_byte_limit = 75e5,
86		retry_limit = 50,
87		clear_scratch_cache = TRUE,
88		use_future = FALSE,
89		in_memory = TRUE,
90		url = Sys.getenv("RECEPTIVITI_URL"),
91		key = Sys.getenv("RECEPTIVITI_KEY"),
92		secret = Sys.getenv("RECEPTIVITI_SECRET"),
93		verbose = TRUE
94		) {
95	12x	params <- handle_request_params(url, key, secret)
96	12x	if (name_only) {
97	5x	req <- curl::curl_fetch_memory(
98	5x	paste0(params$url, "/v2/norming"),
99	5x	params$handler
100		)
101	5x	if (req$status_code != 200) {
102	!	stop(
103	!	"failed to make norming list request: ",
104	!	req$status_code,
105	!	call. = FALSE
106		)
107		}
108	5x	norms <- jsonlite::fromJSON(rawToChar(req$content))
109	5x	if (verbose) {
110	1x	if (length(norms)) {
111	1x	message(
112	1x	"available norming context(s): ",
113	1x	paste(sub("custom/", "", norms, fixed = TRUE), collapse = ", ")
114		)
115		} else {
116	!	message("no custom norming contexts found")
117		}
118		}
119	5x	return(norms)
120		}
121
122	7x	baseurl <- paste0(params$url, "/v2/norming/custom/")
123	7x	if (!is.null(name) && grepl("[^a-z0-9_.-]", name)) {
124	1x	stop(
125	1x	"`name` can only include lowercase letters, numbers, hyphens, underscores, or periods",
126	1x	call. = FALSE
127		)
128		}
129
130		# list current contexts
131	6x	req <- curl::curl_fetch_memory(baseurl, params$handler)
132	6x	if (req$status_code != 200) {
133	!	stop(
134	!	"failed to make norming list request: ",
135	!	req$status_code,
136	!	call. = FALSE
137		)
138		}
139	6x	norms <- jsonlite::fromJSON(rawToChar(req$content))
140	6x	if (length(norms)) {
141	6x	if (verbose && is.null(name)) {
142	1x	message(
143	1x	"custom norming context(s) found: ",
144	1x	paste(sub("custom/", "", norms$name, fixed = TRUE), collapse = ", ")
145		)
146		}
147		} else {
148	!	if (verbose && is.null(name)) message("no custom norming contexts found")
149	!	norms <- NULL
150		}
151	6x	if (is.null(name)) {
152	1x	return(norms)
153		}
154
155	5x	context_id <- paste0("custom/", name)
156	5x	if (context_id %in% norms$name) {
157	4x	if (delete) {
158	1x	curl::handle_setopt(params$handler, customrequest = "DELETE")
159	1x	req <- curl::curl_fetch_memory(paste0(baseurl, name), params$handler)
160	1x	if (req$status_code != 200) {
161	!	message <- list(error = rawToChar(req$content))
162	!	if (substr(message$error, 1, 1) == "{")
163	!	message$error <- jsonlite::fromJSON(message$error)
164	!	stop(
165	!	"failed to delete custom norming context: ",
166	!	message$error,
167	!	call. = FALSE
168		)
169		}
170	1x	return(invisible(NULL))
171		}
172	3x	status <- as.list(norms[norms$name == context_id, ])
173	3x	if (length(options)) {
174	!	warning(
175	!	"context ",
176	!	name,
177	!	" already exists, so options do not apply",
178	!	call. = FALSE
179		)
180		}
181	1x	} else if (!delete) {
182		# establish a new context if needed
183	1x	if (verbose) message("requesting creation of custom context ", name)
184	1x	curl::handle_setopt(
185	1x	params$handler,
186	1x	copypostfields = jsonlite::toJSON(
187	1x	c(name = name, options),
188	1x	auto_unbox = TRUE
189		)
190		)
191	1x	req <- curl::curl_fetch_memory(baseurl, params$handler)
192	1x	if (req$status_code != 200) {
193	!	message <- list(error = rawToChar(req$content))
194	!	if (substr(message$error, 1, 1) == "{")
195	!	message$error <- jsonlite::fromJSON(message$error)
196	!	stop(
197	!	"failed to make norming creation request: ",
198	!	message$error,
199	!	call. = FALSE
200		)
201		}
202	1x	status <- jsonlite::fromJSON(rawToChar(req$content))
203	1x	for (option in names(options)) {
204	1x	if (!is.null(status[[option]]) && status[[option]] != options[[option]]) {
205	!	warning(
206	!	"set option ",
207	!	option,
208	!	" does not match the requested value",
209	!	call. = FALSE
210		)
211		}
212		}
213		}
214	4x	if (delete) {
215	!	message("context ", name, " does not exist")
216	!	return(invisible(NULL))
217		}
218	4x	if (verbose) {
219	4x	message(
220	4x	"status of ",
221	4x	name,
222		": ",
223	4x	jsonlite::toJSON(status, pretty = TRUE, auto_unbox = TRUE)
224		)
225		}
226	4x	if (is.null(text)) {
227	3x	return(status)
228		}
229	1x	if (status$status != "created") {
230	!	warning("status is not `created`, so cannot send text", call. = FALSE)
231	!	return(invisible(list(
232	!	initial_status = status,
233	!	first_pass = NULL,
234	!	second_pass = NULL
235		)))
236		}
237	1x	if (verbose) message("sending first-pass samples for ", name)
238	1x	first_pass <- manage_request(
239	1x	text,
240	1x	id = id,
241	1x	text_column = text_column,
242	1x	id_column = id_column,
243	1x	files = files,
244	1x	dir = dir,
245	1x	file_type = file_type,
246	1x	collapse_lines = collapse_lines,
247	1x	encoding = encoding,
248	1x	bundle_size = bundle_size,
249	1x	bundle_byte_limit = bundle_byte_limit,
250	1x	retry_limit = retry_limit,
251	1x	clear_scratch_cache = clear_scratch_cache,
252	1x	cores = 1,
253	1x	use_future = use_future,
254	1x	in_memory = in_memory,
255	1x	url = paste0(baseurl, name, "/one"),
256	1x	key = key,
257	1x	secret = secret,
258	1x	verbose = verbose,
259	1x	to_norming = TRUE
260	1x	)$final_res
261	1x	second_pass <- NULL
262		if (
263	1x	!is.null(first_pass$analyzed_samples) &&
264	1x	all(first_pass$analyzed_samples == 0)
265		) {
266	!	warning(
267	!	"no texts were successfully analyzed in the first pass, so second pass was skipped",
268	!	call. = FALSE
269		)
270		} else {
271	1x	if (verbose) message("sending second-pass samples for ", name)
272	1x	second_pass <- manage_request(
273	1x	text,
274	1x	id = id,
275	1x	text_column = text_column,
276	1x	id_column = id_column,
277	1x	files = files,
278	1x	dir = dir,
279	1x	file_type = file_type,
280	1x	collapse_lines = collapse_lines,
281	1x	encoding = encoding,
282	1x	bundle_size = bundle_size,
283	1x	bundle_byte_limit = bundle_byte_limit,
284	1x	retry_limit = retry_limit,
285	1x	clear_scratch_cache = clear_scratch_cache,
286	1x	cores = 1,
287	1x	use_future = use_future,
288	1x	in_memory = in_memory,
289	1x	url = paste0(baseurl, name, "/two"),
290	1x	key = key,
291	1x	secret = secret,
292	1x	verbose = verbose,
293	1x	to_norming = TRUE
294	1x	)$final_res
295		}
296		if (
297	1x	!is.null(second_pass$analyzed_samples) &&
298	1x	all(second_pass$analyzed_samples == 0)
299		) {
300	!	warning(
301	!	"no texts were successfully analyzed in the second pass",
302	!	call. = FALSE
303		)
304		}
305	1x	invisible(list(
306	1x	initial_status = status,
307	1x	first_pass = first_pass,
308	1x	second_pass = second_pass
309		))
310		}

1		#' List Available Frameworks
2		#'
3		#' Retrieve the list of frameworks available to your account.
4		#' @param url,key,secret Request arguments; same as those in \code{\link{receptiviti}}.
5		#' @returns A character vector containing the names of frameworks available to your account.
6		#' @examples
7		#' \dontrun{
8		#'
9		#' # see which frameworks are available to your account
10		#' frameworks <- receptiviti_frameworks()
11		#' }
12		#' @export
13
14		receptiviti_frameworks <- function(
15		url = Sys.getenv("RECEPTIVITI_URL"),
16		key = Sys.getenv("RECEPTIVITI_KEY"),
17		secret = Sys.getenv("RECEPTIVITI_SECRET")
18		) {
19	3x	params <- handle_request_params(url, key, secret)
20	2x	req <- curl::curl_fetch_memory(
21	2x	paste0(params$url, "/v2/frameworks"),
22	2x	params$handler
23		)
24	2x	if (req$status_code == 200) {
25	2x	return(jsonlite::fromJSON(rawToChar(req$content)))
26		}
27	!	content <- list(message = rawToChar(req$content))
28	!	if (substr(content$message, 1, 1) == "{")
29	!	content <- jsonlite::fromJSON(content$message)
30	!	stop("failed to retrieve frameworks list: ", content$message, call. = FALSE)
31		}