#' @title Test internet connection
#'
#' @description
#' Test internet connection by looking to the IP config.
#'
#' @return boolean
havingIP <- function() {
ipmessage <- if (.Platform$OS.type == "windows") system("ipconfig", intern = TRUE)
else ipmessage <- system("ifconfig", intern = TRUE)
validIP <- "((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)[.]){3}(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)"
any(grep(validIP, ipmessage))
}
#' @title Format text
#'
#' @description
#' Format text
#' \itemize{
#' \item replace "NA", "NaN" & empty characters vector by NA
#' \item remove white space at begin & end of each string
#' \item replace " by '
#' }
#' @param chars vector of characters
#'
#' @return vector of characters of same length as parameter chars
#'
#' @examples
#' \dontrun{format_text(c("test 1", "test 2"))}
format_text <- function(chars) {
chars <- stringr::str_trim(chars, side = "both")
chars <- gsub("\"", "'", chars)
chars[which(chars == "NA" | chars == "NaN" | chars == "")] <- NA
chars
}
#' @title Is variable not in a vector?
#'
#' @description
#' Checks if variable x is present in vector.
#'
#' @param x variable
#' @param vec vector
#'
#' @return boolean
`%not in%` <- function (x, vec) is.na(match(x, vec, nomatch=NA_integer_))
#' @title Format integers
#'
#' @description
#' Format & check integers
#' \itemize{
#' \item convert into characters if needed
#' \item convert into numeric if needed
#' \item check if no digits
#'}
#'
#' @param integers vector of integers
#'
#' @return vector with integers, filled with NA values if cannot get the number
#'
#' @examples
#' \dontrun{format_int(c(42, 404))}
format_int <- function(integers) {
if (class(integers) == "factor") integers <- as.character(integers)
if (class(integers) == "character") integers <- as.numeric(integers)
integers[which(integers %% 1 != 0 | is.na(integers))] <- NA
integers
}
#' @title Remove row with NA
#'
#' @description
#' Remove row in dataframe or matrix with NA values(s)
#'
#' @param df dataframe or matrix
#'
#' @return dataframe or matrix
#'
#' @examples
#' \dontrun{na_row_omit(mtcars)}
na_row_omit <- function(df) df[which(sapply(df, function(x) !any(is.na(x)))), ]
#' @describeIn stringr::str_detect ignore NA values
str_detect <- function(string, pattern, negate = FALSE) {
valid <- rep(FALSE, length(string))
valid[which(!is.na(string))] <- stringr::str_detect(
string[which(!is.na(string))], pattern, negate)
valid
}
#' @title Bind columns of two dataframes or matrices
#'
#' @description Bind columns of two dataframe or matrices, if one of them contains no row it will return an empty dataframe
#'
#' @param df1 dataframe or matrix
#' @param df2 dataframe or matrix
#'
#' @return dataframe or matrix
#'
cbind_forced <- function(df1, df2) {
if (nrow(df1) == 0 | nrow(df2) == 0) data.frame()
else cbind(df1, df2)
}
#' @title Custom trycatch block
#'
#' @description
#' Custom trycatch block, print a message according type of the error
#' the invalid_args class error is always an arg failure
#' the invalid class error is when an error is expected & the function must be stopped
#' the error class is in the case of an unexpected error: it will record all parameters & the function where it happened
#'
#' @param expr R expression to try
#' @param params a list with the function name & the parameters used to record in a RDS file
#' @param return_object the object to return if the R expression doesn't work
#' @param shiny boolean, use of sweetAlert from shinyWidgets pkg or not (only if a shiny session existed)
#'
#' @return the return_object argument
#'
#' @examples
#' \dontrun{try_it(check_arg("NA" != "a", "NA is always NA"),
#' list(func = "try_it", params = list(`NA`= "a")), FALSE)}
try_it <- function(expr, params, return_object = NULL, shiny = FALSE) {
tryCatch(expr
, invalid_args = function(e) return_object
, invalid = function(e) {
if (shiny) shinytoastr::toastr_error(e$message, position = "top-center")
else message(e$message)
return_object
}, error = function(e) {
if (shiny) shinyWidgets::show_alert(title = "Error", text = e$message,
type = "error", showCloseButton = TRUE)
message(e)
rds_dir <- utils::choose.dir(default = "~", caption = "Choose the directory where to record the error file")
if (!is.na(rds_dir)) {
rds_path <- file.path(rds_dir, "metabSeek_error.rds")
saveRDS(params, rds_path)
msg <- sprintf("Please send me the file %s at sebastien.hutinet@gmail.com to help me fix this", rds_path)
if (shiny) shinyWidgets::show_alert(title = "Error", text = msg,
type = "error", showCloseButton = TRUE)
message(msg)
}
return_object
})
}
# Allow to create error classes
condition <- function(subclass, message, call=sys.call(-1), ...){
structure(
class=c(subclass, "condition"),
list(message=message, call=call),
...
)
}
custom_stop <- function(subclass, message, call=sys.call(-1), ...){
c <- condition(c(subclass, "error"), message, call=call, ...)
stop(c)
}
#' @title Check R expression(s)
#'
#' @description
#' Reject an invalid error (custom class error) if any R expression is false
#'
#' @param exprs vector of boolean(s) or vector of R expression(s) which return boolean
#' @param msgs vector of string, message(s) to print to the console
#'
#' @examples
#' \dontrun{check_arg(c(is.numeric("a"), is.numeric(1)),
#' c("\"a\" is not a numeric", "1 is not numeric"))}
check_args <- function(exprs, msgs) {
if (any(!exprs)) {
sapply(paste("Error:", msgs[which(!exprs)], message))
custom_stop("invalid_args", paste(msgs[which(!exprs)], collapse = "\n"))
}
}
#' @title Check shiny inputs
#'
#' @description
#' Reject an invalid error (custom class error) if any R expression is false
#' also use shinytoastr & shinyFeedback to alert user
#'
#' @param inputs vector of character(s) representing name(s) of the input(s)
#' @param exprs vector of boolean(s) or vector of R expression(s) which return boolean
#' @param msgs vector of string, message(s) to show to the user
#'
#' @examples
#' \dontrun{check_inputs(c("tol", "units"),
#' c(input$tol >= 0, input$units %in% c("mda", "ppm")),
#' c("Tolerance must be positive", "mDa or ppm unit only supported"))}
check_inputs <- function(inputs, exprs, msgs) {
if (any(exprs)) sapply(inputs[which(exprs)], shiny_valid)
if (any(!exprs)) {
sapply(which(!exprs), function(i) shiny_error(inputs[i], msgs[i]))
custom_stop("invalid_args", paste(msgs[which(!exprs)], collapse = "\n"))
}
}
#' @title Show error message
#'
#' @description
#' Show an error message in a shiny session with the shinyFeedback & shinytoastr pkg
#'
#' @param input character, name of the input
#' @param msg character, msg to show to the user
#'
#' @examples
#' \dontrun{shiny_error("tol", "tolerance must be a positive number")}
shiny_error <- function(input, msg) {
if (input != "") {
shinytoastr::toastr_error(msg, position = "top-center", preventDuplicates = TRUE)
shinyFeedback::showFeedbackDanger(input, msg)
}
}
#' @title Show a validation message
#'
#' @description
#' For now only use shinyFeedback to hide alerts
#'
#' @param input character, name of the input
shiny_valid <- function(input) if (input != "") shinyFeedback::hideFeedback(input)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.