R/harrington1.R

Defines functions h1.solve.params harrington1 print.harrington1 dharrington1 ddesire.harrington1 pharrington1 pdesire.harrington1 qharrington1 qdesire.harrington1 rharrington1 eharrington1 edesire.harrington1 vharrington1 vdesire.harrington1

Documented in ddesire.harrington1 dharrington1 edesire.harrington1 eharrington1 h1.solve.params harrington1 pdesire.harrington1 pharrington1 qdesire.harrington1 qharrington1 rharrington1 vdesire.harrington1 vharrington1

##
## harrington1.R - One sided  Harrington type desiraility functions
##
## Authors:
##  Heike Trautmann  <trautmann@statistik.tu-dortmund.de>
##  Detlef Steuer    <detlef.steuer@hsu-hamburg.de>
##  Olaf Mersmann    <olafm@statistik.tu-dortmund.de>
##

h1.solve.params <- function(y1, d1, y2, d2) {
  ## Solve for constants b0, b1
  ## See Trautmann Diss. p. 13-14
  X <- cbind(1, c(y1, y2))
  b <- solve(X, -log(-log(c(d1, d2))))
  return(b)
}

harrington1 <- function(y1, d1, y2, d2) {
  ev <- function(y, ...) {
    ys <- b0 + b1*y
    return(exp(-exp(-ys)))
  }
  b <- h1.solve.params(y1, d1, y2, d2)
  b0 <- b[1];  b1 <- b[2]
  
  class(ev) <- c("harrington1", "desire.function")
  attr(ev, "desire.type") <- "One sided Harrington"
  attr(ev, "y.range") <- c(y1, y2)
  ## Remove cruft to save space
  rm(b)
  return(ev)
}

## print method
print.harrington1 <- function(x, ...) {
  e <- environment(x)
  message("    One sided Harrington type desirability")
  message("")  
  pi <- c(e$y1, e$d1, e$y2, e$d2)
  names(pi) <- c("y1", "d1", "y2", "d2")
  pc <- c(e$b0, e$b1)
  names(pc) <- c("b0", "b1")
  message("Input parameters:")
  print.default(format(pi, width=8), print.gap=2, quote=FALSE, ...)
  message("Computed parameters:")
  print.default(format(pc, width=8), print.gap=2, quote=FALSE, ...)  
}

## Density
dharrington1 <- function(x, y1, d1, y2, d2, mean, sd) {
  b <- h1.solve.params(y1, d1, y2, d2)
  mu.t <- -(b[1] + b[2] * mean)
  ## OME: sigma.t^2 = b[2]^2 * sd^2 => abs!
  sd.t <- abs(b[2]*sd)
  dloglognorm(x, mu.t, sd.t)
}

ddesire.harrington1 <- function(x, f, mean, sd) {
  e <- environment(f)
  mu.t <- -(e$b0 + e$b1*mean)
  ## OME: sigma.t^2 = e$b1^2 * sd^2 => abs!
  sd.t <- abs(e$b1*sd)
  dloglognorm(x, mu.t, sd.t)
}

## CDF
pharrington1 <- function(q, y1, d1, y2, d2, mean, sd) {
  b <- h1.solve.params(y1, d1, y2, d2)
  mu.t <- -(b[1] + b[2] * mean)
  sd.t <- b[2]*sd
  ploglognorm(q, mu.t, sd.t)
}

pdesire.harrington1 <- function(q, f, mean, sd) {
  e <- environment(f)
  mu.t <- -(e$b0 + e$b1*mean)
  sd.t <- e$b1*sd
  ploglognorm(q, mu.t, sd.t)
}

## Quantiles
qharrington1 <- function(p, y1, d1, y2, d2, mean, sd) {
  b <- h1.solve.params(y1, d1, y2, d2)
  mu.t <- -(b[1] + b[2] * mean)
  sd.t <- b[2]*sd
  qloglognorm(p, mu.t, sd.t)
}

qdesire.harrington1 <- function(p, f, mean, sd) {
  e <- environment(f)
  mu.t <- -(e$b0 + e$b1*mean)
  sd.t <- e$b1*sd
  qloglognorm(p, mu.t, sd.t)
}

## Random numbers
rharrington1 <- function(n, y1, d1, y2, d2, mean, sd)
  harrington1(y1, d1, y2, d2)(rnorm(n, mean, sd))

## Expectation
eharrington1 <- function(y1, d1, y2, d2, mean, sd) {
  b <- h1.solve.params(y1, d1, y2, d2)
  mu.t <- -(b[1] + b[2] * mean)
  sd.t <- b[2]*sd
  eloglognorm(mu.t, sd.t)
}

edesire.harrington1 <- function(f, mean, sd) {
  e <- environment(f)
  mu.t <- -(e$b0 + e$b1*mean)
  sd.t <- e$b1*sd
  eloglognorm(mu.t, sd.t)
}

## Variance
vharrington1 <- function(y1, d1, y2, d2, mean, sd) {
  b <- h1.solve.params(y1, d1, y2, d2)
  mu.t <- -(b[1] + b[2] * mean)
  sd.t <- b[2]*sd
  vloglognorm(mu.t, sd.t)
}

vdesire.harrington1 <- function(f, mean, sd) {
  e <- environment(f)
  mu.t <- -(e$b0 + e$b1*mean)
  sd.t <- e$b1*sd
  vloglognorm(mu.t, sd.t)
}

Try the desire package in your browser

Any scripts or data that you put into this service are public.

desire documentation built on May 2, 2019, 5:50 p.m.