Bedingte Balken als Teil einer HTML-Tabelle

Question

Ich suche nach einer Möglichkeit, ein bedingtes Balkendiagramm als Teil einer gtTabelle zu erstellen (das wunderbare Paket zur Grammatik von Tabellen). Es scheint möglich zu sein DT, datatablewie hier gezeigt, styleColorBar Center und je nach Vorzeichen nach links / rechts zu verschieben . Hier ist ein Bild von dem, was ich will, und unten ist Code, um dieses Bild in zu generieren DT. Ich suche jedoch nach einer gtLösung.

library(tidyverse)
library(DT)

# custom function that uses CSS gradients to make the kind of bars I need
color_from_middle <- function (data, color1,color2) 
{
  max_val=max(abs(data))
  JS(sprintf("isNaN(parseFloat(value)) || value < 0 ? 'linear-gradient(90deg, transparent, transparent ' + (50 + value/%s * 50) + '%%, %s ' + (50 + value/%s * 50) + '%%,%s  50%%,transparent 50%%)': 'linear-gradient(90deg, transparent, transparent 50%%, %s 50%%, %s ' + (50 + value/%s * 50) + '%%, transparent ' + (50 + value/%s * 50) + '%%)'",
             max_val,color1,max_val,color1,color2,color2,max_val,max_val))
} 

mtcars %>%
  rownames_to_column() %>%
  select(rowname, mpg) %>%
  head(10) %>%
  mutate(mpg = (mpg - 20) %>% round) %>%
  datatable() %>%
  formatStyle(
    "mpg",
    background = color_from_middle(mtcars$mpg,'red','green')
    )

Answer 1

tab_barfügt die Balken der angegebenen Spalte hinzu. Es skaliert die Werte zwischen 0und 100. Werte von 0werden zugeordnet 50.

tab_style wird verwendet, um für jeden der Werte den Hintergrundgradienten festzulegen.

library(tidyverse)
library(gt)

tab_bar <- function(data, column) {
  vals <- data[['_data']][[column]]
  
  scale_offset <- (max(vals) - min(vals)) / 2
  scale_multiplier <- 1 / max(abs(vals - scale_offset))
  
  for (val in unique(vals)) {
    if (val > 0) {
      color <- "lightgreen"
      start <- "50"
      end <- ((val - scale_offset) * scale_multiplier / 2 + 1) * 100
    } else {
      color <- "#FFCCCB"
      start <- ((val - scale_offset) * scale_multiplier / 2 + 0.5) * 100
      end <- "50"
    }
    
    data <-
      data %>%
      tab_style(
        style = list(
          css = glue::glue("background: linear-gradient(90deg, transparent, transparent {start}%, {color} {start}%, {color} {end}%, transparent {end}%);")
        ),
        locations = cells_body(
          columns = column,
          rows = vals == val
        )
      )
  }
  
  data
}

Hier ist es mit mtcars.

out <-
  mtcars %>%
  rownames_to_column() %>%
  select(rowname, mpg) %>%
  head(10) %>%
  mutate(mpg = (mpg - 20) %>% round) %>%
  gt()

out %>%
  cols_width(vars(mpg) ~ 120) %>%
  tab_bar(column = "mpg")

Answer 2

Ermöglicht auch mehrere Spalten.

library(tidyverse)
library(gt)

tab_bar <- function(.data, .columns = .data[["_data"]] %>% select_if(is.numeric) %>% names(), .col_neg = "#FFCCCB", .col_pos = "lightgreen"){
  
  for (column in .columns){
    vals <- .data[['_data']][[column]]
    
    scale_multiplier <- 50/abs(max(vals) - min(vals))
    
    for (val in setdiff(unique(vals), 0)) {
      if (val > 0) {
        color <- .col_pos
        start <- "50"
        end <- 50 + val * scale_multiplier + 2
      } else if (val < 0) {
        color <- .col_neg
        start <- 50 + val * scale_multiplier - 2
        end <- "50"
      }
      
      .data <-
        .data %>%
        tab_style(
          style = list(
            css = glue::glue("background: linear-gradient(90deg, transparent, transparent {start}%, {color} {start}%, {color} {end}%, transparent {end}%);")
          ),
          locations = cells_body(
            columns = column,
            rows = vals == val
          )
        )
    }
    
  }
  
  .data
}

map(
  set_names(letters[1:5]),
  ~runif(10, -1, 1)
  ) %>%
  as_tibble() %>%
  gt() %>%
  tab_bar()