Nothing
#----------------------------------------------#
# Author: Laurent Berge
# Date creation: Wed Jul 27 10:06:18 2022
# ~: checking functions
#----------------------------------------------#
# NOTE: it's unusual for me but there will be A LOT of code duplication
# the objective is to limit the most possible the overheads, hence this decision
# + the functions are simple and to the point (much less complex than what is possible with dreamerr), so that's manageable
####
#### checking ####
####
check_logical = function(x, null = FALSE, scalar = FALSE, l0 = FALSE, no_na = FALSE, mbt = FALSE, up = 0){
set_up(up + 1)
if(missing(x)){
if(mbt){
x_dp = deparse_short(substitute(x))
stop_up("The argument `", x_dp, "` must be provided. PROBLEM: it is missing.")
}
return()
}
if(null && is.null(x)){
return()
}
if(!is.logical(x)){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
type = if(scalar) "scalar" else "vector"
stop_up("The ", nullable, "argument `", x_dp, "` must be a logical ", type, ".",
" PROBLEM: it is not logical, it is of class {enum?class(x)}.")
}
len_x = length(x)
if(len_x == 0 && l0) return()
if(scalar){
if(missing(no_na)) no_na = TRUE
if(len_x != 1){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
stop_up("The ", nullable, "argument `", x_dp, "` must be a logical scalar.",
" PROBLEM: it is not of length 1, it is of length ", length(x), ".")
}
}
if(no_na && anyNA(x)){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
type = if(scalar) "scalar" else "vector without NA"
problem = if(scalar) "it is equal to NA" else "it contains NA values"
stop_up("The ", nullable, "argument `", x_dp, "` must be a logical ", type, ". ",
"PROBLEM: ", problem, ".")
}
}
check_numeric = function(x, null = FALSE, scalar = FALSE, l0 = FALSE, no_na = FALSE,
mbt = FALSE, integer = FALSE, complex = FALSE, up = 0){
set_up(up + 1)
if(missing(x)){
if(mbt){
x_dp = deparse_short(substitute(x))
stop_up("The argument `", x_dp, "` must be provided. PROBLEM: it is missing.")
}
return()
}
if(null && is.null(x)){
return()
}
if((!complex && !is.numeric(x)) || (complex && !is_num_complex(x))){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
vector_type = if(scalar) "scalar" else "vector"
type = if(integer) "an integer" else "a numeric"
if(complex) paste0(type, ", or complex,")
stop_up("The ", nullable, "argument `", x_dp, "` must be ", type, " ", vector_type, ".",
" PROBLEM: it is not {'^.+ 'r ? type} it is of class {enum?class(x)}.")
}
len_x = length(x)
if(len_x == 0 && l0) return()
if(scalar){
if(missing(no_na)) no_na = TRUE
if(len_x != 1){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
type = if(integer) "an integer" else "a numeric"
stop_up("The ", nullable, "argument `", x_dp, "` must be ", type, " scalar.",
" PROBLEM: it is not of length 1, it is of length ", length(x), ".")
}
}
if(no_na && anyNA(x)){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
vector_type = if(scalar) "scalar" else "vector without NA"
type = if(integer) "an integer" else "a numeric"
problem = if(scalar) "it is equal to NA" else "it contains NA values"
stop_up("The ", nullable, "argument `", x_dp, "` must be ", type, " ", vector_type, ". ",
"PROBLEM: ", problem, ".")
}
if(integer){
if(complex){
for(part in 1:2){
z = if(part == 1) Re(x) else Im(x)
if(any(z != round(z))){
x_dp = deparse_short(substitute(x))
i = which(z != round(z))[1]
intro = ""
if(part == 1 && all(Im(x) == 0)){
msg = .sma("is equal to {z}")
} else {
msg = .sma("has {&i==1;a real;an imaginary} part equal to {z}")
}
stop_up("The argument {bq?x_dp} must be an integer {&scalar ; scalar ; vector}.",
"\nPROBLEM: {&len(x)==1 ; it ; the {nth ? i} value} ",
"{msg}, not an integer.")
}
}
} else {
if(any(x != round(x))){
x_dp = deparse_short(substitute(x))
i = which(x != round(x))[1]
stop_up("The argument {bq?x_dp} must be an integer {&scalar ; scalar ; vector}.",
"\nPROBLEM: {&length(x)==1 ; it is equal to {x} ; the {nth ? i} ",
"value is equal to {x[i]}}, not an integer.")
}
}
}
}
check_character = function(x, null = FALSE, scalar = FALSE, l0 = FALSE,
no_na = FALSE, mbt = TRUE, up = 0){
set_up(up + 1)
if(missing(x)){
if(mbt){
x_dp = deparse_short(substitute(x))
stop_up("The argument `", x_dp, "` must be provided. PROBLEM: it is missing.")
}
return()
}
if(null && is.null(x)){
return()
}
if(!is.character(x)){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
type = if(scalar) "scalar" else "vector"
stop_up("The ", nullable, "argument `", x_dp, "` must be a character ", type, ".",
" PROBLEM: it is not character, it is of class {enum?class(x)}.")
}
len_x = length(x)
if(len_x == 0 && l0 && !scalar) return()
if(scalar){
if(missing(no_na)) no_na = TRUE
if(len_x != 1){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
stop_up("The ", nullable, "argument `", x_dp, "` must be a character scalar.",
" PROBLEM: it is not of length 1, it is of length ", length(x), ".")
}
}
if(no_na && anyNA(x)){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
type = if(scalar) "scalar" else "vector without NA"
problem = if(scalar) "it is equal to NA" else "it contains NA values"
stop_up("The ", nullable, "argument `", x_dp, "` must be a character ", type, ". ",
"PROBLEM: ", problem, ".")
}
}
check_set_character = function(x, null = FALSE, scalar = FALSE, l0 = FALSE,
no_na = FALSE, mbt = TRUE){
if(missing(x)){
if(mbt){
x_dp = deparse_short(substitute(x))
stop_up("The argument `", x_dp, "` must be provided. PROBLEM: it is missing.")
}
return(NULL)
}
if(null && is.null(x)){
return(NULL)
}
if(!is.atomic(x)){
x_dp = deparse_short(substitute(x))
stop_up("Argument {bq?x_dp} must be atomic. ",
"\nPROBLEM: Currently it is of the non-atomic class {bq?class(x)[1]}.")
}
if(!is.character(x) || !identical(class(x), "character")){
x = as.character(x)
}
len_x = length(x)
if(len_x == 0 && l0 && !scalar){
return(character(0))
}
if(scalar){
if(missing(no_na)) no_na = TRUE
if(len_x != 1){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
stop_up("The ", nullable, "argument `", x_dp, "` must be a character scalar.\n",
" PROBLEM: it is not of length 1, it is of length ", length(x), ".")
}
}
if(no_na && anyNA(x)){
x_dp = deparse_short(substitute(x))
nullable = if(null) "(nullable) " else ""
type = if(scalar) "scalar" else "vector without NA"
problem = if(scalar) "it is equal to NA" else "it contains NA values"
stop_up("The ", nullable, "argument `", x_dp, "` must be a character ", type, ". \n",
" PROBLEM: ", problem, ".")
}
return(x)
}
check_envir = function(x){
if(!inherits(x, "environment")){
x_dp = deparse_short(substitute(x))
if(is.list(x)){
stop_up("The argument `", x_dp, "` must be an environment (ex: parent.frame()). ",
"\nPROBLEM: it is not an environment, ",
"it is a {&is.data.frame(x) ; data.frame ; list}.",
"\nUse the argument `.data` instead.")
} else {
stop_up("The argument `", x_dp, "` must be an environment (ex: parent.frame()). ",
"PROBLEM: it is not an environment, it is of class {enum?class(x)}.")
}
}
}
check_function = function(x, null = FALSE, up = 0, argname = NULL){
set_up(up + 1)
if(null && is.null(x)){
return(NULL)
}
if(!is.function(x)){
if(is.null(argname)){
x_dp = deparse_short(substitute(x))
}
stop_up("The argument `", x_dp, "` must be a function. ",
"PROBLEM: it is not a function, it is of class {enum?class(x)}.")
}
}
check_set_dots = function(..., mc = NULL, mbt = FALSE, character = FALSE,
no_na = FALSE, scalar = FALSE, nofun = FALSE){
# check the dots arguments
n = ...length()
if(n == 0){
if(mbt){
stop_up("At least one element in `...` must be provided. PROBLEM: `...` is empty.")
} else {
return(list())
}
}
if(is.null(mc)){
sysOrigin = sys.parent()
mc = match.call(definition = sys.function(sysOrigin),
call = sys.call(sysOrigin), expand.dots = FALSE)
}
dots = vector("list", n)
dots_nm = names(mc[["..."]])
# We first catch evaluation problems
for(i in 1:n){
elem = try(...elt(i), silent = TRUE)
if(isError(elem) || (nofun && is.function(elem))){
nm = if(is.null(dots_nm)) "" else dots_nm[i]
if(is.na(nm)) nm = ""
mc_dots = mc[["..."]]
value = deparse_short(mc_dots[[i]])
nm = string_magic(" ({if(.C<4 ; erase) ! {nm} = }{value})")
if(isError(elem)){
if(grepl("try(...", elem, fixed = TRUE)){
elem = gsub("^[^:]+:", "", elem)
}
stop_up("In the argument `...`, the {#nth ? i} element{nm} raises an error:\n",
elem)
} else {
stop_up("In the argument `...`, the elements must not be functions.",
"\nPROBLEM: the {#nth ? i} element{nm} is a function.")
}
}
dots[[i]] = elem
}
# now we catch type problems
if(scalar){
if(any(lengths(dots) != 1)){
len_dots = lengths(dots)
i_pblm = which(len_dots != 1)
len_pblm = len_dots[i_pblm]
# I purposefully copy-paste in each block
# otherwise the code becomes too complicated and especially more difficult to debug
# We try to give as much info as possible
n_pblm = length(i_pblm)
nm_pblm = character(n_pblm)
if(!is.null(dots_nm)){
rep = dots_nm[i_pblm]
rep[is.na(rep)] = ""
nm_pblm = rep
}
# the value of the variables
mc_dots = mc[["..."]]
value_all = sapply(i_pblm, function(i) deparse_short(mc_dots[[i]]))
info_call = .string_magic("`{if(.C<4 ; erase) ! {nm_pblm} = }{value_all}`")
stop_up("In the argument `...`, all elements must be scalars (i.e. of length 1).\nPROBLEM: ",
"{'\n'c ! The {nth ? i_pblm} element ({info_call}) is ",
"of length {format, ws ? len_pblm}.}")
}
}
if(character){
# we convert to character => requirement is atomicity
if(!all(sapply(dots, is.atomic))){
i_pblm = which(!sapply(dots, is.atomic))
# We try to give as much info as possible
n_pblm = length(i_pblm)
nm_pblm = character(n_pblm)
if(!is.null(dots_nm)){
rep = dots_nm[i_pblm]
rep[is.na(rep)] = ""
nm_pblm = rep
}
# the value of the variables
mc_dots = mc[["..."]]
value_all = sapply(i_pblm, function(i) deparse_short(mc_dots[[i]]))
info_call = string_magic("`{if(.C<4 ; erase) ! {nm_pblm} = }{value_all}`")
cls_pblm = sapply(dots[i_pblm], function(x) string_magic("{bq ! {enum ? class(x)}}"))
stop_up("In the argument `...`, all elements must be atomic (i.e. convertible to a character string).",
"\nPROBLEM: {'\n 'c ! The {Nth ? i_pblm} element ({info_call}) is not character",
" (instead it is of class: {cls_pblm}).}")
}
true_character = function(x) is.character(x) && identical(class(x), "character")
i_no_char = which(!sapply(dots, true_character))
for(i in i_no_char){
dots[[i]] = as.character(dots[[i]])
}
}
if(no_na){
if(any(sapply(dots, anyNA))){
i_pblm = which(sapply(dots, anyNA))
# We try to give as much info as possible
n_pblm = length(i_pblm)
nm_pblm = character(n_pblm)
if(!is.null(dots_nm)){
rep = dots_nm[i_pblm]
rep[is.na(rep)] = ""
nm_pblm = rep
}
# the value of the variables
mc_dots = mc[["..."]]
value_all = sapply(i_pblm, function(i) deparse_short(mc_dots[[i]]))
info_call = string_magic("`{if(.C<4 ; erase) ! {nm_pblm} = }{value_all}`")
stop_up("In the argument `...`, all elements must be without NA.\nPROBLEM: ",
"The {nth, enum ? i_pblm} element{$s} ({C ? info_call})",
" {$contain} NA values.")
}
}
names(dots) = dots_nm
return(dots)
}
check_set_options = function(x, options, op = NULL, free = FALSE, case = FALSE){
# x: always a character vector
# options: the options to match
if(length(x) == 0) return(x)
n = length(x)
res = x
for(i in 1:n){
v = x[i]
pm = pmatch(v, options)
if(is.na(pm) && !case){
pm = pmatch(tolower(v), tolower(options))
}
if(is.na(pm) && !free){
# absence of a match
stop_hook("The option {bq?v} is not valid {&is.null(op) ; for the current operation ; for the operator {bq?op}}.\n",
"FYI the option{$s ? options} available {$are, enum.bq}.")
}
if(!is.na(pm)){
res[i] = options[pm]
}
}
res
}
check_last = function(.last){
if(is.null(.last) || is.function(.last)){
# ok, no check
} else if(!is.character(.last)){
stop_hook("Argument `.last` mut be equal to an `string_magic` operations chain",
" or a function.",
"\nPROBLEM: instead it is of class {enum.bq?class(.last)}.")
} else {
check_character(.last, null = TRUE, scalar = TRUE)
}
}
check_set_delimiters = function(.delim){
check_character(.delim, no_na = TRUE, up = 1)
if(length(.delim) == 1){
.delim = strsplit(.delim, " ", fixed = TRUE)[[1]]
}
check_delimiters(.delim)
.delim
}
check_set_width = function(width_expr){
sw = getOption("width")
data = list(.sw = sw)
width = eval(width_expr, data, parent.frame(2))
if(isFALSE(width)){
width = Inf
}
if(is.null(width)){
width = min(120, 0.9 * sw)
}
width
}
check_set_split = function(split){
if(missing(split)){
if(isTRUE(split)){
split = ","
}
return(split)
}
if(is.logical(split)){
check_logical(split, scalar = TRUE, up = 1)
if(split){
split = ","
}
} else if(is.character(split)){
check_character(split, scalar = TRUE, up = 1)
if(nchar(split) != 1){
stop_hook("The argument `.split` must be a logical scalar or a single character symbol.",
"\nPROBLEM: it is currently a character scalar ({10 Short, Q ? split}) but ",
"contains {nchar(split)} characters.")
}
} else {
stop_hook("The argument `.split` must be a logical scalar or a single character symbol.",
"\nPROBLEM: instead it is of class {enum.bq ? class(split)}.")
}
split
}
is_num_complex = function(x){
is.numeric(x) || is.complex(x)
}
check_set_mat = function(cmat, nmat, df){
res = TRUE
if(is.logical(cmat)){
check_logical(cmat, scalar = TRUE)
if(cmat){
attr(res, "auto") = TRUE
return(res)
}
} else if(is_num_complex(cmat)){
check_numeric(cmat, scalar = TRUE, complex = TRUE)
attr(res, "row_col") = c(Re(cmat), Im(cmat))
return(res)
} else {
stop_hook("The argument `.cmat` must be a logical scalar, an integer (giving the ",
"nber of rows) or an imaginary (ex: `3i`, giving the number of columns).",
"\nPROBLEM: instead it is of class {enum.bq ? class(split)}.")
}
if(is.logical(nmat)){
check_logical(nmat, scalar = TRUE)
if(nmat){
attr(res, "auto") = TRUE
attr(res, "num") = TRUE
return(res)
}
} else if(is_num_complex(nmat)){
check_numeric(nmat, scalar = TRUE, complex = TRUE)
attr(res, "num") = TRUE
attr(res, "row_col") = c(Re(nmat), Im(nmat))
return(res)
} else {
stop_hook("The argument `.cmat` must be a logical scalar, an integer (giving the ",
"nber of rows) or an imaginary (ex: `3i`, giving the number of columns).",
"\nPROBLEM: instead it is of class {enum.bq ? class(split)}.")
}
if(is.logical(df)){
check_logical(df, scalar = TRUE)
if(df){
attr(res, "auto") = TRUE
attr(res, "df") = TRUE
return(res)
}
} else if(is_num_complex(df)){
check_numeric(df, scalar = TRUE, complex = TRUE)
attr(res, "df") = TRUE
attr(res, "row_col") = c(Re(df), Im(df))
return(res)
} else if(is.character(df)){
if(length(df) == 1){
colnames = strsplit(df, ",[ \t\n]*")[[1]]
} else {
colnames = df
}
attr(res, "df") = TRUE
attr(res, "colnames") = colnames
attr(res, "row_col") = c(0, length(colnames))
return(res)
} else {
stop_hook("The argument `.df` must be a logical scalar, an integer (giving the ",
"nber of rows), an imaginary (ex: `3i`, giving the number of columns), ",
"or a character scalar giving the (comma separated) column names.",
"\nPROBLEM: instead it is of class {enum.bq ? class(split)}.")
}
res = FALSE
res
}
check_delimiters = function(.delim){
if(!length(.delim) == 2){
stop_hook("The argument .`delim` must lead to a character vector of length 2",
" (after splitting the space if relevant).",
"\nPROBLEM: it is of length {len?.delim}.")
}
if(any(nchar(.delim) == 0)){
info = c("opening", "closing")[nchar(.delim) == 0]
stop_hook("Argument `.delim` must be composed of non-empty delimiters.",
"\nPROBLEM: the {C?info} delimiter{$s, are} equal to the empty string.")
}
forbid = "();?! "
forbid_regex = paste0("[", forbid, "]")
if(any(grepl(forbid_regex, .delim))){
i = which(grepl(forbid_regex, .delim))[1]
pblm = string_ops(.delim[i], paste0("'", forbid_regex, "'X"))
info = string_magic("{&i == 1;opening;closing} delimiter (equal to {bq?.delim[i]})")
stop_hook("Argument `.delim` cannot contain the following, reserved, ",
"characters: {''s, bq, C?forbid}.",
"\nPROBLEM: the {info} contains the forbidden character{$s ? pblm}: {$enum.bq}.")
}
}
get_string_magic_context = function(){
# this is specific to functions running within string_magic_internal
up = 1
while(!get0("is_string_magic_internal", parent.frame(up), inherits = FALSE, ifnotfound = FALSE)){
up = up + 1
if(identical(parent.frame(up), .GlobalEnv)){
return("")
}
}
x = get("x", parent.frame(up))
.delim = get(".delim", parent.frame(up))
i = get("i", parent.frame(up))
n = get("n", parent.frame(up))
# we reparse
x_parsed = cpp_string_magic_parser(x, .delim, TRUE)
context_specific = x_parsed[[i]]
# normalizing newlines or very confusing
x = escape_newline(x)
context_specific = escape_newline(context_specific)
# normalizing the if-else semi-colon
x = gsub("_;;;_", ";", x)
context_specific = gsub("_;;;_", ";", context_specific)
same_context = gsub(" ", "", x) == gsub(" ", "", context_specific)
if(same_context){
res = .sma("CONTEXT: Problem found in {bq?context_specific}.")
} else {
res = .sma("CONTEXT: Problem found in {'80|..'k, Q?x},",
"\n when dealing with the interpolation {bq?context_specific}.")
}
res
}
check_set_string_magic_parsing = function(x, check, .delim){
# x is a character string to be turned into an R expression
if(check){
x_call = try(parse(text = x, keep.source = FALSE), silent = TRUE)
} else {
x_call = parse(text = x, keep.source = FALSE)
return(x_call)
}
if(inherits(x_call, "try-error")){
open = .delim[1]
close = .delim[2]
context = get_string_magic_context()
first_char = substr(x, 1, 1)
if(first_char %in% c("#", "$")){
msg = string_magic("PROBLEM: there is a syntax error in the pluralization (the ",
"interpolation starting with {bq?first_char}).",
"\nFor more information on the syntax, type `string_magic(.help = TRUE)` and go to the section ",
"{Q!Interpolation and string operations: Principle}")
} else if(first_char == "&"){
msg = string_magic("PROBLEM: there is a syntax error in the if-else (the ",
"interpolation starting with {'^&+'x, bq?x}).",
"\nFor more information on the syntax, type `string_magic(.help = TRUE)` and go to the section ",
"{Q!Special interpolation: if-else}")
} else {
if(grepl("[!?]", x)){
type = paste0("2 (`", open, "ops ? expr", close, "`) or 3 (`", open, "ops ! verbatim", close, "`)")
if(!grepl("!", x)){
type = paste0("2 (`", open, "ops ? expr", close, "`)")
} else if(!grepl("[?]", x)){
type = paste0("3 (`", open, "ops ! verbatim", close, "`)")
}
extra = string_magic("\nCurrently the interpolation has been parsed as the first case: ",
"`{open}expr{close}`.",
"\nMaybe there is a syntax mistake preventing it to be interpreted as case {type}?")
} else {
extra = "\nCurrently it seems that the expression to be interpolated is not a valid R expression."
}
help_suggest = .sma("\nFor more information on the syntax, type `string_magic(.help = TRUE)` and go to the section ",
"{!Operations: General syntax}")
x_call_clean = gsub("Error in parse[^:]+: ?", "Error when parsing: ", x_call)
msg = .sma("PROBLEM: The expression {bq?x} could not be parsed, see error below:",
"\n{x_call_clean}",
"\nINFO: Interpolations can be of the form `{open}expr{close}`, ",
"`{open}op1, op2?expr{close}`, or",
" `{open}op1, op2!verbatim{close}`. ",
"{extra}",
"{help_suggest}")
}
.stop_hook(context, "\n", msg)
}
x_call
}
check_set_string_magic_eval = function(call, data, envir, check){
# we need to eval the call
is_dt = "dt_data" %in% names(attributes(envir))
if(!check){
if(is_dt){
x = eval_dt(call, data, envir)
} else {
x = eval(call, data, envir)
}
} else {
# now with check = TRUE
if(is_dt){
x = try(eval_dt(call, data, envir), silent = TRUE)
} else {
x = try(eval(call, data, envir), silent = TRUE)
}
if(inherits(x, "try-error")){
context = get_string_magic_context()
call_dp = deparse_short(call)
if(grep("^expression\\(", call_dp)){
call_dp = gsub("^expression\\(|\\)", "", call_dp)
}
x_clean = gsub("^Error in eva[^:]+: ?", "Error: ", x)
msg = .sma("PROBLEM: The expression {bq ? call_dp} could not be evaluated, see error below:",
"\n{x_clean}")
stop_hook("{context}\n{msg}")
}
}
if(is.function(x)){
context = get_string_magic_context()
call_dp = deparse_short(call)
msg = .sma("EXPECTATION: interpolated variables should be coercible to character strings.",
"\nPROBLEM: the expression {bq?call_dp} is a **function**. Please provide a character string.")
stop_hook("{context}\n{msg}")
}
x
}
# oparg: operator's argument
check_set_oparg_parse = function(argument, operator, check){
if(check){
call = try(str2lang(argument), silent = TRUE)
} else {
call = str2lang(argument)
return(call)
}
if(inherits(call, "try-error")){
context = get_string_magic_context()
msg = .sma("EXPECTATION: In operation \"{bq?argument}{operator}\" the argument ",
"in backticks is evaluated from the calling environment.",
"\nPROBLEM: {bq?argument} is not a valid R-expression, see parsing error below:",
"\n{call}")
stop_hook("{context}\n{msg}")
}
call
}
check_set_oparg_eval = function(call, data, envir, operator, check){
if(check){
x = try(eval(call, data, envir), silent = TRUE)
} else {
x = eval(call, data, envir)
return(x)
}
if(inherits(x, "try-error")){
context = get_string_magic_context()
msg = .sma("EXPECTATION: In operation {bq?operator} the argument ",
"in backticks is evaluated from the calling environment.",
"\nPROBLEM: {bq?deparse_short(call)} could not be evaluated, see error below:",
"\n{x}")
stop_hook("{context}\n{msg}")
}
x
}
report_string_magic_parsing_error = function(x, x_parsed, .delim, error = TRUE){
x_parsed = x_parsed[[1]]
error_msg = x_parsed[1]
xi = x_parsed[2]
#
# getting the context
#
open = .delim[1]
close = .delim[2]
x = escape_newline(x)
xi = escape_newline(xi)
same_context = gsub(" ", "", x) == gsub(" ", "", xi)
if(same_context){
context = .sma("CONTEXT: Problem found in {bq?xi}.")
} else {
context = .sma("CONTEXT: Problem found in {'80|..'k, Q?x},",
"\n when dealing with the interpolation {bq?xi}.")
}
#
# the error message
#
suggest = ""
if(error_msg == "slash operator not ending correctly"){
if(is_box_open(xi, .delim) && !is_box_close(xi, .delim)){
msg = .sma("PROBLEM: the opening delimiter ({bq?.delim[1]}) is not ",
"matched with a closing delimiter ({bq?.delim[2]}).",
"\nNOTE: to escape the meaning of the delimiter, use a ",
"double backslash: \\\\{.delim[1]}")
suggest= "INFO: see string_magic(.help = TRUE) and go to the section 'Escaping and special cases'"
} else {
# we diagnose the substring
if(is_box_open(xi, .delim)){
xi_small = string_trim(xi, 1)
} else {
xi_small = string_trim(xi, nchar(open), nchar(close))
}
xi_small_parsed = cpp_string_magic_parser(xi_small, .delim)
if(length(xi_small_parsed) == 1 && isTRUE(attr(xi_small_parsed, "error"))){
msg = report_string_magic_parsing_error(xi_small_parsed, xi_small, .delim, FALSE)
msg = gsub("^CONTEXT:", " ", msg)
} else {
# here I don't knwo what the error can be
# in theory, we should not be here
stop("Internal error: uncaught parsing error, could you report your string_magic() call?")
}
# We don't add a suggestion since it should be in the 'msg'
}
} else if(error_msg == "no closing bracket"){
# {unik, sort ? iris[['Species']}
# we first try on iris[['Species'] only
done = FALSE
expr_msg = ""
if(grepl("?", xi, fixed = TRUE)){
xi_expr = gsub(".+[?]", "", xi)
pblm = cpp_find_closing_problem(xi_expr, .delim)
if(pblm %in% c("", "delim")){
# no problem found or delim prblm (we check with the full xi)
} else {
done = TRUE
close = .delim[2]
xi_expr_clean = string_ops(xi_expr, "'mf/{close}'s, -1 last, `close`collapse, tws")
expr_msg = .sma("in the expression {bq?xi_expr_clean}, ")
}
}
if(!done){
pblm = cpp_find_closing_problem(xi, .delim)
}
if(pblm == "delim"){
suggest = "INFO: see string_magic(.help = TRUE) and go to the section 'Escaping and special cases'"
}
delim_msg = if(all(.delim == c("{", "}"))) "bracket" else "delimiter"
pblm = switch(pblm,
"delim" = .sma("the opening {delim_msg} ({bq?.delim[1]}) is not ",
"matched with a closing {delim_msg} ({bq?.delim[2]}).",
"\n\nNOTE: to escape the meaning of the {delim_msg}, use a ",
"double backslash: \\\\{.delim[1]}."),
"'" = "a single quote (') open is not closed.",
"\"" = "a double quote (\") open is not closed.",
"`" = "a backtick (`) open is not closed.",
"(" = "a parenthesis (`(`) open is not closed.",
"{" = "a bracket (`{`) open is not closed.",
"[" = "a bracket (`[`) open is not closed.",
"it seems that something open is not closed."
)
msg = .sma("PROBLEM: {expr_msg}{pblm}")
} else if(string_x(error_msg, 7) == "if-else"){
type = if(string_x(xi, 2, 1 + nchar(open)) == "&&") "&&" else "&"
syntax = if(type == "&&") "{&&cond ; verb_true}" else "{&cond ; verb_true ; verb_false}"
intro = .sma("The syntax of the if-else operation is {syntax}, with ",
"`verb_.` a verbatim expression (possibly containing interpolations).")
if(error_msg == "if-else: error extracting condition"){
msg = .sma("{intro}\nPROBLEM: no semi-colon (used to delimit the condition) ",
"was found so the condition could not be parsed.")
} else if(error_msg == "if-else: error extracting the first part"){
msg = .sma("{intro}\nPROBLEM: no semi-colon {&type == '&' ; or closing bracket }was ",
"found to delimit `verb_true`.")
} else if(error_msg == "if-else: error extracting the second part"){
msg = .sma("{intro}\nPROBLEM: no closing bracket was found to delimit `verb_false`.")
}
suggest = "INFO: see string_magic(.help = TRUE) and go to the section 'Special interpolation: if-else'"
} else {
# pluralization
suggest = "INFO: see string_magic(.help = TRUE) and go to the section 'Special interpolation: Pluralization'"
type = string_x(xi, 1, 1 + nchar(open))
syntax = .sma("{open}{type}op1, op2{close} or {open}{type}op1, op2 ? variable{close}")
if(error_msg == "pluralization: operators cannot contain parentheses"){
msg = .sma("In pluralization, the parenthesis is a forbidden character *except* ",
"for the special operation `(v1;v2)` (without any letter before the paren!).",
"\nPROBLEM: a parenthesis was found attached to an operator.")
} else if(error_msg == "pluralization: the interpolation ends incorrectly"){
msg = .sma("The syntax of the pluralization is {syntax}, with `op` pluralization operations.",
"\nPROBLEM: The pluralization did not end correctly.")
} else {
# (v1;v2) case
type = string_ops(error_msg, "(first|second|third) x")
pblm = switch(type,
"first" = "The semi-colon to delimit the first part is missing.",
"second" = "The semi-colon or closing parenthesis to delimit the second part is missing.",
"third" = "The closing parenthesis to delimit the third part is missing.")
msg = .sma("In pluralizations, the special verbatim operation must be of the ",
"form (v1;v2) or (v1;v2;v3), with `v.` verbatim expressions ",
"(possibly containing interpolations).",
"\nPROBLEM: the {type} verbatim expression could not be extracted. {pblm}")
}
}
full_msg = .sma("{context}\n{msg}{if(.C>0;'\n'paste) ? suggest}")
if(error){
.stop_hook(full_msg)
} else {
return(full_msg)
}
}
check_set_eval_fun = function(fun__, x__, ...){
# we postfix weirdly to avoid common argument names
# the .x is pretty common
check_function(fun__, up = 1, argname = deparse(substitute(fun__)))
# NOTA: formalArgs does not work for primitives, like sum
arg_names = names(formals(args(fun__)))
dots = list(...)
args = list()
args[[1]] = x__
if(!is.null(arg_names)){
arg_ok = intersect(names(dots), arg_names)
args[arg_ok] = dots[arg_ok]
}
res = try(do.call(fun__, args), silent = TRUE)
if(isError(res)){
fun_arg = deparse(substitute(fun__))
stop_hook("The evaluation of the function in argument {bq?fun_arg} ",
"led to an error, see below:",
"\n{'^.+do\\.call[^\n]+\n'r?res}")
}
res
}
####
#### utilities ####
####
suggest_item = function(x, items, write_msg = TRUE, newline = TRUE, info = "variable"){
# typical use: x is not in items
# we want to suggest possible values
# returns vector of length 0 if no suggestion
items_origin = items
# 1: with case
nx = nchar(x)
items_nx = substr(items, 1, nx)
qui = items_nx == x
if(length(x) == 0){
res = character(0)
} else if(any(qui)){
res = items[qui]
} else {
# 2: without case
x = tolower(x)
items_nx = tolower(items_nx)
qui = items_nx == x
if(any(qui)){
res = items[qui]
} else {
# 3: with spelling mistakes, keeping the order
# only if x > 3 characters
if(nx < 3) return(character(0))
# lazy algorithm
score = numeric(length(items))
for(i in 1:nx){
score = score + (substr(items_nx, i, i) == substr(x, i, i))
}
if(any(score > (nx / 2))){
s_order = order(score, decreasing = TRUE)
score = score[s_order]
items = items[s_order]
res = items[score > nx / 2]
} else {
# 4: with spelling mistakes, ignoring the order
x_letters = strsplit(x, "")[[1]]
score = numeric(length(items))
for(i in 1:nx){
score = score + (substr(items_nx, i, i) %in% x_letters)
}
s_order = order(score, decreasing = TRUE)
score = score[s_order]
items = items[s_order]
res = items[score > (nx * 0.65)]
}
}
}
if(write_msg){
if(length(res) == 0){
if(length(items_origin) <= 5){
res = string_magic("FYI the {info}{$s, are, enum.bq ? items_origin}.")
} else {
res = string_magic("\nFYI the {info}s are: {sort, ', 'c ? items_origin}.")
}
} else {
res = string_magic("Maybe you meant {enum.bq.or ? res}?")
}
if(newline){
res = paste0("\n", res)
}
} else {
if(length(res) == 0){
res = head(items_origin, 5)
}
}
res
}
opt_equal = function(x, option){
any(!is.na(pmatch(x, option)))
}
deparse_short = function(x){
x_dp = deparse(x)
if(length(x_dp) > 1){
x_dp = paste0(x_dp, "...")
}
x_dp
}
deparse_long = function(x){
x_dp = deparse(x, width.cutoff = 500L)
if(length(x_dp) > 1){
x_dp = paste0(x_dp, collapse = "\n")
}
x_dp
}
####
#### dreamerr's copies ####
####
setDreamerr_show_stack = function(show_full_stack = FALSE){
check_logical(show_full_stack, scalar = TRUE, mbt = TRUE)
options("dreamerr_show_full_stack" = show_full_stack)
}
set_up = function(.up = 1){
if(length(.up) == 1 && is.numeric(.up) && !is.na(.up) && .up == floor(.up) && .up >= 0){
assign("DREAMERR__UP", .up, parent.frame())
} else {
stop("Argument '.up' must be an integer scalar greater or equal to 1. ",
"This is currently not the case.")
}
}
set_pblm_hook = function(){
assign("string_magic_HOOK", 1, parent.frame())
}
get_up_hook = function(){
# up with set_up
f = parent.frame()
up = 1
while(!identical(f, .GlobalEnv)){
if(exists("string_magic_HOOK", f)){
break
}
up = up + 1
f = parent.frame(up + 1)
}
# we accept direct nestedness
f_up = parent.frame(up + 2)
while(!identical(f_up, .GlobalEnv) && exists("string_magic_HOOK", f_up)){
up = up + 1
f = f_up
f_up = parent.frame(up + 2)
}
if(identical(f, .GlobalEnv)){
up = 1
}
up
}
.stop_hook = function(..., msg = NULL, envir = parent.frame()){
# verbatim version
up = get_up_hook()
stop_up(..., up = up, msg = msg, envir = envir, verbatim = TRUE)
}
stopi = function(..., envir = parent.frame()){
stop_up(..., up = 1, envir = envir, verbatim = FALSE)
}
stop_hook = function(..., msg = NULL, envir = parent.frame(), verbatim = FALSE){
up = get_up_hook()
stop_up(..., up = up, msg = msg, envir = envir, verbatim = verbatim)
}
stop_up = function(..., up = 1, msg = NULL, envir = parent.frame(), verbatim = FALSE){
if(verbatim){
main_msg = paste0(...)
} else {
main_msg = .string_magic(..., .envir = envir)
}
# up with set_up
mc = match.call()
if(!"up" %in% names(mc)){
up_value = mget("DREAMERR__UP", parent.frame(), ifnotfound = 1)
up = up_value[[1]]
}
up = up + 1
show_full_stack = isTRUE(getOption("dreamerr_show_full_stack"))
sc = sys.calls()
if(show_full_stack){
# The user requests the full stack
my_call = sapply(sc, function(x) deparse(x, width.cutoff = 200L, nlines = 1))
my_call = string_magic("{'\n'c ! [{format.0 ? 1:length(my_call)}] {'100|...'k ? my_call}}")
intro = paste0("the full stack is shown (set this off with setDreamerr_show_stack(FALSE))\n", my_call)
} else {
# only the original call
my_call = sys.call(sys.parent(up))
my_call = deparse(my_call)[1]
nmax = 50
if(nchar(my_call) > nmax) my_call = paste0(substr(my_call, 1, nmax - 1), "...")
intro = paste0("in ", my_call)
}
main_msg = fit_screen(main_msg)
if(!is.null(msg)){
if(length(msg) > 1){
msg = paste(msg, collapse = "")
}
msg = fit_screen(msg)
on.exit(message(msg))
}
stop(intro, ": \n", main_msg, call. = FALSE)
}
warn_no_named_dots = function(dots, extra_args = NULL, extra_funName = ""){
if(!is.null(names(dots))){
is_extra = !is.null(extra_args)
args_fun = names(formals(sys.function(sys.parent())))
args_fun = unique(c(args_fun, extra_args))
args_fun = setdiff(args_fun, "...")
dot_names = names(dots)
dot_names = dot_names[nchar(dot_names) > 0]
sugg_txt = suggest_item(dot_names[1], args_fun, info = "argument")
warn_up("The arguments in `...` shall not have names{&is_extra; or may refer to the ",
"arguments of the function in {bq?extra_funName}}. ",
"The name{$s, enum.bq ? dot_names}",
" may refer to {$(an;some)} argument{$s}?", sugg_txt)
}
}
.warn_hook = function(..., envir = parent.frame(), immediate. = FALSE){
up = get_up_hook()
warn_up(..., up = up, envir = envir, verbatim = TRUE, immediate. = immediate.)
}
warn_hook = function(..., envir = parent.frame(), immediate. = FALSE, verbatim = FALSE){
up = get_up_hook()
warn_up(..., up = up, envir = envir, verbatim = verbatim, immediate. = immediate.)
}
warni = function(..., envir = parent.frame(), immediate. = FALSE){
warn_up(..., up = 1, envir = envir, verbatim = FALSE, immediate. = immediate.)
}
warn_up = function (..., up = 1, immediate. = FALSE, envir = parent.frame(), verbatim = FALSE){
if(verbatim){
message = paste0(...)
} else {
message = .string_magic(..., .envir = envir)
}
mc = match.call()
if (!"up" %in% names(mc)) {
up_value = mget("DREAMERR__UP", parent.frame(), ifnotfound = 1)
up = up_value[[1]]
}
up = up + 1
my_call = sys.call(sys.parent(up))
my_call = deparse(my_call)[1]
nmax = 50
if (nchar(my_call) > nmax){
my_call = paste0(substr(my_call, 1, nmax - 1), "...")
}
warning("In ", my_call, ":\n ", fit_screen(message),
call. = FALSE, immediate. = immediate.)
}
fit_screen = function(msg, width = NULL, leading_ws = TRUE, leader = ""){
# makes a message fit the current screen, by cutting the text at the appropriate location
# msg must be a character string of length 1
if(length(msg) == 0) return(msg)
# Note that \t are NOT handled
# eval
width = check_set_width(substitute(width))
N_LEAD = nchar(leader)
if(width > 1){
MAX_WIDTH = width
} else {
MAX_WIDTH = getOption("width") * width
}
MAX_WIDTH = max(MAX_WIDTH, 15)
res = c()
msg_split = strsplit(msg, "\n", fixed = TRUE)[[1]]
for(m in msg_split){
if(nchar(m) <= MAX_WIDTH){
res = c(res, paste0(leader, m))
} else {
# we apply a splitting algorithm
lead_ws = gsub("^([ \t]*).*", "\\1", m, perl = TRUE)
m = trimws(m)
N_LEAD_WS = nchar(lead_ws)
add_lead = TRUE
first = TRUE
m_split = strsplit(m, "(?<=[^ ]) ", perl = TRUE)[[1]]
while(TRUE){
if(add_lead){
width = MAX_WIDTH - N_LEAD_WS - N_LEAD
prefix = paste0(leader, lead_ws)
} else {
width = MAX_WIDTH - N_LEAD
prefix = leader
}
if(sum(nchar(m_split) + 1) - 1 <= width){
res = c(res, paste0(prefix, paste(m_split, collapse = " ")))
break
}
where2split = which.max(cumsum(nchar(m_split) + 1) - 1 > width) - 1
res = c(res, paste0(prefix, paste(m_split[1:where2split], collapse = " ")))
m_split = m_split[-(1:where2split)]
if(!leading_ws && first){
add_lead = FALSE
first = FALSE
}
}
}
}
paste(res, collapse = "\n")
}
isError = function(x){
inherits(x, "try-error")
}
####
#### fixest copies ####
####
check_expr = function(expr, ..., clean, up = 0, arg_name, verbatim = FALSE){
res = tryCatch(expr, error = function(e) structure(list(conditionCall(e),
conditionMessage(e)), class = "try-error"))
if(inherits(res, "try-error")){
if(missing(up)){
# up with set_up
f = parent.frame()
up = 1
while(!identical(f, .GlobalEnv)){
if(exists("string_magic_HOOK", f)){
break
}
up = up + 1
f = parent.frame(up + 1)
}
if(identical(f, .GlobalEnv)){
up = 1
}
}
up = up + 1
if(verbatim){
msg = paste0(..., collapse = "")
} else {
msg = .string_magic(..., .envir = parent.frame())
}
if(nchar(msg) == 0){
if(missing(arg_name)){
arg_name = deparse(substitute(expr))
}
msg = paste0("Argument '", arg_name, "' could not be evaluated: ")
stop_up(msg, res[[2]], verbatim = verbatim, envir = parent.frame(), up = up)
} else {
call_non_informative = deparse(substitute(expr),100)[1]
call_error = deparse(res[[1]], 100)[1]
if(call_error == call_non_informative || call_error == "NULL" || grepl("^(doTry|eval)", call_error)){
call_error = ""
} else {
call_error = paste0("In ", call_error, ": ")
}
err = res[[2]]
if(grepl("^in eval\\(str[^:]+:\n", err)){
err = sub("^in eval\\(str[^:]+:\n", "", err)
}
# cleaning ugly call repetition
current_call = deparse(sys.call(sys.parent(up)))[1]
first_err = gsub("\n.+", "", err)
if(grepl(substr(current_call, 1, 20), first_err, fixed = TRUE)){
err = gsub("^[^\n]+\n", "", err)
}
# cleaning extra artifacts
i_clean = 0
msg_split = strsplit(msg, "\n")[[1]]
err_split = strsplit(err, "\n")[[1]]
while(i_clean < min(length(msg_split), length(err_split))){
if(string_x(msg_split[i_clean + 1], 15) == string_x(err_split[i_clean + 1], 15)){
i_clean = i_clean + 1
} else {
break
}
}
for(i in seq_len(i_clean)){
err = gsub("^[^\n]+\n", "", err)
}
if(!missing(clean)){
err = string_clean(err, clean)
}
stop_up(msg, "\n", call_error, err, verbatim = TRUE, up = up)
}
}
res
}
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.