R/utils.R

In abodein/timeOmics_BioC: Time-Course Multi-Omics data integration

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)
}

is_almostInteger_vector <- function(X){
    if(!is.vector(X) || is.list(X)){
        return(FALSE)
    }
    # if(!is.numeric(X) & !is.vector(X)) return(FALSE)
    #return(all(sapply(X, is_almostInteger)))
    return(all(vapply(X, is_almostInteger, logical(1))))
}

is_almostInteger_list <- function(X){
    if(!is.list(X)) return(FALSE)
    # if(!is.numeric(X) & !is.vector(X)) return(FALSE)
    # return(all(sapply(X, is_almostInteger)))
    return(all(vapply(X, is_almostInteger, logical(1))))
}



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) <- 1:nrow(X)
    }
    if(is.null(colnames(X))){
        colnames(X) <- paste0("V", 1:ncol(X))
    }
    return(X)
}


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

validate_matrix_Y <- function(Y){
    # X should be a numeric matrix
    Y <- check_matrix(Y)
    if(!is.numeric(Y)){
        stop("Y must be a numeric matrix/data.frame")
    }
    # if(any(!Y)) stop("Y must be a numeric matrix/data.frame")
    return(Y)
}

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

validate_ncomp <- function(ncomp, X){
    # ncomp should be a positive non-null integer
    # lower than ncol(X)
    nrow_X <- ifelse(is.list(X), nrow(X[[1]]), nrow(X))
    ncomp.max <- min(unlist(lapply(X,function(x)ncol(x))), nrow_X)
    if(is.list(X)){
        ncomp.max <- min(ncomp.max, ncol(X))
    }
    if(!is_almostInteger(ncomp)){
        stop(paste0("'ncomp' should be an integer between 1 and ", ncomp.max))
    }
    if(ncomp > ncomp.max || ncomp==0){
        stop(paste0("'ncomp' should be an integer between 1 and ", ncomp.max))
    }
    ncomp <- round(ncomp)
    return(ncomp)
}

validate_test_keepX <- function(test.keepX, X){
    # test.keepX should be a vecter of positive integer of size > 1
    # every value of test.keepX should be lower than ncol(X)
    # ncomp and X have already been validate
    if(is.null(test.keepX)){
        test.keepX <- ncol(X)
    }
    if(!is_almostInteger_vector(test.keepX)){
        stop("'test.keepX' should be numeric")
    }
    if(any(test.keepX>ncol(X))){
        stop(paste0("'test.keepX' must be lower than ", ncol(X), ", ncol(X)"))
    }
    return(sort(unique(test.keepX)))
}

validate_test_keepY <- function(test.keepY, Y){
    # test.keepX should be a vecter of positive integer of size > 1
    # every value of test.keepX should be lower than ncol(X)
    # ncomp and X have already been validate
    if(is.null(Y)){  # case of keepY null in block spls
        return(NULL)
    } else {
        if(is.null(test.keepY)){
            test.keepY <- ncol(Y)
        }
        if(!is_almostInteger_vector(test.keepY)){
            stop("'test.keepY' should be numeric")
        }
        if(any(test.keepY>ncol(Y))){
            stop(paste0("'test.keepY' must be lower than ", ncol(Y), ", ncol(Y)"))
        }
    }
    return(sort(unique(test.keepY)))
}

validate_test_list_keepX <- function(test.keepX, ncomp, X){
    # for block spls
    # same length of X (list)
    # if (is.null(test.keepX)) {
    #     test.keepX = lapply(seq_along(X), function(x) {
    #         c(5, 10, 15)[which(c(5, 10, 15) < ncol(X[[x]]))]
    #     })
    #     names(test.keepX) = names(X)
    # }
    if(is.null(test.keepX)){
        stop(paste0("'test.list.keepX' must be a list of numeric of size ", length(X), "."))
    }
    if(is_almostInteger_list(test.keepX)){
        stop(paste0("'test.list.keepX' must be a list of numeric of size ", length(X), "."))
    }
    if(!(all(names(test.keepX) %in% names(X)) && all(names(X) %in% names(test.keepX)))){
        stop("'list.test.keepX' should have the same names as X")
    }
    lapply(1:length(X), function(i){
        if(any(ncol(X[[i]]) < test.keepX[[i]])){
            stop(paste0("'test.list.keepX[[",i,"]] sould be lower than ",ncol(X[[i]]),", ncol(X[[",i,"]])."))
        }
    })
    test.keepX <- lapply(test.keepX, function(x){x})
    return(test.keepX)
}

validate_indY <- function(indY, X){
    # X already checked
    if(is.null(indY)){
        stop(paste0("'indY' must be a numeric value lower or equal to ", length(X), ", the number of blocks in X."))
    }
    if(!is_almostInteger(indY) | !(indY %in% c(1:length(X))) ){
        stop(paste0("'indY' must be a numeric value lower or equal to ", length(X), ", the number of blocks in X."))
    }
    return(indY)
}

sd_new <- function(x, ...){
    if(length(x) == 1){
        return(0)
    }else{
        return(sd(x, ...))
    }
}

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

check_legend.block.name <- function(legend.block.name, cluster){
    stopifnot(is(legend.block.name, "character"))
    stopifnot(is(legend.block.name, "vector"))
    
    # cluster <- getCluster(...)
    size_block <- unique(cluster$block)
    stopifnot(length(legend.block.name) == length(size_block))
}