R/fit_wizirt.R

In Pflegermeister/wizirt2: A United API for IRT in R

#' The main function of the advanced user interface (API) for wizirt. Must be used in conjunction with fit_wizirt to estimate the model.
#'
#' @param mode Must be 'regression' for item response theory. A future version will add 'classification' for latent class analysis.
#' @param item_type The type of IRT model to be run. A character vector of either 'Rasch' or '2PL'.
#' @param irt_pars Logical. Should the parameters be traditional IRT parameterization?
#' @return An object to be passed to 'fit_wizirt'.
#' @examples
#' my_model <- irt(item_type = 'Rasch') %>%
#' set_engine("ltm") %>%
#' fit_wizirt(data = responses)
#' @export
irt <- function(mode = "regression", item_type = NULL, irt_pars = TRUE, rownames = NULL, tol = 1e-5){
  args <- list(item_type = rlang::enquo(item_type),
               irt_pars = rlang::enquo(irt_pars),
               rownames = rlang::enquo(rownames),
               tol = rlang::enquo(tol))
  out <- list(args = args,
              eng_args = NULL,
              mode = mode,
              method = NULL,
              engine = NULL)
  class(out) <- parsnip::make_classes("irt")
  out
}

#' Estimates the result of the irt() function.
#'
#' @param object The object returned by a fit function.
#' @param data A dataframe with persons as rows and items as columns.
#' @return A list with the estimated information. Most information is found in the 'fit' slot.
#' @examples
#' my_model <- irt(item_type = 'Rasch') %>%
#' set_engine("ltm") %>%
#' fit_wizirt(data = responses)
#' @export
fit_wizirt <- #fit_wizirt.model_spec How do I get the fit_wizirt without the '.model_spec'?
  function(object,
           data,
           formula = NULL, # This is for the eventual addition of covariates and multilevel. # But formula will also be used to specify which items to retain.
           control = parsnip:::control_parsnip(), # formula %>%  will be theta ~ items + covariates and # will remove items not wanted.
           ...
  ) {
    #object <- check_mode(object, levels(y)) # I want to retain this to limit changes, however I am not sure where this fits in.
    dots <- rlang::quos(...)
    if (is.null(object$engine)) {
      eng_vals <- parsnip:::possible_engines(object)
      object$engine <- eng_vals[1]
      if (control$verbosity > 0) {
        rlang::warn(glue::glue("Engine set to `{object$engine}`."))
      }
    }

    cl <- match.call(expand.dots = TRUE)
    eval_env <- rlang::env()
    eval_env$responses <- data
    eval_env$formula <- formula
    fit_interface <- check_wizirt_interface(eval_env$responses, cl, eval_env$formula) #xxxx check 9/24/2020 dependencies

    # populate `method` with the details for this model type
    object <- parsnip:::add_methods(object, engine = object$engine)

    parsnip:::check_installs(object)

    interfaces <- paste(fit_interface, object$method$fit$interface, sep = "_")

    # Now call the wrappers that transition between the interface
    # called here ("fit" interface) that will direct traffic to
    # what the underlying model uses. For example, if a formula is
    # used here, `fit_interface_formula` will determine if a
    # translation has to be made if the model interface is x/y/

    res <- # Ok so this will have to set it to wizirt_form

      wizirt_form( # xxxx check 9/24/2020 for dependencies
        object = object,
        env = eval_env,
        control = control,
        ...
      )
    #rlang::abort(glue::glue("{interfaces} is unknown."))

    model_classes <- class(res$fit)
    class(res) <- c(paste0("_", model_classes[1]), "wizirt_fit", "_model_fit")
    res
  }

wizirt_form <-
  function(object, control, env, ...) {

    if (object$mode == "classification") {
      rlang::abort("Classification models not currently supported by wizirt.")
    }

    # evaluate quoted args once here to check them
    #object <- check_args(object) # had to drop for the time being

    # sub in arguments to actual syntax for corresponding engine
    object <- parsnip:::translate(object, engine = object$engine)

    fit_call <- make_wizirt_call(object, env = env)

    res <- list(
      #lvl = y_levels,
      spec = object
    )

    elapsed <- system.time(
      res$fit <- parsnip:::eval_mod(
        fit_call,
        capture = control$verbosity == 0,
        catch = control$catch,
        env = env,
        ...
      )
    )
    res$preproc <- list(y_var = all.vars(env$formula[[2]]))
    res$elapsed <- elapsed
    res
  }

make_wizirt_call <- function(object, env = NULL) {
  fit_args <- object$method$fit$args

  # Get the arguments related to data:
  if (is.null(object$method$fit$data)) {
    data_args <- c(formula = "model", data = "data") # Ok, so how is this used?
  } else {
    data_args <- object$method$fit$data
  }

  # add data arguments
  for (i in seq_along(data_args)) {
    fit_args[[ unname(data_args[i]) ]] <- rlang::sym(names(data_args)[i])
  }

  # sub in actual formula
  fit_args[[ unname(data_args["formula"]) ]]  <- env$formula


  fit_call <- parsnip:::make_call(
    fun = object$method$fit$func["fun"],
    ns = object$method$fit$func["pkg"],
    fit_args
  )
  fit_call
}

check_wizirt_interface <- function(data, cl, model) {
  parsnip:::inher(data, c("data.frame", "matrix"), cl)


  # Determine the `fit()` interface
  matrix_interface <- !is.null(data) && is.matrix(data)
  df_interface <- !is.null(data) && is.data.frame(data)

  if (matrix_interface)
    return("data.frame")
  if (df_interface)
    return("data.frame")
  rlang::abort("Error when checking the interface")
}