diff --git a/cute_little_R_functions.R b/cute_little_R_functions.R index ec771eafd63c0d3ecde07763912f4044687e1948..11581c9624519ec2f2d3630557f64edd7fe625ee 100644 --- a/cute_little_R_functions.R +++ b/cute_little_R_functions.R @@ -1861,18 +1861,19 @@ cute.path = "C:\\Users\\Gael\\Documents\\Git_projects\\cute_little_R_functions\\ # REQUIRED PACKAGES # lubridate # parallel if thread.nb argument is not NULL (included in the R installation packages but not automatically loaded) -# if the tested function is in a package, this package must be imported first (no parallelization) or must be in the classical R package folder indicated by the lib.path argument (parallelization) +# pdftools if thread.nb argument is not NULL (included in the R installation packages but not automatically loaded) +# If the tested function is in a package, this package must be imported first (no parallelization) or must be in the classical R package folder indicated by the lib.path argument (parallelization) # RETURN # if export is FALSE a list containing: # $fun: the tested function +# $instruction: the initial instruction +# $sys.info: system and packages info # $data: a data frame of all the combination tested, containing the following columns: # the different values tested, named by arguments # $kind: a vector of character strings indicating the kind of test result: either "ERROR", or "WARNING", or "OK" # $problem: a logical vector indicating if error or not # $expected.error: optional logical vector indicating the expected error specified in the expect.error argument # $message: either NULL if $kind is always "OK", or the messages -# $instruction: the initial instruction -# $sys.info: system and packages info # if export is TRUE 1) the same list object into a .RData file, 2) also the $data data frame into a .txt file, and 3) if expect.error is non NULL and if any discrepancy, the $data data frame into a .txt file but containing only the rows with discrepancies between expected and observed errors # one or several pdf if a plotting function is tested and if the plot.fun argument is TRUE # REQUIRED PACKAGES @@ -2069,7 +2070,7 @@ warning(paste0("\n", tempo.cat, "\n"), call. = FALSE) } # end second round of checking and data preparation # package checking -fun_pack(req.package = c("lubridate"), lib.path = lib.path) +fun_pack(req.package = c("lubridate", "pdftools"), lib.path = lib.path) if( ! is.null(thread.nb)){ fun_pack(req.package = c("parallel"), lib.path = lib.path) } @@ -2368,6 +2369,8 @@ window.nb <- dev.cur() invisible(dev.set(window.nb)) # end plot management # new environment +ini.date <- Sys.time() +ini.time <- as.numeric(ini.date) # time of process begin, converted into env.name <- paste0("env", ini.time) if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE") @@ -2377,8 +2380,6 @@ assign(env.name, new.env()) assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val } # end new environment -ini.date <- Sys.time() -ini.time <- as.numeric(ini.date) # time of process begin, converted into print.count.loop <- 0 suppressMessages(suppressWarnings(eval(parse(text = code)))) colnames(data) <- arg @@ -2393,7 +2394,7 @@ sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # invisible(dev.off(window.nb)) rm(env.name) # optional, because should disappear at the end of the function execution # output -output <- list(fun = fun, data = data, instruction = instruction, sys.info = sys.info) +output <- list(fun = fun, instruction = instruction, sys.info = sys.info) # data = data finally removed from the output list, because everything combined in a RData file at the end save(output, file = paste0(res.path, "/fun_test_", x[1], ifelse(base::length(x) == 1L, ".RData", paste0("-", x[base::length(x)], ".RData")))) if(plot.fun == TRUE & plot.count == 0L){ warn.count <- warn.count + 1 @@ -2401,26 +2402,90 @@ tempo.warn <- paste0("(", warn.count,") IN PROCESS ", process.id, ": NO PDF PLOT warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) file.remove(paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".pdf", paste0("-", x[base::length(x)], ".pdf")))) } -table.out <- as.matrix(output$data) +table.out <- as.matrix(data) # table.out[table.out == ""] <- " " # does not work # because otherwise read.table() converts "" into NA table.out <- gsub(table.out, pattern = "\n", replacement = " ") write.table(table.out, file = paste0(res.path, "/table_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".txt", paste0("-", x[base::length(x)], ".txt"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n") } ) parallel::stopCluster(Clust) -# txt files assembly +# files assembly if(base::length(cluster.list) > 1){ for(i2 in 1:base::length(cluster.list)){ -tempo.name <- paste0(res.path, "/table_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".txt", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".txt"))) -tempo <- read.table(file = tempo.name, header = TRUE, stringsAsFactors = FALSE, sep = "\t", row.names = 1, comment.char = "", colClasses = "character") # row.names = 1 (1st column) because now read.table() adds a NA in the header if the header starts by a tabulation, comment.char = "" because colors with #, colClasses = "character" otherwise convert "" (from NULL) into NA -file.remove(tempo.name) +tempo.file <- paste0(res.path, "/table_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".txt", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".txt"))) # txt file +tempo <- read.table(file = tempo.file, header = TRUE, stringsAsFactors = FALSE, sep = "\t", row.names = 1, comment.char = "", colClasses = "character") # row.names = 1 (1st column) because now read.table() adds a NA in the header if the header starts by a tabulation, comment.char = "" because colors with #, colClasses = "character" otherwise convert "" (from NULL) into NA +if(file.exists(paste0(res.path, "/plots_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".pdf", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".pdf"))))){ +tempo.pdf <- paste0(res.path, "/plots_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".pdf", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".pdf"))) # pdf file +}else{ +tempo.pdf <- NULL +} +tempo.rdata <- paste0(res.path, "/fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".RData", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".RData"))) # RData file if(i2 == 1L){ final.file <- tempo +final.pdf <- tempo.pdf +# new env for RData combining +env.name <- paste0("env", ini.time) +if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function +tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE") +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == +# end new env for RData combining }else{ -final.file <- rbind(final.file, tempo, stringsAsFactors = TRUE) +assign(env.name, new.env()) +load(tempo.rdata, envir = get(env.name)) +tempo.rdata1 <- tempo.rdata +assign("final.output", get("output", envir = get(env.name)), envir = get(env.name)) } +}else{ +final.file <- rbind(final.file, tempo, stringsAsFactors = TRUE) +final.pdf <- c(final.pdf, tempo.pdf) +load(tempo.rdata, envir = get(env.name)) +if( ! identical(get("final.output", envir = get(env.name))[c("R.version", "locale", "platform")], get("output", envir = get(env.name))[c("R.version", "locale", "platform")])){ +tempo.cat <- paste0("ERROR IN ", function.name, ": DIFFERENCE BETWEEN OUTPUTS WHILE THEY SHOULD BE IDENTICAL\nPLEASE CHECK\n", tempo.rdata1, "\n", tempo.rdata) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == +}else{ +# add the differences in RData $sysinfo into final.output +tempo.base1 <- sort(get("final.output", envir = get(env.name))$sys.info$basePkgs) +tempo.base2 <- sort(get("output", envir = get(env.name))$sys.info$basePkgs) +tempo.other1 <- names(get("final.output", envir = get(env.name))$sys.info$otherPkgs) +tempo.other2 <- names(get("output", envir = get(env.name))$sys.info$otherPkgs) +tempo.loaded1 <- names(get("final.output", envir = get(env.name))$sys.info$loadedOnly) +tempo.loaded2 <- names(get("output", envir = get(env.name))$sys.info$loadedOnly) +assign("final.output", { +x <- get("final.output", envir = get(env.name)) +y <- get("output", envir = get(env.name)) +x$sys.info$basePkgs <- sort(unique(tempo.base1, tempo.base2)) +if( ! all(tempo.other2 %in% tempo.other1)){ +x$sys.info$otherPkgs <- c(x$sys.info$otherPkgs, y$sys.info$otherPkgs[ ! (tempo.other2 %in% tempo.other1)]) +x$sys.info$otherPkgs <- x$sys.info$otherPkgs[order(names(x$sys.info$otherPkgs))] +} +if( ! all(tempo.loaded2 %in% tempo.loaded1)){ +x$sys.info$loadedOnly <- c(x$sys.info$loadedOnly, y$sys.info$loadedOnly[ ! (tempo.loaded2 %in% tempo.loaded1)]) +x$sys.info$loadedOnly <- x$sys.info$loadedOnly[order(names(x$sys.info$loadedOnly))] +} +x +}, envir = get(env.name)) +# add the differences in RData $sysinfo into final.output +} +} +file.remove(c(tempo.file, tempo.rdata)) +} +# combine pdf and save +if( ! is.null(final.pdf)){ +pdftools::pdf_combine( +input = final.pdf, +output = paste0(res.path, "/plots_from_fun_test_1-", total.comp.nb, ".pdf") +) +file.remove(final.pdf) } +# end combine pdf and save +# save RData +assign("output", c(get("final.output", envir = get(env.name)), data = list(final.file)), envir = get(env.name)) +save(output, file = paste0(res.path, "/fun_test__1-", total.comp.nb, ".RData"), envir = get(env.name)) +rm(env.name) # optional, because should disappear at the end of the function execution +# end save RData +# save txt write.table(final.file, file = paste0(res.path, "/table_from_fun_test_1-", total.comp.nb, ".txt"), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n") +# end save txt if( ! is.null(expect.error)){ final.file <- final.file[ ! final.file$problem == final.file$expected.error, ] if(nrow(final.file) == 0L){ @@ -2431,7 +2496,7 @@ write.table(final.file, file = paste0(res.path, "/discrepancy_table_from_fun_tes } } } -# end txt files assembly +# end files assembly }else{ # plot management if(plot.fun == TRUE){ @@ -2466,7 +2531,7 @@ sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # invisible(dev.off(window.nb)) rm(env.name) # optional, because should disappear at the end of the function execution # output -output <- list(fun = fun, data = data, instruction = instruction, sys.info = sys.info) +output <- list(fun = fun, instruction = instruction, sys.info = sys.info, data = data) if(plot.fun == TRUE & plot.count == 0L){ warn.count <- warn.count + 1 tempo.warn <- paste0("(", warn.count,") NO PDF PLOT BECAUSE ONLY ERRORS REPORTED") diff --git a/cute_little_R_functions.docx b/cute_little_R_functions.docx index 3c8d2dbd513bc9be6dec1f08e5441c3c21b3c1cf..f5a781ea755551fa9b28f5e5c2b4cb941a706895 100644 Binary files a/cute_little_R_functions.docx and b/cute_little_R_functions.docx differ diff --git a/other/cute_checks.docx b/other/cute_checks.docx index cd60936d66265b32f06e392cb4e05ff8c7cf3316..ebb1284521f4b83ab6a42edcb0251a7adc29f63c 100644 Binary files a/other/cute_checks.docx and b/other/cute_checks.docx differ