R/utils.R

In PLAY-behaviorome/databraryapi: Interact with the 'Databrary.org' API

# R/utils.R
# 
# Utility functions.

#-------------------------------------------------------------------------------
#' Get Duration (In ms) Of A File.
#'
#' @param asset_id Asset number.
#' @param types_w_durations Asset types that have valid durations.
#' @param vb A Boolean value. If TRUE provides verbose output.
#' @param rq An `httr2` request object. Default is NULL.
#' 
#' @returns Duration of a file in ms.
#' 
#' @examples
#' \donttest{
#' get_file_duration() # default is the test video from databrary.org/volume/1
#' }
#' 
#' @export
get_file_duration <- function(asset_id = 1,
                              types_w_durations = c("-600", "-800"),
                              vb = FALSE,
                              rq = NULL) {

  assertthat::assert_that(is.numeric(asset_id))
  assertthat::assert_that(asset_id > 0)
  assertthat::assert_that(length(asset_id) == 1)
  
  assertthat::assert_that(is.character(types_w_durations))
  
  assertthat::assert_that(is.logical(vb))
  assertthat::assert_that(length(vb) == 1)
  
  assertthat::assert_that(is.null(rq) |
                            ("httr2_request" %in% class(rq)))
  
  # Handle NULL rq
  if (is.null(rq)) {
    if (vb) {
      message("NULL request object. Will generate default.")
      message("Not logged in. Only public information will be returned.")  
    }
    rq <- databraryr::make_default_request()
  }
  rq <- rq %>%
    httr2::req_url(sprintf(GET_ASSET_BY_ID, asset_id))
  
  resp <- tryCatch(
    httr2::req_perform(rq),
    httr2_error = function(cnd)
      NULL
  )
  if (!is.null(resp)) {
    asset_df <- httr2::resp_body_json(resp)
    if (asset_df$format %in% types_w_durations) {
      asset_df$duration
    } else {
      if (vb)
        message("File type does not have a defined duration.")
      return(NULL)
    }
  } else {
    resp
  }
}

#-------------------------------------------------------------------------------
#' Get Time Range For An Asset.
#'
#' @param vol_id Volume ID
#' @param session_id Slot/session number.
#' @param asset_id Asset number.
#' @param convert_JSON A Boolean value. If TRUE, convert JSON to a data frame. Default is TRUE.
#' @param segment_only A Boolean value. If TRUE, returns only the segment values. Otherwise returns
#' a data frame with two fields, segment and permission. Default is TRUE.
#' @param vb A Boolean value. If TRUE provides verbose output.
#' @param rq An `httr2` request object. Default is NULL.
#'
#' @returns The time range (in ms) for an asset, if one is indicated.
#' 
#' @examples
#' \donttest{
#' get_asset_segment_range()
#' }
#' 
#' @export
get_asset_segment_range <- function(vol_id = 1,
                                    session_id = 9807,
                                    asset_id = 1,
                                    convert_JSON = TRUE,
                                    segment_only = TRUE,
                                    vb = FALSE,
                                    rq = NULL) {
  
  assertthat::assert_that(is.numeric(vol_id))
  assertthat::assert_that(vol_id > 0)
  assertthat::assert_that(length(vol_id) == 1)
  
  assertthat::assert_that(is.numeric(session_id))
  assertthat::assert_that(session_id > 0)
  assertthat::assert_that(length(session_id) == 1)
  
  assertthat::assert_that(is.numeric(asset_id))
  assertthat::assert_that(asset_id > 0)
  assertthat::assert_that(length(asset_id) == 1)
  
  assertthat::assert_that(is.logical(convert_JSON))
  assertthat::assert_that(length(convert_JSON) == 1)
  
  assertthat::assert_that(is.logical(convert_JSON))
  assertthat::assert_that(length(convert_JSON) == 1)
  
  assertthat::assert_that(is.logical(segment_only))
  assertthat::assert_that(length(segment_only) == 1)
  
  assertthat::assert_that(is.logical(vb))
  assertthat::assert_that(length(vb) == 1)
  
  assertthat::assert_that(is.null(rq) |
                            ("httr2_request" %in% class(rq)))
  # Handle NULL rq
  if (is.null(rq)) {
    if (vb) {
      message("NULL request object. Will generate default.")
      message("Not logged in. Only public information will be returned.")  
    }
    rq <- databraryr::make_default_request()
  }
  rq <- rq %>%
    httr2::req_url(sprintf(GET_ASSET_BY_VOLUME_SESSION_ID, vol_id, session_id, asset_id))
  
  resp <- tryCatch(
    httr2::req_perform(rq),
    httr2_error = function(cnd)
      NULL
  )
  if (!is.null(resp)) {
    asset_info <- httr2::resp_body_json(resp)
    if (vb) {
      message(
        "Returning segment start & end times (in ms) from volume ",
        vol_id,
        ", session ",
        session_id,
        ", asset ",
        asset_id
      )
    }
    if (segment_only) {
      asset_info$segment %>% unlist()
    } else {
      asset_info
    }
  } else {
    resp
  }
}

#-------------------------------------------------------------------------------
#' Extract Databrary Permission Levels.
#' 
#' @param vb A Boolean value. If TRUE provides verbose output.
#' @returns An array with the permission levels that can be assigned to data.
#' 
#' @examples
#' \donttest{
#' get_permission_levels()
#' }
#' 
#' @export
get_permission_levels <- function(vb = FALSE) {
  c <- assign_constants(vb = vb)
  c$permission %>% unlist()
}

