R/logLikelihood.R

In LuchTiarna/PsyMetFuns: Package for extrapolating psychometric information

#'@name logLikelihood
#'@rdname logLikelihood
#'@title logLikelihood
#'
#'@description Provides the frame for psycometrics function models. Combines the sigmoid and core function.
#'@param object a fitted model object for whicht there exists a logLik method to extract the corresponding log-likelihood
#'@return vector of return values
NULL

#'@rdname logLikelihood
#'@export
logLikelihood <- function(object, ...){
  UseMethod("logLikelihood")
}

#'@rdname logLikelihood
#'@export
logLikelihood.PFm <- function(object, ...){
  formula <- object$formula
  data <- object$data
  dd <- data.frame(levels=data[[formula[[2]]]], yes=data[[formula[[3]][[2]]]],no=data[[formula[[3]][[3]]]]) # creating a suiting representation of data
  if(tolower(object$type)=="hitpercentage"){
    #conversing to yes/no arrangement
    dd$yes <-  dd$yes * dd$no
    dd$no <- dd$no - dd$yes
  }else if (tolower(type) != "yes/no"){
    warning("Unknown data organization. Use \"hitPercentage\" or \"yes/no\" notation.");return(NULL)
  }
  if(!all(dd$yes == round(dd$yes)) || !all(dd$no == round(dd$no))){
    if(tolower(type) == "hitpercentage"){warning("The product fo hitPercengate and obsNumbers should be an integer, because Yes and No responses counts should be integers.")}
    else{ warning("Yes and No responses counts should be integers.")}
  }

  x <- PFunction(object$sigmoid, object$core, data$levels, object$gamma, object$lambda, object$params)

  if(length(x) != length(data$yes) || length(data$yes) != length(data$no) )
  {warning("All vectors must have the same length."); return(NaN)}

  pe <- base::log(base::choose(data$yes+data$no,data$yes))
  pe <- pe + data$yes*base::log(x)
  pe <- pe + data$no*base::log(1-x)

  return(-sum(pe))
}