diff --git a/README.md b/README.md
index af9942a178e5890d1b82391e2809fea73ccbcdc3..34ec1e91f9e6bd7185fce6b6b548a281e95cac0d 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,6 @@
#### DESCRIPTION
-Cute Little R Functions contains 18 functions for R/RStudio that facilitate basic procedures in 1) object analysis, 2) object modification, 3) graphic handling and 4) log file management.
+Cute Little R Functions contains 19 functions for R/RStudio that facilitate basic procedures in 1) object analysis, 2) object modification, 3) graphic handling and 4) log file management.
The function names are:
@@ -15,6 +15,7 @@ fun_rounding() round a vector of values, if decimal, with the desired number of
fun_90clock_matrix_rot() 90° clockwise matrix rotation
fun_hexa_hsv_color_matrix() convert a matrix made of numbers into a hexadecimal matrix for rgb colorization
fun_by_case_matrix_op() assemble several matrices of same dimensions by performing by case operation
+fun_mat_inv() return the inverse of a square matrix when solve() cannot
fun_window_width_resizing() rescale the width of a window to open depending on the number of classes to plot
fun_open_window() open a pdf or screen (GUI) graphic window
fun_graph_param_prior_plot() very convenient to erase the axes for post plot axis redrawing using fun_feature_post_plot()
@@ -63,6 +64,11 @@ Check for updated versions (most recent tags) at https://gitlab.pasteur.fr/gmill
#### WHAT'S NEW IN
+## v4.9.0
+
+1) fun_mat_inv() function added
+
+
## v4.8.0
1) magnific argument removed in fun_feature_post_plot() because no need anymore
diff --git a/cute_little_R_functions.R b/cute_little_R_functions.R
index e5c61edd7aeba59cfe7bbfdfd9e6a276bd864ec1..847b0b85230a44b4e378109d20e3e98fd3ff1749 100644
--- a/cute_little_R_functions.R
+++ b/cute_little_R_functions.R
@@ -1,6 +1,6 @@
################################################################
## ##
-## CUTE LITTLE R FUNCTIONS v4.8.0 ##
+## CUTE LITTLE R FUNCTIONS v4.9.0 ##
## ##
## Gael A. Millot ##
## ##
@@ -11,7 +11,6 @@
-
################################ OUTLINE ################################
@@ -28,15 +27,16 @@
######## fun_90clock_matrix_rot() #### 90° clockwise matrix rotation 27
######## fun_hexa_hsv_color_matrix() #### Conversion of a numeric matrix into hexadecimal color matrix 28
######## fun_by_case_matrix_op() #### assembling of several matrices with operation 30
-################ Graphics 32
-######## fun_window_width_resizing() #### window width depending on classes to plot 33
-######## fun_open_window() #### Open a GUI or pdf graphic window 34
-######## fun_graph_param_prior_plot() #### Graph param before plotting 37
-######## fun_feature_post_plot() #### Graph param after plotting 41
-######## fun_close_specif_window() #### Closing specific graphic windows 52
-######## fun_var_trim_display() #### Display values from a quantitative variable and trim according to defined cut-offs 54
-################ Exporting results (text & tables) 62
-######## fun_export_data() #### Print string or data object into output file 62
+######## fun_mat_inv() #### return the inverse of a square matrix 33
+################ Graphics 34
+######## fun_window_width_resizing() #### window width depending on classes to plot 34
+######## fun_open_window() #### Open a GUI or pdf graphic window 35
+######## fun_graph_param_prior_plot() #### Graph param before plotting 39
+######## fun_feature_post_plot() #### Graph param after plotting 43
+######## fun_close_specif_window() #### Closing specific graphic windows 53
+######## fun_var_trim_display() #### Display values from a quantitative variable and trim according to defined cut-offs 55
+################ Exporting results (text & tables) 63
+######## fun_export_data() #### Print string or data object into output file 63
################################ FUNCTIONS ################################
@@ -225,63 +225,63 @@ fun_param_check <- function(data, data.name = NULL, class = NULL, typeof = NULL,
if( ! is.null(get(arg.names[i2]))){
# script to execute
tempo.script <- '
- problem <- TRUE ;
- if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
- text <- paste0("PROBLEM: THE ", data.name, " PARAMETER MUST BE ") ;
- }else{
- text <- paste0(text, " AND ");
- }
- text <- paste0(text, toupper(arg.names[i2]), " ", get(arg.names[i2]))
- '
- if(typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & get(arg.names[i2]) == "integer") | (arg.names[i2] == "typeof" & get(arg.names[i2]) == "integer"))){
- if(! all(data%%1 == 0)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line
- eval(parse(text = tempo.script)) # execute tempo.script
- }
- }else if(eval(parse(text = paste0(arg.names[i2], "(data)"))) != get(arg.names[i2])){
+problem <- TRUE ;
+if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
+text <- paste0("PROBLEM: THE ", data.name, " PARAMETER MUST BE ") ;
+}else{
+text <- paste0(text, " AND ");
+}
+text <- paste0(text, toupper(arg.names[i2]), " ", get(arg.names[i2]))
+'
+ if(typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & get(arg.names[i2]) == "integer") | (arg.names[i2] == "typeof" & get(arg.names[i2]) == "integer"))){
+ if(! all(data%%1 == 0)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line
eval(parse(text = tempo.script)) # execute tempo.script
}
+ }else if(eval(parse(text = paste0(arg.names[i2], "(data)"))) != get(arg.names[i2])){
+ eval(parse(text = tempo.script)) # execute tempo.script
}
- }
- }
- if( ! is.null(prop)){
- if(prop == TRUE){
- if(any(data < 0 | data > 1, na.rm = TRUE)){
- problem <- TRUE
- if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
- text <- paste0("PROBLEM: ")
- }else{
- text <- paste0(text, " AND ")
- }
- text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE DECIMAL VALUES BETWEEN 0 AND 1")
}
}
}
- if(na.contain == FALSE & any(is.na(data)) == TRUE){
- problem <- TRUE
- if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
- text <- paste0("PROBLEM: ")
- }else{
- text <- paste0(text, " AND ")
- }
- text <- paste0(text, "THE ", data.name, " PARAMETER CONTAINS NA WHILE NOT AUTHORIZED (na.contain ARGUMENT SET TO FALSE)")
- }
- if(neg.values == FALSE){
- if(any(data < 0, na.rm = TRUE)){
+if( ! is.null(prop)){
+ if(prop == TRUE){
+ if(any(data < 0 | data > 1, na.rm = TRUE)){
problem <- TRUE
if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
text <- paste0("PROBLEM: ")
}else{
text <- paste0(text, " AND ")
}
- text <- paste0(text, "THE ", data.name, " PARAMETER MUST NON NEGATIVE NUMERIC VALUES")
+ text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE DECIMAL VALUES BETWEEN 0 AND 1")
}
}
- if(print == TRUE & problem == TRUE){
- cat(paste0("\n\n================\n\n", text, "\n\n================\n\n"))
+}
+if(na.contain == FALSE & any(is.na(data)) == TRUE){
+ problem <- TRUE
+ if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
+ text <- paste0("PROBLEM: ")
+ }else{
+ text <- paste0(text, " AND ")
}
- output <- list(problem = problem, text = text, param.name = data.name)
- return(output)
+ text <- paste0(text, "THE ", data.name, " PARAMETER CONTAINS NA WHILE NOT AUTHORIZED (na.contain ARGUMENT SET TO FALSE)")
+}
+if(neg.values == FALSE){
+ if(any(data < 0, na.rm = TRUE)){
+ problem <- TRUE
+ if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
+ text <- paste0("PROBLEM: ")
+ }else{
+ text <- paste0(text, " AND ")
+ }
+ text <- paste0(text, "THE ", data.name, " PARAMETER MUST NON NEGATIVE NUMERIC VALUES")
}
+}
+if(print == TRUE & problem == TRUE){
+ cat(paste0("\n\n================\n\n", text, "\n\n================\n\n"))
+}
+output <- list(problem = problem, text = text, param.name = data.name)
+return(output)
+}
######## fun_object_info() #### Recovering object information
@@ -1534,6 +1534,71 @@ fun_by_case_matrix_op <- function(mat.list, kind.of.operation = "+"){
}
+######## 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
+ # REQUIRED FUNCTIONS
+ # fun_param_check()
+ # ARGUMENTS:
+ # mat: a square numeric matrix without NULL, NA, Inf or single case (dimension 1, 1) of 0
+ # RETURN
+ # the inversed matrix
+ # 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
+ # required function checking
+ if(length(find("fun_param_check", mode = "function")) == 0){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_mat_inv(): 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
+ ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
+ tempo <- fun_param_check(data = mat, class = "matrix", mode = "numeric") ; eval(ee)
+ 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 to check arguments status and if they have been checked using fun_param_check()
+ if(ncol(mat) != nrow(mat)){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_mat_inv(): mat ARGUMENT MUST BE A SQUARE MATRIX\n\n================\n\n")
+ stop(tempo.cat)
+ }
+ if(any(mat %in% c(Inf, -Inf, NA))){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_mat_inv(): mat ARGUMENT MUST BE A MATRIX WITHOUT Inf, -Inf OR NA\n\n================\n\n")
+ stop(tempo.cat)
+ }
+ if(all(mat == 0) & ncol(mat) == 1){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_mat_inv(): mat ARGUMENT CANNOT BE A SQUARE MATRIX MADE OF A SINGLE CASE OF 0\n\n================\n\n")
+ stop(tempo.cat)
+ }
+ # end argument checking
+ if(any(grepl(x = try(solve(mat), silent = TRUE)[], pattern = "Error"))){
+ 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))
+ }
+}
+
+
################ Graphics
diff --git a/cute_little_R_functions.docx b/cute_little_R_functions.docx
index e51ba92c47dd802a8a581ccb77f4c883a3eff57e..12466d98d3c48e8ae08ea7b02c5f121a597b90f5 100644
Binary files a/cute_little_R_functions.docx and b/cute_little_R_functions.docx differ
diff --git a/examples_alone.txt b/examples_alone.txt
index b753c1c5c4defbc8b2ec0e392c936ad024015070..22e2f990b68cbc157f48e0d825754565d0ec053f 100644
--- a/examples_alone.txt
+++ b/examples_alone.txt
@@ -52,6 +52,14 @@ mat1 = matrix(c(1,1,1,2,1,5,9,8), ncol = 2, dimnames = list(LETTERS[1:4], letter
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_by_case_matrix_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_by_case_matrix_op(mat.list = list(mat1, mat2, mat3), kind.of.operation = "+")
+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)
+
fun_window_width_resizing(class.nb = 10, inches.per.class.nb = 0.2, ini.window.width = 7, inch.left.space = 1, inch.right.space = 1, boundarie.space = 0.5)
fun_open_window(pdf.disp = FALSE, path.fun = "C:/Users/Gael/Desktop", pdf.name.file = "graph", width.fun = 7, height.fun = 7, paper = "special", no.pdf.overwrite = TRUE, return.output = TRUE)