cute_little_R_functions.R 616 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
8001
}
Gael  MILLOT's avatar
Gael MILLOT committed
8002
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.unknown.dots", "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8003
8004
8005
8006
8007
8008
8009
8010
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 UNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
8011
8012
8013
8014
}
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8015
8016
# end plot
tempo.list <- list(data1.removed.row.nb = data1.removed.row.nb, data1.removed.rows = data1.removed.rows, data2.removed.row.nb = data2.removed.row.nb, data2.removed.rows = data2.removed.rows, hframe = hframe, vframe = vframe, data1.signif.dot = data1.signif.dot, data1.non.signif.dot = data1.non.signif.dot, data1.inconsistent.dot = data1.incon.dot, data2.signif.dot = data2.signif.dot, data2.non.signif.dot = data2.non.signif.dot, data2.unknown.dot = data2.unknown.dot, data2.inconsistent.dot = data2.incon.dot, warnings = warning)
Gael  MILLOT's avatar
Gael MILLOT committed
8017
8018
8019
8020
8021
8022
8023
return(tempo.list)
}


################ Import


Gael  MILLOT's avatar
Gael MILLOT committed
8024
######## fun_pack_import() #### check if R packages are present and import into the working environment
Gael  MILLOT's avatar
Gael MILLOT committed
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087


# Check OK: clear to go Apollo
fun_pack_import <- function(req.package, path.lib = NULL){
# AIM
# check if the specified R packages are present in the computer and import them into the working environment
# ARGUMENTS
# req.package: character vector of package names to import
# path.lib: optional character vector specifying the absolute pathways of the directories containing some of the listed packages
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_param_check()
# RETURN
# nothing
# EXAMPLES
# fun_pack_import(req.package = "nopackage")
# fun_pack_import(req.package = "ggplot2")
# fun_pack_import(req.package = "ggplot2", path.lib = "blablabla")
# DEBUGGING
# req.package = "ggplot2" ; path.lib = "C:/Program Files/R/R-3.5.1/library"
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
tempo <- fun_param_check(data = req.package, class = "character", fun.name = function.name) ; eval(ee)
if( ! is.null(path.lib)){
tempo <- fun_param_check(data = path.lib, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(path.lib))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE path.lib PARAMETER DOES NOT EXISTS: ", path.lib, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
}
}
if(any(arg.check) == TRUE){
stop() # nothing else because print = TRUE by default in fun_param_check()
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_param_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_param_check()
# end argument checking
# main code
if(is.null(path.lib)){
path.lib <- .libPaths() # .libPaths(new = path.lib) # or .libPaths(new = c(.libPaths(), path.lib))
}else{
.libPaths(new = sub(x = path.lib, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. Beware: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
}
for(i0 in 1:length(req.package)){
if( ! req.package[i0] %in% rownames(installed.packages(lib.loc = path.lib))){
stop(paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i0], " MUST BE INSTALLED IN:\n", paste(path.lib, collapse = "\n"), "\n\n================\n\n"))
}else{
suppressWarnings(suppressPackageStartupMessages(library(req.package[i0], lib.loc = path.lib, quietly = TRUE, character.only = TRUE)))
}
}
}


Gael  MILLOT's avatar
Gael MILLOT committed
8088
######## fun_python_pack_import() #### check if python packages are present
Gael  MILLOT's avatar
Gael MILLOT committed
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
8117
8118
8119
8120
8121
8122
8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164
8165
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175
8176
8177


# Check OK: clear to go Apollo
fun_python_pack_import <- function(req.package, path.lib = NULL, R.path.lib = NULL){
# AIM
# check if the specified python packages are present in the computer (no import)
# ARGUMENTS
# req.package: character vector of package names to import
# path.lib: optional character vector specifying the absolute pathways of the directories containing some of the listed packages
# R.path.lib: absolute path of the required packages, if not in the default folders
# REQUIRED PACKAGES
# reticulate
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_param_check()
# fun_pack_import()
# RETURN
# nothing
# EXAMPLES
# fun_python_pack_import(req.package = "nopackage")
# fun_python_pack_import(req.package = "serpentine")
# fun_python_pack_import(req.package = "serpentine", path.lib = "blablabla")
# DEBUGGING
# req.package = "serpentine" ; path.lib = "C:/Program Files/R/R-3.5.1/library" ; R.path.lib = NULL
# req.package = "bad" ; path.lib = NULL ; R.path.lib = NULL
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
if(length(find("fun_pack_import", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_pack_import() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
tempo <- fun_param_check(data = req.package, class = "character", fun.name = function.name) ; eval(ee)
if( ! is.null(path.lib)){
tempo <- fun_param_check(data = path.lib, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(path.lib))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE path.lib PARAMETER DOES NOT EXISTS: ", path.lib, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
}
}
if( ! is.null(R.path.lib)){
tempo <- fun_param_check(data = R.path.lib, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(R.path.lib))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE R.path.lib PARAMETER DOES NOT EXISTS: ", R.path.lib, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
}
}
if(any(arg.check) == TRUE){
stop() # nothing else because print = TRUE by default in fun_param_check()
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_param_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_param_check()
# end argument checking
# package checking
fun_pack_import(req.package = "reticulate", path.lib = R.path.lib)
# end package checking
# main code
if(is.null(path.lib)){
path.lib <- reticulate::py_run_string("
import sys ;
path_lib = sys.path
") # python string
path.lib <- path.lib$path_lib
}
for(i0 in 1:length(req.package)){
tempo.try <- vector("list", length = length(path.lib))
for(i1 in 1:length(path.lib)){
tempo.try[[i1]] <- try(suppressWarnings(reticulate::import_from_path(req.package[i0], path = path.lib[i1])), silent = TRUE)
}
if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){
stop(paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i0], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(path.lib, collapse = "\n"), "\n\n================\n\n"))
}else{
assign(req.package[i0], reticulate::import(req.package[i0]))
}
}
}


