Nothing
################################################################################
# #
# utility and value function package #
# ================================== #
# #
# version 1.4 Peter Reichert 05.06.2016 #
# #
################################################################################
# ==============================================================================
# conversion node from values to utilities with parametric function:
# class "utility.conversion.parfun"
# ==============================================================================
# constructor:
# ------------
utility.conversion.parfun.create <- function(name.node, # character(1)
node, # node
name.fun, # name of f(a,par)
par, # numeric(n)
names.par = rep(NA,length(par)),
required = FALSE,
col = "black",
shift.levels = 0)
{
# consistency checks:
check.ok <- T
if ( length(par) != length(names.par) )
{
cat("*** Warning: par and names.par of different length:",
length(par),length(names.par),"\n")
check.ok <- F
}
if ( ! utility.check.name(name.node,list(node)) )
{
cat("*** Warning: node with same name \"",name.node,"\" exists already ",
"as sub-node","\n")
check.ok <- F
}
if ( ! check.ok )
{
cat("*** Warning: node \"",name.node,"\" could not be constructed","\n",
sep="")
return(NA)
}
# construct class:
n <- list()
n$name <- name.node
n$description <- "utility/value parametric function conversion node"
n$type <- "utility.conversion.parfun"
n$nodes <- list(node)
n$name.fun <- name.fun
n$par <- par
n$names.par <- names.par
n$required <- required
n$num.required <- 1
n$utility <- TRUE
n$col <- col
n$shift.levels <- shift.levels
class(n) <- "utility.conversion.parfun"
# print and return class
#cat(n$description," \"",name.node,"\" constructed","\n",sep="")
return(n)
}
# update parameter values:
# ------------------------
updatepar.utility.conversion.parfun <- function(x,par=NA,...)
{
node <- x
# check availabiliy of named parameter vector:
if ( length(names(par)) == 0 ) return(node)
# update adequate values in interpolation list:
n <- node
for ( i in 1:length(n$par) )
{
if ( ! is.na(n$names.par[i]) )
{
ind <- which(n$names.par[i] == names(par) )
if ( length(ind) > 1 )
{
warning("Node \"",node$name,"\": multiple occurrences of parameter",
names(par)[ind[1]],sep="")
ind <- ind[1]
}
if ( length(ind) == 1 )
{
n$par[i] <- par[ind]
}
}
}
n$nodes[[1]] <- updatepar(n$nodes[[1]],par)
# return updated node:
return(n)
}
# evaluate values or utilities:
# -----------------------------
evaluate_utility.conversion.parfun <- function(x,v)
{
node <- x
u <- do.call(node$name.fun,list(v,node$par))
return(u)
}
evaluate.utility.conversion.parfun <- function(x,
attrib, # data.frame, numeric
par = NA,
...)
{
node <- x
# update parameters:
n <- updatepar(node,par)
# evaluate results:
v <- evaluate(n$nodes[[1]],attrib)
if ( ! is.data.frame(v) )
{
v <- as.data.frame(v)
}
u <- evaluate_utility.conversion.parfun(n,v[,1])
u <- as.data.frame(u)
names(u) <- n$name
ind <- !is.na(u) & (u<0 | u>1)
if ( sum(ind) > 0 )
{
warning("Node \"",node$name,"\": node \"",n$name,"\" produced values outside of [0,1]: ",
paste(u[ind],collapse=","),sep="")
}
# return results:
u <- cbind(u,v)
rownames(u) <- rownames(attrib)
# return results:
return(u)
}
# print:
# -----
print.utility.conversion.parfun <- function(x,...)
{
cat(paste(rep("-",50),collapse=""),"\n")
summary(x,...)
cat(paste(rep("-",50),collapse=""),"\n")
}
# summary:
# --------
summary.utility.conversion.parfun <- function(object,...)
{
node <- object
cat(node$name,"\n")
cat(paste(rep("-",nchar(node$name)),collapse=""),"\n")
cat(node$description,"\n")
cat("node : ",node$nodes[[1]]$name,"\n")
cat("function type: ","utility","\n")
cat("required: ",node$required,"\n")
cat("function: ",node$name.fun,"\n")
cat("parameters:","\n")
names.par <- ifelse(is.na(node$names.par),"",node$names.par)
print(data.frame(names.par=names.par,par=node$par))
for ( i in 1:length(node$nodes) )
{
cat("***","\n")
summary(node$nodes[[i]])
}
}
# plot:
# -----
plot.utility.conversion.parfun <-
function(x,
u = NA,
uref = NA,
par = NA,
type = c("hierarchy","table","node","nodes"),
nodes = NA,
col = utility.calc.colors(),
gridlines = c(0.2,0.4,0.6,0.8),
main = "",
cex.main = 1,
cex.nodes = 1,
cex.attrib = 1,
f.reaches = 0.2,
f.nodes = 0.2,
with.attrib = TRUE,
levels = NA,
plot.val = TRUE,
print.val = TRUE,
two.lines = FALSE,
...)
{
node <- x
n <- updatepar(node,par)
utility.plot(node = n,
u = u,
uref = uref,
type = type,
nodes = nodes,
col = col,
gridlines = gridlines,
cex.main = cex.main,
cex.nodes = cex.nodes,
cex.attrib = cex.attrib,
f.reaches = f.reaches,
f.nodes = f.nodes,
with.attrib = with.attrib,
levels = levels,
plot.val = plot.val,
print.val = print.val,
two.lines = two.lines,
...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.