Barre de couleurs bicolore en R formatable

Question

J'ai une colonne qui est la somme de deux autres colonnes. J'essaie d'obtenir un formateur color_bar avec deux couleurs, chaque largeur représentant les numéros individuels. J'ai essayé d'augmenter le code de barre de couleur en ajoutant un autre color_bar. L'idée était la grande barre serait la colonne de la somme. Ensuite, j'ai juste besoin d'une autre barre pour être l'un des numéros individuels et j'ai ma barre avec deux couleurs.

Couple de problèmes: Principalement, lorsque je supprime la variable avant le ~ et que j'ai placé la colonne dans le bloc de largeur, R ne semble pas comprendre la référence. Deuxièmement, quand j'essaie juste de voir s'il est possible d'avoir deux blocs de couleur, en ajustant la hauteur du second bloc, seul le second bloc est affiché. J'ai mis le code ci-dessous. Informez-moi si quelqu'un a des conseils, des idées ou des solutions. Je suis ouvert aux idées alternatives pour afficher comment les deux colonnes individuelles se résument à la colonne totale. Comme je tape, peut-être une tarte sparkline?

Voici le code:

#Make a formattable with a dual color bar 

#Packages 
library(dplyr) 
library(formattable) 

#Function 
#Ideally, I'd like it to be a function, but can't visualize how to do it. 
dualbar <- function(bar1 = "lightgray", bar2 = "lightblue", 
        fun = "comma", digits = 0) { 

    fun <- match.fun(fun) 
    formatter("span", x ~ fun(x, digits = digits), 
      style = y ~ style(
       display = "inline-block", 
       direction = "rtl", 
       "border-radius" = "4px", 
       "padding-right" = "2px", 
       "background-color" = csscolor(bar1), 
       width = percent(proportion(as.numeric(y), na.rm = TRUE))), 
      style = z ~ style(
       display = "inline-block", 
       direction = "rtl", 
       "border-radius" = "4px", 
       "padding-right" = "2px", 
       "background-color" = csscolor(bar2), 
       width = percent(proportion(as.numeric(z), na.rm = TRUE)), 
       height = "10px") 
      ) 
} 

#Generate Data 
set.seed(1234) 
df <- data.frame(month = month.name[1:12], 
       valx = runif(12, 0, 5), 
       valy = runif(12, 2, 7)) 
df$total <- df$valx + df$valy 

tab <- df %>% 
    formattable(list(area(row = 1:12, col = 2) ~ 
        formatter("span", x ~ comma(x, digits = 0), 
           style = y ~ style(
           display = "inline-block", 
           direction = "rtl", 
           "border-radius" = "4px", 
           "padding-right" = "2px", 
           "background-color" = csscolor("lightgray"), 
           width = percent(proportion(as.numeric(y), na.rm = TRUE))), 
           z ~ style(
           display = "inline-block", 
           direction = "rtl", 
           "border-radius" = "4px", 
           "padding-right" = "2px", 
           "background-color" = csscolor("lightblue"), 
           width = percent(proportion(as.numeric(z), na.rm = TRUE))) 
       ))) %>% 
    select(-valx, -valy) %>% 
    formattable::as.htmlwidget() 

tab 

Answer 1

Je voulais faire pendant un certain temps la même chose, donc voici au moins une solution. Plutôt que d'essayer d'obtenir formatable() pour reconnaître deux ou plusieurs colonnes séparées, les colonnes pertinentes sont concaténées en une seule variable de caractère. Les différentes fonctions CSS et de formatage analysent ensuite ces chaînes en conséquence.

La largeur maximale est codée en dur ici (= 300px), donc vous voudrez probablement rendre cela réactif.

library(dplyr) # (>= 0.7.0) 
library(formattable) 
library(glue) 
library(stringr) 
library(tidyr) 
library(scales) 

set.seed(1234) 
df <- data.frame(month = month.name[1:12], 
      valx = runif(12, 0, 5), 
      valy = runif(12, 2, 7)) 
df$total <- df$valx + df$valy 


extr <- function(v, n, size = 6){ 
    str_split_fixed(v, "_", size)[,n] %>% as.double 
} 

lblue <- csscolor(col2rgb("lightblue")) 
lgray <- csscolor(col2rgb("lightgray")) 

df %>% mutate(orders = row_number()) %>% 
    mutate_if(is.double, funs(lbl = round(., 0))) %>% 
    gather(key = item, value = score, valx:total) %>% 
    mutate(score = rescale(score, to = c(0,300)), 
     score = round(score, 0), 
     item = factor(item, levels = c("valx", "valy", "total"))) %>% 
    spread(key = item, value = score) %>% 
    arrange(orders) %>% 
    mutate(vals = str_c(valx, "_", valy, "_", total, "_", valx_lbl, "_",  
     valy_lbl, "_", total_lbl)) %>% 
    select(month, vals) %>% 
    formattable(align = "l", list(
    vals = formatter("span", 
       style = x ~ style(
        display = "inline-block", 
        direction = "ltr", 
        "border-radius" = "4px", 
        "padding-right" = "2px", 
        "text-indent" = str_c(extr(x,1)-10, "px"), 
        "background-image" = glue("linear-gradient(to right, 
        {lgray}, {lgray}), linear-gradient(to right, {lblue}, {lblue})"), 
        "background-repeat" = "no-repeat", 
        "background-position" = str_c("0 0, ", extr(x,1), "px 0"), 
        "background-size" = str_c(extr(x,1), "px 100%, ", extr(x,2), "px 100%"), 
        "width" = str_c(extr(x,3), "px"), 
        "text-align" = "left", 
        "position" = "relative" 
       ), x ~ str_c(extr(x,4), "  ", str_c(extr(x,5)))) 
)) 

La mise en forme CSS a été inspirée par this answer.