Mercurial > repos > iuc > rgcca

comparison launcher.R @ 1:6bf48c098d36 draft default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
"planemo upload for repository https://github.com/galaxyproject/tools-iuc/tree/master/tools/rgcca commit ce05b5eb018ae1c4d580ab5ce1a33896c1aa8c5b"
author iuc
date Sun, 18 Jul 2021 18:02:32 +0000
parents 4809cae1b724
children
comparison
equal deleted inserted replaced
0:4809cae1b724 1:6bf48c098d36
1 #!/usr/bin/env Rscript
2
1 # Author: Etienne CAMENEN 3 # Author: Etienne CAMENEN
2 # Date: 2020 4 # Date: 2021
3 # Contact: arthur.tenenhaus@centralesupelec.fr 5 # Contact: etienne.camenen@gmail.com
4 # Key-words: omics, RGCCA, multi-block 6 # Key-words: omics, RGCCA, multi-block
5 # EDAM operation: analysis, correlation, visualisation 7 # EDAM operation: analysis, correlation, visualisation
6 # 8 #
7 # Abstract: Performs multi-variate analysis (PCA, CCA, PLS, R/SGCCA, etc.) 9 # Abstract: Performs multi-variate analysis (PCA, CCA, PLS, R/SGCCA, etc.)
8 # and produces textual and graphical outputs (e.g. variables and individuals 10 # and produces textual and graphical outputs (e.g. variables and individuals
72 make_option( 74 make_option(
73 opt_str = "--type", 75 opt_str = "--type",
74 type = "character", 76 type = "character",
75 metavar = "character", 77 metavar = "character",
76 default = opt[2], 78 default = opt[2],
77 help = "Type of analysis [default: %default] (among: rgcca, pca, 79 help = "Type of analysis [default: %default] (among: rgcca, sgcca,
78 cca, gcca, cpca-w, hpca, maxbet-b, maxbet, maxdiff-b, maxdiff, 80 pca, spca, pls, spls, cca, ifa, ra, gcca, maxvar, maxvar-b,
79 maxvar-a, maxvar-b, maxvar, niles, r-maxvar, rcon-pca, ridge-gca, 81 maxvar-a, mcoa,cpca-1, cpca-2, cpca-4, hpca, maxbet-b, maxbet,
80 sabscor, ssqcor, ssqcor, ssqcov-1, ssqcov-2, ssqcov, sum-pca, 82 maxdiff-b, maxdiff, maxvar-a, sabscor, ssqcor, ssqcov-1, ssqcov-2,
81 sumcor, sumcov-1, sumcov-2, sumcov)" 83 ssqcov, sumcor, sumcov-1, sumcov-2, sumcov, sabscov, sabscov-1,
84 sabscov-2)"
82 ), 85 ),
83 make_option( 86 make_option(
84 opt_str = "--ncomp", 87 opt_str = "--ncomp",
85 type = "character", 88 type = "character",
86 metavar = "integer list", 89 metavar = "integer list",
243 ) 246 )
244 ) 247 )
245 return(optparse::OptionParser(option_list = option_list)) 248 return(optparse::OptionParser(option_list = option_list))
246 } 249 }
247 250
248 char_to_list <- function(x) {
249 strsplit(gsub(" ", "", as.character(x)), ",")[[1]]
250 }
251
252 check_arg <- function(opt) { 251 check_arg <- function(opt) {
253 # Check the validity of the arguments opt : an optionParser object 252 # Check the validity of the arguments opt : an optionParser object
254 253
255 if (is.null(opt$datasets)) 254 if (is.null(opt$datasets))
256 stop_rgcca(paste0("datasets is required."), exit_code = 121) 255 stop_rgcca(paste0("datasets is required."), exit_code = 121)
315 for (x in c("compx", "compy")) 314 for (x in c("compx", "compy"))
316 opt[[x]] <- check_compx(x, opt[[x]], rgcca$call$ncomp, opt$block) 315 opt[[x]] <- check_compx(x, opt[[x]], rgcca$call$ncomp, opt$block)
317 316
318 return(opt) 317 return(opt)
319 } 318 }
320
321 check_integer <- function(x, y = x, type = "scalar", float = FALSE, min = 1) {
322
323 if (is.null(y))
324 y <- x
325
326 if (type %in% c("matrix", "data.frame"))
327 y_temp <- y
328
329 y <- suppressWarnings(as.double(as.matrix(y)))
330
331 if (any(is.na(y)))
332 stop_rgcca(paste(x, "should not be NA."))
333
334 if (!is(y, "numeric"))
335 stop_rgcca(paste(x, "should be numeric."))
336
337 if (type == "scalar" && length(y) != 1)
338 stop_rgcca(paste(x, "should be of length 1."))
339
340 if (!float)
341 y <- as.integer(y)
342
343 if (all(y < min))
344 stop_rgcca(paste0(x, " should be higher than or equal to ", min, "."))
345
346 if (type %in% c("matrix", "data.frame"))
347 y <- matrix(
348 y,
349 dim(y_temp)[1],
350 dim(y_temp)[2],
351 dimnames = dimnames(y_temp)
352 )
353
354 if (type == "data.frame")
355 as.data.frame(y)
356
357 return(y)
358 }
359
360 load_libraries <- function(librairies) {
361 for (l in librairies) {
362 if (!(l %in% installed.packages()[, "Package"]))
363 utils::install.packages(l, repos = "cran.us.r-project.org")
364 suppressPackageStartupMessages(
365 library(
366 l,
367 character.only = TRUE,
368 warn.conflicts = FALSE,
369 quietly = TRUE
370 ))
371 }
372 }
373
374 stop_rgcca <- function(
375 message,
376 exit_code = "1",
377 call = NULL) {
378
379 base::stop(
380 structure(
381 class = c(exit_code, "simpleError", "error", "condition"),
382 list(message = message, call. = NULL)
383 ))
384 }
385 319
386 ########## Main ########## 320 ########## Main ##########
387 321
388 # Get arguments : R packaging install, need an opt variable with associated 322 # Get arguments : R packaging install, need an opt variable with associated
389 # arguments 323 # arguments
409 c("agriculture", "industry", "politic"), 343 c("agriculture", "industry", "politic"),
410 ".tsv", 344 ".tsv",
411 collapse = ",") 345 collapse = ",")
412 ) 346 )
413 347
414 load_libraries(c("ggplot2", "optparse", "scales", "igraph", "MASS", "rlang", "Deriv")) 348 # Load functions
349 all_funcs <- unclass(lsf.str(envir = asNamespace("RGCCA"), all = TRUE))
350 for (i in all_funcs)
351 eval(parse(text = paste0(i, "<-RGCCA:::", i)))
352
353 load_libraries(c("ggplot2", "optparse", "scales", "igraph", "MASS", "Deriv"))
415 try(load_libraries("ggrepel"), silent = TRUE) 354 try(load_libraries("ggrepel"), silent = TRUE)
416 355
417 tryCatch( 356 tryCatch(
418 opt <- check_arg(optparse::parse_args(get_args())), 357 opt <- check_arg(optparse::parse_args(get_args())),
419 error = function(e) { 358 error = function(e) {
421 stop_rgcca(e[[1]], exit_code = 140) 360 stop_rgcca(e[[1]], exit_code = 140)
422 }, warning = function(w) 361 }, warning = function(w)
423 stop_rgcca(w[[1]], exit_code = 141) 362 stop_rgcca(w[[1]], exit_code = 141)
424 ) 363 )
425 364
426 # Load functions
427 all_funcs <- unclass(lsf.str(envir = asNamespace("RGCCA"), all = T))
428 for (i in all_funcs)
429 eval(parse(text = paste0(i, "<-RGCCA:::", i)))
430
431 # Set missing parameters by default 365 # Set missing parameters by default
432 opt$header <- !("header" %in% names(opt)) 366 opt$header <- !("header" %in% names(opt))
433 opt$superblock <- !("superblock" %in% names(opt)) 367 opt$superblock <- !("superblock" %in% names(opt))
434 opt$scale <- !("scale" %in% names(opt)) 368 opt$scale <- !("scale" %in% names(opt))
435 opt$text <- !("text" %in% names(opt)) 369 opt$text <- !("text" %in% names(opt))
370 cex_lab <- 20
371 cex_main <- 25
372 cex_point <- 3
373 cex_sub <- 20
374 cex_axis <- 10
375 cex <- 1.25
436 376
437 status <- 0 377 status <- 0
438 tryCatch({ 378 tryCatch({
439 379
440 blocks <- load_blocks(opt$datasets, opt$names, opt$separator) 380 blocks <- load_blocks(opt$datasets, opt$names, opt$separator)
448 response = opt$response, 388 response = opt$response,
449 superblock = opt$superblock, 389 superblock = opt$superblock,
450 ncomp = opt$ncomp, 390 ncomp = opt$ncomp,
451 scheme = opt$scheme, 391 scheme = opt$scheme,
452 scale = opt$scale, 392 scale = opt$scale,
453 type = opt$type 393 method = opt$type
454 ) 394 )
455 ) 395 )
456 if (tolower(opt$type) %in% c("sgcca", "spca", "spls")) { 396 if (tolower(opt$type) %in% c("sgcca", "spca", "spls")) {
457 func[["sparsity"]] <- opt$penalty 397 func[["sparsity"]] <- opt$penalty
458 }else { 398 }else {
475 opt$compx, 415 opt$compx,
476 opt$compy, 416 opt$compy,
477 opt$block, 417 opt$block,
478 opt$text, 418 opt$text,
479 opt$block_y, 419 opt$block_y,
480 "Response" 420 "Response",
421 cex_lab = cex_lab,
422 cex_point = cex_point,
423 cex_main = cex_main,
424 cex = cex
481 ) 425 )
482 ) 426 )
483 save_plot(opt$o1, individual_plot) 427 save_plot(opt$o1, individual_plot)
484 } 428 }
485 429
489 rgcca_out, 433 rgcca_out,
490 opt$compx, 434 opt$compx,
491 opt$compy, 435 opt$compy,
492 opt$block, 436 opt$block,
493 opt$text, 437 opt$text,
494 n_mark = opt$nmark 438 n_mark = opt$nmark,
439 cex_lab = cex_lab,
440 cex_point = cex_point,
441 cex_main = cex_main,
442 cex = cex
495 ) 443 )
496 ) 444 )
497 save_plot(opt$o2, corcircle) 445 save_plot(opt$o2, corcircle)
498 } 446 }
499 447
500 top_variables <- plot_var_1D( 448 top_variables <- plot_var_1D(
501 rgcca_out, 449 rgcca_out,
502 opt$compx, 450 opt$compx,
503 opt$nmark, 451 opt$nmark,
504 opt$block, 452 opt$block,
505 type = "cor" 453 type = "loadings",
454 title = paste0("Variable correlations", ": ", names(rgcca_out$call$blocks)[opt$block], " with "),
455 cex_sub = cex_sub,
456 cex_main = cex_main,
457 cex_axis = cex_axis,
458 cex = cex
506 ) 459 )
507 save_plot(opt$o3, top_variables) 460 save_plot(opt$o3, top_variables)
508 461
509 # Average Variance Explained 462 # Average Variance Explained
510 (ave <- plot_ave(rgcca_out)) 463 (ave <- plot_ave(
464 rgcca_out,
465 cex_main = cex_main,
466 cex_sub = cex_sub,
467 cex_axis = cex_axis,
468 cex = cex))
511 save_plot(opt$o4, ave) 469 save_plot(opt$o4, ave)
512 470
513 # Creates design scheme 471 # Creates design scheme
514 design <- function() plot_network(rgcca_out) 472 design <- function() plot_network(
473 rgcca_out,
474 cex_main = cex_main,
475 cex_point = cex_point,
476 cex = cex)
515 save_plot(opt$o5, design) 477 save_plot(opt$o5, design)
516 478
517 save_ind(rgcca_out, opt$compx, opt$compy, opt$o6) 479 save_ind(rgcca_out, opt$o6)
518 save_var(rgcca_out, opt$compx, opt$compy, opt$o7) 480 save_var(rgcca_out, opt$o7)
519 save(rgcca_out, file = opt$o8) 481 save(rgcca_out, file = opt$o8)
520 482
521 }, error = function(e) { 483 }, error = function(e) {
522 if (class(e)[1] %in% c("simpleError", "error", "condition")) 484 if (class(e)[1] %in% c("simpleError", "error", "condition"))
523 status <<- 1 485 status <<- 1
524 else 486 else
525 status <<- class(e)[1] 487 status <<- class(e)[1]
488 msg <- "The design matrix C"
489 if (grepl(msg, e$message)) {
490 e$message <- gsub(msg, "The connection file", e$message)
491 }
526 message(e$message) 492 message(e$message)
527 }) 493 })
528 quit(status = status) 494 quit(status = status)