Merge pull request #13 from MindTheGap-ERC/improve_plotting

Improve plotting

NAMESPACE

@@ -55,8 +55,10 @@ export(get_total_duration)
 export(get_total_thickness)
 export(is_adm)
 export(is_destructive)
+export(make_legend)
 export(merge_adm_to_multiadm)
 export(merge_multiadm)
+export(plot_erosive_intervals)
 export(sedrate_to_multiadm)
 export(set_L_unit)
 export(set_T_unit)

R/L_axis_lab.R

@@ -8,7 +8,7 @@ L_axis_lab = function(label = "Height", unit = TRUE, sep = " ", brac = c("[", "]
   #' 
   #' @param label Axis label
   #' @param unit Logical or character, should unit be plotted
-  #' @param sep separater between label and unit
+  #' @param sep separator between label and unit
   #' @param brac brackets surrounding unit
   #' @param line parameter passed to _mtext_, see ?mtext for details
   #' @param outer parameter passed to _mtext_, see ?mtext for details
@@ -38,7 +38,7 @@ L_axis_lab = function(label = "Height", unit = TRUE, sep = " ", brac = c("[", "]
     L_lab = paste0(sep, brac[1], unit, brac[2])
   }
 
-  graphics::mtext(text = paste(label, L_lab, sep = " "),
+  graphics::mtext(text = paste(label, L_lab, sep = ""),
                   side = 2,
                   line = line,
                   outer = outer,

R/T_axis_lab.R

@@ -8,7 +8,7 @@ T_axis_lab = function(label = "Time", unit = TRUE, sep = " ", brac = c("[", "]")
   #' 
   #' @param label Axis label
   #' @param unit Logical or character, should unit be plotted
-  #' @param sep separater between label and unit
+  #' @param sep separator between label and unit
   #' @param brac brackets surrounding unit
   #' @param line parameter passed to _mtext_, see ?mtext for details
   #' @param outer parameter passed to _mtext_, see ?mtext for details
@@ -38,7 +38,7 @@ T_axis_lab = function(label = "Time", unit = TRUE, sep = " ", brac = c("[", "]")
     T_lab = paste0(sep, brac[1], unit, brac[2])
   }
 
-  graphics::mtext(text = paste(label, T_lab, sep = " "),
+  graphics::mtext(text = paste(label, T_lab, sep = ""),
         side = 1,
         line = line,
         outer = outer,

R/make_adm_canvas.R

@@ -0,0 +1,24 @@
+make_adm_canvas = function(){
+
+  #'
+  #' @noRd
+  #' @keywords internal
+  #' 
+  #' @title initialize amd plot
+  #' 
+  #' @description
+    #' generates an empty plot for adm plotting
+    #' 
+  #' 
+  #' @returns invisible NULL 
+
+  list = get("adm_plot_info", envir = .adm_plot_env)
+
+
+
+  plot(NULL,
+       xlim = list$t_range,
+       ylim = list$h_range,
+       xlab = "",
+       ylab = "")
+}

R/plot.adm.R

@@ -1,50 +1,45 @@
-plot.adm = function(x, lwd_hiat = 1, lwd_cons = 1, lty_hiat = 3, lty_cons = 1, 
-                    col_hiat = "black", col_cons = "black", ...){
+plot.adm = function(x, lwd_destr = 1, lwd_acc = 1, lty_destr = 3, lty_acc = 1, 
+                    col_destr = "black", col_acc = "black", ...){
 
   #'
   #'@export
   #'
   #' @title plotting adm objects
   #' 
   #' @param x an adm object
-  #' @param lwd_hiat line width of hiatuse
-  #' @param lwd_cons line width of conservative intervals
-  #' @param lty_hiat linetype of hiatuses
-  #' @param lty_cons line type of conservative intervals
-  #' @param col_hiat color of erosive intervals
-  #' @param col_cons color of conservative intervals
+  #' @param lwd_destr line width of hiatuse
+  #' @param lwd_acc line width of conservative intervals
+  #' @param lty_destr linetype of hiatuses
+  #' @param lty_acc line type of conservative intervals
+  #' @param col_destr color of erosive intervals
+  #' @param col_acc color of conservative intervals
   #' @param ... arguments passed to plot
   #' 
 
-  assign("adm_plot_info",list("T_unit" = x$T_unit,
-                              "L_unit" = x$L_unit), envir = .adm_plot_env)
+  assign(x = "adm_plot_info",
+         value = list("T_unit" = x$T_unit,
+                      "L_unit" = x$L_unit,
+                      "h_range" = range(x$h),
+                      "t_range" = range(x$t),
+                      "adm" = x),
+         envir = .adm_plot_env)
 
   adm = x
 
   in_list = list(...)
 
-  plot(x = adm$t,
-       y = adm$h,
-       type = "l",
-       lty = "blank",
-       xlab = "",
-       ylab = "",
-       ...)
+  make_adm_canvas()
 
 
 
   # non-erosive parts
-  x = replace(adm$t, is_destructive(adm, adm$t, mode = "open"), NA)
-  y = replace(adm$h, is_destructive(adm, adm$t, mode = "open"), NA)
-  graphics::lines(x = x, y = y,
-                  lwd = lwd_cons,
-                  lty = lty_cons,
-                  col = col_cons)
+  plot_acc_parts(lwd_acc = lwd_acc, lty_acc = lty_acc, 
+                            col_acc = col_acc)
 
   # erosive parts
-  x= replace(adm$t, ! is_destructive(adm, adm$t, mode = "closed"), NA)
-  y= replace(adm$h, ! is_destructive(adm, adm$t, mode = "closed"), NA)
-  graphics::lines(x, y, lwd = lwd_hiat, lty = lty_hiat, col = col_hiat)
+  plot_destr_parts(lwd_destr = lwd_destr, lty_destr = lty_destr, col_destr = col_destr)
+
+  return(invisible())
 
 }
 

R/plot.multiadm.R

@@ -1,4 +1,4 @@
-plot.multiadm = function(x,...){
+plot.multiadm = function(x, ...){
 
   #'
   #' @export
@@ -11,64 +11,104 @@ plot.multiadm = function(x,...){
   #' @returns a plot of the multiadm object
   #' 
 
+
+
+
   arg_list = list(...)
-
-  if ("mode" %in% names(arg_list)){
-    if (arg_list[["mode"]] == "envelope"){
-      mode = "envelope"
-    } else {
-      mode = "lines"
-    }
-  } else {
-    mode == "lines"
-  }
 
-  assign("adm_plot_info",list("T_unit" = x$T_unit,
-                              "L_unit" = x$L_unit), envir = .adm_plot_env)
+  move_multiadm_to_env(x)
 
   multiadm = x
 
-  if (mode == "lines") {
-    no_of_entries = multiadm$no_of_entries
-    t_min = min(sapply(seq_len(no_of_entries), function(x) min(multiadm[["t"]][[x]])))
-    t_max = max(sapply(seq_len(no_of_entries), function(x) max(multiadm[["t"]][[x]])))
-    h_min = min(sapply(seq_len(no_of_entries), function(x) min(multiadm[["h"]][[x]])))
-    h_max = max(sapply(seq_len(no_of_entries), function(x) max(multiadm[["h"]][[x]])))
-
-    plot(NULL,
-         xlim = c(t_min, t_max),
-         ylim = c(h_min, h_max),
-         xlab = "",
-         ylab = "")
-
-    for ( i in seq_len(no_of_entries)){
-      graphics::lines(multiadm$t[[i]], multiadm$h[[i]])
-    }
-  }
+  make_adm_canvas()
 
-  if (mode == "envelope"){
-    no_of_entries = multiadm$no_of_entries
-    t_min = min(sapply(seq_len(no_of_entries), function(x) min(multiadm[["t"]][[x]])))
-    t_max = max(sapply(seq_len(no_of_entries), function(x) max(multiadm[["t"]][[x]])))
-    h_min = min(sapply(seq_len(no_of_entries), function(x) min(multiadm[["h"]][[x]])))
-    h_max = max(sapply(seq_len(no_of_entries), function(x) max(multiadm[["h"]][[x]])))
+  plot_envelope()
 
-    plot(NULL,
-         xlim = c(t_min, t_max),
-         ylim = c(h_min, h_max),
-         xlab = "",
-         ylab = "")
-
-    h = seq(h_min, h_max, length.out = 100)
-    h_list = get_time(multiadm, h)
-    h_t= list()
-    for ( i in seq_len(100)){
-      h_t[[i]] = sapply(h_list, function(x) x[i])
-    }
-    graphics::lines(sapply(h_t, function(x) stats::quantile(x, 0.025, na.rm = TRUE)),h, col = "blue")
-    graphics::lines(sapply(h_t, function(x) stats::quantile(x, 0.975, na.rm = TRUE)),h, col = "blue")
-    graphics::lines(sapply(h_t, function(x) stats::quantile(x, 0.5, na.rm = TRUE)),h, col = "red")
+
+}
+
+move_multiadm_to_env = function(x, ...){
+
+  #' 
+  #' @keywords internal
+  #' @noRd
+  #' 
+  #' @title moves multiadm to environments
+  #' 
+  #' @description
+    #' Moves the params used for plotting into the plotting environment
+  #'
+  #' @param x multiadm object
+  #' @param ... further plotting parameters
+  #' 
+  #' @returns invisible NULL
+  #' 
+
+  multiadm = x
+
+  no_of_entries = multiadm$no_of_entries
+  t_min = min(sapply(seq_len(no_of_entries), function(x) min(multiadm[["t"]][[x]])))
+  t_max = max(sapply(seq_len(no_of_entries), function(x) max(multiadm[["t"]][[x]])))
+  h_min = min(sapply(seq_len(no_of_entries), function(x) min(multiadm[["h"]][[x]])))
+  h_max = max(sapply(seq_len(no_of_entries), function(x) max(multiadm[["h"]][[x]])))
+
+  assign(x = "adm_plot_info",
+         value = list("T_unit" = x$T_unit,
+                      "L_unit" = x$L_unit,
+                      "h_range" = c(h_min, h_max),
+                      "t_range" = c(t_min, t_max),
+                      "median_col" = "red",
+                      "envelope_col" = "blue",
+                      "p_envelope" = 0.9,
+                      "madm" = x),
+         envir = .adm_plot_env)
+  return(invisible())
+}
+
+plot_envelope = function(){
+
+  #' 
+  #' @keywords internal
+  #' @noRd
+  #' 
+  #' @title plot envelope for multiadm
+  #' 
+  #' @returns invisible NULL
+  #' 
+
+  list = get("adm_plot_info", envir = .adm_plot_env)
+
+  multiadm = list$madm
+
+  h = seq(list$h_range[1], list$h_range[2], length.out = 100)
+  h_list = get_time(multiadm, h)
+  h_t= list()
+  for ( i in seq_len(100)){
+    h_t[[i]] = sapply(h_list, function(x) x[i])
   }
+  graphics::lines(sapply(h_t, function(x) stats::quantile(x, 0.5 * (1 - list$p_envelope) , na.rm = TRUE)),h, col = list$envelope_col)
+  graphics::lines(sapply(h_t, function(x) stats::quantile(x, 0.5 * (1 - list$p_envelope) + list$p_envelope, na.rm = TRUE)),h, col = list$envelope_col)
+  graphics::lines(sapply(h_t, function(x) stats::quantile(x, 0.5, na.rm = TRUE)),h, col = list$median_col)
+
+  return(invisible())
+}
 
+make_legend = function(){
+  #' @export
+  #' 
+  #' @title plot legend
+  #' 
+  #' @description
+    #' plots a legend for the multiadm plot
+    #' 
+  #' 
+  #' @returns invisible NULL
+  #' 
 
+  list = get("adm_plot_info", envir = .adm_plot_env)
+  graphics::legend("topleft",
+         lwd = 1,
+         lty = 1,
+         col = c(list$median_col, list$envelope_col),
+         legend = c("Median", paste0(list$p_envelope, " Percentile Envelope" )))
 }

R/plot_acc_parts.R

@@ -0,0 +1,34 @@
+plot_acc_parts = function(lwd_acc = 1, lty_acc = 1, 
+                          col_acc = "black"){
+
+  #'
+  #' @keywords internal
+  #' @noRd
+  #' 
+  #' @title draw sed accumulation
+  #' 
+  #' @description
+    #' draws time intervals where sediment is accumulated
+  #'
+  #' @param lwd_acc line width
+  #' @param lty_acc line type
+  #' @param col_acc color
+  #' 
+  #' @returns invisible NULL
+
+
+  list = get("adm_plot_info", envir = .adm_plot_env)
+
+  x = list$adm
+
+  for ( i in seq_along(x$destr)){
+    if (!x$destr[i]){
+      graphics::lines(x = c(x$t[c(i, i+1)]),
+                      y = c(x$h[c(i, i+1)]),
+                      col = col_acc,
+                      lwd = lwd_acc,
+                      lty = lty_acc)
+    }
+  }
+  return(invisible())
+}

R/plot_destr_parts.R

@@ -0,0 +1,32 @@
+plot_destr_parts = function(lwd_destr = 1, lty_destr = 3, col_destr = "black"){
+
+  #'
+  #' @keywords internal
+  #' @noRd
+  #' 
+  #' @title draw destr. intervals
+  #' 
+  #' @description
+  #' draws time intervals no sediment is accumulated and signals are destroyed
+  #'
+  #' @param lwd_destr line width
+  #' @param lty_destr line type
+  #' @param col_destr color
+  #' 
+  #' @returns invisible NULL
+
+  list = get("adm_plot_info", envir = .adm_plot_env)
+
+  x = list$adm
+
+  for ( i in seq_along(x$destr)){
+    if (x$destr[i]){
+      graphics::lines(x = c(x$t[c(i, i+1)]),
+                      y = c(x$h[c(i, i+1)]),
+                      col = col_destr,
+                      lwd = lwd_destr,
+                      lty = lty_destr)
+    }
+  }
+  return(invisible())
+}