R/PFunction.R

In LuchTiarna/PsyMetFuns: Package for extrapolating psychometric information

#'PFunction
#'
#'Provides the frame for psycometrics functions. Combines the sigmoid and core function.
#'@param type specifies, whether function is CDF of PDF type
#'@param gama sets the loves boundary of function
#'@param lambda sets the highes boundary of function
#'@param sigmoid determines the sigmoid of the fuction
#'@param core dermines the core of the function
#'@param x the vector of level values
#'@param ... specifies the parametres or core function
#'@return vector of return values
#'@export
PFunction <- function(sigmoid, core, x, gamma, lambda, ... , type="cdf", inverse=FALSE){
  gamma <-  as.double(gamma)
  lambda <- as.double(lambda)
  params <- c(...)

  if(gamma < 0) {warning("Gamma must be a least 0."); return(rep(NaN, length(x)))}
  if(lambda < 0) {warning("Lambda must be a least 0."); return(rep(NaN, length(x)))}
  if((gamma + lambda) > 1) {warning("Summ of gamma and lambda must be lesser than 1."); return(rep(NaN, length(x)))}
  if(inverse && tolower(type)!="cdf"){stop("Inverse is avaible only for cdf type function.")}

  if(is.character(sigmoid)){
    sigmoidName <- sigmoid
  }else{
    sigmoidName <- as.character(substitute(sigmoid))
  }

  if(is.character(core)){
    coreName <- core
  }else{
    coreName <- as.character(substitute(core))
  }

  if(!inverse){
    sigmoidName <- paste(sigmoidName, "orig",sep=".")
    coreName <- paste(coreName, "orig",sep=".")
  }else{
    sigmoidName <- paste(sigmoidName, "inverse_x",sep=".")
    coreName <- paste(coreName, "inverse_x",sep=".")
  }

  type = tolower(type)
  if(substr(type,1,3)=="cdf"){
    coref <- function(){eval(body(paste(coreName , type, sep=".")))}
    formals(coref) <- formals(coreName)

    sigmoidf <- function(){eval(body(paste(sigmoidName, type, sep=".")))}
    formals(sigmoidf) <- formals(sigmoidName)

    if(!inverse){
      y <- gamma + (1 - gamma - lambda) * sigmoidf(coref(x, params))
    }else{
      y <- coref(sigmoidf((x-gamma)/(1-lambda-gamma)), params)
    }
  }else if(substr(type,1,3)=="pdf"){
    coref <- function(){eval(body(paste(coreName, "cdf", sep=".")))}
    formals(coref) <- formals(coreName)

    corePdf <- function(){eval(body(paste(coreName, type, sep=".")))}
    formals(corePdf) <- formals(coreName)

    sigmoidf <- function(){eval(body(paste(sigmoidName, "cdf", sep=".")))}
    formals(sigmoidf) <- formals(sigmoidName)

    sigmoidPdf <- function(){eval(body(paste(sigmoidName, "pdf", sep=".")))}
    formals(sigmoidPdf) <- formals(sigmoidName)

    if(substr(type,5,5)=="g"){
      y <- 1 - sigmoidf(coref(x, params))
    }else if(substr(type,5,5)=="l"){
      y  <-  - sigmoidf(coref(x, params))
    }else{
      y <- (1 - gamma - lambda) * sigmoidPdf(coref(x, params))*corePdf(x, params)
    }
  }else{
    warning("invalid function type, must be either cdf or pdf");return(rep(NaN, length(x)))
  }
  return(y)
}