R/computations.R

Defines functions .comp_category .comp_box .comp_custom .comp_target .comp_min .comp_max

.comp_max <- function(x, low, high, scale, missing) {
  check_unit_range(missing)
  check_numeric(x)
  check_value_order(low, high)

  out <- rep(missing, length(x))
  out[x < low & !is.na(x)] <- 0
  out[x > high & !is.na(x)] <- 1
  middle <- x <= high & x >= low & !is.na(x)
  out[middle] <- ((x[middle] - low)/ (high - low))^scale
  out
}

.comp_min <- function(x, low, high, scale, missing) {
  check_unit_range(missing)
  check_numeric(x)
  check_value_order(low, high)

  out <- rep(missing, length(x))
  out[x < low & !is.na(x)] <- 1
  out[x > high & !is.na(x)] <- 0
  middle <- x <= high & x >= low & !is.na(x)
  out[middle] <- ((x[middle] - high)/ (low - high))^scale
  out
}


.comp_target <- function(x, low, target, high, scale_low, scale_high, missing) {
  check_unit_range(missing)
  check_numeric(x)
  check_value_order(low, high, target)

  out <- rep(missing, length(x))

  out[(x < low | x > high) &  !is.na(x)] <- 0
  lower <- x <= target & x >= low & !is.na(x)
  out[lower] <- ((x[lower] - low) / (target - low))^scale_low
  upper <- x <= high & x >= target & !is.na(x)
  out[upper] <- ((x[upper] - high) / (target - high))^scale_high

  out
}


.comp_custom <- function(x, values, d, missing) {
  check_unit_range(missing)
  check_unit_range(d)
  check_numeric(x)
  is_vector_args(values, d)

  ord <- order(values)
  values <- values[ord]
  d <- d[ord]

  out <- rep(missing, length(x))
  out[x < min(values) & !is.na(x)] <- 0
  out[x > max(values) & !is.na(x)] <- 1

  middle <- x <= max(values) & x >= min(values) & !is.na(x)
  x_mid <- x[middle]
  out[middle] <- stats::approx(values, d, xout = x_mid)$y

  out
}


.comp_box <- function(x, low, high, missing) {
  check_numeric(x)
  check_unit_range(missing)
  check_value_order(low, high)

  out <- rep(missing, length(x))
  out[x < low | x > high & !is.na(x)] <- 0
  out[x >= low & x <= high & !is.na(x)] <- 1

  out
}


.comp_category <- function(x, values, missing) {
  check_categorical(x)
  check_unit_range(missing)
  check_unit_range(values)

  # make consistent factors when needed, check names, better missing handling

  values <- tibble::tibble(value = names(values), d = unname(values))
  dat <- tibble::tibble(value = x, order = seq_along(x))
  out <- dplyr::left_join(dat, values, by = "value")

  out$d[out$order]
}

Try the desirability2 package in your browser

Any scripts or data that you put into this service are public.

desirability2 documentation built on May 31, 2023, 8:57 p.m.