R/methods.R

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

# print methods


#' print method for wizirt models
#' @param x An object exported from fit_wizirt()
#' @param type A character string that is one of 'tech', 'desc'. More coming soon!
#'
# @method print wizirt_fit
#' @export
print.irt <- function(x, type = 'tech'){
  UseMethod("print")
  if(type == 'tech'){

    parms = c('package',
              'function',
              'version',
              'call',
              'factors',
              'item type',
              'converged',
              'method',
              'log-likelihood',
              'criteria',
              'iterations')

    vals = c(x$fit$model$engine$pkg,
             x$fit$model$engine$func,
             paste(x$fit$model$engine$ver),
             paste(trimws(capture.output(x$fit$model$engine$call)), collapse = ""),
             x$fit$model$n_factors,
             x$fit$model$item_type,
             x$fit$estimation$convergence,
             x$fit$estimation$method,
             x$fit$estimation$log_lik,
             x$fit$estimation$criteria,
             x$fit$estimation$iterations)

    tibble::tibble(parameter = parms,
                   value = vals)

  } else  if(type == 'desc'){
    parms <- c('N Items',
                   'Avg Difficulty',
                   'Avg Diff (CTT)',
                   'N Persons',
                   'Avg Ability',
                   'Avg % Correct',
                   'Avg % Completion')
    vals <- c(
      ncol(x$fit$data),
      round(mean(x$fit$parameters$coefficients$difficulty,
           na.rm =T), 2),
      round(mean(colMeans(x$fit$data, na.rm = T)),2),
      nrow(x$fit$data),
      round(mean(x$fit$parameters$persons$ability,
           na.rm = T),2),
      round(mean(rowMeans(replace(x$fit$data, is.na(x$fit$data), 0))),2)*100,
      round(mean(rowMeans(!is.na(x$fit$data), na.rm = T)), 2)*100
    )

    tibble::tibble(parameter = parms,
                   value = vals)

  } else {
    rlang::abort(glue::glue('Print method "{type}" is not available.'))
  }

}
registerS3method("print", "wizirt_irt", print.irt)

#registerS3method("print", "wizirt_fit", print.irt)

#' print method for wizirt person-fit objects
#' @param x An object exported from irt_person_fit()
#' @param patterns Logical. Should the response patterns be printed as well?
#' @export
print.pfa <- function(x, patterns = FALSE){
  item_col = max(which(grepl("_cut", colnames(x$person_estimates)))) + 1
  if(patterns == TRUE){
    return(tidyr::unite(x$person_estimates, pattern, item_col:ncol(x$person_estimates)) )
  } else {
    return(x$person_estimates[1:(item_col-1)])
  }

}
registerS3method("print", "wizirt_pfa", print.pfa)

#' print method for wizirt item-fit objects
#' @param x An object exported from irt_item_fit()
#'
#' @export
print.ifa <- function(x){
  x$item_stats
}
registerS3method("print", "wizirt_ifa", print.ifa)


#'
#' @export
predict.irt <- function(wizirt_fit, rownames = NULL){
  if (is.null(rownames)) {
    rownames <- 1:nrow(wizirt_fit$fit$data)
  }

  data <- data.frame(cbind(ids = rownames, wizirt_fit$fit$parameters$persons, wizirt_fit$fit$data)) %>%
    tidyr::pivot_longer(cols = -1:-3, names_to = 'item') %>%
    dplyr::left_join(wizirt_fit$fit$parameters$coefficients, by = 'item')
  data <- data %>% tibble::as_tibble() %>%
    dplyr::mutate(prob = 0 + (1-0)/
                    (1 + exp(-1.7*discrimination*(ability-difficulty))) )

  return(data)

}
#registerS3method("plot", "wizirt_ifa", plot.ifa)


# summary methods are coming soon

# summary.irt()
#
# summary.pfa()
#
# summary.ifa()