-
Notifications
You must be signed in to change notification settings - Fork 17
/
medists.R
197 lines (185 loc) · 7.86 KB
/
medists.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
#' Measurement error distributions
#'
#' Truncated Normal and Uniform distributions, where the response is also
#' subject to a Normally distributed measurement error.
#'
#' The normal distribution with measurement error has density
#'
#' \deqn{
#' \frac{\Phi(u, \mu_2, \sigma_3) - \Phi(l, \mu_2, \sigma_3)}{\Phi(u, \mu_2, \sigma_3) -
#' \Phi(l, \mu_2, \sigma_3)} \phi(x, \mu_0 + \mu_\epsilon, \sigma_2)}{(Phi(upper, mu2, sigma3) - Phi(lower, mu2, sigma3)) / (Phi(upper,
#' mean, sd) - Phi(lower, mean, sd)) * phi(x, mean + meanerr, sigma2)}
#'
#' where
#'
#' \deqn{\sigma_2^2 = \sigma_0^2 + \sigma_\epsilon^2,}{sigma2*sigma2 = sd*sd +
#' sderr*sderr,}
#'
#' \deqn{\sigma_3 = \sigma_0 \sigma_\epsilon / \sigma_2,}{sigma3
#' = sd*sderr / sigma2,}
#'
#' \deqn{\mu_2 = (x - \mu_\epsilon) \sigma_0^2 + \mu_0 \sigma_\epsilon^2,
#' }{mu2 = (x - meanerr)*sd*sd + mean*sderr*sderr,}
#'
#' \eqn{\mu_0}{mean} is the mean of the original Normal distribution before
#' truncation, \cr \eqn{\sigma_0}{sd} is the corresponding standard deviation,
#' \cr \eqn{u} is the upper truncation point, \cr \eqn{l} is the lower
#' truncation point, \cr \eqn{\sigma_\epsilon}{sderr} is the standard deviation
#' of the additional measurement error, \cr \eqn{\mu_\epsilon}{meanerr} is the
#' mean of the measurement error (usually 0). \cr \eqn{\phi(x)}{phi(x)} is the
#' density of the corresponding normal distribution, and \cr
#' \eqn{\Phi(x)}{Phi(x)} is the distribution function of the corresponding
#' normal distribution.
#'
#' The uniform distribution with measurement error has density
#'
#' \deqn{(\Phi(x, \mu_\epsilon+l, \sigma_\epsilon) - \Phi(x, \mu_\epsilon+u,
#' \sigma_\epsilon)) }{(Phi(x, meanerr+l, sderr) - Phi(x, meanerr+u, sderr)) /
#' (upper - lower)}\deqn{ / (u - l)}{(Phi(x, meanerr+l, sderr) - Phi(x,
#' meanerr+u, sderr)) / (upper - lower)}
#'
#' These are calculated from the original truncated Normal or Uniform density
#' functions \eqn{f(. | \mu, \sigma, l, u)}{f(. | mu, sd)} as
#'
#' \deqn{ \int f(y | \mu, \sigma, l, u) \phi(x, y + \mu_\epsilon, \sigma_\epsilon) dy }{
#' \int f(y | mu, sd, l, u) \phi(x, y + meanerr, sderr) dy }
#'
#' If \code{sderr} and \code{meanerr} are not specified they assume the default
#' values of 0, representing no measurement error variance, and no constant
#' shift in the measurement error, respectively.
#'
#' Therefore, for example with no other arguments, \code{dmenorm(x)}, is simply
#' equivalent to \code{dtnorm(x)}, which in turn is equivalent to
#' \code{dnorm(x)}.
#'
#' These distributions were used by Satten and Longini (1996) for CD4 cell
#' counts conditionally on hidden Markov states of HIV infection, and later by
#' Jackson and Sharples (2002) for FEV1 measurements conditionally on states of
#' chronic lung transplant rejection.
#'
#' These distribution functions are just provided for convenience, and are not
#' optimised for numerical accuracy or speed. To fit a hidden Markov model
#' with these response distributions, use a \code{\link{hmmMETNorm}} or
#' \code{\link{hmmMEUnif}} constructor. See the \code{\link{hmm-dists}} help
#' page for further details.
#'
#' @name medists
#' @aliases medists dmenorm pmenorm qmenorm rmenorm dmeunif pmeunif qmeunif
#' rmeunif
#' @param x,q vector of quantiles.
#' @param p vector of probabilities.
#' @param n number of observations. If \code{length(n) > 1}, the length is
#' taken to be the number required.
#' @param mean vector of means.
#' @param sd vector of standard deviations.
#' @param lower lower truncation point.
#' @param upper upper truncation point.
#' @param sderr Standard deviation of measurement error distribution.
#' @param meanerr Optional shift for the measurement error distribution.
#' @param log,log.p logical; if TRUE, probabilities \eqn{p} are given as
#' \eqn{\log(p)}{log(p)}, or log density is returned.
#' @param lower.tail logical; if TRUE (default), probabilities are \eqn{P[X <=
#' x]}, otherwise, \eqn{P[X > x]}.
#' @return \code{dmenorm}, \code{dmeunif} give the density, \code{pmenorm},
#' \code{pmeunif} give the distribution function, \code{qmenorm},
#' \code{qmeunif} give the quantile function, and \code{rmenorm},
#' \code{rmeunif} generate random deviates, for the Normal and Uniform versions
#' respectively.
#' @author C. H. Jackson \email{chris.jackson@@mrc-bsu.cam.ac.uk}
#' @seealso \code{\link{dnorm}}, \code{\link{dunif}}, \code{\link{dtnorm}}
#' @references Satten, G.A. and Longini, I.M. Markov chains with measurement
#' error: estimating the 'true' course of a marker of the progression of human
#' immunodeficiency virus disease (with discussion) \emph{Applied Statistics}
#' 45(3): 275-309 (1996)
#'
#' Jackson, C.H. and Sharples, L.D. Hidden Markov models for the onset and
#' progression of bronchiolitis obliterans syndrome in lung transplant
#' recipients \emph{Statistics in Medicine}, 21(1): 113--128 (2002).
#' @keywords distribution
#' @examples
#'
#' ## what does the distribution look like?
#' x <- seq(50, 90, by=1)
#' plot(x, dnorm(x, 70, 10), type="l", ylim=c(0,0.06)) ## standard Normal
#' lines(x, dtnorm(x, 70, 10, 60, 80), type="l") ## truncated Normal
#' ## truncated Normal with small measurement error
#' lines(x, dmenorm(x, 70, 10, 60, 80, sderr=3), type="l")
#'
NULL
#' @rdname medists
#' @export
dmenorm <- function(x, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0, log = FALSE)
{
sumsq <- sd*sd + sderr*sderr
sigtmp <- sd*sderr / sqrt(sumsq)
mutmp <- ((x - meanerr)*sd*sd + mean*sderr*sderr) / sumsq
nc <- 1/(pnorm(upper, mean, sd) - pnorm(lower, mean, sd))
nctmp <- pnorm(upper, mutmp, sigtmp) - pnorm(lower, mutmp, sigtmp)
if (log)
log(nc) + log(nctmp) + log(dnorm(x, meanerr + mean, sqrt(sumsq), 0))
else
nc * nctmp * dnorm(x, meanerr + mean, sqrt(sumsq), 0)
}
#' @rdname medists
#' @export
pmenorm <- function(q, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0, lower.tail = TRUE, log.p = FALSE)
{
ret <- numeric(length(q))
dmenorm2 <- function(x)dmenorm(x, mean=mean, sd=sd, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr)
for (i in 1:length(q)) {
ret[i] <- integrate(dmenorm2, -Inf, q[i])$value
}
if (!lower.tail) ret <- 1 - ret
if (log.p) ret <- log(ret)
ret[upper < lower] <- NaN
ret
}
#' @rdname medists
#' @export
qmenorm <- function(p, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0, lower.tail=TRUE, log.p=FALSE)
{
qgeneric(pmenorm, p=p, mean=mean, sd=sd, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr,
lbound=lower, ubound=upper, lower.tail=lower.tail, log.p=log.p)
}
#' @rdname medists
#' @export
rmenorm <- function(n, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0)
{
rnorm(n, meanerr + rtnorm(n, mean, sd, lower, upper), sderr)
}
### Uniform distribution with measurement error
#' @rdname medists
#' @export
dmeunif <- function(x, lower=0, upper=1, sderr=0, meanerr=0, log = FALSE)
{
if (log)
log( pnorm(x, meanerr + lower, sderr) - pnorm(x, meanerr + upper, sderr) ) - log(upper - lower)
else
( pnorm(x, meanerr + lower, sderr) - pnorm(x, meanerr + upper, sderr) ) / (upper - lower)
}
#' @rdname medists
#' @export
pmeunif <- function(q, lower=0, upper=1, sderr=0, meanerr=0, lower.tail = TRUE, log.p = FALSE)
{
ret <- numeric(length(q))
dmeunif2 <- function(x)dmeunif(x, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr)
for (i in 1:length(q)) {
ret[i] <- integrate(dmeunif2, -Inf, q[i])$value
}
if (!lower.tail) ret <- 1 - ret
if (log.p) ret <- log(ret)
ret
}
#' @rdname medists
#' @export
qmeunif <- function(p, lower=0, upper=1, sderr=0, meanerr=0, lower.tail=TRUE, log.p=FALSE)
{
qgeneric(pmeunif, p=p, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr,
lbound=lower, ubound=upper, lower.tail=lower.tail, log.p=log.p)
}
#' @rdname medists
#' @export
rmeunif <- function(n, lower=0, upper=1, sderr=0, meanerr=0)
{
rnorm(n, meanerr + runif(n, lower, upper), sderr)
}