R/FUN.R

In shutinet/MetaboSeeker: Search in several databases metabolites masses or spectras

#' @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
#'
#' @export
#' @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, "MetaboSeeker_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
#'
#' @export
#' @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)