R/utils.R

In abodein/netOmics: Multi-Omics (time-course) network-based integration and interpretation

# from timeOmics
check_matrix <- function(X){
  # add rownames and colnames if absent, cast into matrix
  if(!(is.matrix(X) || is.data.frame(X))) return(FALSE)
  
  if(is.data.frame(X)){
    X <- as.matrix(X)
  }
  if(is.null(rownames(X))){
    rownames(X) <- seq_len(nrow(X))
  }
  if(is.null(colnames(X))){
    colnames(X) <- paste0("V", seq_len(ncol(X)))
  }
  return(X)
}

validate_matrix_X <- function(X, var.name = "'X' "){
  # X should be a numeric matrix
  X <- check_matrix(X)
  if(!is.numeric(X)){
    stop(var.name,"must be a numeric matrix/data.frame")
  }
  # if(any(!X)) stop("X must be a numeric matrix/data.frame")
  return(X)
}

validate_list_matrix_X <- function(X, var.name = "'X' "){
  if(!is.list(X)){
    stop(var.name, "must be a list of matrix/data.frame")
  }
  X <- lapply(X, validate_matrix_X)
  return(X)
}

# is_almostInteger <- function (X) 
# {
#     if (!is.numeric(X) & !is.vector(X)) 
#         return(FALSE)
#     if (length(X) != 1) 
#         return(FALSE)
#     if (!is.finite(X)) 
#         return(FALSE)
#     X.round <- round(X)
#     if (X == X.round) 
#         return(TRUE)
#     return(FALSE)
# }

#' @importFrom methods is
check_getCluster <- function(X){
  if(!(is(X, "cluster.df") || is.null(X))){
    stop("cluster must be NULL or a result from getCluster()")
  }
  #stopifnot(is(X, "cluster.df") || is.null(X))
  return(X)
}

check_graph <- function(X){
  stopifnot(is(X, "igraph") || 
              is(X, "grn") || 
              is.list(X) || 
              is(X, "list.igraph"))
  
  if(is(X, "list")){
    stopifnot(all(as.logical(lapply(X, 
                                    function(x) {is(x, "igraph") || 
                                        is(x, "list.igraph")}))))
    class(X) <- c("list.igraph", class(X))
  }
  return(X)
}

check_db <- function(X, var.name = "'db' "){
  # ADD list of db
  # x is a dataframe with 2 columns (from, to) or igraph
  if(!(is(X, "igraph") || is(X, "data.frame"))){
    stop(var.name, "must be an igraph or data.frame object")
  }
  if(is(X, "data.frame") & !(all(c("from", "to") %in% colnames(X)))){
    stop(var.name, "must contains the columns 'from' and 'to'")
  }
  return(X)
}

#' @importFrom purrr is_empty
#' @importFrom stats na.omit
check_vector_char <- function(X, 
                              X.length = NULL, 
                              default = NULL, 
                              var.name = "'X' "){
  if(is.null(X)){
    return(default)
  }
  
  # remove NA
  X <- na.omit(X)
  if(is_empty(X)){
    return(default)
  } else if(!is.character(X)){
    stop(var.name, "must be a charactor vector")
  } else if(!is.null(X.length)){
    if(length(X) != X.length){
      stop("invalid length")
    } else { # good length
      return(X)
    }
  } else{
    return(X)
  }
  #    return(default)
}

return_true_false <- function(x, default){
  if(is.logical(x)){
    if(is.finite(x)){
      return(x)
    } else { #NA
      return(default)
    }
  } else {
    return(default)
  }
}


check_single_numeric_value <- function(x, 
                                       min = NULL, 
                                       max = NULL, 
                                       var.name = "'r' "){
  if(!is.numeric(x) & !is.matrix(x) & length(x) == 1){
    stop(var.name, "must be a numeric value")
  }
  if(!is.null(min) & !is.null(max)){
    if(x < min | x > max){
      # internal, no need to check min and max order
      stop(var.name, "must be a numeric value between ", min, " and ", max)
    }
  }
  return(x)
}

check_named_vector <- function(X, var.name = "'X' "){
  if(!(is(X, 'list') | is(X, "atomic"))){
    stop(var.name, "must be a named verctor or list")
  }
  if(is.null(names(X))){
    stop(var.name, "must be a named verctor or list")
  }
  return(X)
}