cute_little_R_functions.R 871 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
2001
2002
2003
cute.path
){
# check again: very important because another R
Gael  MILLOT's avatar
Gael MILLOT committed
2004
2005
process.id <- Sys.getpid()
cat(paste0("\nPROCESS ID ", process.id, " -> TESTS ", x[1], " TO ", x[length(x)], "\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
source(cute.path, local = .GlobalEnv)
fun_pack(req.package = "lubridate", lib.path = lib.path, load = TRUE) # load = TRUE to be sure that functions are present in the environment. And this prevent to use R.lib.path argument of fun_python_pack()
# end check again: very important because another R
# plot management
if(plot.fun == TRUE){
pdf(file = paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(length(x) == 1, ".pdf", paste0("-", x[length(x)], ".pdf"))))
}else{
pdf(file = NULL) # send plots into a NULL file, no pdf file created
}
window.nb <- dev.cur()
2016
invisible(dev.set(window.nb))
Gael  MILLOT's avatar
Gael MILLOT committed
2017
2018
2019
# end plot management
# new environment
env.name <- paste0("env", ini.time)
2020
if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
2021
2022
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 ==
Gael  MILLOT's avatar
Gael MILLOT committed
2023
2024
}else{
assign(env.name, new.env())
2025
assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
Gael  MILLOT's avatar
Gael MILLOT committed
2026
2027
2028
2029
}
# end new environment
ini.date <- Sys.time()
ini.time <- as.numeric(ini.date) # time of process begin, converted into 
Gael  MILLOT's avatar
Gael MILLOT committed
2030
print.count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
2031
2032
suppressMessages(suppressWarnings(eval(parse(text = code))))
colnames(data) <- arg
2033
2034
2035
if( ! is.null(expect.error)){
data <- data.frame(data, kind = kind, problem = problem, expected.error = expected.error, message = res, stringsAsFactors = FALSE)
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
2036
data <- data.frame(data, kind = kind, problem = problem, message = res, stringsAsFactors = FALSE)
2037
}
Gael  MILLOT's avatar
Gael MILLOT committed
2038
row.names(data) <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), x))
Gael  MILLOT's avatar
Gael MILLOT committed
2039
sys.info <- sessionInfo()
2040
sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # sort the packages
Gael  MILLOT's avatar
Gael MILLOT committed
2041
2042
2043
invisible(dev.off(window.nb))
rm(env.name) # optional, because should disappear at the end of the function execution
# output
2044
output <- list(fun = fun, data = data, instruction = instruction, sys.info = sys.info)
Gael  MILLOT's avatar
Gael MILLOT committed
2045
2046
save(output, file = paste0(res.path, "/fun_test_", x[1], ifelse(length(x) == 1, ".RData", paste0("-", x[length(x)], ".RData"))))
if(plot.fun == TRUE & plot.count == 0){
2047
2048
2049
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") IN PROCESS ", process.id, ": NO PDF PLOT BECAUSE ONLY ERRORS REPORTED")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
2050
2051
2052
file.remove(paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(length(x) == 1, ".pdf", paste0("-", x[length(x)], ".pdf"))))
}
table.out <- as.matrix(output$data)
2053
# table.out[table.out == ""] <- " " # does not work # because otherwise read.table() converts "" into NA
Gael  MILLOT's avatar
Gael MILLOT committed
2054
2055
2056
2057
2058
table.out <- gsub(table.out, pattern = "\n", replacement = " ")
write.table(table.out, file = paste0(res.path, "/table_from_fun_test_", x[1], ifelse(length(x) == 1, ".txt", paste0("-", x[length(x)], ".txt"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n")
}
)
parallel::stopCluster(Clust)
2059
2060
2061
2062
# txt files assembly
if(length(cluster.list) > 1){
for(i2 in 1:length(cluster.list)){
tempo.name <- paste0(res.path, "/table_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(length(cluster.list[[i2]]) == 1, ".txt", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".txt")))
2063
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
2064
2065
2066
2067
file.remove(tempo.name)
if(i2 == 1){
final.file <- tempo
}else{
2068
final.file <- rbind(final.file, tempo, stringsAsFactors = TRUE)
2069
2070
2071
}
}
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")
2072
2073
2074
2075
2076
2077
2078
2079
2080
if( ! is.null(expect.error)){
final.file <- final.file[ ! final.file$problem == final.file$expected.error, ]
if(nrow(final.file) == 0){
cat(paste0("NO DISCREPANCY BETWEEN EXPECTED AND OBSERVED ERRORS\n\n"))
}else{
cat(paste0("DISCREPANCIES BETWEEN EXPECTED AND OBSERVED ERRORS (SEE THE discrepancy_table_from_fun_test_1-", total.comp.nb, ".txt FILE)\n\n"))
write.table(final.file, file = paste0(res.path, "/discrepancy_table_from_fun_test_1-", total.comp.nb, ".txt"), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n")
}
}
2081
2082
}
# end txt files assembly
Gael  MILLOT's avatar
Gael MILLOT committed
2083
2084
2085
2086
2087
2088
2089
2090
}else{
# plot management
if(plot.fun == TRUE){
pdf(file = paste0(res.path, "/plots_from_fun_test_1", ifelse(total.comp.nb == 1, ".pdf", paste0("-", total.comp.nb, ".pdf"))))
}else{
pdf(file = NULL) # send plots into a NULL file, no pdf file created
}
window.nb <- dev.cur()
2091
invisible(dev.set(window.nb))
Gael  MILLOT's avatar
Gael MILLOT committed
2092
2093
2094
2095
# end plot management
# new environment
env.name <- paste0("env", ini.time)
if(exists(env.name, where = -1)){
2096
2097
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 ==
Gael  MILLOT's avatar
Gael MILLOT committed
2098
2099
}else{
assign(env.name, new.env())
2100
assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
Gael  MILLOT's avatar
Gael MILLOT committed
2101
2102
}
# end new environment
Gael  MILLOT's avatar
Gael MILLOT committed
2103
2104
suppressMessages(suppressWarnings(eval(parse(text = code))))
colnames(data) <- arg
2105
2106
2107
2108
expect.data <- data.frame()
if( ! is.null(expect.error)){
data <- data.frame(data, kind = kind, problem = problem, expected.error = expected.error, message = res, stringsAsFactors = FALSE)
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
2109
data <- data.frame(data, kind = kind, problem = problem, message = res, stringsAsFactors = FALSE)
2110
}
Gael  MILLOT's avatar
Gael MILLOT committed
2111
2112
row.names(data) <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), 1:total.comp.nb))
sys.info <- sessionInfo()
2113
sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # sort the packages
Gael  MILLOT's avatar
Gael MILLOT committed
2114
2115
2116
invisible(dev.off(window.nb))
rm(env.name) # optional, because should disappear at the end of the function execution
# output
2117
output <- list(fun = fun, data = data, instruction = instruction, sys.info = sys.info)
Gael  MILLOT's avatar
Gael MILLOT committed
2118
if(plot.fun == TRUE & plot.count == 0){
2119
2120
2121
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NO PDF PLOT BECAUSE ONLY ERRORS REPORTED")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
2122
file.remove(paste0(res.path, "/plots_from_fun_test_1", ifelse(total.comp.nb == 1, ".pdf", paste0("-", total.comp.nb, ".pdf"))))
Gael  MILLOT's avatar
Gael MILLOT committed
2123
}
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
if( ! is.null(expect.error)){
expect.data <- output$data[ ! output$data$problem == output$data$expected.error, ]
if(nrow(expect.data) == 0){
cat(paste0("NO DISCREPANCY BETWEEN EXPECTED AND OBSERVED ERRORS\n\n"))
}else{
cat(paste0("DISCREPANCIES BETWEEN EXPECTED AND OBSERVED ERRORS (SEE THE ", if(export == TRUE){paste0("discrepancy_table_from_fun_test_1", ifelse(total.comp.nb == 1, "", paste0("-", total.comp.nb)), ".txt FILE")}else{"$data RESULT"}, ")\n\n"))
if(export == TRUE){
expect.data <- as.matrix(expect.data)
expect.data <- gsub(expect.data, pattern = "\n", replacement = "  ")
write.table(expect.data, file = paste0(res.path, "/discrepancy_table_from_fun_test_1", ifelse(total.comp.nb == 1, ".txt", paste0("-", total.comp.nb, ".txt"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n")
}
}
}
2137
if( ! is.null(warn)){
2138
options(warning.length = 8170)
2139
on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
2140
on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
2141
}
Gael  MILLOT's avatar
Gael MILLOT committed
2142
2143
2144
if(export == TRUE){
save(output, file = paste0(res.path, "/fun_test_1", ifelse(total.comp.nb == 1, ".RData", paste0("-", total.comp.nb, ".RData"))))
table.out <- as.matrix(output$data)
2145
table.out <- gsub(table.out, pattern = "\n", replacement = "  ")
Gael  MILLOT's avatar
Gael MILLOT committed
2146
2147
write.table(table.out, file = paste0(res.path, "/table_from_fun_test_1", ifelse(total.comp.nb == 1, ".txt", paste0("-", total.comp.nb, ".txt"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n")
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
2148
return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
2149
}
Gael  MILLOT's avatar
Gael MILLOT committed
2150
}
Gael  MILLOT's avatar
Gael MILLOT committed
2151
2152
2153
end.date <- Sys.time()
end.time <- as.numeric(end.date)
total.lapse <- round(lubridate::seconds_to_period(end.time - ini.time))
2154
cat(paste0("fun_test JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n\n\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
2155
}
Gael  MILLOT's avatar
Gael MILLOT committed
2156

Gael  MILLOT's avatar
Gael MILLOT committed
2157

Gael  MILLOT's avatar
Gael MILLOT committed
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
################ Object modification


######## fun_name_change() #### check a vector of character strings and modify any string if present in another vector


# Check OK: clear to go Apollo
fun_name_change <- function(data1, data2, added.string = "_modif"){
# AIM
# this function allow to check if a vector of character strings, like column names of a data frame, has elements present in another vector (vector of reserved words or column names of another data frame before merging)
# ARGUMENTS
# data1: vector of character strings to check and modify
# data2: reference vector of character strings
# added.string: string added at the end of the modified string in data1 if present in data2
# RETURN
# a list containing
2174
# $data: the modified data1 (in the same order as in the initial data1)
Gael  MILLOT's avatar
Gael MILLOT committed
2175
2176
# $ini: the initial elements before modification. NULL if no modification
# $post: the modified elements in the same order as in ini. NULL if no modification
Gael's avatar
tempo    
Gael committed
2177
2178
2179
2180
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2181
2182
2183
2184
2185
2186
# EXAMPLES
# obs1 <- c("A", "B", "C", "D") ; obs2 <- c("A", "C") ; fun_name_change(obs1, obs2)
# obs1 <- c("A", "B", "C", "C_modif1", "D") ; obs2 <- c("A", "A_modif1", "C") ; fun_name_change(obs1, obs2) # the function checks that the new names are neither in obs1 nor in obs2 (increment the number after the added string)
# DEBUGGING
# data1 = c("A", "B", "C", "D") ; data2 <- c("A", "C") ; added.string = "_modif" # for function debugging
# function name
2187
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2188
2189
2190
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2191
2192
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = data1, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = data2, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = added.string, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# 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_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_check()
# end argument checking
# main code
ini <- NULL
post <- NULL
if(any(data1 %in% data2)){
tempo.names <- data1[data1 %in% data2]
ini <- NULL
post <- NULL
2215
for(i2 in 1:length(tempo.names)){
Gael  MILLOT's avatar
Gael MILLOT committed
2216
count <- 0
2217
tempo <- tempo.names[i2]
Gael  MILLOT's avatar
Gael MILLOT committed
2218
2219
while(any(tempo %in% data2) | any(tempo %in% data1)){
count <- count + 1
2220
tempo <- paste0(tempo.names[i2], "_modif", count)
Gael  MILLOT's avatar
Gael MILLOT committed
2221
}
2222
data1[data1 %in% tempo.names[i2]] <- paste0(tempo.names[i2], "_modif", count)
Gael  MILLOT's avatar
Gael MILLOT committed
2223
if(count != 0){
2224
2225
ini <- c(ini, tempo.names[i2])
post <- c(post, paste0(tempo.names[i2], "_modif", count))
Gael  MILLOT's avatar
Gael MILLOT committed
2226
2227
2228
2229
2230
2231
2232
2233
}
}
data <- data1
}else{
data <- data1
}
output <- list(data = data, ini = ini, post = post)
return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
2234
2235
2236
}


Gael  MILLOT's avatar
Gael MILLOT committed
2237
######## fun_df_remod() #### remodeling a data frame to have column name as a qualitative values and vice-versa
Gael  MILLOT's avatar
Gael MILLOT committed
2238
2239


Gael  MILLOT's avatar
Gael MILLOT committed
2240
# Check OK: clear to go Apollo
Gael's avatar
tempo    
Gael committed
2241
2242
2243
2244
2245
fun_df_remod <- function(
data, 
quanti.col.name = "quanti", 
quali.col.name = "quali"
){
Gael  MILLOT's avatar
Gael MILLOT committed
2246
2247
# AIM
# if the data frame is made of numeric columns, a new data frame is created, with the 1st column gathering all the numeric values, and the 2nd column being the name of the columns of the initial data frame. If row names were present in the initial data frame, then a new ini_rowname column is added with the names of the rows
Gael  MILLOT's avatar
Gael MILLOT committed
2248

Gael  MILLOT's avatar
Gael MILLOT committed
2249
2250
 
# If the data frame is made of one numeric column and one character or factor column, a new data frame is created, with the new columns corresponding to the split numeric values (according to the character column). NA are added a the end of each column to have the same number of rows. BEWARE: in such data frame, rows are not individuals. This means that in the example below, values 10 and 20 are associated on the same row but that means nothing in term of association
Gael  MILLOT's avatar
Gael MILLOT committed
2251

Gael  MILLOT's avatar
Gael MILLOT committed
2252
2253
2254
2255
2256
2257
2258
2259
 

# ARGUMENTS
# data: data frame to convert
# quanti.col.name: optional name for the quanti column of the new data frame
# quali.col.name: optional name for the quali column of the new data frame
# RETURN
# the modified data frame
Gael's avatar
tempo    
Gael committed
2260
2261
2262
2263
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2264
# EXAMPLES
2265
2266
2267
# obs <- data.frame(col1 = (1:4)*10, col2 = c("A", "B", "A", "A"), stringsAsFactors = TRUE) ; obs ; fun_df_remod(obs)
# obs <- data.frame(col1 = (1:4)*10, col2 = 5:8, stringsAsFactors = TRUE) ; obs ; fun_df_remod(obs, quanti.col.name = "quanti", quali.col.name = "quali")
# obs <- data.frame(col1 = (1:4)*10, col2 = 5:8, stringsAsFactors = TRUE) ; rownames(obs) <- paste0("row", 1:4) ; obs ; fun_df_remod(obs, quanti.col.name = "quanti", quali.col.name = "quali")
Gael  MILLOT's avatar
Gael MILLOT committed
2268
# DEBUGGING
2269
2270
2271
2272
2273
2274
# data = data.frame(a = 1:3, b = 4:6, stringsAsFactors = TRUE) ; quanti.col.name = "quanti" ; quali.col.name = "quali" # for function debugging
# data = data.frame(a = 1:3, b = 4:6, c = 11:13, stringsAsFactors = TRUE) ; quanti.col.name = "quanti" ; quali.col.name = "quali" # for function debugging
# data = data.frame(a = 1:3, b = letters[1:3], stringsAsFactors = TRUE) ; quanti.col.name = "quanti" ; quali.col.name = "quali" # for function debugging
# data = data.frame(a = 1:3, b = letters[1:3], stringsAsFactors = TRUE) ; quanti.col.name = "TEST" ; quali.col.name = "quali" # for function debugging
# data = data.frame(b = letters[1:3], a = 1:3, stringsAsFactors = TRUE) ; quanti.col.name = "quanti" ; quali.col.name = "quali" # for function debugging
# data = data.frame(b = c("e", "e", "h"), a = 1:3, stringsAsFactors = TRUE) ; quanti.col.name = "quanti" ; quali.col.name = "quali" # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
2275
# function name
2276
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2277
2278
2279
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2280
2281
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2282
2283
2284
2285
2286
}
# end required function checking
# argument checking
# argument checking without fun_check()
if( ! any(class(data) %in% "data.frame")){
2287
2288
tempo.cat <- paste0("ERROR IN ", function.name, ": THE data ARGUMENT MUST BE A DATA FRAME")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
}
# end argument checking without fun_check()
# argument checking with fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = quanti.col.name, class = "character", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = quali.col.name, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end argument checking with fun_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_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_check()
# end argument checking
# main code
tempo.factor <- unlist(lapply(data, class))
for(i in 1:length(tempo.factor)){ # convert factor columns as character
if(all(tempo.factor[i] == "factor")){
data[, i] <- as.character(data[, i])
}
}
tempo.factor <- unlist(lapply(data, mode))
if(length(data) == 2){
if( ! ((mode(data[, 1]) == "character" & mode(data[, 2]) == "numeric") | mode(data[, 2]) == "character" & mode(data[, 1]) == "numeric" | mode(data[, 2]) == "numeric" & mode(data[, 1]) == "numeric") ){
2314
2315
tempo.cat <- paste0("ERROR IN ", function.name, ": IF data ARGUMENT IS A DATA FRAME MADE OF 2 COLUMNS, EITHER A COLUMN MUST BE NUMERIC AND THE OTHER CHARACTER, OR THE TWO COLUMNS MUST BE NUMERIC")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2316
2317
}
if((mode(data[, 1]) == "character" | mode(data[, 2]) == "character") & (quanti.col.name != "quanti" | quali.col.name != "quali")){
2318
2319
tempo.cat <- paste0("ERROR IN ", function.name, ": IMPROPER quanti.col.name OR quali.col.name RESETTINGS. THESE ARGUMENTS ARE RESERVED FOR DATA FRAMES MADE OF n NUMERIC COLUMNS ONLY")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2320
2321
2322
}
}else{
if( ! all(tempo.factor %in% "numeric")){
2323
2324
tempo.cat <- paste0("ERROR IN ", function.name, ": IF data ARGUMENT IS A DATA FRAME MADE OF ONE COLUMN, OR MORE THAN 2 COLUMNS, THESE COLUMNS MUST BE NUMERIC")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2325
2326
2327
}
}
if(( ! any(tempo.factor %in% "character")) & is.null(names(data))){
2328
2329
tempo.cat <- paste0("ERROR IN ", function.name, ": NUMERIC DATA FRAME in the data ARGUMENT MUST HAVE COLUMN NAMES")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2330
2331
2332
2333
2334
2335
2336
}
if(all(tempo.factor %in% "numeric")){ # transfo 1
quanti <- NULL
for(i in 1:length(data)){
quanti <-c(quanti, data[, i])
}
quali <- rep(names(data), each = nrow(data))
2337
output.data <- data.frame(quanti, quali, stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
2338
2339
2340
2341
2342
2343
2344
2345
names(output.data) <- c(quanti.col.name, quali.col.name)
# add the ini_rowname column
ini.rownames <- rownames(data)
tempo.data <- data
rownames(tempo.data) <- NULL
null.rownames <- (tempo.data)
if( ! identical(ini.rownames, null.rownames)){
ini_rowname <- rep(ini.rownames, times = ncol(data))
2346
output.data <- cbind(output.data, ini_rowname, stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
2347
2348
2349
}
}else{ # transfo 2
if(class(data[, 1]) == "character"){
2350
data <- cbind(data[2], data[1], stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
2351
2352
2353
2354
2355
}
nc.max <- max(table(data[, 2])) # effectif maximum des classes
nb.na <- nc.max - table(data[,2]) # nombre de NA à ajouter pour réaliser la data frame
tempo<-split(data[, 1], data[, 2])
for(i in 1:length(tempo)){tempo[[i]] <- append(tempo[[i]], rep(NA, nb.na[i]))} # des NA doivent être ajoutés lorsque les effectifs sont différents entre les classes. C'est uniquement pour que chaque colonne ait le même nombre de lignes
2356
output.data<-data.frame(tempo, stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
}
return(output.data)
}




######## fun_round() #### rounding number if decimal present


# Check OK: clear to go Apollo
fun_round <- function(data, dec.nb = 2, after.lead.zero = TRUE){
# AIM
# round a vector of values, if decimal, with the desired number of decimal digits after the decimal leading zeros
# WARNINGS
# Work well with numbers as character strings, but not always with numerical numbers because of the floating point
# Numeric values are really truncated from a part of their decimal digits, whatever options(digits) settings
# See ?.Machine or https://stackoverflow.com/questions/5173692/how-to-return-number-of-decimal-places-in-r, with the interexting formula: abs(x - round(x)) > .Machine$double.eps^0.5
# ARGUMENTS
# data: a vector of numbers (numeric or character mode)
# dec.nb: number of required decimal digits
# after.lead.zero: logical. If FALSE, rounding is performed for all the decimal numbers, whatever the leading zeros (e.g., 0.123 -> 0.12 and 0.00128 -> 0.00). If TRUE, dec.nb are taken after the leading zeros (e.g., 0.123 -> 0.12 and 0.00128 -> 0.0013)
# RETURN
# the modified vector
Gael's avatar
tempo    
Gael committed
2381
2382
2383
2384
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2385
2386
2387
2388
2389
2390
2391
2392
2393
# EXAMPLES
# ini.options <- options()$digits ; options(digits = 8) ; cat(fun_round(data = c(NA, 10, 100.001, 333.0001254, 12312.1235), dec.nb = 2, after.lead.zero = FALSE), "\n\n") ; options(digits = ini.options)
# ini.options <- options()$digits ; options(digits = 8) ; cat(fun_round(data = c(NA, 10, 100.001, 333.0001254, 12312.1235), dec.nb = 2, after.lead.zero = TRUE), "\n\n") ; options(digits = ini.options)
# ini.options <- options()$digits ; options(digits = 8) ; cat(fun_round(data = c(NA, "10", "100.001", "333.0001254", "12312.1235"), dec.nb = 2, after.lead.zero = FALSE), "\n\n") ; options(digits = ini.options)
# ini.options <- options()$digits ; options(digits = 8) ; cat(fun_round(data = c(NA, "10", "100.001", "333.0001254", "12312.1235"), dec.nb = 2, after.lead.zero = TRUE), "\n\n") ; options(digits = ini.options)
# DEBUGGING
# data = data = c(10, 100.001, 333.0001254, 12312.1235) ; dec.nb = 2 ; after.lead.zero = FALSE # # for function debugging
# data = data = c("10", "100.001", "333.0001254", "12312.1235") ; dec.nb = 2 ; after.lead.zero = TRUE # # for function debugging
# function name
2394
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2395
2396
2397
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2398
2399
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2400
2401
2402
2403
2404
}
# end required function checking
# argument checking
# argument checking without fun_check()
if( ! (all(typeof(data) == "character") | all(typeof(data) == "double") | all(typeof(data) == "integer"))){
2405
2406
tempo.cat <- paste0("ERROR IN ", function.name, ": data ARGUMENT MUST BE A VECTOR OF NUMBERS (IN NUMERIC OR CHARACTER MODE)")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
}
# end argument checking without fun_check()
# argument checking with fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = data, class = "vector", na.contain = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dec.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = after.lead.zero, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end argument checking with fun_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_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_check()
# end argument checking
# main code
tempo <- grepl(x = data, pattern = "\\.") # detection of decimal numbers
ini.mode <- mode(data)
data <- as.character(data) # to really truncate decimal digits
for(i in 1:length(data)){ # scan all the numbers of the vector
if(tempo[i] == TRUE){ # means decimal number
if(after.lead.zero == TRUE){
zero.pos <- unlist(gregexpr(text=data[i], pattern = 0)) # recover all the position of the zeros in the number. -1 if no zeros (do not record the leading and trailing zeros)
}else{
zero.pos <- -1 # -1 as if no zero
}
dot.pos <- unlist(gregexpr(text=data[i], pattern = "\\.")) # recover all the position of the zeros in the number
digit.pos <- unlist(gregexpr(text=data[i], pattern = "[[:digit:]]")) # recover all the position of the digits in the number
dec.pos <- digit.pos[digit.pos > dot.pos]
count <- 0
while((dot.pos + count + 1) %in% zero.pos & (dot.pos + count + 1) <= max(dec.pos) & (count + dec.nb) < length(dec.pos)){ # count the number of leading zeros in the decimal part
count <- count + 1
}
data[i] <- formatC(as.numeric(data[i]), digits = (count + dec.nb), format = "f")
}
}
if(ini.mode != "character"){
data <- as.numeric(data)
}
return(data)
}


######## fun_mat_rotate() #### 90° clockwise matrix rotation


# Check OK: clear to go Apollo
fun_mat_rotate <- function(data){
# AIM
# 90° clockwise matrix rotation
# applied twice, the function provide the mirror matrix, according to vertical and horizontal symmetry
# ARGUMENTS
# data: matrix (matrix class)
# RETURN
# the modified matrix
Gael's avatar
tempo    
Gael committed
2463
2464
2465
2466
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2467
2468
2469
2470
2471
2472
# EXAMPLES
# obs <- matrix(1:10, ncol = 1) ; obs ; fun_mat_rotate(obs)
# obs <- matrix(LETTERS[1:10], ncol = 5) ; obs ; fun_mat_rotate(obs)
# DEBUGGING
# data = matrix(1:10, ncol = 1)
# function name
2473
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2474
2475
2476
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2477
2478
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = data, class = "matrix", fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# 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_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_check()
# end argument checking
# main code
for (i in 1:ncol(data)){data[,i] <- rev(data[,i])}
data <- t(data)
return(data)
}


######## fun_mat_num2color() #### convert a numeric matrix into hexadecimal color matrix


# Check OK: clear to go Apollo
Gael's avatar
tempo    
Gael committed
2503
2504
2505
2506
2507
2508
2509
2510
fun_mat_num2color <- function(
mat1, 
mat.hsv.h = TRUE, 
notch = 1, 
s = 1, 
v = 1, 
forced.color = NULL
){
Gael  MILLOT's avatar
Gael MILLOT committed
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
# AIM
# convert a matrix made of numbers into a hexadecimal matrix for rgb colorization
# ARGUMENTS:
# mat1: matrix 1 of non negative numerical values that has to be colored (matrix class). NA allowed
# mat.hsv.h: logical. Is mat1 the h of hsv colors ? (if TRUE, mat1 must be between zero and 1)
# notch: single value between 0 and 1 to shift the successive colors on the hsv circle by + notch
# s: s argument of hsv(). Must be between 0 and 1
# v: v argument of hsv(). Must be between 0 and 1
# forced.color: Must be NULL or hexadecimal color code or name given by colors(). The first minimal values of mat1 will be these colors. All the color of mat1 can be forced using this argument
# RETURN
# a list containing:
# $mat1.name: name of mat1
# $colored.mat: colors of mat1 in hexa
# $problem: logical. Is any colors of forced.color overlap the colors designed by the function. NULL if forced.color = NULL
# $text.problem: text when overlapping colors. NULL if forced.color = NULL or problem == FALSE
Gael's avatar
tempo    
Gael committed
2526
2527
2528
2529
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2530
2531
2532
2533
2534
# EXAMPLES
# mat1 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2) ; dimnames(mat1) <- list(LETTERS[1:4], letters[1:2]) ; fun_mat_num2color(mat1, mat.hsv.h = FALSE, notch = 1, s = 1, v = 1, forced.color = NULL)
# DEBUGGING
# mat1 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2) ; dimnames(mat1) <- list(LETTERS[1:4], letters[1:2]); mat.hsv.h = FALSE ; notch = 1 ; s = 1 ; v = 1 ; forced.color = c(hsv(1,1,1), hsv(0,0,0)) # for function debugging
# function name
2535
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2536
2537
2538
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2539
2540
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
}
# end required function checking
# argument checking
# argument checking with fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = mat1, mode = "numeric", class = "matrix", na.contain = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = mat.hsv.h, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = notch, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = s, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = v, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end argument checking with fun_check()
# argument checking without fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2559
if(mat.hsv.h == TRUE & fun_check(data = mat1, mode = "numeric", prop = TRUE)$problem == TRUE){
2560
2561
tempo.cat <- paste0("ERROR IN ", function.name, ": mat1 ARGUMENT MUST BE A MATRIX OF PROPORTIONS SINCE THE mat.hsv.h ARGUMENT IS SET TO TRUE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2562
2563
2564
2565
}
if( ! is.null(forced.color)){
tempo <- fun_check(data = forced.color, class = "character")
if(any(tempo$problem == TRUE)){
2566
2567
paste0("\n\n================\n\n", paste(tempo$text[tempo$problem], collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2568
2569
}
if( ! all(forced.color %in% colors() | grepl(pattern = "^#", forced.color))){ # check that all strings of forced.color start by #
2570
2571
tempo.cat <- paste0("ERROR IN ", function.name, ": forced.color ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
}
}
# end argument checking without fun_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_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_check()
# end argument checking
# main code
problem <- NULL
text.problem <- NULL
mat1.name <- deparse(substitute(mat1))
# change the scale of the plotted matrix
if(mat.hsv.h == TRUE){
if(any(min(mat1, na.rm = TRUE) < 0 | max(mat1, na.rm = TRUE) > 1, na.rm = TRUE)){
2584
2585
tempo.cat <- paste0("ERROR IN ", function.name, ": mat1 MUST BE MADE OF VALUES BETWEEN 0 AND 1 BECAUSE mat.hsv.h ARGUMENT SET TO TRUE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2586
2587
2588
}
}else{
if(any(mat1 - floor(mat1) > 0, na.rm = TRUE) | any(mat1 == 0, na.rm = TRUE)){ # no need of isTRUE(all.equal()) because we do not require approx here but strictly 0, thus == is ok
2589
2590
tempo.cat <- paste0("ERROR IN ", function.name, ": mat1 MUST BE MADE OF INTEGER VALUES WITHOUT 0 BECAUSE mat.hsv.h ARGUMENT SET TO FALSE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
}else{
mat1 <- mat1 / max(mat1, na.rm = TRUE)
}
}
if(notch != 1){
different.color <- unique(as.vector(mat1))
different.color <- different.color[ ! is.na(different.color)]
tempo.different.color <- different.color + c(0, cumsum(rep(notch, length(different.color) - 1)))
tempo.different.color <- tempo.different.color - floor(tempo.different.color)
if(any(duplicated(tempo.different.color) == TRUE)){
2601
2602
tempo.cat <- paste0("ERROR IN ", function.name, ": DUPLICATED VALUES AFTER USING notch (", paste(tempo.different.color[duplicated(tempo.different.color)], collapse = " "), "). TRY ANOTHER notch VALUE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2603
}else if(length(different.color) != length(tempo.different.color)){
2604
2605
tempo.cat <- paste0("ERROR IN ", function.name, ": LENGTH OF different.color (", paste(different.color, collapse = " "), ") DIFFERENT FROM LENGTH OF tempo.different.color (", paste(tempo.different.color, collapse = " "), ")")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
}else{
for(i in 1:length(different.color)){
mat1[mat1 == different.color[i]] <- tempo.different.color[i] # no need of isTRUE(all.equal()) because different.color comes from mat1
}
}
}
if( ! is.null(forced.color)){
hexa.values.to.change <- hsv(unique(sort(mat1))[1:length(forced.color)], s, v)
}
mat1[ ! is.na(mat1)] <- hsv(mat1[ ! is.na(mat1)], s, v)
if( ! is.null(forced.color)){
if(any(forced.color %in% mat1, na.rm = TRUE)){
problem <- TRUE
text.problem <- paste0("THE FOLLOWING COLORS WHERE INTRODUCED USING forced.color BUT WHERE ALREADY PRESENT IN THE COLORED MATRIX :", paste(forced.color[forced.color %in% mat1], collapse = " "))
}else{
problem <- FALSE
}
for(i in 1:length(hexa.values.to.change)){
if( ! any(mat1 == hexa.values.to.change[i], na.rm = TRUE)){# no need of isTRUE(all.equal()) because character
2625
2626
tempo.cat <- paste0("ERROR IN ", function.name, ": THE ", hexa.values.to.change[i], " VALUE FROM hexa.values.to.change IS NOT REPRESENTED IN mat1 : ", paste(unique(as.vector(mat1)), collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
}else{
mat1[which(mat1 == hexa.values.to.change[i])] <- forced.color[i] # no need of isTRUE(all.equal()) because character
}
}
}
output <- list(mat1.name = mat1.name, colored.mat = mat1, problem = problem, text.problem = text.problem)
return(output)
}


######## fun_mat_op() #### assemble several matrices with operation


# Check OK: clear to go Apollo
fun_mat_op <- function(mat.list, kind.of.operation = "+"){
# AIM
# assemble several matrices of same dimensions by performing by case operation. For instance add the value of all the case 1 (row1 & column1) of the matrices and put it in the case 1 of a new matrix M, add the value of all the case 2 (row2 & column1) of the matrices and put it in the case 2 of a new matrix M, etc.
 
# c: case
# i: row number
# j: column number
# k: matrix number
# z: number of matrices
# ARGUMENTS:
# mat.list: list of matrices
# kind.of.operation: either "+" (by case addition), "-" (by case subtraction) or "*" (by case multiplication)
# RETURN
# the assembled matrix, with row and/or column names only if all the matrices have identical row/column names
Gael's avatar
tempo    
Gael committed
2655
2656
2657
2658
2659
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_comp_2d()
Gael  MILLOT's avatar
Gael MILLOT committed
2660
2661
2662
2663
2664
2665
2666
2667
2668
# EXAMPLES
# mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2) ; mat2 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2) ; fun_mat_op(mat.list = list(mat1, mat2), kind.of.operation = "+")
# mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2, dimnames = list(LETTERS[1:4], letters[1:2])) ; mat2 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2, dimnames = list(LETTERS[1:4], letters[1:2])) ; fun_mat_op(mat.list = list(mat1, mat2), kind.of.operation = "*")
# mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2, dimnames = list(LETTERS[1:4], c(NA, NA))) ; mat2 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2, dimnames = list(LETTERS[1:4], letters[1:2])) ; fun_mat_op(mat.list = list(mat1, mat2), kind.of.operation = "-")
# mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2, dimnames = list(c("A1", "A2", "A3", "A4"), letters[1:2])) ; mat2 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2, dimnames = list(LETTERS[1:4], letters[1:2])) ; mat3 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2, dimnames = list(LETTERS[1:4], letters[1:2])) ; fun_mat_op(mat.list = list(mat1, mat2, mat3), kind.of.operation = "+")
# DEBUGGING
# mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2) ; mat2 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2) ; mat.list = list(mat1, mat2) ; kind.of.operation = "+" # for function debugging
# mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2, dimnames = list(LETTERS[1:4], c(NA, NA))) ; mat2 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2, dimnames = list(LETTERS[1:4], letters[1:2])) ; mat.list = list(mat1, mat2) ; kind.of.operation = "*" # for function debugging
# function name
2669
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2670
2671
2672
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2673
2674
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2675
2676
}
if(length(utils::find("fun_check", mode = "function")) == 0){
2677
2678
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_comp_2d() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
}
# end required function checking
# argument checking
# argument checking with fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = mat.list, class = "list", fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = kind.of.operation, options = c("+", "-", "*"), length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end argument checking with fun_check()
# argument checking without fun_check()
if(length(mat.list) < 2){
2695
2696
tempo.cat <- paste0("ERROR IN ", function.name, ": mat.list ARGUMENT MUST BE A LIST CONTAINING AT LEAST 2 MATRICES")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2697
}
2698
2699
for(i1 in 1:length(mat.list)){
tempo <- fun_check(data = mat.list[[i1]], class = "matrix", mode = "numeric", na.contain = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
2700
if(tempo$problem == TRUE){
2701
2702
tempo.cat <- paste0("ERROR IN ", function.name, ": ELEMENT ", i1, " OF mat.list ARGUMENT MUST BE A NUMERIC MATRIX")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2703
2704
2705
2706
}
}
ident.row.names <- TRUE
ident.col.names <- TRUE
2707
2708
for(i1 in 2:length(mat.list)){
tempo <- fun_comp_2d(data1 = mat.list[[1]], data2 = mat.list[[i1]])
Gael  MILLOT's avatar
Gael MILLOT committed
2709
if(tempo$same.dim == FALSE){
2710
2711
tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX ", i1, " OF mat.list ARGUMENT MUST HAVE THE SAME DIMENSION (", paste(dim(mat.list[[i1]]), collapse = " "), ") THAN THE MATRIX 1 IN mat.list (", paste(dim(mat.list[[1]]), collapse = " "), ")")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
}
if( ! is.null(tempo$same.row.name)){
if(tempo$same.row.name != TRUE){ # != TRUE to deal with NA
ident.row.names <- FALSE
}
}
if( ! is.null(tempo$same.col.name)){
if(tempo$same.col.name != TRUE){ # != TRUE to deal with NA
ident.col.names <- FALSE
}
}
}
# end argument checking without fun_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_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_check()
# end argument checking
# main code
output <- mat.list[[1]]
2729
for(i1 in 2:length(mat.list)){
2730
output <- get(kind.of.operation)(output, mat.list[[i1]]) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
Gael  MILLOT's avatar
Gael MILLOT committed
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
}
dimnames(output) <- NULL
if(ident.row.names == TRUE){
rownames(output) <- rownames(mat.list[[1]])
}
if(ident.col.names == TRUE){
colnames(output) <- colnames(mat.list[[1]])
}
return(output)
}


######## fun_mat_inv() #### return the inverse of a square matrix


# Check OK: clear to go Apollo
fun_mat_inv <- function(mat){
# AIM
# return the inverse of a square matrix when solve() cannot
# ARGUMENTS:
# mat: a square numeric matrix without NULL, NA, Inf or single case (dimension 1, 1) of 0
# RETURN
# the inversed matrix
Gael's avatar
tempo    
Gael committed
2754
2755
2756
2757
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
# EXAMPLES
# mat1 = matrix(c(1,1,1,2,1,5,9,8,9), ncol = 3) ; fun_mat_inv(mat = mat1) # use solve()
# mat1 = matrix(c(0,0,0,0,0,0,0,0,0), ncol = 3) ; fun_mat_inv(mat = mat1) # use the trick
# mat1 = matrix(c(1,1,1,2,Inf,5,9,8,9), ncol = 3) ; fun_mat_inv(mat = mat1)
# mat1 = matrix(c(1,1,1,2,NA,5,9,8,9), ncol = 3) ; fun_mat_inv(mat = mat1)
# mat1 = matrix(c(1,2), ncol = 1) ; fun_mat_inv(mat = mat1)
# mat1 = matrix(0, ncol = 1) ; fun_mat_inv(mat = mat1)
# mat1 = matrix(2, ncol = 1) ; fun_mat_inv(mat = mat1)
# DEBUGGING
# mat = matrix(c(1,1,1,2,1,5,9,8,9), ncol = 3) # for function debugging
# function name
2769
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2770
2771
2772
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2773
2774
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
}
# end required function checking
# argument checking
# argument checking with fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = mat, class = "matrix", mode = "numeric", fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end argument checking with fun_check()
# argument checking without fun_check()
if(ncol(mat) != nrow(mat)){
2790
2791
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT MUST BE A SQUARE MATRIX")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2792
2793
}
if(any(mat %in% c(Inf, -Inf, NA))){
2794
2795
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT MUST BE A MATRIX WITHOUT Inf, -Inf OR NA")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2796
2797
}
if(all(mat == 0) & ncol(mat) == 1){
2798
2799
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT CANNOT BE A SQUARE MATRIX MADE OF A SINGLE CASE OF 0")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
}
# end argument checking without fun_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_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_check()
# end argument checking
# main code
if(any(grepl(x = try(solve(mat), silent = TRUE)[], pattern = "[Ee]rror"))){
tempo <- svd(mat)
val.critique <- which(tempo$d < 10^-8)
Diag.mod <- diag(1 / tempo$d)
for(i in val.critique){
Diag.mod[i, i] <- 0
}
return(tempo$v %*% Diag.mod %*% t(tempo$u))
}else{
return(solve(mat))
}
}


######## fun_mat_fill() #### fill the empty half part of a symmetric square matrix


# Check OK: clear to go Apollo
fun_mat_fill <- function(mat, empty.cell.string = 0, warn.print = FALSE){
# AIM
# detect the empty half part of a symmetric square matrix (either topleft, topright, bottomleft or bottomright)
# fill this empty half part using the other symmetric half part of the matrix
# WARNINGS
# a plot verification using fun_gg_heatmap() is recommanded
# ARGUMENTS:
# mat: a numeric or character square matrix with the half part (according to the grand diagonal) filled with NA (any kind of matrix), "0" (character matrix) or 0 (numeric matrix) exclusively (not a mix of 0 and NA in the empty part)
# empty.cell.string: a numeric, character or NA (no quotes) indicating what empty cells are filled with
# warn.print: logical. Print warnings at the end of the execution? No print if no warning messages
# RETURN
# a list containing:
# $mat: the filled matrix
# $warn: the warning messages. Use cat() for proper display. NULL if no warning
Gael's avatar
tempo    
Gael committed
2837
2838
2839
2840
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
# EXAMPLES
# mat1 = matrix(c(1,NA,NA,NA, 0,2,NA,NA, NA,3,4,NA, 5,6,7,8), ncol = 4) ; mat1 ; fun_mat_fill(mat = mat1, empty.cell.string = NA, warn.print = TRUE) # bottomleft example
# mat1 = matrix(c(1,1,1,2, 0,2,3,0, NA,3,0,0, 5,0,0,0), ncol = 4) ; mat1 ; fun_mat_fill(mat = mat1, empty.cell.string = NA, warn.print = TRUE) # error example
# mat1 = matrix(c(1,1,1,2, 0,2,3,0, NA,3,0,0, 5,0,0,0), ncol = 4) ; mat1 ; fun_mat_fill(mat = mat1, empty.cell.string = 0, warn.print = TRUE) # bottomright example
# mat1 = matrix(c(1,1,1,2, "a",2,3,NA, "a","a",0,0, "a","a","a",0), ncol = 4) ; mat1 ; fun_mat_fill(mat = mat1, empty.cell.string = "a", warn.print = TRUE) # topright example
# mat1 = matrix(c(0,0,0,2, 0,0,3,0, 0,3,0,NA, 5,0,0,0), ncol = 4) ; mat1 ; fun_mat_fill(mat = mat1, empty.cell.string = 0, warn.print = TRUE) # topleft example
# mat1 = matrix(c(0,0,0,2, 0,0,3,0, 0,3,0,0, 5,0,0,0), ncol = 4) ; mat1 ; fun_mat_fill(mat = mat1, empty.cell.string = 0, warn.print = TRUE) # error example
# DEBUGGING
# mat = matrix(c(1,NA,NA,NA, 0,2,NA,NA, NA,3,4,NA, 5,6,7,8), ncol = 4) ; empty.cell.string = NA ; warn.print = TRUE # for function debugging
# mat = matrix(c(0,0,0,2, 0,0,3,0, 0,3,0,NA, 5,0,0,0), ncol = 4) ; empty.cell.string = 0 ; warn.print = TRUE # for function debugging # topleft example
# mat = matrix(c(0,0,0,2, 0,0,3,0, 0,3,0,NA, 5,0,0,0), ncol = 4) ; empty.cell.string = NA ; warn.print = TRUE # for function debugging # topleft example
# function name
2853
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
2854
2855
2856
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
2857
2858
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
}
# end required function checking
# argument checking
# argument checking with fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = mat, class = "matrix", na.contain = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = empty.cell.string, class = "vector", na.contain = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = warn.print, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end argument checking with fun_check()
# argument checking without fun_check()
if(ncol(mat) != nrow(mat)){
2876
2877
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT MUST BE A SQUARE MATRIX")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2878
2879
}
if( ! (mode(mat) %in% c("numeric", "character"))){
2880
2881
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT MUST BE A NUMERIC OR CHARACTER MATRIX")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2882
2883
}
if(nrow(mat) == 1 & ncol(mat) == 1){
2884
2885
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT CANNOT BE A SQUARE MATRIX MADE OF A SINGLE CASE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2886
2887
}
if(ifelse(is.na(empty.cell.string), ! any(is.na(mat)), ! any(mat == empty.cell.string, na.rm = TRUE))){
2888
2889
tempo.cat <- paste0("ERROR IN ", function.name, ": mat ARGUMENT MATRIX MUST HAVE CELLS WITH THE EMPTY STRING SPECIFIED IN empty.cell.string ARGUMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2890
2891
2892
2893
2894
2895
}
# end argument checking without fun_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_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_check()
# end argument checking
# main code
list.diag <- vector("list", length = nrow(mat) - 1)
2896
2897
for(i1 in 1:(nrow(mat) - 1)){
list.diag[[i1]] <- numeric(length = nrow(mat) - i1)
Gael  MILLOT's avatar
Gael MILLOT committed
2898
2899
2900
}
sector <- c("topleft", "topright", "bottomright", "bottomleft")
diag.scan <-c( # same order as sector. Recover each diag from center to corner
2901
2902
2903
2904
"mat[as.matrix(as.data.frame(list(1:(nrow(mat) - i2), (ncol(mat) -i2):1), stringsAsFactors = TRUE))]", # topleft part
"mat[as.matrix(as.data.frame(list(1:(nrow(mat) - i2), (1:ncol(mat))[-(1:i2)]), stringsAsFactors = TRUE))]", # topright part
"mat[as.matrix(as.data.frame(list((1 + i2):nrow(mat), ncol(mat):(1 + i2)), stringsAsFactors = TRUE))]", # bottomright part
"mat[as.matrix(as.data.frame(list((1 + i2):nrow(mat), 1:(ncol(mat) -i2)), stringsAsFactors = TRUE))]" # bottomleft part
Gael  MILLOT's avatar
Gael MILLOT committed
2905
2906
2907
2908
2909
)
# empty part detection
tempo.list.diag <- list.diag
empty.sector <- NULL
full.sector <- NULL
2910
ini.warning.length <- options()$warning.length
Gael  MILLOT's avatar
Gael MILLOT committed
2911
warn <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
2912
warn.count <- 0
2913
for(i1 in 1:length(sector)){
Gael  MILLOT's avatar
Gael MILLOT committed
2914
tempo.list.diag <- list.diag
2915
2916
2917
2918
for(i2 in 1:(nrow(mat) - 1)){
tempo.list.diag[[i2]] <- eval(parse(text = diag.scan[i1]))
if(ifelse(is.na(empty.cell.string), ! all(is.na(tempo.list.diag[[i2]])), ! (all(tempo.list.diag[[i2]] == empty.cell.string, na.rm = TRUE) & ! (is.na(all(tempo.list.diag[[i2]] == empty.cell.string, na.rm = FALSE)))))){ # I had to add this ! (is.na(all(tempo.list.diag[[i2]] == empty.cell.string, na.rm = FALSE))) because all(tempo.list.diag[[i2]] == empty.cell.string, na.rm = FALSE) gives NA and not FALSE if one NA in tempo.list.diag[[i2]] -> not good for if()
full.sector <- c(full.sector, sector[i1])
Gael  MILLOT's avatar
Gael MILLOT committed
2919
2920
2921
2922
2923
break
}
}
if(i1 == nrow(mat) - 1){
if(all(unlist(lapply(tempo.list.diag, FUN = function(x){if(is.na(empty.cell.string)){is.na(x)}else{x == empty.cell.string}})), na.rm = TRUE)){
2924
empty.sector <- c(empty.sector, sector[i1])
Gael  MILLOT's avatar
Gael MILLOT committed
2925
warn.count <- warn.count + 1
2926
tempo.warn <- paste0("(", warn.count,") EMPTY SECTOR DETECTED ON THE ", toupper(sector[i1]), " CORNER, FULL OF ", empty.cell.string)
Gael  MILLOT's avatar
Gael MILLOT committed
2927
2928
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else{
2929
2930
tempo.cat <- paste0("ERROR IN ", function.name, ": THE ", toupper(sector[i1]), " SECTOR, DETECTED AS EMPTY, IS NOT? DIFFERENT VALUES IN THIS SECTOR:\n", paste(names(table(unlist(tempo.list.diag), useNA = "ifany")), collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2931
2932
2933
2934
2935
}
}
}
# end empty part detection
if(length(empty.sector) == 0){
Gael  MILLOT's avatar
Gael MILLOT committed
2936
warn.count <- warn.count + 1
2937
tempo.warn <- paste0("(", warn.count,") ACCORDING TO empty.cell.string ARGUMENT (", empty.cell.string, "), mat ARGUMENT MATRIX HAS ZERO EMPTY HALF PART")
Gael  MILLOT's avatar
Gael MILLOT committed
2938
2939
2940
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else{
if(length(empty.sector) > 1){
2941
2942
tempo.cat <- paste0("ERROR IN ", function.name, ": ACCORDING TO empty.cell.string ARGUMENT (", empty.cell.string, "), mat ARGUMENT MATRIX HAS MORE THAN ONE EMPTY HALF PART (ACCORDING TO THE GRAND DIAGONAL): ", paste(empty.sector, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2943
}else if(any(full.sector %in% empty.sector, na.rm = TRUE)){
2944
2945
tempo.cat <- paste0("ERROR IN ", function.name, ": THE FUNCTION HAS DETECTED EMPTY AND NON EMPTY HALF PART IN THE SAME SECTOR: ", paste(full.sector[full.sector %in% empty.sector], collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2946
}else if(length(empty.sector) + length(full.sector)!= 4){
2947
2948
tempo.cat <- paste0("ERROR IN ", function.name, ": THE FUNCTION HAS DETECTED MORE OR LESS SECTORS THAN 4:\nHALF SECTORS:", paste(empty.sector, collapse = " "), "\nFULL SECTORS:", paste(full.sector, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
2949
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
2950
warn.count <- warn.count + 1
2951
tempo.warn <- paste0("(", warn.count,") ", toupper(empty.sector), " SECTOR HAS BEEN COMPLETED TO BECOME SYMMETRICAL")
Gael  MILLOT's avatar
Gael MILLOT committed
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
# matrix filling
for(i1 in 1:(nrow(mat) - 1)){
if(empty.sector == "topleft"){
eval(parse(text = paste0(diag.scan[1], " <- ", diag.scan[3])))
}else if(empty.sector == "topright"){
eval(parse(text = paste0(diag.scan[2], " <- ", diag.scan[4])))
}else if(empty.sector == "bottomright"){
eval(parse(text = paste0(diag.scan[3], " <- ", diag.scan[1])))
}else if(empty.sector == "bottomleft"){
eval(parse(text = paste0(diag.scan[4], " <- ", diag.scan[2])))
}
}
# end matrix filling
}
if(warn.print == TRUE & ! is.null(warn)){
2969
options(warning.length = 8170)
2970
on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
2971
on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
2972
2973
2974
2975
2976
2977
2978
2979
}
return(list(mat = mat, warn = warn))
}


######## fun_permut() #### progressively breaks a vector order


Gael's avatar
tempo    
Gael committed
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
fun_permut <- function(
data1, 
data2 = NULL, 
n = NULL, 
seed = NULL, 
print.count = 10, 
text.print = "", 
cor.method = "spearman", 
cor.limit = 0.2, 
warn.print = FALSE, 
lib.path = NULL
){
Gael  MILLOT's avatar
Gael MILLOT committed
2992
2993
2994
2995
2996
# AIM
# reorder the elements of the data1 vector by flipping 2 randomly selected  consecutive positions either:
# 1) n times (when n is precised) or
# 2) until the correlation between data1 and data2 decreases down to the cor.limit (0.2 by default). See cor.limit below to deal with negative correlations
# Example of consecutive position flipping: ABCD -> BACD -> BADC, etc.
Gael's avatar
Gael committed
2997
# designed for discrete values, but worls also for continuous values
Gael  MILLOT's avatar
Gael MILLOT committed
2998
2999
# WARNINGS
# see # https://www.r-bloggers.com/strategies-to-speedup-r-code/ for code speedup
Gael's avatar
Gael committed
3000
# the random switch of non consecutive positions (ABCD -> DBCA for instance) does not work very well as the correlation is quickly obtained but the initial vector structure is mainly kept (no much order). Ths code would be: pos <- ini.pos[1:2] ; pos <- sample.int(n = n , size = 2, replace = FALSE) ; tempo.pos[pos] <- tempo.pos[rev(pos)]