#-------------------------------------------------------------------------------
#' Convert Timestamp String To ms.
#'
#' @param HHMMSSmmm a string in the format "HH:MM:SS:mmm"
#' @returns A numeric value in ms from the input string.
#' @examples
#' HHMMSSmmm_to_ms() # 01:01:01:333 in ms
#' @export
HHMMSSmmm_to_ms <- function(HHMMSSmmm = "01:01:01:333") {
  
  # Check parameters
  if (!is.character(HHMMSSmmm)) {
    stop("HHMMSSmmm must be a string.")
  }
  
  if (stringr::str_detect(HHMMSSmmm, "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})")) {
    time_segs <- stringr::str_match(HHMMSSmmm, "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})")
    as.numeric(time_segs[5]) + as.numeric(time_segs[4])*1000 + as.numeric(time_segs[3])*1000*60 +
      as.numeric(time_segs[2])*1000*60*60
  } else {
    NULL
  }
}

#-------------------------------------------------------------------------------
#' Show Databrary Release Levels
#'
#' @param vb A Boolean value. If TRUE provides verbose output.
#' @returns A data frame with Databrary's release levels.
#' 
#' @examples
#' \donttest{
#' get_release_levels()
#' }
#' 
#' @export
get_release_levels <- function(vb = FALSE) {
  c <- assign_constants(vb = vb)
  c$release %>% unlist()
}

#-------------------------------------------------------------------------------
#' Extracts File Types Supported by Databrary.
#' 
#' @param vb A Boolean value. If TRUE provides verbose output.
#' @returns A data frame with the file types permitted on Databrary.
#' 
#' @examples
#' \donttest{
#' get_supported_file_types()
#' }
#' 
#' @export
get_supported_file_types <- function(vb = FALSE) {
  c <- assign_constants(vb = vb)
  ft <- Reduce(function(x,y) merge(x, y, all=TRUE), c$format)
  ft <- dplyr::rename(ft, asset_type = "name", asset_type_id = "id")
  ft
}

#-------------------------------------------------------------------------------
#' Is This Party An Institution?
#'
#' @param party_id Databrary party ID
#' @param vb A Boolean value. If TRUE provides verbose output.
#' @param rq An `httr2` request object.
#' 
#' @returns TRUE if the party is an institution, FALSE otherwise.
#' 
#' @examples
#' \donttest{
#' is_institution() # Is party 8 (NYU) an institution.
#' }
#' 
#' @export
is_institution <- function(party_id = 8, vb = FALSE, rq = NULL) {
  
  assertthat::assert_that(is.numeric(party_id))
  assertthat::assert_that(party_id > 0)
  assertthat::assert_that(length(party_id) == 1)
  
  assertthat::assert_that(is.logical(vb))
  assertthat::assert_that(length(vb) == 1)
  
  assertthat::assert_that(is.null(rq) |
                            ("httr2_request" %in% class(rq)))
  
  # Handle NULL rq
  if (is.null(rq)) {
    if (vb) {
      message("NULL request object. Will generate default.")
      message("Not logged in. Only public information will be returned.")  
    }
    rq <- databraryr::make_default_request()
  }
  
  party_info <- databraryr::get_party_by_id(party_id, vb, rq)
  
  if (("institution" %in% names(party_info)) && (!is.null(party_info[['institution']]))) {
    TRUE
  } else {
    FALSE
  }
}

#-------------------------------------------------------------------------------
#' Is This Party A Person?
#'
#' @param party_id Databrary party ID
#' @param vb A boolean value. If TRUE provides verbose output.
#' @param rq An `httr2` request object.
#' @returns TRUE if the party is a person, FALSE otherwise.
#' 
#' @examples
#' \donttest{
#' is_person()
#' }
#' 
#' @export
is_person <- function(party_id = 7, vb = FALSE, rq = NULL){
  return(!is_institution(party_id, vb, rq))
}

#-------------------------------------------------------------------------------
#' Make Portable File Names
#'
#' @param fn Databrary party ID
#' @param vb A boolean value. If TRUE provides verbose output.
#' @param replace_regex A character string. A regular expression to capture 
#' the "non-portable" characters in fn.
#' @param replacement_char A character string. The character(s) that will replace
#' the non-portable characters.
#' 
#' @returns A "cleaned" portable file name
make_fn_portable <- function(fn, vb = FALSE, 
                             replace_regex = "[ &\\!\\)\\(\\}\\{\\[\\]\\+\\=@#\\$%\\^\\*]",
                             replacement_char = "_") {
  
  assertthat::is.string(fn)
  assertthat::assert_that(!is.numeric(fn))
  assertthat::assert_that(!is.logical(fn))
  assertthat::assert_that(length(fn) == 1)
  
  assertthat::assert_that(is.logical(vb))
  assertthat::assert_that(length(vb) == 1)
  
  assertthat::is.string(replace_regex)
  assertthat::assert_that(length(replace_regex) == 1)
  
  assertthat::is.string(replacement_char)
  assertthat::assert_that(length(replacement_char) == 1)
  
  if (vb) {
    non_portable_chars <- stringr::str_detect(fn, replace_regex)
    message("There are ", sum(non_portable_chars), " in ", fn)
  }
  new_fn <- stringr::str_replace_all(fn, replace_regex, replacement_char)
  new_fn
}