R/transform.R

In vital: Tidy Analysis Tools for Mortality, Fertility, Migration and Population Data

# Lookup table for function inverses
inverse_table <- function() {
  table <- new.env(parent = emptyenv())
  list(
    add = function(ns, fn, inv) {
      table[[ns]] <- as.list(table[[ns]])
      table[[ns]][[fn]] <- inv
    },
    get = function(ns, fn) {
      ns_name <- environmentName(ns)
      if (nchar(ns_name) == 0) {
        ns_name <- "base"
      }
      ret <- table[[ns_name]][[fn]]
      if (is.null(ret)) {
        t_fn <- get(fn, envir = ns)
        if (inherits(t_fn, "transformation")) {
          ret <- function(operation, target, result) {
            args <- call_args(operation)
            target_pos <- match(list(target), args)
            call2(
              expr(invert_transformation(!!t_fn)),
              !!!replace(args, target_pos, list(result))
            )
          }
        } else {
          abort(sprintf(
            "No supported inverse for the `%s` transformation.",
            fn
          ))
        }
      }
      ret
    }
  )
}

undo_transformation <- function(operation, target, result) {
  fn <- call_name(operation)
  env <- get_env(operation, caller_env())
  ns <- eval_tidy(expr(environment(get(!!fn))), env = env)
  inverse_table$get(ns, fn)(operation, get_expr(target), result)
}

inverse_table <- inverse_table()

map(
  c("log", "logb"),
  function(.x) {
    inverse_table$add(
      "base",
      .x,
      function(operation, target, result) {
        args <- call_args(operation)
        target_pos <- match(list(target), args)
        if (length(args) == 1) {
          expr(exp(!!result))
        } else {
          expr((!!args[[2]])^!!result)
        }
      }
    )
  }
)

inverse_table$add(
  "base",
  "log10",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(10^!!result)
  }
)

inverse_table$add(
  "base",
  "log2",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(2^!!result)
  }
)

inverse_table$add(
  "base",
  "log1p",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(expm1(!!result))
  }
)

inverse_table$add(
  "base",
  "expm1",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(log1p(!!result))
  }
)

inverse_table$add(
  "base",
  "exp",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(log(!!!replace(args, target_pos, list(result))))
  }
)

inverse_table$add(
  "fabletools",
  "box_cox",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(inv_box_cox(!!!replace(args, target_pos, list(result))))
  }
)

inverse_table$add(
  "fabletools",
  "inv_box_cox",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(box_cox(!!!replace(args, target_pos, list(result))))
  }
)

inverse_table$add(
  "base",
  "sqrt",
  function(operation, target, result) {
    expr((!!result)^2)
  }
)

inverse_table$add(
  "base",
  "^",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    if (target_pos == 1) {
      if (args[[2]] == 0) {
        abort(sprintf("Cannot invert %s.", expr_text(operation)))
      }
      expr((!!result)^(1 / !!args[[2]]))
    } else {
      expr(log(!!result) / log(!!args[[1]]))
    }
  }
)

inverse_table$add(
  "base",
  "+",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    if (length(args) == 1) {
      result
    } else {
      expr(!!result - !!args[[-target_pos]])
    }
  }
)

inverse_table$add(
  "base",
  "-",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    if (length(args) == 1) {
      expr(-!!result)
    } else {
      if (target_pos == 1) {
        expr(!!result + !!args[[2]])
      } else {
        expr(!!args[[1]] - !!result)
      }
    }
  }
)

inverse_table$add(
  "base",
  "/",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    if (target_pos == 1) {
      expr(!!args[[2]] * !!result)
    } else {
      expr(!!args[[1]] / !!result)
    }
  }
)

inverse_table$add(
  "base",
  "*",
  function(operation, target, result) {
    args <- call_args(operation)
    target_pos <- match(list(target), args)
    expr(!!result / !!args[[-target_pos]])
  }
)

inverse_table$add(
  "base",
  "(",
  function(operation, target, result) {
    call2("(", !!!exprs(!!result))
  }
)