################ Exporting results (text & tables)


Gael  MILLOT's avatar
Gael MILLOT committed
8178
######## fun_export_data() #### print string or data object into output file
Gael  MILLOT's avatar
Gael MILLOT committed
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
8240
8241
8242
8243
8244
8245
8246
8247
8248
8249
8250
8251
8252
8253
8254
8255
8256
8257
8258
8259
8260
8261
8262
8263
8264
8265
8266
8267
8268
8269
8270
8271
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283


# Check OK: clear to go Apollo
fun_export_data <- function(data = NULL, output ="results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = TRUE, sep = 2){
# AIM
# log file function: print a character string or a data object into a same output file
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_param_check()
# ARGUMENTS
# data: object to print in the output file. cannot be NULL
# output: name of the output file
# path: location of the output file
# no.overwrite: (logical) if output file already exists, defines if the printing is appended (default TRUE) or if the output file content is erased before printing (FALSE)
# rownames.kept: (logical) defines whether row names have to be removed or not in small tables (less than length.rows rows)
# vector.cat (logical). If TRUE print a vector of length > 1 using cat() instead of capture.output(). Otherwise (default FALSE) the opposite
# noquote: (logical). If TRUE no quote are present for the characters
# sep: number of separating lines after printed data (must be integer)
# RETURN
# nothing
# EXAMPLES
# fun_export_data()
# fun_export_data(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = FALSE, sep = 2)
# DEBUGGING
# data = 1:3 ; output = "results.txt" ; path = "C:/Users/Gael/Desktop" ; no.overwrite = TRUE ; rownames.kept = FALSE ; vector.cat = FALSE ; noquote = FALSE ; sep = 2 # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
# argument checking without fun_param_check()
if(is.null(data)){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": data ARGUMENT CANNOT BE NULL\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking without fun_param_check()
# argument checking with fun_param_check()
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
tempo <- fun_param_check(data = output, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & output == ""){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": output ARGUMENT AS \"\" DOES NOT CORRESPOND TO A VALID FILE NAME\n\n================\n\n")
arg.check <- c(arg.check, TRUE)
}
tempo <- fun_param_check(data = path, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & dir.exists(path) == FALSE){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", paste(path, collapse = "\n"),"\n\n================\n\n")
arg.check <- c(arg.check, TRUE)
}
tempo <- fun_param_check(data = no.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = rownames.kept, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = vector.cat, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = noquote, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = sep, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop() # nothing else because print = TRUE by default in fun_param_check()
}
# end argument checking with fun_param_check()
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_param_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_param_check()
# the 4 next lines are inactivated but kept because at a time, I might have a problem with data (solved with data = NULL). These 4 lines are just to know how to detect a missing argument. Important here because if data is not provided, print the code of the data function
# arg.user.list <- as.list(match.call(expand.dots=FALSE))[-1] # recover all the arguments provided by the function user (excluding the argument with defaults values not provided by the user. Thus, it is really the list indicated by the user)
# default.arg.list <- formals(fun = sys.function(sys.parent())) # list of all the arguments of the function with their default values (not the values of the user !). It seems that ls() as first line of the function provide the names of the arguments (empty, called, etc., or not)
# arg.without.default.value <- sapply(default.arg.list, is.symbol) & sapply(sapply(default.arg.list, as.character), identical, "") # logical to detect argument without default values (these are typeof "symbol" and class "name" and empty character
# if( ! all(names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list))){ # test that the arguments with no null values are provided by the user
# tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n")
#stop(tempo.cat)
# }
# end argument checking
# main code
if(all(class(data) %in% c("matrix", "data.frame", "table"))){
if(rownames.kept == FALSE & all(class(data) == "data.frame") & nrow(data) != 0 & nrow(data) <= 4){ # for data frames with nrows <= 4
rownames.output.tables <- ""
length.rows <- nrow(data)
for(i in 1:length.rows){ # replace the rownames of the first 4 rows by increasing number of spaces (beacause identical row names not allowed in data frames). This method cannot be extended to more rows as the printed data frame is shifted on the right because of "big empty rownames"
rownames.output.tables <- c(rownames.output.tables, paste0(rownames.output.tables[i]," ", collapse=""))
}
row.names(data) <- rownames.output.tables[1:length.rows]
}else if(rownames.kept == FALSE & all(class(data) %in% c("matrix", "table"))){
rownames(data) <- rep("", nrow(data)) # identical row names allowed in matrices and tables
}
if(noquote == TRUE){
capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
}
}else if(is.vector(data) & all(class(data) != "list") & (length(data) == 1 | vector.cat == TRUE)){
if(noquote == TRUE){
cat(noquote(data), file= paste0(path, "/", output), append = no.overwrite)
}else{
cat(data, file= paste0(path, "/", output), append = no.overwrite)
}
}else{ # other (array, list, factor or vector with vector.cat = FALSE)
if(noquote == TRUE){
capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
}
}
sep.final <- paste0(rep("\n", sep), collapse = "")
write(sep.final, file= paste0(path, "/", output), append = TRUE) # add a sep
Gael  MILLOT's avatar
Gael MILLOT committed
8284
8285
8286
}