diff --git a/NEWS.md b/NEWS.md index b80a19d5..a4c7a045 100644 --- a/NEWS.md +++ b/NEWS.md @@ -50,7 +50,9 @@ where the formatting is also better._ - Fixed dynamic y-axis margin spacing for flipped `"boxplot"` and `"jitter"` types. Thanks to @eddelbuettel for the report in #357 (@grantmcdermott). - Fixed dynamic x-axis margin spacing for perpendicular (vertical) label text, - i.e. cases where `las = 2` or `las = 3`. #369 (@grantmcdermott). + i.e. cases where `las = 2` or `las = 3`. (#369 @grantmcdermott) +- Better integration with the Positron IDE graphics pane. Thanks to @thomasp85 + for the report and helpful suggestions. (#377 @grantmcdermott) ### Internals: diff --git a/R/draw_legend.R b/R/draw_legend.R index 88c2e2c0..6c09ee30 100644 --- a/R/draw_legend.R +++ b/R/draw_legend.R @@ -112,359 +112,379 @@ draw_legend = function( new_plot = TRUE ) { - if (is.null(lmar)) { - lmar = tpar("lmar") - } else { - if (!is.numeric(lmar) || length(lmar)!=2) stop ("lmar must be a numeric of length 2.") - } - - soma = outer_right = outer_bottom = NULL - - # - ## legend args ---- + # Note: We wrap everything in recordGraphics to preserve legend spacing if + # the plot is resized + recordGraphics( + { - if (is.null(legend_args[["x"]])) { - if (is.null(legend)) { - legend_args[["x"]] = "right!" - } else if (is.character(legend)) { - legend_args = utils::modifyList(legend_args, list(x = legend)) - } else if (class(legend) %in% c("call", "name")) { - largs = as.list(legend) - if (is.null(largs[["x"]])) { - lnms = names(largs) - # check second position b/c first will be a symbol - if (is.null(lnms)) { - largs = stats::setNames(largs, c("", "x")) - } else if (length(largs)>=2 && lnms[2] == "") { - lnms[2] = "x" - largs = stats::setNames(largs, lnms) - } else { - largs[["x"]] = "right!" + if (is.null(lmar)) { + lmar = tpar("lmar") + } else { + if (!is.numeric(lmar) || length(lmar)!=2) stop ("lmar must be a numeric of length 2.") + } + + soma = outer_right = outer_bottom = NULL + + # + ## legend args ---- + + if (is.null(legend_args[["x"]])) { + if (is.null(legend)) { + legend_args[["x"]] = "right!" + } else if (is.character(legend)) { + legend_args = utils::modifyList(legend_args, list(x = legend)) + } else if (class(legend) %in% c("call", "name")) { + largs = as.list(legend) + if (is.null(largs[["x"]])) { + lnms = names(largs) + # check second position b/c first will be a symbol + if (is.null(lnms)) { + largs = stats::setNames(largs, c("", "x")) + } else if (length(largs)>=2 && lnms[2] == "") { + lnms[2] = "x" + largs = stats::setNames(largs, lnms) + } else { + largs[["x"]] = "right!" + } + } + # Finally, combine with any pre-existing legend args (e.g., title from the by label) + legend_args = utils::modifyList(legend_args, largs, keep.null = TRUE) } } - # Finally, combine with any pre-existing legend args (e.g., title from the by label) - legend_args = utils::modifyList(legend_args, largs, keep.null = TRUE) - } - } - - ## Use `!exists` rather than `is.null` for title in case user specified no title - if (!exists("title", where = legend_args)) legend_args[["title"]] = by_dep - - legend_args[["pch"]] = legend_args[["pch"]] %||% pch - legend_args[["lty"]] = legend_args[["lty"]] %||% lty - legend_args[["col"]] = legend_args[["col"]] %||% col - legend_args[["bty"]] = legend_args[["bty"]] %||% "n" - legend_args[["horiz"]] = legend_args[["horiz"]] %||% FALSE - legend_args[["xpd"]] = legend_args[["xpd"]] %||% NA - - if (!isTRUE(type %in% c("p", "ribbon", "polygon", "polypath"))) { - legend_args[["lwd"]] = legend_args[["lwd"]] %||% lwd - } - - if (isTRUE(type %in% c("p", "pointrange", "errorbar")) && (length(col) == 1 || length(cex) == 1)) { - legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% cex - } - - # turn off inner line for "barplot" type - if (identical(type, "barplot")) { - legend_args[["lty"]] = 0 - } - - if (isTRUE(type %in% c("rect", "ribbon", "polygon", "polypath", "boxplot", "hist", "histogram", "spineplot", "ridge", "barplot", "violin")) || isTRUE(gradient)) { - legend_args[["pch"]] = 22 - legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% 3.5 - legend_args[["y.intersp"]] = legend_args[["y.intersp"]] %||% 1.25 - legend_args[["seg.len"]] = legend_args[["seg.len"]] %||% 1.25 - } - - if (isTRUE(type %in% c("ribbon", "hist", "histogram", "spineplot"))) { - legend_args[["pt.lwd"]] = legend_args[["pt.lwd"]] %||% 0 - } - - if (identical(type, "p")) { - legend_args[["pt.lwd"]] = legend_args[["pt.lwd"]] %||% lwd - } - - if (identical(type, "n") && isFALSE(gradient)) { - legend_args[["pch"]] = legend_args[["pch"]] %||% par("pch") - } - - if (identical(type, "spineplot")) { - legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% legend_args[["col"]] - } - - if (identical(type, "ridge") && isFALSE(gradient)) { - legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% sapply(legend_args[["col"]], function(ccol) seq_palette(ccol, n = 2)[2]) - } - - legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% bg - - legend_args[["legend"]] = legend_args[["legend"]] %||% lgnd_labs - if (length(lgnd_labs) != length(eval(legend_args[["legend"]]))) { - warning( - "\nUser-supplied legend labels do not match the number of groups.\n", - "Defaulting to automatic labels determined by the group splits in `by`,\n" - ) - legend_args[["legend"]] = lgnd_labs - } - - # - ## legend placement ---- - - ooma = par("oma") - omar = par("mar") - topmar_epsilon = 0.1 - - # Catch to avoid recursive offsets, e.g. repeated tinyplot calls with - # "bottom!" legend position. - - ## restore inner margin defaults - ## (in case the plot region/margins were affected by the preceding tinyplot call) - dynmar = isTRUE(.tpar[["dynmar"]]) - if (any(ooma != 0) && !dynmar) { - if ( ooma[1] != 0 & omar[1] == par("mgp")[1] + 1*par("cex.lab") ) omar[1] = 5.1 - if ( ooma[2] != 0 & omar[2] == par("mgp")[1] + 1*par("cex.lab") ) omar[2] = 4.1 - if ( ooma[3] == topmar_epsilon & omar[3] != 4.1 ) omar[3] = 4.1 - if ( ooma[4] != 0 & omar[4] == 0 ) omar[4] = 2.1 - par(mar = omar) - } - ## restore outer margin defaults - par(omd = c(0,1,0,1)) - ooma = par("oma") - - ## Legend to outer side (either right or left) of plot - if (grepl("right!$|left!$", legend_args[["x"]])) { - - outer_right = grepl("right!$", legend_args[["x"]]) + + ## Use `!exists` rather than `is.null` for title in case user specified no title + if (!exists("title", where = legend_args)) legend_args[["title"]] = by_dep - # extra bump for spineplot if outer_right legend (to accommodate secondary y-axis) - if (identical(type, "spineplot")) lmar[1] = lmar[1] + 1.1 + legend_args[["pch"]] = legend_args[["pch"]] %||% pch + legend_args[["lty"]] = legend_args[["lty"]] %||% lty + legend_args[["col"]] = legend_args[["col"]] %||% col + legend_args[["bty"]] = legend_args[["bty"]] %||% "n" + legend_args[["horiz"]] = legend_args[["horiz"]] %||% FALSE + legend_args[["xpd"]] = legend_args[["xpd"]] %||% NA - ## Switch position anchor (we'll adjust relative to the _opposite_ side below) - if (outer_right) legend_args[["x"]] = gsub("right!$", "left", legend_args[["x"]]) - if (!outer_right) legend_args[["x"]] = gsub("left!$", "right", legend_args[["x"]]) - - ## We have to set the inner margins of the plot before the (fake) legend is - ## drawn, otherwise the inset calculation---which is based in the legend - ## width---will be off the first time. - if (outer_right) { - omar[4] = 0 - } else { - # For outer left we have to account for the y-axis label too, which - # requires additional space - omar[2] = par("mgp")[1] + 1*par("cex.lab") - } - par(mar = omar) - - # if (isTRUE(new_plot)) plot.new() - if (isTRUE(new_plot)) { - plot.new() - # Experimental: For themed + dynamic plots, we need to make sure the - # adjusted plot margins for the legend are reinstated (after being - # overwritten by the before.plot.new hook. - if (dynmar) { - omar = par("mar") - if (outer_right) { - omar[4] = 0 - } else { - omar[2] = par("mgp")[1] + 1*par("cex.lab") - } - par(mar = omar) + if (!isTRUE(type %in% c("p", "ribbon", "polygon", "polypath"))) { + legend_args[["lwd"]] = legend_args[["lwd"]] %||% lwd } - } - legend_args[["horiz"]] = FALSE + if (isTRUE(type %in% c("p", "pointrange", "errorbar")) && (length(col) == 1 || length(cex) == 1)) { + legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% cex + } - # "draw" fake legend - fklgnd.args = modifyList( - legend_args, - list(x = 0, y = 0, plot = FALSE), - keep.null = TRUE - ) - if (isTRUE(gradient)) { - lgnd_labs_tmp = na.omit(fklgnd.args[["legend"]]) - if (length(lgnd_labs_tmp) < 5L) { - nmore = 5L - length(lgnd_labs_tmp) - lgnd_labs_tmp = c(lgnd_labs_tmp, rep("", nmore)) - } - fklgnd.args = modifyList( - fklgnd.args, - list(legend = lgnd_labs_tmp), - keep.null = TRUE - ) - } - fklgnd = do.call("legend", fklgnd.args) + # turn off inner line for "barplot" type + if (identical(type, "barplot")) { + legend_args[["lty"]] = 0 + } + + if (isTRUE(type %in% c("rect", "ribbon", "polygon", "polypath", "boxplot", "hist", "histogram", "spineplot", "ridge", "barplot", "violin")) || isTRUE(gradient)) { + legend_args[["pch"]] = 22 + legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% 3.5 + legend_args[["y.intersp"]] = legend_args[["y.intersp"]] %||% 1.25 + legend_args[["seg.len"]] = legend_args[["seg.len"]] %||% 1.25 + } - # calculate outer margin width in lines - soma = grconvertX(fklgnd$rect$w, to="lines") - grconvertX(0, to="lines") - # Add legend margins to the outer margin - soma = soma + sum(lmar) - ## differing outer margin adjustments depending on side - if (outer_right) { - ooma[4] = soma - } else { - ooma[2] = soma - } - par(oma = ooma) + if (isTRUE(type %in% c("ribbon", "hist", "histogram", "spineplot"))) { + legend_args[["pt.lwd"]] = legend_args[["pt.lwd"]] %||% 0 + } - # determine legend inset - inset = grconvertX(lmar[1], from="lines", to="npc") - grconvertX(0, from = "lines", to = "npc") - if (isFALSE(outer_right)) { - # extra space needed for "left!" b/c of lhs inner margin - inset_bump = grconvertX(par("mar")[2], from = "lines", to = "npc") - grconvertX(0, from = "lines", to = "npc") - inset = inset + inset_bump - } - # GM: The legend inset spacing only works _exactly_ if we refresh the plot - # area. I'm not sure why (and it works properly if we use the same - # parameters manually while debugging), but this hack seems to work. - ## v0.3.0 update: Using (temporary) hook instead of direct par(new = TRUE) - ## assignment to play nice with tinytheme logic. - oldhook = getHook("before.plot.new") - setHook("before.plot.new", function() par(new = TRUE), action = "append") - setHook("before.plot.new", function() par(mar = omar), action = "append") - plot.new() - setHook("before.plot.new", oldhook, action = "replace") - # Finally, set the inset as part of the legend args. - legend_args[["inset"]] = c(1+inset, 0) + if (identical(type, "p")) { + legend_args[["pt.lwd"]] = legend_args[["pt.lwd"]] %||% lwd + } - ## Legend at the outer top or bottom of plot - } else if (grepl("bottom!$|top!$", legend_args[["x"]])) { + if (identical(type, "n") && isFALSE(gradient)) { + legend_args[["pch"]] = legend_args[["pch"]] %||% par("pch") + } - outer_bottom = grepl("bottom!$", legend_args[["x"]]) + if (identical(type, "spineplot")) { + legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% legend_args[["col"]] + } - ## Switch position anchor (we'll adjust relative to the _opposite_ side below) - if (outer_bottom) legend_args[["x"]] = gsub("bottom!$", "top", legend_args[["x"]]) - if (!outer_bottom) legend_args[["x"]] = gsub("top!$", "bottom", legend_args[["x"]]) + if (identical(type, "ridge") && isFALSE(gradient)) { + legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% sapply(legend_args[["col"]], function(ccol) seq_palette(ccol, n = 2)[2]) + } - ## We have to set the inner margins of the plot before the (fake) legend is - ## drawn, otherwise the inset calculation---which is based in the legend - ## width---will be off the first time. - if (outer_bottom) { - omar[1] = par("mgp")[1] + 1*par("cex.lab") - if (isTRUE(has_sub) && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]]==1)) omar[1] = omar[1] + 1*par("cex.sub") - } else { - ## For "top!", the logic is slightly different: We don't expand the outer - ## margin b/c we need the legend to come underneath the main title. So - ## we rather expand the existing inner margin. - ooma[3] = ooma[3] + topmar_epsilon - par(oma = ooma) - } - par(mar = omar) + legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% bg - # if (isTRUE(new_plot)) plot.new() - if (isTRUE(new_plot)) { - plot.new() - # Experimental: For themed + dynamic plots, we need to make sure the - # adjusted plot margins for the legend are reinstated (after being - # overwritten by the before.plot.new hook. - if (dynmar) { - omar = par("mar") + legend_args[["legend"]] = legend_args[["legend"]] %||% lgnd_labs + if (length(lgnd_labs) != length(eval(legend_args[["legend"]]))) { + warning( + "\nUser-supplied legend labels do not match the number of groups.\n", + "Defaulting to automatic labels determined by the group splits in `by`,\n" + ) + legend_args[["legend"]] = lgnd_labs + } + + # + ## legend placement ---- + + ooma = par("oma") + omar = par("mar") + topmar_epsilon = 0.1 + + # Catch to avoid recursive offsets, e.g. repeated tinyplot calls with + # "bottom!" legend position. + + ## restore inner margin defaults + ## (in case the plot region/margins were affected by the preceding tinyplot call) + dynmar = isTRUE(.tpar[["dynmar"]]) + if (any(ooma != 0) && !dynmar) { + if ( ooma[1] != 0 & omar[1] == par("mgp")[1] + 1*par("cex.lab") ) omar[1] = 5.1 + if ( ooma[2] != 0 & omar[2] == par("mgp")[1] + 1*par("cex.lab") ) omar[2] = 4.1 + if ( ooma[3] == topmar_epsilon & omar[3] != 4.1 ) omar[3] = 4.1 + if ( ooma[4] != 0 & omar[4] == 0 ) omar[4] = 2.1 + par(mar = omar) + } + ## restore outer margin defaults + par(omd = c(0,1,0,1)) + ooma = par("oma") + + ## Legend to outer side (either right or left) of plot + if (grepl("right!$|left!$", legend_args[["x"]])) { + + outer_right = grepl("right!$", legend_args[["x"]]) + + # extra bump for spineplot if outer_right legend (to accommodate secondary y-axis) + if (identical(type, "spineplot")) lmar[1] = lmar[1] + 1.1 + + ## Switch position anchor (we'll adjust relative to the _opposite_ side below) + if (outer_right) legend_args[["x"]] = gsub("right!$", "left", legend_args[["x"]]) + if (!outer_right) legend_args[["x"]] = gsub("left!$", "right", legend_args[["x"]]) + + ## We have to set the inner margins of the plot before the (fake) legend is + ## drawn, otherwise the inset calculation---which is based in the legend + ## width---will be off the first time. + if (outer_right) { + omar[4] = 0 + } else { + # For outer left we have to account for the y-axis label too, which + # requires additional space + omar[2] = par("mgp")[1] + 1*par("cex.lab") + } + par(mar = omar) + + # if (isTRUE(new_plot)) plot.new() + if (isTRUE(new_plot)) { + plot.new() + # Experimental: For themed + dynamic plots, we need to make sure the + # adjusted plot margins for the legend are reinstated (after being + # overwritten by the before.plot.new hook. + if (dynmar) { + omar = par("mar") + if (outer_right) { + omar[4] = 0 + } else { + omar[2] = par("mgp")[1] + 1*par("cex.lab") + } + par(mar = omar) + } + } + + legend_args[["horiz"]] = FALSE + + # "draw" fake legend + fklgnd.args = modifyList( + legend_args, + list(x = 0, y = 0, plot = FALSE), + keep.null = TRUE + ) + if (isTRUE(gradient)) { + lgnd_labs_tmp = na.omit(fklgnd.args[["legend"]]) + if (length(lgnd_labs_tmp) < 5L) { + nmore = 5L - length(lgnd_labs_tmp) + lgnd_labs_tmp = c(lgnd_labs_tmp, rep("", nmore)) + } + fklgnd.args = modifyList( + fklgnd.args, + list(legend = lgnd_labs_tmp), + keep.null = TRUE + ) + } + fklgnd = do.call("legend", fklgnd.args) + + # calculate outer margin width in lines + soma = grconvertX(fklgnd$rect$w, to="lines") - grconvertX(0, to="lines") + # Add legend margins to the outer margin + soma = soma + sum(lmar) + ## differing outer margin adjustments depending on side + if (outer_right) { + ooma[4] = soma + } else { + ooma[2] = soma + } + par(oma = ooma) + + # determine legend inset + inset = grconvertX(lmar[1], from="lines", to="npc") - grconvertX(0, from = "lines", to = "npc") + if (isFALSE(outer_right)) { + # extra space needed for "left!" b/c of lhs inner margin + inset_bump = grconvertX(par("mar")[2], from = "lines", to = "npc") - grconvertX(0, from = "lines", to = "npc") + inset = inset + inset_bump + } + # GM: The legend inset spacing only works _exactly_ if we refresh the plot + # area. I'm not sure why (and it works properly if we use the same + # parameters manually while debugging), but this hack seems to work. + ## v0.3.0 update: Using (temporary) hook instead of direct par(new = TRUE) + ## assignment to play nice with tinytheme logic. + oldhook = getHook("before.plot.new") + setHook("before.plot.new", function() par(new = TRUE), action = "append") + setHook("before.plot.new", function() par(mar = omar), action = "append") + plot.new() + setHook("before.plot.new", oldhook, action = "replace") + # Finally, set the inset as part of the legend args. + legend_args[["inset"]] = c(1+inset, 0) + + ## Legend at the outer top or bottom of plot + } else if (grepl("bottom!$|top!$", legend_args[["x"]])) { + + outer_bottom = grepl("bottom!$", legend_args[["x"]]) + + ## Switch position anchor (we'll adjust relative to the _opposite_ side below) + if (outer_bottom) legend_args[["x"]] = gsub("bottom!$", "top", legend_args[["x"]]) + if (!outer_bottom) legend_args[["x"]] = gsub("top!$", "bottom", legend_args[["x"]]) + + ## We have to set the inner margins of the plot before the (fake) legend is + ## drawn, otherwise the inset calculation---which is based in the legend + ## width---will be off the first time. if (outer_bottom) { - # omar[1] = par("mgp")[1] + 1*par("cex.lab") - omar[1] = theme_clean$mgp[1] + 1*par("cex.lab") ## bit of a hack + omar[1] = par("mgp")[1] + 1*par("cex.lab") if (isTRUE(has_sub) && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]]==1)) omar[1] = omar[1] + 1*par("cex.sub") } else { + ## For "top!", the logic is slightly different: We don't expand the outer + ## margin b/c we need the legend to come underneath the main title. So + ## we rather expand the existing inner margin. ooma[3] = ooma[3] + topmar_epsilon par(oma = ooma) } par(mar = omar) - } - } - - legend_args[["horiz"]] = TRUE - - # Catch for horizontal ribbon legend spacing - if (type=="ribbon" && isTRUE(legend_args[["horiz"]])) { - if (legend_args[["pt.lwd"]] == 1) { - legend_args[["x.intersp"]] = 1 + + # if (isTRUE(new_plot)) plot.new() + if (isTRUE(new_plot)) { + plot.new() + # Experimental: For themed + dynamic plots, we need to make sure the + # adjusted plot margins for the legend are reinstated (after being + # overwritten by the before.plot.new hook. + if (dynmar) { + omar = par("mar") + if (outer_bottom) { + # omar[1] = par("mgp")[1] + 1*par("cex.lab") + omar[1] = theme_clean$mgp[1] + 1*par("cex.lab") ## bit of a hack + if (isTRUE(has_sub) && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]]==1)) omar[1] = omar[1] + 1*par("cex.sub") + } else { + ooma[3] = ooma[3] + topmar_epsilon + par(oma = ooma) + } + par(mar = omar) + } + } + + legend_args[["horiz"]] = TRUE + + # Catch for horizontal ribbon legend spacing + if (type=="ribbon" && isTRUE(legend_args[["horiz"]])) { + if (legend_args[["pt.lwd"]] == 1) { + legend_args[["x.intersp"]] = 1 + } else { + legend_args[["x.intersp"]] = 0.5 + } + } else if (isTRUE(gradient) && isTRUE(legend_args[["horiz"]])) { + legend_args[["x.intersp"]] = 0.5 + } + + # "draw" fake legend + fklgnd.args = modifyList( + legend_args, + list(plot = FALSE), + keep.null = TRUE + ) + if (isTRUE(gradient)) { + lgnd_labs_tmp = na.omit(fklgnd.args[["legend"]]) + if (length(lgnd_labs_tmp) < 5L) { + nmore = 5L - length(lgnd_labs_tmp) + lgnd_labs_tmp = c(lgnd_labs_tmp, rep("", nmore)) + } + fklgnd.args = modifyList( + fklgnd.args, + list(legend = lgnd_labs_tmp, title = NULL), + keep.null = TRUE + ) + } + fklgnd = do.call("legend", fklgnd.args) + + # calculate outer margin width in lines + soma = grconvertY(fklgnd$rect$h, to="lines") - grconvertY(0, to="lines") + # Add legend margins to outer margin + soma = soma + sum(lmar) + ## differing outer margin adjustments depending on side + if (outer_bottom) { + ooma[1] = soma + } else { + omar[3] = omar[3] + soma - topmar_epsilon + par(mar = omar) + } + par(oma = ooma) + + # determine legend inset + inset = grconvertY(lmar[1], from="lines", to="npc") - grconvertY(0, from="lines", to="npc") + if (isTRUE(outer_bottom)) { + # extra space needed for "bottom!" b/c of lhs inner margin + inset_bump = grconvertY(par("mar")[1], from="lines", to="npc") - grconvertY(0, from="lines", to="npc") + inset = inset + inset_bump + } else { + epsilon_bump = grconvertY(topmar_epsilon, from="lines", to="npc") - grconvertY(0, from="lines", to="npc") + inset = inset + epsilon_bump + } + # GM: The legend inset spacing only works _exactly_ if we refresh the plot + # area. I'm not sure why (and it works properly if we use the same + # parameters manually while debugging), but this hack seems to work. + ## v0.3.0 update: Using (temporary) hook instead of direct par(new = TRUE) + ## assignment to play nice with tinytheme logic. + oldhook = getHook("before.plot.new") + setHook("before.plot.new", function() par(new = TRUE), action = "append") + setHook("before.plot.new", function() par(mar = omar), action = "append") ## experimental dynmar + plot.new() + setHook("before.plot.new", oldhook, action = "replace") + # Finally, set the inset as part of the legend args. + legend_args[["inset"]] = c(0, 1+inset) + } else { - legend_args[["x.intersp"]] = 0.5 + legend_args[["inset"]] = 0 + if (isTRUE(new_plot)) plot.new() } - } else if (isTRUE(gradient) && isTRUE(legend_args[["horiz"]])) { - legend_args[["x.intersp"]] = 0.5 - } - - # "draw" fake legend - fklgnd.args = modifyList( - legend_args, - list(plot = FALSE), - keep.null = TRUE - ) - if (isTRUE(gradient)) { - lgnd_labs_tmp = na.omit(fklgnd.args[["legend"]]) - if (length(lgnd_labs_tmp) < 5L) { - nmore = 5L - length(lgnd_labs_tmp) - lgnd_labs_tmp = c(lgnd_labs_tmp, rep("", nmore)) + + # Finally, plot the legend + if (isTRUE(gradient)) { + if (!more_than_n_unique(legend_args[["col"]], 1)) { + if (!is.null(legend_args[["pt.bg"]]) && length(legend_args[["pt.bg"]])==100) { + legend_args[["col"]] = legend_args[["pt.bg"]] + } + } + gradient_legend(legend_args = legend_args, lmar = lmar, outer_right = outer_right, outer_bottom = outer_bottom) + } else { + do.call("legend", legend_args) } - fklgnd.args = modifyList( - fklgnd.args, - list(legend = lgnd_labs_tmp, title = NULL), - keep.null = TRUE - ) - } - fklgnd = do.call("legend", fklgnd.args) - - # calculate outer margin width in lines - soma = grconvertY(fklgnd$rect$h, to="lines") - grconvertY(0, to="lines") - # Add legend margins to outer margin - soma = soma + sum(lmar) - ## differing outer margin adjustments depending on side - if (outer_bottom) { - ooma[1] = soma - } else { - omar[3] = omar[3] + soma - topmar_epsilon - par(mar = omar) - } - par(oma = ooma) + + }, - # determine legend inset - inset = grconvertY(lmar[1], from="lines", to="npc") - grconvertY(0, from="lines", to="npc") - if (isTRUE(outer_bottom)) { - # extra space needed for "bottom!" b/c of lhs inner margin - inset_bump = grconvertY(par("mar")[1], from="lines", to="npc") - grconvertY(0, from="lines", to="npc") - inset = inset + inset_bump - } else { - epsilon_bump = grconvertY(topmar_epsilon, from="lines", to="npc") - grconvertY(0, from="lines", to="npc") - inset = inset + epsilon_bump - } - # GM: The legend inset spacing only works _exactly_ if we refresh the plot - # area. I'm not sure why (and it works properly if we use the same - # parameters manually while debugging), but this hack seems to work. - ## v0.3.0 update: Using (temporary) hook instead of direct par(new = TRUE) - ## assignment to play nice with tinytheme logic. - oldhook = getHook("before.plot.new") - setHook("before.plot.new", function() par(new = TRUE), action = "append") - setHook("before.plot.new", function() par(mar = omar), action = "append") ## experimental dynmar - plot.new() - setHook("before.plot.new", oldhook, action = "replace") - # Finally, set the inset as part of the legend args. - legend_args[["inset"]] = c(0, 1+inset) + list = list( + legend = legend, + legend_args = legend_args, + by_dep = by_dep, + lgnd_labs = lgnd_labs, + type = type, + pch = pch, + lty = lty, + lwd = lwd, + col = col, + bg = bg, + cex = cex, + gradient = gradient, + lmar = lmar, + has_sub = has_sub, + new_plot = new_plot + ), - } else { - legend_args[["inset"]] = 0 - if (isTRUE(new_plot)) plot.new() - } + getNamespace("tinyplot") - # Finally, plot the legend. Note that we use recordGraphics to preserve the - # legend spacing if the plot is resized. - if (isTRUE(gradient)) { - if (!more_than_n_unique(legend_args[["col"]], 1)) { - if (!is.null(legend_args[["pt.bg"]]) && length(legend_args[["pt.bg"]])==100) { - legend_args[["col"]] = legend_args[["pt.bg"]] - } - } - recordGraphics( - gradient_legend(legend_args = legend_args, lmar = lmar, outer_right = outer_right, outer_bottom = outer_bottom), - list(legend_args = legend_args, lmar = lmar, outer_right = outer_right, outer_bottom = outer_bottom), - getNamespace("tinyplot") - ) - } else { - recordGraphics( - do.call("legend", legend_args), - list(legend_args = legend_args), - getNamespace("tinyplot") - ) - } + ) } diff --git a/R/facet.R b/R/facet.R index f4aa0aab..9b8fbcb5 100644 --- a/R/facet.R +++ b/R/facet.R @@ -1,8 +1,508 @@ -# Facet layout structure -# -# This function is called by `tinyplot`. Given some inputs, it returns -# information about the layout of the facets. -# +#' Draw facet windows +#' +#' @description Internal functions called from `tinyplot` in order to draw the +#' plot window with different facets, grids, axes, etc. +#' +#' `facet_layout` determines the layout of the facets, based on a set of inputs. +#' +#' `draw_facet_window` is the main workhorse function for setting the exterior +#' plot elements as part of a `tinyplot` call, including adjustment of margins +#' for dynamic themes, etc. +#' +#' @keywords internal +#' @rdname facet +draw_facet_window = function( + # add arg first, since that determines what happens (if at all) + add, + # facet-specific args + cex_fct_adj, + facet.args, + facet_newlines, facet_font, facet_rect, facet_text, + facet_col, facet_bg, facet_border, + facet, facets, ifacet, + nfacets, nfacet_cols, nfacet_rows, + # axes args + axes, flip, frame.plot, oxaxis, oyaxis, + xlabs, xlim, xaxt, xaxs, xaxl, + ylabs, ylim, yaxt, yaxs, yaxl, + asp, log, + # other args (in approx. alphabetical + group ordering) + dots, + draw, + grid, + has_legend, + type, + x, xmax, xmin, + y, ymax, ymin + ) { + + # if add is TRUE, just return inputs without any calculations + if (isTRUE(add)) { + return(as.list(environment())) + } + + # draw background color only in the grid rectangle + grid.bg = get_tpar("grid.bg") + if (!is.null(grid.bg)) { + corners = par("usr") + rect(corners[1], corners[3], corners[2], corners[4], col = grid.bg, border = NA) + } + + ## dynamic margins flag + dynmar = isTRUE(.tpar[["dynmar"]]) + + ## optionally allow to modify the style of axis interval calculation + if (!is.null(xaxs)) par(xaxs = xaxs) + if (!is.null(yaxs)) par(yaxs = yaxs) + + if (nfacets > 1) { + # Set facet margins (i.e., gaps between facets) + if (is.null(facet.args[["fmar"]])) { + fmar = tpar("fmar") + } else { + if (length(facet.args[["fmar"]]) != 4) { + warning( + "`fmar` has to be a vector of length four, e.g.", + "`facet.args = list(fmar = c(b,l,t,r))`.", + "\n", + "Resetting to fmar = c(1,1,1,1) default.", + "\n" + ) + fmar = tpar("fmar") + } else { + fmar = facet.args[["fmar"]] + } + } + # We need to adjust for n>=3 facet cases for correct spacing... + if (nfacets >= 3) { + ## ... exception for 2x2 cases + if (!(nfacet_rows == 2 && nfacet_cols == 2)) fmar = fmar * .75 + } + # Extra reduction if no plot frame to reduce whitespace + if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) { + fmar = fmar - 0.5 + } + + ooma = par("oma") + + # Bump top margin down for facet titles + fmar[3] = fmar[3] + 1 + if (isTRUE(attr(facet, "facet_grid"))) { + fmar[3] = max(0, fmar[3] - 1) + # Indent for RHS facet_grid title strip if "right!" legend + if (has_legend && ooma[4] > 0) ooma[4] = ooma[4] + 1 + } + fmar[3] = fmar[3] + facet_newlines * facet_text / cex_fct_adj + + omar = par("mar") + + ## Dynamic plot margin adjustments + if (dynmar) { + if (par("las") %in% 1:2) { + # extra whitespace bump on the y axis + ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME + if (type == "ridge") { + yaxlabs = levels(y) + } else if (!is.null(ylabs)) { + yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs + } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) { + yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs + } else { + # yaxl = axTicks(2) + yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog")) + } + if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl) + # whtsbp = grconvertX(max(strwidth(yaxl, "figure")), from = "nfc", to = "lines") - 1 + whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1 + if (whtsbp > 0) { + omar = omar + c(0, whtsbp, 0, 0) * cex_fct_adj + fmar[2] = fmar[2] + whtsbp * cex_fct_adj + } + # Extra reduction if no plot frame to reduce whitespace + if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) { + fmar[2] = fmar[2] - (whtsbp * cex_fct_adj) + } + } + if (par("las") %in% 2:3) { + # extra whitespace bump on the x axis + # xaxlabs = axTicks(1) + xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else + if (!is.null(names(xlabs))) names(xlabs) else xlabs + if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl) + whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1 + if (whtsbp > 0) { + omar = omar + c(whtsbp, 0, 0, 0) * cex_fct_adj + fmar[1] = fmar[1] + whtsbp * cex_fct_adj + } + # Extra reduction if no plot frame to reduce whitespace + if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) { + fmar[1] = fmar[1] - (whtsbp * cex_fct_adj) + } + } + # FIXME: Is this causing issues for lhs legends with facet_grid? + # catch for missing rhs legend + if (isTRUE(attr(facet, "facet_grid")) && !has_legend) { + omar[4] = omar[4] + 1 + } + } + + # Now we set the margins. The trick here is that we simultaneously adjust + # inner (mar) and outer (oma) margins by the same amount, but in opposite + # directions, to preserve the overall facet and plot centroids. + nmar = (fmar + .1) / cex_fct_adj + noma = (ooma + omar - fmar - .1) / cex_fct_adj + # Catch in case of negative oma values. (Probably only occurs with some + # user-supplied tpar(lmar) values and a "left!" positioned legend.) + if (any(noma < 0)) { + noma_orig = noma + noma[noma < 0] = 0 + # noma_diff = noma-noma_orig + # nmar = nmar + noma_diff + } + # apply changes + par(oma = noma) + par(mar = nmar) + + # Now that the margins have been set, arrange facet rows and columns based + # on our earlier calculations. + par(mfrow = c(nfacet_rows, nfacet_cols)) + } else if (dynmar) { + # Dynamic plot margin adjustments + omar = par("mar") + omar = omar - c(0, 0, 1, 0) # reduce top whitespace since no facet (title) + if (type == "spineplot") omar[4] = 2.1 # FIXME catch for spineplot RHS axis labs + if (par("las") %in% 1:2) { + # extra whitespace bump on the y axis + ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME + if (type == "ridge") { + yaxlabs = levels(y) + } else if (!is.null(ylabs)) { + yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs + } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) { + yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs + } else { + # yaxl = axTicks(2) + yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog")) + } + if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl) + # whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - 1 + whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1 + if (whtsbp > 0) { + omar[2] = omar[2] + whtsbp + } + } + if (par("las") %in% 2:3) { + # extra whitespace bump on the x axis + # xaxl = axTicks(1) + xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else + if (!is.null(names(xlabs))) names(xlabs) else xlabs + if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl) + whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1 + if (whtsbp > 0) { + omar[1] = omar[1] + whtsbp + } + } + par(mar = omar) + } + + ## Loop over the individual facet windows and draw the plot region + ## components (axes, titles, box, grid, etc.) + for (ii in ifacet) { + # See: https://github.com/grantmcdermott/tinyplot/issues/65 + if (nfacets > 1) { + mfgi = ceiling(ii / nfacet_cols) + mfgj = ii %% nfacet_cols + if (mfgj == 0) mfgj = nfacet_cols + par(mfg = c(mfgi, mfgj)) + } + + ## Set the plot window + ## Problem: Passing extra args through ... (e.g., legend_args) to plot.window + ## triggers an annoying warning about unrecognized graphical params. + # plot.window( + # xlim = xlim, ylim = ylim, + # asp = asp, log = log, + # # ... + # ) + ## Solution: Only pass on relevant args using name checking and do.call. + ## Idea borrowed from here: https://stackoverflow.com/a/4128401/4115816 + pdots = dots[names(dots) %in% names(formals(plot.default))] + ## catch for flipped boxplots... + if (type == "boxplot" && isTRUE(flip)) { + log_flip = log + if (!is.null(log)) { + if (log == "x") log_flip = "y" + if (log == "y") log_flip = "x" + } + do.call( + "plot.window", + c(list(xlim = ylim, ylim = xlim, asp = asp, log = log_flip), pdots) + ) + xside = 2 + yside = 1 + } else { + ## ... standard plot window for all other cases + do.call( + "plot.window", + c(list(xlim = xlim, ylim = ylim, asp = asp, log = log), pdots) + ) + xside = 1 + yside = 2 + } + + + # axes, frame.plot and grid + if (isTRUE(axes) || isTRUE(facet.args[["free"]])) { + args_x = list(x, + side = xside, + type = xaxt, + labeller = xaxl, + cex = get_tpar(c("cex.xaxs", "cex.axis"), 0.8), + lwd = get_tpar(c("lwd.xaxs", "lwd.axis"), 1), + lty = get_tpar(c("lty.xaxs", "lty.axis"), 1) + ) + args_y = list(y, + side = yside, + type = yaxt, + labeller = yaxl, + cex = get_tpar(c("cex.yaxs", "cex.axis"), 0.8), + lwd = get_tpar(c("lwd.yaxs", "lwd.axis"), 1), + lty = get_tpar(c("lty.yaxs", "lty.axis"), 1) + ) + type_range_x = type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs) + type_range_y = isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(ylabs) + if (type_range_x) { + args_x = modifyList(args_x, list(at = xlabs, labels = names(xlabs))) + } + if (type_range_y) { + args_y = modifyList(args_y, list(at = ylabs, labels = names(ylabs))) + } + + if (isTRUE(facet.args[["free"]]) && (par("xlog") || par("ylog"))) { + warning( + "\nFree scale axes for faceted plots are currently not supported if the axes are logged. Reverting back to fixed scales.", + "\nIf support for this feature is important to you, please raise an issue on our GitHub repo:", + "\nhttps://github.com/grantmcdermott/tinyplot/issues\n" + ) + facet.args[["free"]] = FALSE + } + + # Special logic if facets are free... + if (isTRUE(facet.args[["free"]])) { + # First, we need to calculate the plot extent and axes range of each + # individual facet. + xfree = split(c(x, xmin, xmax), facet)[[ii]] + yfree = split(c(y, ymin, ymax), facet)[[ii]] + xlim = range(xfree, na.rm = TRUE) + ylim = range(yfree, na.rm = TRUE) + xext = extendrange(xlim, f = 0.04) + yext = extendrange(ylim, f = 0.04) + # We'll save this in a special .fusr env var (list) that we'll re-use + # when it comes to plotting the actual elements later + if (ii == 1) { + fusr = replicate(4, vector("double", length = nfacets), simplify = FALSE) + assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment()))) + } + fusr = get(".fusr", envir = get(".tinyplot_env", envir = parent.env(environment()))) + fusr[[ii]] = c(xext, yext) + assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment()))) + # Explicitly set (override) the current facet extent + par(usr = fusr[[ii]]) + # if plot frame is true then print axes per normal... + if (type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs)) { + tinyAxis(xfree, side = xside, at = xlabs, labels = names(xlabs), type = xaxt) + } else { + tinyAxis(xfree, side = xside, type = xaxt) + } + if (isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(ylabs)) { + tinyAxis(yfree, side = yside, at = ylabs, labels = names(ylabs), type = yaxt) + } else { + tinyAxis(yfree, side = yside, type = yaxt) + } + + # For fixed facets we can just reuse the same plot extent and axes limits + } else if (isTRUE(frame.plot)) { + # if plot frame is true then print axes per normal... + do.call(tinyAxis, args_x) + do.call(tinyAxis, args_y) + } else { + # ... else only print the "outside" axes. + if (ii %in% oxaxis) do.call(tinyAxis, args_x) + if (ii %in% oyaxis) do.call(tinyAxis, args_y) + } + } + + # facet titles + ## Note: facet titles could be done more simply with mtext... but then we + ## couldn't adjust background features (e.g., fill), or rotate the rhs + ## facet grid text. So we're rolling our own "manual" versions with text + ## and rect. + if (!is.null(facet)) { + # Get the four corners of plot area (x1, x2, y1, y2) + corners = par("usr") + # catch for logged axes + xlog = isTRUE(par("xlog")) + ylog = isTRUE(par("ylog")) + if (xlog) corners[1:2] = 10^(corners[1:2]) + if (ylog) corners[3:4] = 10^(corners[3:4]) + # special logic for facet grids + if (is.null(facet_newlines) || facet_newlines == 0) { + facet_title_lines = 1 + } else { + facet_title_lines = 1 + facet_newlines + } + # different logic for facet grids versus regular facets + if (isTRUE(attr(facet, "facet_grid"))) { + ## top facet strips + if (ii %in% 1:nfacet_cols) { + if (isTRUE(facet_rect)) { + line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj + if (ylog) { + line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + rect_height = corners[4] * line_height + } else { + line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + rect_height = corners[4] + line_height + } + rect( + corners[1], corners[4], corners[2], rect_height, + col = facet_bg, border = facet_border, + xpd = NA + ) + } + xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2]) + if (ylog) { + ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + ypos = corners[4] * ypos + } else { + ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + ypos = corners[4] + ypos + } + text( + x = xpos, + y = ypos, + labels = sub("^(.*?)~.*", "\\1", facets[[ii]]), + adj = c(0.5, 0), + cex = facet_text / cex_fct_adj, + col = facet_col, + font = facet_font, + xpd = NA, + ) + } + ## right facet strips + if (ii %% nfacet_cols == 0 || ii == nfacets) { + if (isTRUE(facet_rect)) { + line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj + if (xlog) { + line_height = grconvertX(line_height, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user") + rect_width = corners[2] * line_height + } else { + line_height = grconvertX(line_height, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") + rect_width = corners[2] + line_height + } + rect( + corners[2], corners[3], rect_width, corners[4], + col = facet_bg, border = facet_border, + xpd = NA + ) + } + if (xlog) { + xpos = grconvertX(0.4, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user") + xpos = corners[2] * xpos + } else { + xpos = grconvertX(0.4, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") + xpos = corners[2] + xpos + } + ypos = if (ylog) 10^(mean(log10(corners[3:4]))) else mean(corners[3:4]) + text( + x = xpos, + y = ypos, + labels = sub("^.*?~(.*)", "\\1", facets[[ii]]), + srt = 270, + adj = c(0.5, 0), + cex = facet_text / cex_fct_adj, + col = facet_col, + font = facet_font, + xpd = NA + ) + } + } else { + if (isTRUE(facet_rect)) { + line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj + if (ylog) { + line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + rect_height = corners[4] * line_height + } else { + line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + rect_height = corners[4] + line_height + } + rect( + corners[1], corners[4], corners[2], rect_height, + col = facet_bg, border = facet_border, + xpd = NA + ) + } + xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2]) + if (ylog) { + ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + ypos = corners[4] * ypos + } else { + ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + ypos = corners[4] + ypos + } + text( + x = xpos, + y = ypos, + labels = paste(facets[[ii]]), + adj = c(0.5, 0), + cex = facet_text / cex_fct_adj, + col = facet_col, + font = facet_font, + xpd = NA + ) + } + } + + # plot frame + if (frame.plot) box() + + # panel grid lines + if (is.null(grid)) grid = .tpar[["grid"]] + if (!is.null(grid)) { + if (is.logical(grid)) { + ## If grid is TRUE create a default grid. Rather than just calling the default grid() + ## abline(... = pretty(extendrange(...)), ...) is used. Reason: pretty() is generic + ## and works better for axes based on date/time classes. Exception: For axes in logs, + ## resort to using grid() which is likely better handled there. + if (isTRUE(grid)) { + gnx = gny = NULL + if (!any(c(par("xlog"), type == "boxplot"))) { + xg = if (!inherits(x, c("POSIXt", "Date"))) axTicks(side = 1) else axTicksDateTime(side = 1, x = x) + abline(v = xg, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]]) + gnx = NA + } + if (!any(c(par("ylog"), type == "boxplot"))) { + yg = if (!inherits(y, c("POSIXt", "Date"))) axTicks(side = 2) else axTicksDateTime(side = 2, x = x) + abline(h = yg, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]]) + gny = NA + } + grid(nx = gnx, ny = gny, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]]) + } + } else { + grid + } + } + + # add any drawn elements + if (!is.null(draw)) eval(draw) + } # end of ii facet loop + + return(as.list(environment())) +} + + +#' @rdname facet +#' @keywords internal facet_layout = function(facet, add = FALSE, facet.args = list()) { nfacet_rows = 1 nfacet_cols = 1 @@ -64,8 +564,12 @@ facet_layout = function(facet, add = FALSE, facet.args = list()) { -# utility function for converting facet formulas into variables +# +# helper functions +# + +# utility function for converting facet formulas into variables get_facet_fml = function(formula, data = NULL) { xfacet = yfacet = NULL @@ -114,494 +618,6 @@ get_facet_fml = function(formula, data = NULL) { } - - -# internal function to draw window with different facets, grids, axes, etc. - -draw_facet_window = function(grid, ...) { - list2env(list(...), environment()) - - # draw background color only in the grid rectangle - grid.bg = get_tpar("grid.bg") - if (!is.null(grid.bg)) { - corners = par("usr") - rect(corners[1], corners[3], corners[2], corners[4], col = grid.bg, border = NA) - } - - ## dynamic margins flag - dynmar = isTRUE(.tpar[["dynmar"]]) - - if (isFALSE(add)) { - ## optionally allow to modify the style of axis interval calculation - if (!is.null(xaxs)) par(xaxs = xaxs) - if (!is.null(yaxs)) par(yaxs = yaxs) - - if (nfacets > 1) { - # Set facet margins (i.e., gaps between facets) - if (is.null(facet.args[["fmar"]])) { - fmar = tpar("fmar") - } else { - if (length(facet.args[["fmar"]]) != 4) { - warning( - "`fmar` has to be a vector of length four, e.g.", - "`facet.args = list(fmar = c(b,l,t,r))`.", - "\n", - "Resetting to fmar = c(1,1,1,1) default.", - "\n" - ) - fmar = tpar("fmar") - } else { - fmar = facet.args[["fmar"]] - } - } - # We need to adjust for n>=3 facet cases for correct spacing... - if (nfacets >= 3) { - ## ... exception for 2x2 cases - if (!(nfacet_rows == 2 && nfacet_cols == 2)) fmar = fmar * .75 - } - # Extra reduction if no plot frame to reduce whitespace - if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) { - fmar = fmar - 0.5 - } - - ooma = par("oma") - - # Bump top margin down for facet titles - fmar[3] = fmar[3] + 1 - if (isTRUE(attr(facet, "facet_grid"))) { - fmar[3] = max(0, fmar[3] - 1) - # Indent for RHS facet_grid title strip if "right!" legend - if (has_legend && ooma[4] > 0) ooma[4] = ooma[4] + 1 - } - fmar[3] = fmar[3] + facet_newlines * facet_text / cex_fct_adj - - omar = par("mar") - - ## Dynamic plot margin adjustments - if (dynmar) { - if (par("las") %in% 1:2) { - # extra whitespace bump on the y axis - ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME - if (type == "ridge") { - yaxlabs = levels(y) - } else if (!is.null(ylabs)) { - yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs - } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) { - yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs - } else { - # yaxl = axTicks(2) - yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog")) - } - if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl) - # whtsbp = grconvertX(max(strwidth(yaxl, "figure")), from = "nfc", to = "lines") - 1 - whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1 - if (whtsbp > 0) { - omar = omar + c(0, whtsbp, 0, 0) * cex_fct_adj - fmar[2] = fmar[2] + whtsbp * cex_fct_adj - } - # Extra reduction if no plot frame to reduce whitespace - if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) { - fmar[2] = fmar[2] - (whtsbp * cex_fct_adj) - } - } - if (par("las") %in% 2:3) { - # extra whitespace bump on the x axis - # xaxlabs = axTicks(1) - xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else - if (!is.null(names(xlabs))) names(xlabs) else xlabs - if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl) - whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1 - if (whtsbp > 0) { - omar = omar + c(whtsbp, 0, 0, 0) * cex_fct_adj - fmar[1] = fmar[1] + whtsbp * cex_fct_adj - } - # Extra reduction if no plot frame to reduce whitespace - if (isFALSE(frame.plot) && !isTRUE(facet.args[["free"]])) { - fmar[1] = fmar[1] - (whtsbp * cex_fct_adj) - } - } - # FIXME: Is this causing issues for lhs legends with facet_grid? - # catch for missing rhs legend - if (isTRUE(attr(facet, "facet_grid")) && !has_legend) { - omar[4] = omar[4] + 1 - } - } - - # Now we set the margins. The trick here is that we simultaneously adjust - # inner (mar) and outer (oma) margins by the same amount, but in opposite - # directions, to preserve the overall facet and plot centroids. - nmar = (fmar + .1) / cex_fct_adj - noma = (ooma + omar - fmar - .1) / cex_fct_adj - # Catch in case of negative oma values. (Probably only occurs with some - # user-supplied tpar(lmar) values and a "left!" positioned legend.) - if (any(noma < 0)) { - noma_orig = noma - noma[noma < 0] = 0 - # noma_diff = noma-noma_orig - # nmar = nmar + noma_diff - } - # apply changes - par(oma = noma) - par(mar = nmar) - - # Now that the margins have been set, arrange facet rows and columns based - # on our earlier calculations. - par(mfrow = c(nfacet_rows, nfacet_cols)) - } else if (dynmar) { - # Dynamic plot margin adjustments - omar = par("mar") - omar = omar - c(0, 0, 1, 0) # reduce top whitespace since no facet (title) - if (type == "spineplot") omar[4] = 2.1 # FIXME catch for spineplot RHS axis labs - if (par("las") %in% 1:2) { - # extra whitespace bump on the y axis - ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME - if (type == "ridge") { - yaxlabs = levels(y) - } else if (!is.null(ylabs)) { - yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs - } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) { - yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs - } else { - # yaxl = axTicks(2) - yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog")) - } - if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl) - # whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - 1 - whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1 - if (whtsbp > 0) { - omar[2] = omar[2] + whtsbp - } - } - if (par("las") %in% 2:3) { - # extra whitespace bump on the x axis - # xaxl = axTicks(1) - xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else - if (!is.null(names(xlabs))) names(xlabs) else xlabs - if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl) - whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1 - if (whtsbp > 0) { - omar[1] = omar[1] + whtsbp - } - } - par(mar = omar) - } - - ## Loop over the individual facet windows and draw the plot region - ## components (axes, titles, box, grid, etc.) - for (ii in ifacet) { - # See: https://github.com/grantmcdermott/tinyplot/issues/65 - if (nfacets > 1) { - mfgi = ceiling(ii / nfacet_cols) - mfgj = ii %% nfacet_cols - if (mfgj == 0) mfgj = nfacet_cols - par(mfg = c(mfgi, mfgj)) - } - - ## Set the plot window - ## Problem: Passing extra args through ... (e.g., legend_args) to plot.window - ## triggers an annoying warning about unrecognized graphical params. - # plot.window( - # xlim = xlim, ylim = ylim, - # asp = asp, log = log, - # # ... - # ) - ## Solution: Only pass on relevant args using name checking and do.call. - ## Idea borrowed from here: https://stackoverflow.com/a/4128401/4115816 - pdots = dots[names(dots) %in% names(formals(plot.default))] - ## catch for flipped boxplots... - if (type == "boxplot" && isTRUE(flip)) { - log_flip = log - if (!is.null(log)) { - if (log == "x") log_flip = "y" - if (log == "y") log_flip = "x" - } - do.call( - "plot.window", - c(list(xlim = ylim, ylim = xlim, asp = asp, log = log_flip), pdots) - ) - xside = 2 - yside = 1 - } else { - ## ... standard plot window for all other cases - do.call( - "plot.window", - c(list(xlim = xlim, ylim = ylim, asp = asp, log = log), pdots) - ) - xside = 1 - yside = 2 - } - - - # axes, frame.plot and grid - if (isTRUE(axes) || isTRUE(facet.args[["free"]])) { - args_x = list(x, - side = xside, - type = xaxt, - labeller = xaxl, - cex = get_tpar(c("cex.xaxs", "cex.axis"), 0.8), - lwd = get_tpar(c("lwd.xaxs", "lwd.axis"), 1), - lty = get_tpar(c("lty.xaxs", "lty.axis"), 1) - ) - args_y = list(y, - side = yside, - type = yaxt, - labeller = yaxl, - cex = get_tpar(c("cex.yaxs", "cex.axis"), 0.8), - lwd = get_tpar(c("lwd.yaxs", "lwd.axis"), 1), - lty = get_tpar(c("lty.yaxs", "lty.axis"), 1) - ) - type_range_x = type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs) - type_range_y = isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(ylabs) - if (type_range_x) { - args_x = modifyList(args_x, list(at = xlabs, labels = names(xlabs))) - } - if (type_range_y) { - args_y = modifyList(args_y, list(at = ylabs, labels = names(ylabs))) - } - - if (isTRUE(facet.args[["free"]]) && (par("xlog") || par("ylog"))) { - warning( - "\nFree scale axes for faceted plots are currently not supported if the axes are logged. Reverting back to fixed scales.", - "\nIf support for this feature is important to you, please raise an issue on our GitHub repo:", - "\nhttps://github.com/grantmcdermott/tinyplot/issues\n" - ) - facet.args[["free"]] = FALSE - } - - # Special logic if facets are free... - if (isTRUE(facet.args[["free"]])) { - # First, we need to calculate the plot extent and axes range of each - # individual facet. - xfree = split(c(x, xmin, xmax), facet)[[ii]] - yfree = split(c(y, ymin, ymax), facet)[[ii]] - xlim = range(xfree, na.rm = TRUE) - ylim = range(yfree, na.rm = TRUE) - xext = extendrange(xlim, f = 0.04) - yext = extendrange(ylim, f = 0.04) - # We'll save this in a special .fusr env var (list) that we'll re-use - # when it comes to plotting the actual elements later - if (ii == 1) { - fusr = replicate(4, vector("double", length = nfacets), simplify = FALSE) - assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment()))) - } - fusr = get(".fusr", envir = get(".tinyplot_env", envir = parent.env(environment()))) - fusr[[ii]] = c(xext, yext) - assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment()))) - # Explicitly set (override) the current facet extent - par(usr = fusr[[ii]]) - # if plot frame is true then print axes per normal... - if (type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs)) { - tinyAxis(xfree, side = xside, at = xlabs, labels = names(xlabs), type = xaxt) - } else { - tinyAxis(xfree, side = xside, type = xaxt) - } - if (isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(ylabs)) { - tinyAxis(yfree, side = yside, at = ylabs, labels = names(ylabs), type = yaxt) - } else { - tinyAxis(yfree, side = yside, type = yaxt) - } - - # For fixed facets we can just reuse the same plot extent and axes limits - } else if (isTRUE(frame.plot)) { - # if plot frame is true then print axes per normal... - do.call(tinyAxis, args_x) - do.call(tinyAxis, args_y) - } else { - # ... else only print the "outside" axes. - if (ii %in% oxaxis) do.call(tinyAxis, args_x) - if (ii %in% oyaxis) do.call(tinyAxis, args_y) - } - } - - # facet titles - ## Note: facet titles could be done more simply with mtext... but then we - ## couldn't adjust background features (e.g., fill), or rotate the rhs - ## facet grid text. So we're rolling our own "manual" versions with text - ## and rect. - if (!is.null(facet)) { - # Get the four corners of plot area (x1, x2, y1, y2) - corners = par("usr") - # catch for logged axes - xlog = isTRUE(par("xlog")) - ylog = isTRUE(par("ylog")) - if (xlog) corners[1:2] = 10^(corners[1:2]) - if (ylog) corners[3:4] = 10^(corners[3:4]) - # special logic for facet grids - if (is.null(facet_newlines) || facet_newlines == 0) { - facet_title_lines = 1 - } else { - facet_title_lines = 1 + facet_newlines - } - # different logic for facet grids versus regular facets - if (isTRUE(attr(facet, "facet_grid"))) { - ## top facet strips - if (ii %in% 1:nfacet_cols) { - if (isTRUE(facet_rect)) { - line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj - if (ylog) { - line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") - rect_height = corners[4] * line_height - } else { - line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") - rect_height = corners[4] + line_height - } - rect( - corners[1], corners[4], corners[2], rect_height, - col = facet_bg, border = facet_border, - xpd = NA - ) - } - xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2]) - if (ylog) { - ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") - ypos = corners[4] * ypos - } else { - ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") - ypos = corners[4] + ypos - } - text( - x = xpos, - y = ypos, - labels = sub("^(.*?)~.*", "\\1", facets[[ii]]), - adj = c(0.5, 0), - cex = facet_text / cex_fct_adj, - col = facet_col, - font = facet_font, - xpd = NA, - ) - } - ## right facet strips - if (ii %% nfacet_cols == 0 || ii == nfacets) { - if (isTRUE(facet_rect)) { - line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj - if (xlog) { - line_height = grconvertX(line_height, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user") - rect_width = corners[2] * line_height - } else { - line_height = grconvertX(line_height, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") - rect_width = corners[2] + line_height - } - rect( - corners[2], corners[3], rect_width, corners[4], - col = facet_bg, border = facet_border, - xpd = NA - ) - } - if (xlog) { - xpos = grconvertX(0.4, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user") - xpos = corners[2] * xpos - } else { - xpos = grconvertX(0.4, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") - xpos = corners[2] + xpos - } - ypos = if (ylog) 10^(mean(log10(corners[3:4]))) else mean(corners[3:4]) - text( - x = xpos, - y = ypos, - labels = sub("^.*?~(.*)", "\\1", facets[[ii]]), - srt = 270, - adj = c(0.5, 0), - cex = facet_text / cex_fct_adj, - col = facet_col, - font = facet_font, - xpd = NA - ) - } - } else { - if (isTRUE(facet_rect)) { - line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj - if (ylog) { - line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") - rect_height = corners[4] * line_height - } else { - line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") - rect_height = corners[4] + line_height - } - rect( - corners[1], corners[4], corners[2], rect_height, - col = facet_bg, border = facet_border, - xpd = NA - ) - } - xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2]) - if (ylog) { - ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") - ypos = corners[4] * ypos - } else { - ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") - ypos = corners[4] + ypos - } - text( - x = xpos, - y = ypos, - labels = paste(facets[[ii]]), - adj = c(0.5, 0), - cex = facet_text / cex_fct_adj, - col = facet_col, - font = facet_font, - xpd = NA - ) - } - } - - # plot frame - if (frame.plot) box() - - # panel grid lines - if (is.null(grid)) grid = .tpar[["grid"]] - if (!is.null(grid)) { - if (is.logical(grid)) { - ## If grid is TRUE create a default grid. Rather than just calling the default grid() - ## abline(... = pretty(extendrange(...)), ...) is used. Reason: pretty() is generic - ## and works better for axes based on date/time classes. Exception: For axes in logs, - ## resort to using grid() which is likely better handled there. - if (isTRUE(grid)) { - gnx = gny = NULL - if (!any(c(par("xlog"), type == "boxplot"))) { - if (!inherits(x, c("POSIXt", "Date"))) { - xg = pretty(xlim) - } else { - # Catch for datetime (since xlim has been coerced to numeric) - tz = attributes(x)[["tzone"]] - if (inherits(x, "POSIXt")) { - xg = pretty(as.POSIXct(extendrange(xlim), tz = tz)) - } else { - xg = pretty(as.Date(round(extendrange(xlim)), tz = tz)) - } - } - abline(v = xg, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]]) - gnx = NA - } - if (!any(c(par("ylog"), type == "boxplot"))) { - if (!inherits(y, c("POSIXt", "Date"))) { - yg = pretty(ylim) - } else { - # Catch for datetime (since xlim has been coerced to numeric) - tz = attributes(y)[["tzone"]] - if (inherits(x, "POSIXt")) { - yg = pretty(as.POSIXct(extendrange(ylim), tz = tz)) - } else { - yg = pretty(as.Date(extendrange(ylim), tz = tz)) - } - } - abline(h = yg, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]]) - gny = NA - } - grid(nx = gnx, ny = gny, col = .tpar[["grid.col"]], lty = .tpar[["grid.lty"]], lwd = .tpar[["grid.lwd"]]) - } - } else { - grid - } - } - - # drawn elements - if (!is.null(draw)) eval(draw) - } # end of ii facet loop - } # end of add check - - return(as.list(environment())) -} - ## internal convenience function to determine whether the current facet panel ## has the position "left", "right", "top", or "bottom" in the facet grid is_facet_position = function(position, ifacet, facet_window_args) { diff --git a/R/tinyAxis.R b/R/tinyAxis.R index 674eab05..d71b0aba 100644 --- a/R/tinyAxis.R +++ b/R/tinyAxis.R @@ -21,8 +21,7 @@ tinyAxis = function(x = NULL, ..., type = "standard", labeller = NULL) { if (!is.null(args$at)) { args$labels = if (!is.null(args$labels)) tinylabel(args$labels, labeller) else tinylabel(args$at, labeller) } else { - # FIXME: log ? - args$at = if (!inherits(x, c("POSIXt", "Date"))) axTicks(args$side) else axTicksDate(args$side) + args$at = if (!inherits(x, c("POSIXt", "Date"))) axTicks(args$side) else axTicksDateTime(args$side) args$labels = tinylabel(args$at, labeller) } } @@ -31,13 +30,19 @@ tinyAxis = function(x = NULL, ..., type = "standard", labeller = NULL) { } # Special case for Date-Time, adapted/simplified from axis.date() -axTicksDate = function(side, x, ...) { - range = sort(par("usr")[if (side%%2) 1L:2L else 3:4L]) - range[1L] = ceiling(range[1L]) - range[2L] = floor(range[2L]) - rangeDate = range - class(rangeDate) = "Date" - z = pretty(rangeDate, n = par("lab")[2 - side%%2]) +axTicksDateTime = function(side, x, ...) { + if (inherits(x, "POSIXt")) { + tz = attr(x, "tz") + range = extendrange(x) + rangeDateTime = .POSIXct(range, tz = tz) + } else { + range = sort(par("usr")[if (side%%2) 1L:2L else 3:4L]) + range[1L] = ceiling(range[1L]) + range[2L] = floor(range[2L]) + rangeDateTime = range + class(rangeDateTime) = "Date" + } + z = pretty(rangeDateTime, n = par("lab")[2 - side%%2]) keep = z >= range[1L] & z <= range[2L] z = z[keep] return(z) diff --git a/R/tinyplot.R b/R/tinyplot.R index 16fbd8f5..d5aadd25 100644 --- a/R/tinyplot.R +++ b/R/tinyplot.R @@ -592,6 +592,7 @@ tinyplot.default = function( height = NULL, asp = NA, ...) { + par_first = get_saved_par("first") if (is.null(par_first)) set_saved_par("first", par()) @@ -1090,7 +1091,7 @@ tinyplot.default = function( } # - ## Facet windows + ## Exterior plot elements (plot and facet windows, axes, etc.) # omar = NULL # Placeholder variable for now, which we re-assign as part of facet margins @@ -1130,28 +1131,59 @@ tinyplot.default = function( } # Now draw the individual facet windows (incl. axes, grid lines, and facet titles) - # Skip if adding to an existing plot - - facet_window_args = draw_facet_window( - add = add, asp = asp, axes = axes, cex_fct_adj = cex_fct_adj, dots = dots, - facet = datapoints$facet, facet.args = facet.args, facet_newlines = facet_newlines, - facet_rect = facet_rect, facet_text = facet_text, facet_font = facet_font, - facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border, - facets = facets, ifacet = ifacet, - nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows, nfacets = nfacets, - frame.plot = frame.plot, grid = grid, - has_legend = has_legend, log = log, - oxaxis = oxaxis, oyaxis = oyaxis, type = type, - x = datapoints$x, - y = datapoints$y, - xmax = datapoints$xmax, xmin = datapoints$xmin, - ymax = datapoints$ymax, ymin = datapoints$ymin, - xlabs = xlabs, xlim = xlim, - ylabs = ylabs, ylim = ylim, - xaxt = xaxt, xaxs = xaxs, xaxl = xaxl, - yaxt = yaxt, yaxs = yaxs, yaxl = yaxl, - flip = flip, - draw = draw + # Will be skipped if adding to an existing plot; see ?facet + + facet_window_args = recordGraphics( + draw_facet_window( + add = add, + # facet-specific args + cex_fct_adj = cex_fct_adj, + facet.args = facet.args, + facet_newlines = facet_newlines, facet_font = facet_font, + facet_rect = facet_rect, facet_text = facet_text, + facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border, + facet = facet, + facets = facets, ifacet = ifacet, + nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows, + # axes args + axes = axes, flip = flip, frame.plot = frame.plot, + oxaxis = oxaxis, oyaxis = oyaxis, + xlabs = xlabs, xlim = xlim, xaxt = xaxt, xaxs = xaxs, xaxl = xaxl, + ylabs = ylabs, ylim = ylim, yaxt = yaxt, yaxs = yaxs, yaxl = yaxl, + asp = asp, log = log, + # other args (in approx. alphabetical + group ordering) + dots = dots, + draw = draw, + grid = grid, + has_legend = has_legend, + type = type, + x = x, xmax = xmax, xmin = xmin, + y = y, ymax = ymax, ymin = ymin + ), + list = list( + add = add, + cex_fct_adj = cex_fct_adj, + facet.args = facet.args, + facet_newlines = facet_newlines, facet_font = facet_font, + facet_rect = facet_rect, facet_text = facet_text, + facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border, + facet = datapoints$facet, + facets = facets, ifacet = ifacet, + nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows, + axes = axes, flip = flip, frame.plot = frame.plot, + oxaxis = oxaxis, oyaxis = oyaxis, + xlabs = xlabs, xlim = xlim, xaxt = xaxt, xaxs = xaxs, xaxl = xaxl, + ylabs = ylabs, ylim = ylim, yaxt = yaxt, yaxs = yaxs, yaxl = yaxl, + asp = asp, log = log, + dots = dots, + draw = draw, + grid = grid, + has_legend = has_legend, + type = type, + x = datapoints$x, xmax = datapoints$xmax, xmin = datapoints$xmin, + y = datapoints$y, ymax = datapoints$ymax, ymin = datapoints$ymin + ), + getNamespace("tinyplot") ) list2env(facet_window_args, environment()) @@ -1288,7 +1320,7 @@ tinyplot.default = function( } } } - + # save end pars for possible recall later apar = par(no.readonly = TRUE) set_saved_par(when = "after", apar) diff --git a/inst/tinytest/_tinysnapshot/flip_facet_by.svg b/inst/tinytest/_tinysnapshot/flip_facet_by.svg index de664799..d96c39d3 100644 --- a/inst/tinytest/_tinysnapshot/flip_facet_by.svg +++ b/inst/tinytest/_tinysnapshot/flip_facet_by.svg @@ -80,10 +80,13 @@ - + + + + @@ -134,10 +137,13 @@ - + + + + @@ -188,10 +194,13 @@ - + + + + @@ -254,12 +263,6 @@ - - - - - - @@ -312,12 +315,6 @@ - - - - - - diff --git a/inst/tinytest/_tinysnapshot/flip_p.svg b/inst/tinytest/_tinysnapshot/flip_p.svg index 24df48b8..c5d9eb59 100644 --- a/inst/tinytest/_tinysnapshot/flip_p.svg +++ b/inst/tinytest/_tinysnapshot/flip_p.svg @@ -80,10 +80,13 @@ - + + + + diff --git a/inst/tinytest/_tinysnapshot/flip_p_logx.svg b/inst/tinytest/_tinysnapshot/flip_p_logx.svg index 7dd32f5b..549c43fd 100644 --- a/inst/tinytest/_tinysnapshot/flip_p_logx.svg +++ b/inst/tinytest/_tinysnapshot/flip_p_logx.svg @@ -80,10 +80,13 @@ - + + + + diff --git a/inst/tinytest/_tinysnapshot/tinytheme_dynamic_clean.svg b/inst/tinytest/_tinysnapshot/tinytheme_dynamic_clean.svg index 1ea35617..4ba8f9f2 100644 --- a/inst/tinytest/_tinysnapshot/tinytheme_dynamic_clean.svg +++ b/inst/tinytest/_tinysnapshot/tinytheme_dynamic_clean.svg @@ -88,10 +88,13 @@ - + + + + diff --git a/inst/tinytest/_tinysnapshot/tinytheme_dynamic_dark.svg b/inst/tinytest/_tinysnapshot/tinytheme_dynamic_dark.svg index 29ad0261..5d7d0bb8 100644 --- a/inst/tinytest/_tinysnapshot/tinytheme_dynamic_dark.svg +++ b/inst/tinytest/_tinysnapshot/tinytheme_dynamic_dark.svg @@ -70,10 +70,13 @@ - + + + + diff --git a/inst/tinytest/test-restore_par.R b/inst/tinytest/test-restore_par.R index f911a0d7..de529d59 100644 --- a/inst/tinytest/test-restore_par.R +++ b/inst/tinytest/test-restore_par.R @@ -12,7 +12,7 @@ op = par(no.readonly = TRUE) f1 = function() { tinyplot( Sepal.Width ~ Sepal.Length | Species, iris, - grid = grid(), + grid = TRUE, legend = legend("bottom!", bty = "o") ) points(6,3, pch = 17, col = "hotpink", cex = 1.5) diff --git a/man/facet.Rd b/man/facet.Rd new file mode 100644 index 00000000..da461aea --- /dev/null +++ b/man/facet.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/facet.R +\name{draw_facet_window} +\alias{draw_facet_window} +\alias{facet_layout} +\title{Draw facet windows} +\usage{ +draw_facet_window( + add, + cex_fct_adj, + facet.args, + facet_newlines, + facet_font, + facet_rect, + facet_text, + facet_col, + facet_bg, + facet_border, + facet, + facets, + ifacet, + nfacets, + nfacet_cols, + nfacet_rows, + axes, + flip, + frame.plot, + oxaxis, + oyaxis, + xlabs, + xlim, + xaxt, + xaxs, + xaxl, + ylabs, + ylim, + yaxt, + yaxs, + yaxl, + asp, + log, + dots, + draw, + grid, + has_legend, + type, + x, + xmax, + xmin, + y, + ymax, + ymin +) + +facet_layout(facet, add = FALSE, facet.args = list()) +} +\description{ +Internal functions called from \code{tinyplot} in order to draw the +plot window with different facets, grids, axes, etc. + +\code{facet_layout} determines the layout of the facets, based on a set of inputs. + +\code{draw_facet_window} is the main workhorse function for setting the exterior +plot elements as part of a \code{tinyplot} call, including adjustment of margins +for dynamic themes, etc. +} +\keyword{internal}