R/FUN.R

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

#' @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)