R/Utility.R
In gary-au/pt: Computational models for prospect theory and other theories of risky decision making
########################
#
# Utility, a S4 class
#
########################
#' The Utility class.
#'
#' The Utility class stores both the functional form and parameter specifications for a utility function.
#'
#' @section Slots:
#' \describe{
#' \item{\code{fun}:}{Object of class \code{"text"}, containing a text string that specifies the functional form of the utility function.}
#' \item{\code{par}:}{Object of class \code{"vector"}, containing the parameter specifications for the utility function.}
#' }
#'
#' @note A wrapper function (also called Utility) can be used to create an instance of this class.
#' @seealso {\code{\link{Utility}}}
#' @name Utility-class
#' @aliases Utility-class
#' @rdname Utility-class
#' @exportClass Utility
setClass(Class = "Utility",
representation = representation
(
fun = "character",
par = "vector"
),
# check for input consistency when creating new Utility objects using "new" constructor
validity = function(object)
{
if (get_utility_function(object) == "linear")
{
if (get_number_of_utility_parameters(object) != 1)
{
stop(paste(get_utility_function(object), " utility function requires 1 parameter.\n", sep = ""))
}
}
else if (get_utility_function(object) == "power")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "exponential")
{
if (get_number_of_utility_parameters(object) != 2)
{
stop(paste(get_utility_function(object), " utility function requires 2 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "normalized_exponential")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "normalized_logarithmic")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "normalized_power")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "quadratic")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "logarithmic")
{
if (get_number_of_utility_parameters(object) != 2)
{
stop(paste(get_utility_function(object), " utility function requires 2 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "expo_power")
{
if (get_number_of_utility_parameters(object) != 4)
{
stop(paste(get_utility_function(object), " utility function requires 4 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "general_linear")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "general_power")
{
if (get_number_of_utility_parameters(object) != 5)
{
stop(paste(get_utility_function(object), " utility function requires 5 parameters.\n", sep = ""))
}
}
return (TRUE)
}
)
#' This function creates an instance of a Utility class object.
#' Two arguments need to be provided to create this object. The
#' first argument is a text string that defines the functional
#' form of a utility function stored by the Utility class object.
#' The second argument is a vector of parameters needed for the
#' selected utility function.
#'
#' @name Utility
#' @title Create an instance of a Utility class.
#' @rdname Utility
#' @aliases Utility
#' @description This function creates an instance of a Utility class.
#' @details The following functional forms are currently implemented:
#'
#' linear (requires 1 parameter)
#'
#' power (requires 3 parameters)
#'
#' exponential (requires 2 parameters)
#'
#' normalized_exponential_uf (requires 3 parameters)
#'
#' normalized_logarithmic_uf (requires 3 parameters)
#'
#' normalized_power_uf (requires 3 parameters)
#'
#' quadratic_uf (requires 3 parameters)
#'
#' logarithmic_uf (requires 3 parameters)
#'
#' expo_power_uf (requires 4 parameters)
#'
#' general_linear_uf (requires 3 parameters)
#'
#' general_power_uf (requires 5 parameters)
#'
#' @usage Utility(fun, par)
#' @param fun text, a string selecting the utility function
#' @param par vector, parameters for the utility function
#' @examples
#'
#' # This example creates the power utility function with parameters
#' # used in the Tversky & Kahneman (1992) paper.
#'
#' tk_1992_utility <- Utility(fun="power",
#' par=c(alpha=0.88, beta=0.88, lambda=2.25))
#'
#' # This example creates a linear utility function.
#'
#' my_linear_utility <- Utility(fun="linear",
#' par=c(lambda=1))
#'
#' @references
#' Tversky, A., & Kahneman, D. (1992). Advances in prospect theory: Cumulative representation of uncertainty. Journal of Risk and Uncertainty, 5(4), 297-323.
#'
#' Wakker, P. P. (2010). Prospect theory: For risk and ambiguity. Cambridge, UK: Cambridge University Press.
#'
#' Stott, H. P. (2006). Cumulative prospect theory's functional menagerie. Journal of Risk and Uncertainty, 32(2), 101-130.
#'
#' Birnbaum, M. H. (2008). New paradoxes of risky decision making. Psychological Review, 115(2), 463-501.
#'
#' @export
Utility <- function(fun, par)
{
new(Class = "Utility",
fun = fun,
par = par
)
}
# declare a custom function to retrieve the number of parameters associated with the utility object
setGeneric(name = "get_number_of_utility_parameters",
def = function(object)
{
standardGeneric("get_number_of_utility_parameters")
}
)
# provide implementation of custom function
setMethod(f = "get_number_of_utility_parameters",
signature = "Utility",
definition = function(object)
{
return (length(object@par))
}
)
# declare a custom function to retrieve the utility function character text string
setGeneric(name = "get_utility_function",
def = function(object)
{
standardGeneric("get_utility_function")
}
)
# provide implementation of custom function
setMethod(f = "get_utility_function",
signature = "Utility",
definition = function(object)
{
return (object@fun)
}
)
# declare a custom function to compute the utility, given a utility character string and associated parameters
setGeneric(name = "compute_utility",
def = function(object, ...)
{
standardGeneric("compute_utility")
}
)
# provide implementation of custom function
setMethod(f = "compute_utility",
signature = "Utility",
definition = function(object, objective_consequence)
{
if (get_utility_function(object) == "linear")
{
lambda <- object@par[1]
if (objective_consequence > 0)
{
utility <- objective_consequence
}
else if (objective_consequence == 0)
{
utility <- 0
}
else if (objective_consequence < 0)
{
utility <- -lambda * -objective_consequence
}
}
else if (get_utility_function(object) == "power")
{
# implements Wakker (2010), p.78, Eqn 3.5.1
# and Birnbaum (2008), p.466
# u(-x) = -lambda * u(x), x >= 0
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence > 0)
{
if (alpha > 0)
{
utility <- objective_consequence^alpha
}
else if (alpha == 0)
{
utility <- log(objective_consequence)
}
else if (alpha < 0)
{
utility <- 1 - (1 + objective_consequence)^alpha
}
}
else if (objective_consequence == 0)
{
utility <- 0
}
else if (objective_consequence < 0)
{
if (beta > 0)
{
utility <- -lambda * (-objective_consequence)^beta
}
else if (beta == 0)
{
utility <- -lambda * log(-objective_consequence)
}
else if (beta < 0)
{
utility <- -lambda * (1.0 - (1.0 - objective_consequence)^beta)
}
}
}
else if (get_utility_function(object) == "exponential")
{
# implements Wakker (2010), p.80, Eqn 3.5.4
alpha <- object@par[1]
lambda <- object@par[2]
if (objective_consequence >= 0)
{
if (alpha > 0)
{
utility <- (1 - exp(-alpha * objective_consequence))
}
else if (alpha == 0)
{
utility <- objective_consequence
}
else if (alpha < 0)
{
utility <- (exp(-alpha * objective_consequence) - 1)
}
}
else if (objective_consequence < 0)
{
if (alpha > 0)
{
utility <- lambda * (1 - exp(-alpha * objective_consequence))
}
else if (alpha == 0)
{
utility <- lambda * objective_consequence
}
else if (alpha < 0)
{
utility <- lambda * (exp(-alpha * objective_consequence) - 1)
}
}
}
else if (get_utility_function(object) == "normalized_exponential")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- (1/alpha) * ( 1- exp(-alpha * objective_consequence))
}
else if (objective_consequence < 0)
{
utility <- (-lambda/beta) * (1 - exp(-beta * (-objective_consequence)))
}
}
else if (get_utility_function(object) == "normalized_logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- (1/alpha) * log( 1 + alpha * objective_consequence)
}
else if (objective_consequence < 0)
{
utility <- (-lambda/beta) * log(1 + beta * (-objective_consequence))
}
}
else if (get_utility_function(object) == "normalized_power")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- (1/alpha) * log( 1 + alpha * objective_consequence)
}
else if (objective_consequence < 0)
{
utility <- (-lambda/beta) * log(1 + beta * (-objective_consequence))
}
}
else if (get_utility_function(object) == "quadratic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- alpha * objective_consequence - objective_consequence^2
}
else if (objective_consequence < 0)
{
utility <- -lambda * (beta * (-objective_consequence) - (-objective_consequence)^2)
}
}
else if (get_utility_function(object) == "logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- log(alpha + objective_consequence)
}
else if (objective_consequence < 0)
{
utility <- -lambda * (log(beta + (-objective_consequence)))
}
}
else if (get_utility_function(object) == "expo_power")
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[3]
lambda <- object@par[4]
if (objective_consequence >= 0)
{
utility <- gamma - exp(-beta * objective_consequence^alpha)
}
else if (objective_consequence < 0)
{
utility <- -lambda * gamma - exp(-beta * (-objective_consequence)^alpha)
}
}
else if (get_utility_function(object) == "general_linear")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- alpha * objective_consequence
}
else if (objective_consequence < 0)
{
utility <- -lambda * beta * (-objective_consequence)
}
}
else if (get_utility_function(object) == "general_power")
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[3]
delta <- object@par[4]
lambda <- object@par[5]
if (objective_consequence >= 0)
{
utility <- (beta * objective_consequence^alpha)
}
else if (objective_consequence < 0)
{
utility <- -lambda * (delta * -objective_consequence)^gamma
}
}
return (utility)
}
)
# declare a custom function
setGeneric(name = "compute_certainty_equivalent",
def = function(object, ...)
{
standardGeneric("compute_certainty_equivalent")
}
)
# provide implementation of custom function
setMethod(f = "compute_certainty_equivalent",
signature = "Utility",
definition = function(object, utility)
{
certainty_equivalent <- 0.0
if (get_utility_function(object) == "linear")
{
lambda <- object@par[1]
if (utility > 0)
{
certainty_equivalent <- utility
}
else if (utility == 0)
{
certainty_equivalent <- 0
}
else if (utility < 0)
{
certainty_equivalent <- (-utility / -lambda)
}
}
else if (get_utility_function(object) == "power")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility > 0)
{
if (alpha > 0)
{
certainty_equivalent <- utility^(1 / alpha)
}
else if (alpha == 0)
{
certainty_equivalent <- exp(utility)
}
else if (alpha < 0)
{
certainty_equivalent <- (1 - utility)^(1 / alpha) - 1.0
}
}
else if (utility == 0)
{
certainty_equivalent <- 0
}
else if (utility < 0)
{
if (beta > 0)
{
certainty_equivalent <- -1.0 * (-utility / lambda)^(1 / beta)
}
else if (beta == 0)
{
certainty_equivalent <- -1.0 * exp(-utility / lambda)
}
else if (beta < 0)
{
certainty_equivalent <- (1 - (utility/lambda + 1)^(1 / beta))
}
}
}
else if (get_utility_function(object) == "exponential")
{
alpha <- object@par[1]
lambda <- object@par[2]
if (utility >= 0)
{
if (alpha > 0)
{
certainty_equivalent <- (-1 / alpha) * log(1 - utility)
}
else if (alpha == 0)
{
certainty_equivalent <- utility
}
else if (alpha < 0)
{
certainty_equivalent <- (-1 / alpha) * log(utility + 1)
}
}
else
{
if (alpha > 0)
{
certainty_equivalent <- (-1 / alpha) * log(1 + utility/lambda)
}
else if (alpha == 0)
{
certainty_equivalent <- -utility/lambda
}
else if (alpha < 0)
{
certainty_equivalent <- (-1 / alpha) * log(-utility/lambda + 1)
}
}
}
else if (get_utility_function(object) == "normalized_exponential")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- (-1/alpha) * log(1 - alpha * utility)
}
else if (utility < 0)
{
certainty_equivalent <- (1/beta) * log(1 + (beta/lambda) * utility)
}
}
else if (get_utility_function(object) == "normalized_logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- (1/alpha) * exp(alpha * utility - 1)
}
else if (utility < 0)
{
certainty_equivalent <- (-1/beta) * (1 - exp((-beta/lambda) * utility))
}
}
else if (get_utility_function(object) == "normalized_power")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- ((1 + alpha) * utility)^(1 + alpha)
}
else if (utility < 0)
{
certainty_equivalent <- -(-(1 + beta) * utility / lambda)^(1 + beta)
}
}
else if (get_utility_function(object) == "quadratic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
# take positive root of quadratic equation
if (utility >= 0)
{
certainty_equivalent <- (alpha + sqrt((-alpha)^2 - 4*utility))/2
}
else if (utility < 0)
{
certainty_equivalent <- (lambda * beta + sqrt((-lambda*beta)^2 - 4*utility))/2
}
}
else if (get_utility_function(object) == "logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- exp(utility) - alpha
}
else if (utility < 0)
{
certainty_equivalent <- beta - exp(-utility/lambda)
}
}
else if (get_utility_function(object) == "expo_power")
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[2]
lambda <- object@par[4]
if (utility >= 0)
{
certainty_equivalent <- ((-1/beta) * log(gamma - utility))^(1/alpha)
}
else if (utility < 0)
{
certainty_equivalent <- -((-1/beta)*log(gamma + utility/lambda))^(1/alpha)
}
}
else if (get_utility_function(object) == "general_linear")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- utility / alpha
}
else if (utility < 0)
{
certainty_equivalent <- utility/(lambda * beta)
}
}
else if (get_utility_function(object) == "general_power")
{
if (utility >= 0)
{
alpha <- object@par[1]
beta <- object@par[2]
certainty_equivalent <- (utility / beta)^(1.0 / alpha)
}
else if (utility < 0)
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[3]
delta <- object@par[4]
lambda <- object@par[5]
certainty_equivalent <- -(-utility / (delta * lambda))^(1.0 / gamma)
}
}
return (certainty_equivalent)
}
)
gary-au/pt documentation built on May 16, 2019, 5:41 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
########################
#
# Utility, a S4 class
#
########################
#' The Utility class.
#'
#' The Utility class stores both the functional form and parameter specifications for a utility function.
#'
#' @section Slots:
#' \describe{
#' \item{\code{fun}:}{Object of class \code{"text"}, containing a text string that specifies the functional form of the utility function.}
#' \item{\code{par}:}{Object of class \code{"vector"}, containing the parameter specifications for the utility function.}
#' }
#'
#' @note A wrapper function (also called Utility) can be used to create an instance of this class.
#' @seealso {\code{\link{Utility}}}
#' @name Utility-class
#' @aliases Utility-class
#' @rdname Utility-class
#' @exportClass Utility
setClass(Class = "Utility",
representation = representation
(
fun = "character",
par = "vector"
),
# check for input consistency when creating new Utility objects using "new" constructor
validity = function(object)
{
if (get_utility_function(object) == "linear")
{
if (get_number_of_utility_parameters(object) != 1)
{
stop(paste(get_utility_function(object), " utility function requires 1 parameter.\n", sep = ""))
}
}
else if (get_utility_function(object) == "power")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "exponential")
{
if (get_number_of_utility_parameters(object) != 2)
{
stop(paste(get_utility_function(object), " utility function requires 2 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "normalized_exponential")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "normalized_logarithmic")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "normalized_power")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "quadratic")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "logarithmic")
{
if (get_number_of_utility_parameters(object) != 2)
{
stop(paste(get_utility_function(object), " utility function requires 2 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "expo_power")
{
if (get_number_of_utility_parameters(object) != 4)
{
stop(paste(get_utility_function(object), " utility function requires 4 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "general_linear")
{
if (get_number_of_utility_parameters(object) != 3)
{
stop(paste(get_utility_function(object), " utility function requires 3 parameters.\n", sep = ""))
}
}
else if (get_utility_function(object) == "general_power")
{
if (get_number_of_utility_parameters(object) != 5)
{
stop(paste(get_utility_function(object), " utility function requires 5 parameters.\n", sep = ""))
}
}
return (TRUE)
}
)
#' This function creates an instance of a Utility class object.
#' Two arguments need to be provided to create this object. The
#' first argument is a text string that defines the functional
#' form of a utility function stored by the Utility class object.
#' The second argument is a vector of parameters needed for the
#' selected utility function.
#'
#' @name Utility
#' @title Create an instance of a Utility class.
#' @rdname Utility
#' @aliases Utility
#' @description This function creates an instance of a Utility class.
#' @details The following functional forms are currently implemented:
#'
#' linear (requires 1 parameter)
#'
#' power (requires 3 parameters)
#'
#' exponential (requires 2 parameters)
#'
#' normalized_exponential_uf (requires 3 parameters)
#'
#' normalized_logarithmic_uf (requires 3 parameters)
#'
#' normalized_power_uf (requires 3 parameters)
#'
#' quadratic_uf (requires 3 parameters)
#'
#' logarithmic_uf (requires 3 parameters)
#'
#' expo_power_uf (requires 4 parameters)
#'
#' general_linear_uf (requires 3 parameters)
#'
#' general_power_uf (requires 5 parameters)
#'
#' @usage Utility(fun, par)
#' @param fun text, a string selecting the utility function
#' @param par vector, parameters for the utility function
#' @examples
#'
#' # This example creates the power utility function with parameters
#' # used in the Tversky & Kahneman (1992) paper.
#'
#' tk_1992_utility <- Utility(fun="power",
#' par=c(alpha=0.88, beta=0.88, lambda=2.25))
#'
#' # This example creates a linear utility function.
#'
#' my_linear_utility <- Utility(fun="linear",
#' par=c(lambda=1))
#'
#' @references
#' Tversky, A., & Kahneman, D. (1992). Advances in prospect theory: Cumulative representation of uncertainty. Journal of Risk and Uncertainty, 5(4), 297-323.
#'
#' Wakker, P. P. (2010). Prospect theory: For risk and ambiguity. Cambridge, UK: Cambridge University Press.
#'
#' Stott, H. P. (2006). Cumulative prospect theory's functional menagerie. Journal of Risk and Uncertainty, 32(2), 101-130.
#'
#' Birnbaum, M. H. (2008). New paradoxes of risky decision making. Psychological Review, 115(2), 463-501.
#'
#' @export
Utility <- function(fun, par)
{
new(Class = "Utility",
fun = fun,
par = par
)
}
# declare a custom function to retrieve the number of parameters associated with the utility object
setGeneric(name = "get_number_of_utility_parameters",
def = function(object)
{
standardGeneric("get_number_of_utility_parameters")
}
)
# provide implementation of custom function
setMethod(f = "get_number_of_utility_parameters",
signature = "Utility",
definition = function(object)
{
return (length(object@par))
}
)
# declare a custom function to retrieve the utility function character text string
setGeneric(name = "get_utility_function",
def = function(object)
{
standardGeneric("get_utility_function")
}
)
# provide implementation of custom function
setMethod(f = "get_utility_function",
signature = "Utility",
definition = function(object)
{
return (object@fun)
}
)
# declare a custom function to compute the utility, given a utility character string and associated parameters
setGeneric(name = "compute_utility",
def = function(object, ...)
{
standardGeneric("compute_utility")
}
)
# provide implementation of custom function
setMethod(f = "compute_utility",
signature = "Utility",
definition = function(object, objective_consequence)
{
if (get_utility_function(object) == "linear")
{
lambda <- object@par[1]
if (objective_consequence > 0)
{
utility <- objective_consequence
}
else if (objective_consequence == 0)
{
utility <- 0
}
else if (objective_consequence < 0)
{
utility <- -lambda * -objective_consequence
}
}
else if (get_utility_function(object) == "power")
{
# implements Wakker (2010), p.78, Eqn 3.5.1
# and Birnbaum (2008), p.466
# u(-x) = -lambda * u(x), x >= 0
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence > 0)
{
if (alpha > 0)
{
utility <- objective_consequence^alpha
}
else if (alpha == 0)
{
utility <- log(objective_consequence)
}
else if (alpha < 0)
{
utility <- 1 - (1 + objective_consequence)^alpha
}
}
else if (objective_consequence == 0)
{
utility <- 0
}
else if (objective_consequence < 0)
{
if (beta > 0)
{
utility <- -lambda * (-objective_consequence)^beta
}
else if (beta == 0)
{
utility <- -lambda * log(-objective_consequence)
}
else if (beta < 0)
{
utility <- -lambda * (1.0 - (1.0 - objective_consequence)^beta)
}
}
}
else if (get_utility_function(object) == "exponential")
{
# implements Wakker (2010), p.80, Eqn 3.5.4
alpha <- object@par[1]
lambda <- object@par[2]
if (objective_consequence >= 0)
{
if (alpha > 0)
{
utility <- (1 - exp(-alpha * objective_consequence))
}
else if (alpha == 0)
{
utility <- objective_consequence
}
else if (alpha < 0)
{
utility <- (exp(-alpha * objective_consequence) - 1)
}
}
else if (objective_consequence < 0)
{
if (alpha > 0)
{
utility <- lambda * (1 - exp(-alpha * objective_consequence))
}
else if (alpha == 0)
{
utility <- lambda * objective_consequence
}
else if (alpha < 0)
{
utility <- lambda * (exp(-alpha * objective_consequence) - 1)
}
}
}
else if (get_utility_function(object) == "normalized_exponential")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- (1/alpha) * ( 1- exp(-alpha * objective_consequence))
}
else if (objective_consequence < 0)
{
utility <- (-lambda/beta) * (1 - exp(-beta * (-objective_consequence)))
}
}
else if (get_utility_function(object) == "normalized_logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- (1/alpha) * log( 1 + alpha * objective_consequence)
}
else if (objective_consequence < 0)
{
utility <- (-lambda/beta) * log(1 + beta * (-objective_consequence))
}
}
else if (get_utility_function(object) == "normalized_power")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- (1/alpha) * log( 1 + alpha * objective_consequence)
}
else if (objective_consequence < 0)
{
utility <- (-lambda/beta) * log(1 + beta * (-objective_consequence))
}
}
else if (get_utility_function(object) == "quadratic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- alpha * objective_consequence - objective_consequence^2
}
else if (objective_consequence < 0)
{
utility <- -lambda * (beta * (-objective_consequence) - (-objective_consequence)^2)
}
}
else if (get_utility_function(object) == "logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- log(alpha + objective_consequence)
}
else if (objective_consequence < 0)
{
utility <- -lambda * (log(beta + (-objective_consequence)))
}
}
else if (get_utility_function(object) == "expo_power")
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[3]
lambda <- object@par[4]
if (objective_consequence >= 0)
{
utility <- gamma - exp(-beta * objective_consequence^alpha)
}
else if (objective_consequence < 0)
{
utility <- -lambda * gamma - exp(-beta * (-objective_consequence)^alpha)
}
}
else if (get_utility_function(object) == "general_linear")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (objective_consequence >= 0)
{
utility <- alpha * objective_consequence
}
else if (objective_consequence < 0)
{
utility <- -lambda * beta * (-objective_consequence)
}
}
else if (get_utility_function(object) == "general_power")
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[3]
delta <- object@par[4]
lambda <- object@par[5]
if (objective_consequence >= 0)
{
utility <- (beta * objective_consequence^alpha)
}
else if (objective_consequence < 0)
{
utility <- -lambda * (delta * -objective_consequence)^gamma
}
}
return (utility)
}
)
# declare a custom function
setGeneric(name = "compute_certainty_equivalent",
def = function(object, ...)
{
standardGeneric("compute_certainty_equivalent")
}
)
# provide implementation of custom function
setMethod(f = "compute_certainty_equivalent",
signature = "Utility",
definition = function(object, utility)
{
certainty_equivalent <- 0.0
if (get_utility_function(object) == "linear")
{
lambda <- object@par[1]
if (utility > 0)
{
certainty_equivalent <- utility
}
else if (utility == 0)
{
certainty_equivalent <- 0
}
else if (utility < 0)
{
certainty_equivalent <- (-utility / -lambda)
}
}
else if (get_utility_function(object) == "power")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility > 0)
{
if (alpha > 0)
{
certainty_equivalent <- utility^(1 / alpha)
}
else if (alpha == 0)
{
certainty_equivalent <- exp(utility)
}
else if (alpha < 0)
{
certainty_equivalent <- (1 - utility)^(1 / alpha) - 1.0
}
}
else if (utility == 0)
{
certainty_equivalent <- 0
}
else if (utility < 0)
{
if (beta > 0)
{
certainty_equivalent <- -1.0 * (-utility / lambda)^(1 / beta)
}
else if (beta == 0)
{
certainty_equivalent <- -1.0 * exp(-utility / lambda)
}
else if (beta < 0)
{
certainty_equivalent <- (1 - (utility/lambda + 1)^(1 / beta))
}
}
}
else if (get_utility_function(object) == "exponential")
{
alpha <- object@par[1]
lambda <- object@par[2]
if (utility >= 0)
{
if (alpha > 0)
{
certainty_equivalent <- (-1 / alpha) * log(1 - utility)
}
else if (alpha == 0)
{
certainty_equivalent <- utility
}
else if (alpha < 0)
{
certainty_equivalent <- (-1 / alpha) * log(utility + 1)
}
}
else
{
if (alpha > 0)
{
certainty_equivalent <- (-1 / alpha) * log(1 + utility/lambda)
}
else if (alpha == 0)
{
certainty_equivalent <- -utility/lambda
}
else if (alpha < 0)
{
certainty_equivalent <- (-1 / alpha) * log(-utility/lambda + 1)
}
}
}
else if (get_utility_function(object) == "normalized_exponential")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- (-1/alpha) * log(1 - alpha * utility)
}
else if (utility < 0)
{
certainty_equivalent <- (1/beta) * log(1 + (beta/lambda) * utility)
}
}
else if (get_utility_function(object) == "normalized_logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- (1/alpha) * exp(alpha * utility - 1)
}
else if (utility < 0)
{
certainty_equivalent <- (-1/beta) * (1 - exp((-beta/lambda) * utility))
}
}
else if (get_utility_function(object) == "normalized_power")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- ((1 + alpha) * utility)^(1 + alpha)
}
else if (utility < 0)
{
certainty_equivalent <- -(-(1 + beta) * utility / lambda)^(1 + beta)
}
}
else if (get_utility_function(object) == "quadratic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
# take positive root of quadratic equation
if (utility >= 0)
{
certainty_equivalent <- (alpha + sqrt((-alpha)^2 - 4*utility))/2
}
else if (utility < 0)
{
certainty_equivalent <- (lambda * beta + sqrt((-lambda*beta)^2 - 4*utility))/2
}
}
else if (get_utility_function(object) == "logarithmic")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- exp(utility) - alpha
}
else if (utility < 0)
{
certainty_equivalent <- beta - exp(-utility/lambda)
}
}
else if (get_utility_function(object) == "expo_power")
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[2]
lambda <- object@par[4]
if (utility >= 0)
{
certainty_equivalent <- ((-1/beta) * log(gamma - utility))^(1/alpha)
}
else if (utility < 0)
{
certainty_equivalent <- -((-1/beta)*log(gamma + utility/lambda))^(1/alpha)
}
}
else if (get_utility_function(object) == "general_linear")
{
alpha <- object@par[1]
beta <- object@par[2]
lambda <- object@par[3]
if (utility >= 0)
{
certainty_equivalent <- utility / alpha
}
else if (utility < 0)
{
certainty_equivalent <- utility/(lambda * beta)
}
}
else if (get_utility_function(object) == "general_power")
{
if (utility >= 0)
{
alpha <- object@par[1]
beta <- object@par[2]
certainty_equivalent <- (utility / beta)^(1.0 / alpha)
}
else if (utility < 0)
{
alpha <- object@par[1]
beta <- object@par[2]
gamma <- object@par[3]
delta <- object@par[4]
lambda <- object@par[5]
certainty_equivalent <- -(-utility / (delta * lambda))^(1.0 / gamma)
}
}
return (certainty_equivalent)
}
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.