pvalue -log10 transformation (compatible with ggtext)

pval_trans.R

# # MIT License
#
# Copyright (c) 2024 Mickaël Canouil
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

#' pval_trans
#' @import scales
pval_trans <- function(alpha = NULL, md = FALSE, prefix = FALSE, colour = "#b22222") {
  scales::trans_new(
    name = "pval",
    domain = c(0, 1),
    transform = function(x) {
      x[x < .Machine$double.xmin] <- .Machine$double.xmin
      -log(x, 10)
    },
    inverse = function(x) {10^-x},
    breaks = (function(n = 5) {
      function(x) {
        max <- floor(-log(min(c(x, alpha), na.rm = TRUE), base = 10))
        if (max == 0) 1 else sort(unique(c(10^-seq(0, max, by = floor(max / n) + 1), alpha)))
      }
    })(),
    format = (function(x, digits = 3) {
      if (md & nchar(system.file(package = "ggtext")) != 0) {
        prefix_text <- if (prefix) "&alpha; = " else ""
        x_fmt <- gsub(
          "^(.*)e[+]*([-]*)0*(.*)$",
          "\\1 &times; 10<sup>\\2\\3</sup>",
          format(x, scientific = TRUE, digits = digits)
        )
        x_fmt[x %in% c(0, 1)] <- x[x %in% c(0, 1)]
        x_fmt <- gsub("^1 &times; ", "", x_fmt)
        alpha_idx <- format(x, scientific = TRUE, digits = digits) ==
          format(alpha, scientific = TRUE, digits = digits)
        x_fmt[alpha_idx] <- paste0("<b style='color:", colour, ";'>", prefix_text, x_fmt[alpha_idx], "</b>")
        x_fmt
      } else {
        prefix_text <- if (prefix) "alpha == " else ""
        x_fmt <- gsub(
          "^(.*)e[+]*([-]*)0*(.*)$",
          "\\1 %*% 10^\\2\\3",
          format(x, scientific = TRUE, digits = digits)
        )
        x_fmt[x %in% c(0, 1)] <- x[x %in% c(0, 1)]
        x_fmt <- gsub("^1 \\%\\*\\% ", "", x_fmt)
        alpha_idx <- format(x, scientific = TRUE, digits = digits) ==
          format(alpha, scientific = TRUE, digits = digits)
        x_fmt[alpha_idx] <- paste0(prefix_text, x_fmt[alpha_idx])
        parse(text = x_fmt)
      }
    })
  )
}

library(ggplot2)
library(scales)
devtools::source_gist("d7cbc59a7fcbb6d231f432801ec7aa19")
#> Sourcing https://gist.githubusercontent.com/mcanouil/d7cbc59a7fcbb6d231f432801ec7aa19/raw/338f5407f511397e5fe19b2651f02113402262e3/pval_trans.R
#> SHA-1 hash of file is c90a0f6bbe9d84a0da56f9eab7cc323f4cae3039

p <- ggplot(
  data = data.frame(y = 10^-seq(0, 5), x = 1:(5 +1)),
  mapping = aes(x = x, y = y)
) + 
  geom_point() +
  geom_hline(yintercept = 0.05, colour = "firebrick2")

p + scale_y_continuous(trans = "pval")

p + scale_y_continuous(trans = pval_trans(alpha = 0.05, md = FALSE, prefix = FALSE))

p + scale_y_continuous(trans = pval_trans(alpha = 0.05, md = FALSE, prefix = TRUE))

library(ggtext)
p_md <- p + theme(axis.text.y = element_markdown())
p_md + scale_y_continuous(trans = "pval")

p_md + scale_y_continuous(trans = pval_trans(alpha = 0.05, md = TRUE, prefix = FALSE))

p_md + scale_y_continuous(trans = pval_trans(alpha = 0.05, md = TRUE, prefix = TRUE))