Nothing
#' Checking error for forest plot
#'
#' @inheritParams forest
#'
#' @keywords internal
#'
check_errors <- function(data,
est,
lower,
upper,
sizes,
ref_line,
vert_line,
ci_column,
is_summary,
xlim,
x_trans,
ticks_at,
ticks_digits,
ticks_minor,
title,
arrow_lab,
xlab){
if(!is.numeric(ci_column))
stop("ci_column must be numeric atomic vector.")
if(!is.null(title) && length(title) != 1)
stop("title must be of length 1.")
# Check length
if(length(unique(c(length(est), length(lower), length(upper)))) != 1)
stop("Estimate, lower and upper should have the same length.")
if(inherits(sizes, "list") & length(est) != length(sizes))
stop("sizes should have the same length as est.")
if(!is.numeric(unlist(sizes)))
stop("Sizes must be numeric.")
# Check size value
if(any(unlist(sizes) <= 0, na.rm = TRUE))
stop("Sizes must be larger than 0.")
# Check type
if(typeof(est) != typeof(lower) | typeof(est) != typeof(upper))
stop("Estimate, lower and upper should have the same type.")
if(!is.numeric(unlist(est)) | !is.numeric(unlist(lower)) | !is.numeric(unlist(upper)))
stop("Estimate, lower and upper must be numeric.")
if(inherits(est, "list") | inherits(lower, "list") | inherits(upper, "list")){
est_len <- vapply(est, length, FUN.VALUE = 1L)
lower_len <- vapply(lower, length, FUN.VALUE = 1L)
upper_len <- vapply(upper, length, FUN.VALUE = 1L)
if(length(unique(c(est_len, lower_len, upper_len))) != 1)
stop("All the elements in estimate, lower and upper should have the same length")
if(inherits(sizes, "list") & length(unique(c(est_len, vapply(sizes, length, FUN.VALUE = 1L)))) != 1)
stop("All the elements in sizes should have the same length as estimate")
}
# Check length for the summary
if(!is.null(is_summary) && length(is_summary) != nrow(data))
stop("is_summary should have same legnth as data rownumber.")
if(!is.null(is_summary) && ! is.logical(is_summary))
stop("is_summary must be logical vector.")
# Check ref_line
if(!is.numeric(ref_line) || !length(ref_line) %in% c(1, length(ci_column)))
stop("ref_line should be of length 1 or the same length as ci_column.")
# Check the x_trans
if(!all(x_trans %in% c("none", "log", "log2", "log10")) || !length(x_trans) %in% c(1, length(ci_column)))
stop("x_trans must be in \"none\", \"log\", \"log2\", \"log10\" and of length 1 or the same length as ci_column.")
# Check the xlab
if(!is.null(xlab) && !length(xlab) %in% c(1, length(ci_column)))
stop("xlab must be of length 1 or the same length as ci_column.")
# Check tick_digits
if(!is.null(ticks_digits)){
if(!length(ticks_digits) %in% c(1, length(ci_column)))
stop("ticks_digits must be length of 1 or same length as ci_column.")
if(!is.numeric(unlist(ticks_digits)))
stop("ticks_digits must be numeric.")
}
# If only one CI column
if(length(ci_column) == 1){
# Check vertical line
if(!is.null(vert_line) && !is.numeric(vert_line))
stop("vert_line must be a numeric vector.")
# Check arrow
if(!is.null(arrow_lab) & length(arrow_lab) != 2)
stop("Arrow label must of length 2.")
# Check xlim
if(!is.null(xlim) && (!is.numeric(xlim) || length(xlim) != 2 || xlim[1] >= xlim[2]))
stop("xlim must be numeric and of length 2, with first element less than the second.")
# Check the break
if(!is.null(ticks_at) && !is.numeric(ticks_at))
stop("ticks_at must be numeric.")
if(!is.null(ticks_minor) && !is.numeric(ticks_minor))
stop("ticks_minor must be numeric.")
if(!is.null(ticks_at) && !is.null(xlim)){
if(max(ticks_at) > max(xlim) || min(ticks_at) < min(xlim))
warning("ticks_at is outside the xlim.")
}
if(!is.null(ticks_minor) && !is.null(xlim)){
if(max(ticks_minor) > max(xlim) || min(ticks_minor) < min(xlim))
warning("ticks_minor is outside the xlim.")
}
}else{
# Check vertical line
if(!is.null(vert_line)){
if(inherits(vert_line, "list")){
if(length(vert_line) != length(ci_column))
stop("vert_line must have the same length as ci_column.")
cl <- sapply(vert_line, is.numeric)
if(any(!cl))
stop("vert_line must be all numeric.")
}else {
if(!is.numeric(vert_line))
stop("vert_line must be a numeric vector.")
}
}
# Check arrow
if(!is.null(arrow_lab)){
if(inherits(arrow_lab, "list")){
if(length(arrow_lab) != length(ci_column))
stop("arrow_lab must have the same length as ci_column.")
cl <- sapply(arrow_lab, length) == 2
if(any(!cl))
stop("Elements in the arrow_lab must of length 2.")
}else {
if(!is.null(arrow_lab) & length(arrow_lab) != 2)
stop("Arrow label must of length 2.")
}
}
# Check xlim
if(!is.null(xlim)){
if(inherits(xlim, "list")){
if(length(xlim) != length(ci_column))
stop("xlim must have the same length as ci_column.")
tst <- sapply(xlim, function(x){
!is.numeric(x) || length(x) != 2 || x[1] >= x[2]
})
if(any(tst))
stop("Elements in the xlim must be numeric and of length 2, with first element less than the second.")
}else {
if(!is.numeric(xlim) || length(xlim) != 2 || xlim[1] >= xlim[2])
stop("xlim must be numeric and of length 2, with first element less than the second.")
}
}
# Check the break
if(!is.null(ticks_at)){
if(inherits(ticks_at, "list")){
if(length(ticks_at) != length(ci_column))
stop("ticks_at must have the same length as ci_column.")
cl <- sapply(ticks_at, is.numeric)
if(any(!cl))
stop("Elements in the ticks_at must be numeric.")
}else {
if(!is.numeric(ticks_at))
stop("ticks_at must be numeric.")
}
}
if(!is.null(ticks_minor)){
if(inherits(ticks_minor, "list")){
if(length(ticks_minor) != length(ci_column))
stop("ticks_minor must have the same length as ci_column.")
cl <- sapply(ticks_minor, is.numeric)
if(any(!cl))
stop("Elements in the ticks_minor must be numeric.")
}else {
if(!is.numeric(ticks_minor))
stop("ticks_minor must be numeric.")
}
}
}
}
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.