Skip to content

Commit

Permalink
added while loop to extract-bias vignette to prevent incoherent values
Browse files Browse the repository at this point in the history
  • Loading branch information
@joshwlambert
joshwlambert committed May 1, 2024
1 parent 59be142 commit 1c6345e
Show file tree
Hide file tree
Showing 2 changed files with 87 additions and 82 deletions.
14 changes: 2 additions & 12 deletions R/extract_param.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -81,12 +81,7 @@ extract_param <- function(type = c("percentiles", "range"),
if (distribution == "norm") {
checkmate::assert_numeric(values)
} else {

# if (any(values <= 1e-10)) {
# stop("Distribution is ", distribution, " Values are ", values, " Samples are ", samples)
# }

checkmate::assert_numeric(values, lower = 0)
checkmate::assert_numeric(values, lower = 1e-10)
}

if (type == "percentiles") {
Expand All @@ -100,11 +95,6 @@ extract_param <- function(type = c("percentiles", "range"),
checkmate::assert_numeric(percentiles, lower = 0, upper = 1, len = 2)
}
if (identical(type, "range")) {

if (!(values[2] < values[1] && values[1] < values[3])) {
stop("Distribution is ", distribution, " Values are ", values, " Type is ", type)
}

stopifnot(
"samples need to be given for type = 'range'" =
!missing(samples),
Expand Down Expand Up @@ -231,7 +221,7 @@ extract_param <- function(type = c("percentiles", "range"),
}
if (distribution == "weibull") {
names(param) <- c("shape", "scale")
lower <- c(1e-5, 1e-5)
lower <- c(1e-10, 1e-10)
}
if (distribution == "norm") {
names(param) <- c("mean", "sd")
Expand Down
155 changes: 85 additions & 70 deletions vignettes/extract-bias.Rmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -206,46 +206,54 @@ estim_params <- vector("list", nrow(parameters_range))
for (params_idx in seq_len(nrow(parameters_range))) {
dist <- as.character(parameters_range[params_idx, "dist"])
n_samples <- parameters_range[params_idx, "n_samples"]
if (dist == "lnorm") {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]

Check warning on line 209 in vignettes/extract-bias.Rmd

View workflow job for this annotation

GitHub Actions / lint-changed-files 

file=vignettes/extract-bias.Rmd,line=209,col=1,[trailing_whitespace_linter] Trailing whitespace is superfluous.
# while loop to ensure values are min < median < max
resample_values <- TRUE
while (resample_values) {
if (dist == "lnorm") {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- c(min(true_range), max(true_range))
} else {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
true_range <- c(min(true_range), max(true_range))
} else {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- c(min(true_range), max(true_range))
true_range <- c(min(true_range), max(true_range))
}

Check warning on line 250 in vignettes/extract-bias.Rmd

View workflow job for this annotation

GitHub Actions / lint-changed-files 

file=vignettes/extract-bias.Rmd,line=250,col=1,[trailing_whitespace_linter] Trailing whitespace is superfluous.
true_values <- c(true_median, true_range)
if (true_values[2] < true_values[1] && true_values[1] < true_values[3]) {
resample_values <- FALSE
}
}
true_values <- c(true_median, true_range)

Check warning on line 256 in vignettes/extract-bias.Rmd

View workflow job for this annotation

GitHub Actions / lint-changed-files 

file=vignettes/extract-bias.Rmd,line=256,col=1,[trailing_whitespace_linter] Trailing whitespace is superfluous.
# message about stochastic optimisation suppressed
estim_params[[params_idx]] <- suppressMessages(
expr = extract_param(
Expand Down Expand Up @@ -392,46 +400,53 @@ for (params_idx in seq_len(nrow(parameters_range))) {
dist <- as.character(parameters_range[params_idx, "dist"])
n_samples <- parameters_range[params_idx, "n_samples"]
if (dist == "lnorm") {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
# while loop to ensure values are min < median < max
resample_values <- TRUE
while (resample_values) {
if (dist == "lnorm") {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
meanlog = parameters_range[params_idx, "param_1"],
sdlog = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- c(min(true_range), max(true_range))
} else {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
true_range <- c(min(true_range), max(true_range))
} else {
true_median <- do.call(
paste0("q", dist),
list(
p = 0.5,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
true_range <- do.call(
paste0("r", dist),
list(
n = n_samples,
shape = parameters_range[params_idx, "param_1"],
scale = parameters_range[params_idx, "param_2"]
)
)
)
true_range <- c(min(true_range), max(true_range))
true_range <- c(min(true_range), max(true_range))
}

Check warning on line 443 in vignettes/extract-bias.Rmd

View workflow job for this annotation

GitHub Actions / lint-changed-files 

file=vignettes/extract-bias.Rmd,line=443,col=1,[trailing_whitespace_linter] Trailing whitespace is superfluous.
true_values <- c(true_median, true_range)
if (true_values[2] < true_values[1] && true_values[1] < true_values[3]) {
resample_values <- FALSE
}
}
true_values <- c(true_median, true_range)

Check warning on line 449 in vignettes/extract-bias.Rmd

View workflow job for this annotation

GitHub Actions / lint-changed-files 

file=vignettes/extract-bias.Rmd,line=449,col=1,[trailing_whitespace_linter] Trailing whitespace is superfluous.
# message about stochastic optimisation suppressed
estim <- suppressMessages(
replicate(
Expand Down

0 comments on commit 1c6345e

Please sign in to comment.