cute_little_R_functions.R 697 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
9075
9076
9077
9078
9079
9080
9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
axes <- fun_gg_scatter(data1 = list(data1), x = list(x1), y = list(y1), categ = list(NULL), color = list(fun_gg_palette(2)[2]), geom = list("geom_point"), alpha = list(0.5), xlim = x.range.plot, ylim = y.range.plot, raster = raster, plot = FALSE, return = TRUE)$axes
}else{
axes <- fun_gg_scatter(data1 = list(data1, data2), x = list(x1, x2), y = list(y1, y2), categ = list(NULL, NULL), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1]), geom = list("geom_point", "geom_point"), alpha = list(0.5, 0.5), xlim = x.range.plot, ylim = y.range.plot, raster = raster, plot = FALSE, return = TRUE)$axes
}
# end recovering the axes data whatever plot or not
if(plot == TRUE){
# add a categ for plot legend
tempo.df.name <- c("data1", "data1.signif.dot", "data1.incon.dot", "data2", "data2.signif.dot", "data2.unknown.dot", "data2.incon.dot")
tempo.class.name <- c("data1", "data1", "data1", "data2", "data2", "data2", "data2")
for(i2 in 1:length(tempo.df.name)){
if( ! is.null(get(tempo.df.name[i2]))){
assign(tempo.df.name[i2], data.frame(get(tempo.df.name[i2]), kind = tempo.class.name[i2]))
}
}
# end add a categ for plot legend
if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe), x = list(x1, "x", "x"), y = list(y1, "y", "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
if( ! is.null(data1.signif.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.signif.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS")
}
if( ! is.null(data1.incon.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.incon.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS")
}
if( ! is.null(data2)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe , vframe), x = list(x1, x2, "x", "x"), y = list(y1, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
if( ! is.null(data2.signif.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS")
}
if( ! is.null(data2.incon.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS")
}
if( ! is.null(data2.unknown.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9093

Gael  MILLOT's avatar
Gael MILLOT committed
9094
9095
9096
9097
9098
9099
9100
9101
9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
9143
9144
9145
9146
9147
9148
9149
9150
9151
9152
9153
9154
9155
9156
9157
9158
9159
9160
9161
9162
9163
9164
9165
9166
9167
9168
9169
9170
9171
9172
9173
9174
9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS")
}
}
}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe), x = list(x1, "x"), y = list(y1, "y"), categ = list("kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
if( ! is.null(data1.signif.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS")
}
if( ! is.null(data1.incon.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS")
}
if( ! is.null(data2)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
if( ! is.null(data2.signif.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 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 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS")
}
if( ! is.null(data2.incon.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 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 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS")
}
if( ! is.null(data2.unknown.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 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, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 8, title = "DATA2 + DATA2 UNKNOWN DOTS")
}
}
}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe), x = list(x1, "x"), y = list(y1, "y"), categ = list("kind", "kind"), legend.name = list("DATASET", "VERT FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
if( ! is.null(data1.signif.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "VERT FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS")
}
if( ! is.null(data1.incon.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "VERT FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
}
}else{
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS")
}
if( ! is.null(data2)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, vframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9234
}
Gael  MILLOT's avatar
Gael MILLOT committed
9235
9236
9237
9238
9239
9240
9241
if( ! is.null(data2.signif.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", 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 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9242
}
Gael  MILLOT's avatar
Gael MILLOT committed
9243
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9244
9245
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9246
}
Gael  MILLOT's avatar
Gael MILLOT committed
9247
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
9248
}
Gael  MILLOT's avatar
Gael MILLOT committed
9249
9250
9251
9252
9253
9254
9255
if( ! is.null(data2.incon.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], 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 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot, raster = raster, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9256
9257
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9258
9259
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9260
}
Gael  MILLOT's avatar
Gael MILLOT committed
9261
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
9262
}
Gael  MILLOT's avatar
Gael MILLOT committed
9263
9264
9265
if( ! is.null(data2.unknown.dot)){
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9266
}
Gael  MILLOT's avatar
Gael MILLOT committed
9267
9268
9269
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("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "VERT FRAME"), 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, return = TRUE)
if( ! is.null(tempo.graph$warn)){
warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9270
9271
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9272
9273
if(graph.in.file == FALSE){
fun_open(pdf.disp = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9274
}
Gael  MILLOT's avatar
Gael MILLOT committed
9275
fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 8, title = "DATA2 + DATA2 UNKNOWN DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
9276
9277
9278
9279
}
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
9280
9281
# end plot
if(warn.print == TRUE & ! is.null(warn)){
Gael  MILLOT's avatar
Gael MILLOT committed
9282
9283
warning(warn, call. = FALSE)
cat("\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
9284
}
Gael  MILLOT's avatar
Gael MILLOT committed
9285
9286
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, axes = axes, warn = warn)
return(tempo.list)
Gael  MILLOT's avatar
Gael MILLOT committed
9287
9288
9289
}


Gael  MILLOT's avatar
Gael MILLOT committed
9290
################ Import
Gael  MILLOT's avatar
Gael MILLOT committed
9291
9292


Gael  MILLOT's avatar
Gael MILLOT committed
9293
######## fun_pack() #### check if R packages are present and import into the working environment
Gael  MILLOT's avatar
Gael MILLOT committed
9294
9295


Gael  MILLOT's avatar
Gael MILLOT committed
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
9314
9315
9316
9317
9318
9319
9320
9321
9322
9323
# Check OK: clear to go Apollo
fun_pack <- function(req.package, load = FALSE, lib.path = 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
# req.package: logical. Load the package into the environement (using library())?
# lib.path: 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_check()
# RETURN
# nothing
# EXAMPLES
# fun_pack(req.package = "nopackage")
# fun_pack(req.package = "ggplot2")
# fun_pack(req.package = "ggplot2", lib.path = "blablabla")
# DEBUGGING
# req.package = "ggplot2" ; lib.path = "C:/Program Files/R/R-3.5.1/library"
# req.package = "serpentine" ; lib.path = "C:/users/gael/appdata/roaming/python/python36/site-packages"
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9324
}
Gael  MILLOT's avatar
Gael MILLOT committed
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
# 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 = req.package, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = load, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(lib.path)){
tempo <- fun_check(data = lib.path, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(lib.path))){
tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE lib.path PARAMETER DOES NOT EXISTS: ", lib.path, "\n\n============\n\n")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9339
9340
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
9341
9342
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
Gael  MILLOT's avatar
Gael MILLOT committed
9343
}
Gael  MILLOT's avatar
Gael MILLOT committed
9344
9345
9346
9347
9348
# 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(is.null(lib.path)){
lib.path <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
Gael  MILLOT's avatar
Gael MILLOT committed
9349
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9350
.libPaths(new = sub(x = lib.path, 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
Gael  MILLOT's avatar
Gael MILLOT committed
9351
}
Gael  MILLOT's avatar
Gael MILLOT committed
9352
9353
9354
9355
9356
9357
9358
for(i0 in 1:length(req.package)){
if( ! req.package[i0] %in% rownames(utils::installed.packages(lib.loc = lib.path))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i0], " MUST BE INSTALLED IN:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}else{
if(load == TRUE){
suppressWarnings(suppressPackageStartupMessages(library(req.package[i0], lib.loc = lib.path, quietly = TRUE, character.only = TRUE)))
Gael  MILLOT's avatar
Gael MILLOT committed
9359
9360
9361
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
9362
}
Gael  MILLOT's avatar
Gael MILLOT committed
9363
9364


Gael  MILLOT's avatar
Gael MILLOT committed
9365
######## fun_python_pack() #### check if python packages are present
Gael  MILLOT's avatar
Gael MILLOT committed
9366
9367


Gael  MILLOT's avatar
Gael MILLOT committed
9368
# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
9369
fun_python_pack <- function(req.package, python.exec.path = NULL, lib.path = NULL, R.lib.path = NULL){
Gael  MILLOT's avatar
Gael MILLOT committed
9370
9371
9372
9373
9374
9375
# AIM
# check if the specified python packages are present in the computer (no import)
# WARNINGS
# for python 3.7. Previous versions return an error "Error in sys$stdout$flush() : attempt to apply non-function"
# ARGUMENTS
# req.package: character vector of package names to import
Gael  MILLOT's avatar
Gael MILLOT committed
9376
# python.exec.path: optional character vector specifying the absolute pathways of the executable python file to use (associated to the packages to use). If NULL, the reticulate::import_from_path() function used in fun_python_pack() seeks for an available version of python.exe, and then uses python_config(python_version, required_module, python_versions). But might not be the correct one for the lib.path parameter specified. Thus, it is recommanded to do not leave NULL, notably when using computing clusters
Gael  MILLOT's avatar
Gael MILLOT committed
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
9387
9388
9389
# lib.path: optional character vector specifying the absolute pathways of the directories containing some of the listed packages in the req.package argument
# R.lib.path: absolute path of the reticulate packages, if not in the default folders
# REQUIRED PACKAGES
# reticulate
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_pack()
# RETURN
# nothing
# EXAMPLES
# example of error message
# fun_python_pack(req.package = "nopackage")
# example without error message (require the installation of the python serpentine package from https://github.com/koszullab/serpentine
Gael  MILLOT's avatar
Gael MILLOT committed
9390
# fun_python_pack(req.package = "serpentine", python.exec.path = "C:/ProgramData/Anaconda3/python.exe", lib.path = "c:/programdata/anaconda3/lib/site-packages/")
Gael  MILLOT's avatar
Gael MILLOT committed
9391
9392
9393
# another example of error message
# fun_python_pack(req.package = "serpentine", lib.path = "blablabla")
# DEBUGGING
Gael  MILLOT's avatar
Gael MILLOT committed
9394
# req.package = "serpentine" ; python.exec.path = "C:/ProgramData/Anaconda3/python.exe" ; lib.path = "c:/programdata/anaconda3/lib/site-packages/" ; R.lib.path = NULL
Gael  MILLOT's avatar
Gael MILLOT committed
9395
9396
9397
9398
9399
9400
9401
9402
# req.package = "bad" ; lib.path = NULL ; R.lib.path = NULL
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9403
}
Gael  MILLOT's avatar
Gael MILLOT committed
9404
9405
9406
if(length(utils::find("fun_pack", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_pack() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9407
}
Gael  MILLOT's avatar
Gael MILLOT committed
9408
9409
9410
9411
9412
9413
9414
# 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 = req.package, class = "character", fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
9415
9416
9417
9418
if( ! is.null(python.exec.path)){
tempo <- fun_check(data = python.exec.path, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(file.exists(python.exec.path))){
tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \nFILE PATH INDICATED IN THE python.exec.path PARAMETER DOES NOT EXISTS: ", lib.path, "\n\n============\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
9419
9420
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9421
9422
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
9423
9424
9425
9426
9427
9428
if( ! is.null(lib.path)){
tempo <- fun_check(data = lib.path, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(lib.path))){
tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE lib.path PARAMETER DOES NOT EXISTS: ", lib.path, "\n\n============\n\n")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9429
}
Gael  MILLOT's avatar
Gael MILLOT committed
9430
9431
9432
9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444
9445
9446
9447
}
if( ! is.null(R.lib.path)){
tempo <- fun_check(data = R.lib.path, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(R.lib.path))){
tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE R.lib.path PARAMETER DOES NOT EXISTS: ", R.lib.path, "\n\n============\n\n")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
}
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
# package checking
fun_pack(req.package = "reticulate", lib.path = R.lib.path)
# end package checking
# main code
Gael  MILLOT's avatar
Gael MILLOT committed
9448
9449
if(is.null(python.exec.path)){
python.exec.path <- reticulate::py_run_string("
Gael  MILLOT's avatar
Gael MILLOT committed
9450
9451
9452
import sys ;
path_lib = sys.path
") # python string
Gael  MILLOT's avatar
Gael MILLOT committed
9453
python.exec.path <- python.exec.path$path_lib
Gael  MILLOT's avatar
Gael MILLOT committed
9454
9455
9456
9457
9458
9459
9460
9461
}
if(is.null(lib.path)){
lib.path <- reticulate::py_run_string("
import sys ;
path_lib = sys.path
") # python string
lib.path <- lib.path$path_lib
}
Gael  MILLOT's avatar
Gael MILLOT committed
9462
reticulate::use_python(Sys.which(python.exec.path), required = TRUE) # required to avoid the use of erratic python exec by reticulate::import_from_path()
Gael  MILLOT's avatar
Gael MILLOT committed
9463
9464
9465
9466
9467
9468
9469
9470
9471
9472
9473
9474
9475
for(i0 in 1:length(req.package)){
tempo.try <- vector("list", length = length(lib.path))
for(i1 in 1:length(lib.path)){
tempo.try[[i1]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i0], path = lib.path[i1]), silent = TRUE))
tempo.try[[i1]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i0], path = lib.path[i1]), silent = TRUE)) # done twice to avoid the error message  about flushing present the first time but not the second time. see https://stackoverflow.com/questions/57357001/reticulate-1-13-error-in-sysstdoutflush-attempt-to-apply-non-function
}
if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){
print(tempo.try)
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i0], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
} # else{
# suppressWarnings(suppressPackageStartupMessages(assign(req.package[i0], reticulate::import(req.package[i0])))) # not required because try() already evaluates
# }
Gael  MILLOT's avatar
Gael MILLOT committed
9476
9477
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
9478

Gael  MILLOT's avatar
Gael MILLOT committed
9479

Gael  MILLOT's avatar
Gael MILLOT committed
9480
################ Print / Exporting results (text & tables)
Gael  MILLOT's avatar
Gael MILLOT committed
9481

Gael  MILLOT's avatar
Gael MILLOT committed
9482
9483
9484
9485
9486

######## fun_report() #### print string or data object into output file


# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
9487
fun_report <- function(data, output = "results.txt", path = "C:/Users/Gael/Desktop/", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = TRUE, sep = 2){
Gael  MILLOT's avatar
Gael MILLOT committed
9488
9489
9490
9491
9492
# 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_check()
# ARGUMENTS
Gael  MILLOT's avatar
Gael MILLOT committed
9493
# data: object to print in the output file. If NULL, nothing is done, with no warning
Gael  MILLOT's avatar
Gael MILLOT committed
9494
9495
9496
9497
9498
9499
9500
9501
9502
9503
9504
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514
# 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_report()
# fun_report(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(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9515
}
Gael  MILLOT's avatar
Gael MILLOT committed
9516
9517
9518
9519
9520
9521
9522
9523
9524
9525
9526
# 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 = 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")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9527
}
Gael  MILLOT's avatar
Gael MILLOT committed
9528
9529
9530
9531
9532
9533
9534
9535
9536
9537
9538
9539
9540
9541
tempo <- fun_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")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
tempo <- fun_check(data = no.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = rownames.kept, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = vector.cat, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = noquote, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_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(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
Gael  MILLOT's avatar
Gael MILLOT committed
9542
# end argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
9543
9544
9545
9546
9547
9548
9549
9550
# 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()
# 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, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9551
# }
Gael  MILLOT's avatar
Gael MILLOT committed
9552
9553
# end argument checking
# main code
Gael  MILLOT's avatar
Gael MILLOT committed
9554
if( ! is.null(data)){
Gael  MILLOT's avatar
Gael MILLOT committed
9555
9556
9557
9558
9559
9560
9561
9562
9563
9564
9565
9566
9567
9568
9569
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 (because 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){
utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9570
}
Gael  MILLOT's avatar
Gael MILLOT committed
9571
9572
9573
}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)
Gael  MILLOT's avatar
Gael MILLOT committed
9574
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9575
cat(data, file= paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
9576
}
Gael  MILLOT's avatar
Gael MILLOT committed
9577
9578
9579
9580
9581
}else{ # other (array, list, factor or vector with vector.cat = FALSE)
if(noquote == TRUE){
utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
9582
}
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9583
}
Gael  MILLOT's avatar
Gael MILLOT committed
9584
9585
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
9586
}
Gael  MILLOT's avatar
Gael MILLOT committed
9587
}
Gael  MILLOT's avatar
Gael MILLOT committed
9588
9589


Gael  MILLOT's avatar
Gael MILLOT committed
9590
######## fun_get_message() #### return messages of an expression (that can be exported)
Gael  MILLOT's avatar
Gael MILLOT committed
9591
9592


Gael  MILLOT's avatar
Gael MILLOT committed
9593
9594
9595
9596
9597
9598
9599
9600
9601
9602
9603
9604
9605
9606
9607
9608
9609
9610
9611
9612
9613
9614
9615
9616
9617
# Check OK: clear to go Apollo
fun_get_message <- function(data, kind = "error", header = TRUE, print.no = FALSE, text = NULL, env = NULL){
# AIM
# evaluate an instruction written between "" and return the first of the error, or warning or standard (non error non warning) messages if ever exist
# using argument print.no = FALSE, return NULL if no message, which is convenient in some cases
# WARNING
# Only the first message is returned
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# data: character string to evaluate
# kind: character string. Either "error" to get error messages, or "warning" to get warning messages, or "message" to get non error and non warning messages
# header: logical. Add a header in the returned message?
# print.no: logical. Print a message saying that no message reported?
# text: character string added to the output message (even if no message exists and print.no is TRUE). Inactivated if header is FALSE
# env: the name of an existing environment. NULL if not required
# RETURN
# the message or NULL if no message and print.no is FALSE
# EXAMPLES
# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "warning", print.no = TRUE, text = "IN A")
# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "message", print.no = TRUE, text = "IN A")
# fun_get_message(data = "wilcox.test()", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "sum(1)", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "message('ahah')", kind = "error", print.no = TRUE, text = "IN A")
Gael  MILLOT's avatar
Gael MILLOT committed
9618
# fun_get_message(data = "message('ahah')", kind = "message", print.no = TRUE, text = "IN A")
Gael  MILLOT's avatar
Gael MILLOT committed
9619
9620
9621
# fun_get_message(data = "ggplot2::ggplot(data = data.frame(X = 1:10), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()", kind = "message", print.no = TRUE, text = "IN FUNCTION 1")
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; fun_get_message(data = 'fun_gg_boxplot(data = obs1, y = "Time", categ = "Group1")', kind = "message", print.no = TRUE, text = "IN FUNCTION 1")
# DEBUGGING
Gael  MILLOT's avatar
Gael MILLOT committed
9622
9623
9624
9625
9626
# data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging
# data = "sum(1)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL  # for function debugging
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; data = 'fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1")' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL  # for function debugging
# data = "message('ahah')" ; kind = "error" ; header = TRUE ; print.no = TRUE ; text = "IN A" ; env = NULL 
# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "message" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
9627
9628
9629
9630
9631
9632
9633
9634
9635
9636
9637
9638
9639
9640
9641
9642
9643
9644
9645
9646
9647
9648
9649
9650
9651
9652
9653
9654
9655
9656
9657
9658
9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end required function checking
# no need to use reserved words to avoid bugs, because it is local, and  exists("tempo.warning", inherit = FALSE), never use the scope
# 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 = data, class = "character", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = kind, options = c("error", "warning", "message"), length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = print.no, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = header, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(text)){
tempo <- fun_check(data = text, class = "character", length = 1, fun.name = function.name) ; eval(ee)
}
if( ! is.null(env)){
tempo <- fun_check(data = env, class = "environment", 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
pdf(file = NULL) # send plots into a NULL file, no pdf file created
window.nb <- dev.cur()
# last warning cannot be used because suppressWarnings() does not modify last.warning present in the base evironment (created at first warning in a new R session), or warnings() # to reset the warning history : unlockBinding("last.warning", baseenv()) ; assign("last.warning", NULL, envir = baseenv())
output <- NULL
tempo.error <- try(suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))), silent = TRUE) # get error message, not warning or messages
if(any(class(tempo.error) %in% c("gg", "ggplot"))){
tempo.error <- try(suppressMessages(suppressWarnings(ggplot2::ggplot_build(tempo.error))), silent = TRUE)[1]
}
if(exists("tempo.error", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word
if((length(tempo.error) > 0 & ! any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR"))) | (length(tempo.error) == 0)){
tempo.error <- NULL
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9672
}
Gael  MILLOT's avatar
Gael MILLOT committed
9673
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9674
tempo.error <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
9675
}
Gael  MILLOT's avatar
Gael MILLOT committed
9676
9677
if(kind == "error" & ! is.null(tempo.error)){ # 
if(header == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
9678
tempo.error[1] <- gsub(x = tempo.error[1], pattern = "^Error i|^error i|^ERROR I", replacement = "I")
Gael  MILLOT's avatar
Gael MILLOT committed
9679
9680
9681
9682
9683
9684
9685
9686
9687
output <- paste0("ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.error[1]) #
}else{
output <- tempo.error[1] #
}
}else if(kind == "error" & is.null(tempo.error) & print.no == TRUE){
output <- paste0("NO ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}else if(kind != "error" & ( ! is.null(tempo.error)) & print.no == TRUE){
output <- paste0("NO ", ifelse(kind == "warning", "WARNING", "STANDARD (NON ERROR AND NON WARNING)"), " MESSAGE BECAUSE OF ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}else if(is.null(tempo.error)){
Gael  MILLOT's avatar
Gael MILLOT committed
9688
9689
9690
9691
9692
fun.warning.capture <- function(expr){
# from demo(error.catching) typed in the R console, coming from ?tryCatch
# see also http://mazamascience.com/WorkingWithData/?p=912
# return a character string or NULL
# expr <- wilcox.test.default(c(1, 1, 3), c(1, 2, 4), paired = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9693
9694
W <- NULL
w.handler <- function(w){ # warning handler
Gael  MILLOT's avatar
Gael MILLOT committed
9695
9696
W <<- w # send to the above env, i.e., the inside of the fun.warning.capture function
invokeRestart("muffleWarning") # here w.handler() muffles all the warnings. See http://romainfrancois.blog.free.fr/index.php?post/2009/05/20/Disable-specific-warnings to muffle specific warnings and print others
Gael  MILLOT's avatar
Gael MILLOT committed
9697
9698
}
output <- list(
Gael  MILLOT's avatar
Gael MILLOT committed
9699
value = suppressMessages(withCallingHandlers(tryCatch(expr, error = function(e){e}), warning = w.handler)), # BEWARE: w.handler is a function written without (), like in other functions with FUN argument
Gael  MILLOT's avatar
Gael MILLOT committed
9700
warning = W # processed by w.handler()
Gael  MILLOT's avatar
Gael MILLOT committed
9701
)
Gael  MILLOT's avatar
Gael MILLOT committed
9702
return(if(is.null(output$warning)){NULL}else{as.character(output$warning)})
Gael  MILLOT's avatar
Gael MILLOT committed
9703
}
Gael  MILLOT's avatar
Gael MILLOT committed
9704
9705
tempo.warn <- fun.warning.capture(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))
# warn.options.ini <- options()$warn ; options(warn = 1) ; tempo.warn <- utils::capture.output({tempo <- suppressMessages(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))}, type = "message") ; options(warn = warn.options.ini) # this recover warnings not messages and not errors but does not work in all enviroments
Gael  MILLOT's avatar
Gael MILLOT committed
9706
9707
9708
9709
9710
9711
tempo.message <- utils::capture.output({
tempo <- suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env})))
if(any(class(tempo) %in% c("gg", "ggplot"))){
tempo <- ggplot2::ggplot_build(tempo)
}else{
tempo <- suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))
Gael  MILLOT's avatar
Gael MILLOT committed
9712
}
Gael  MILLOT's avatar
Gael MILLOT committed
9713
}, type = "message") # recover messages not warnings and not errors
Gael  MILLOT's avatar
Gael MILLOT committed
9714
9715
if(kind == "warning" & ! is.null(tempo.warn)){
if(length(tempo.warn) > 0){ # to avoid character(0)
Gael  MILLOT's avatar
Gael MILLOT committed
9716
9717
9718
if( ! any(sapply(tempo.warn, FUN = "grepl", pattern = "() FUNCTION:$"))){
tempo.warn <- paste(unique(tempo.warn), collapse = "\n") # if FALSE, means that the tested data is a special function. If TRUE, means that the data is a standard function. In that case, the output of capture.output() is two strings per warning messages: if several warning messages -> identical first string, which is removed in next messages by unique()
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
9719
tempo.warn <- paste(tempo.warn, collapse = "\n")
Gael  MILLOT's avatar
Gael MILLOT committed
9720
9721
}
if(header == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
9722
9723
if(any(grepl(x = tempo.warn[[1]], pattern = "^simpleWarning i"))){
tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I")
Gael  MILLOT's avatar
Gael MILLOT committed
9724
}
Gael  MILLOT's avatar
Gael MILLOT committed
9725
9726
if(any(grepl(x = tempo.warn[[1]], pattern = "^Warning i"))){
tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I")
Gael  MILLOT's avatar
Gael MILLOT committed
9727
9728
9729
9730
9731
9732
9733
9734
}
output <- paste0("WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.warn) #
}else{
output <- tempo.warn #
}
}else if(print.no == TRUE){
output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}
Gael  MILLOT's avatar
Gael MILLOT committed
9735
}else if(kind == "warning" & is.null(tempo.warn) & print.no == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
9736
9737
9738
9739
9740
9741
9742
9743
9744
9745
9746
9747
9748
9749
9750
9751
9752
output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word
if(length(tempo.message) > 0){ # if something is returned by capture.ouptput() (only in this env) with a length more than 1
if(header == TRUE){
output <- paste0("STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.message) #
}else{
output <- tempo.message #
}
}else if(print.no == TRUE){
output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}
}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == FALSE & print.no == TRUE){
output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}
}
invisible(dev.off(window.nb)) # end send plots into a NULL file
return(output) # do not use cat() because the idea is to reuse the message
Gael  MILLOT's avatar
Gael MILLOT committed
9753
9754
}

Gael  MILLOT's avatar
Gael MILLOT committed
9755
9756