--- a +++ b/R/utils.R @@ -0,0 +1,192 @@ +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)) +}