Paski warunkowe jako część tabeli HTML

Question

Szukam sposobu na stworzenie warunkowego wykresu słupkowego jako części gttabeli (wspaniały pakiet gramatyki tabel). Wydaje się, że jest to możliwe w DT's, datatablejak pokazano tutaj, styleColorBar Środek i przesunięcie w lewo / w prawo w zależności od znaku . Oto obraz tego, czego chcę, a poniżej znajduje się kod do wygenerowania tego obrazu DT. Szukam jednak gtrozwiązania.

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_bardoda pręty do określonej kolumny. Skaluje wartości pomiędzy 0i 100. Wartości 0get mapowane do 50.

tab_style jest używany do na każdej z wartości, aby ustawić gradient tła.

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
}

Tutaj jest z 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

Pozwala również na wiele kolumn.

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()