Специфичные для цвета ячейки данных на основе их значений факторов

Question

У меня есть приведенный ниже кадр данных:

product<-c("ab","ab","ab","ac","ac","ac")
shop<-c("sad","sad","sad","sadas","fghj","xzzv")
category<-c("a","a","a","b","b","b")
tempr<-c(35,35,14,24,14,5)
value<-c(0,0,-6,8,4,0)
store<-data.frame(product,shop,category,tempr,value)

, из которого я создаю store2 с:

store2 <- matrix(NA,ncol=length(unique(store$shop)),nrow=length(unique(store$product)))
colnames(store2) <- unique(store$shop)
rownames(store2) <- unique(store$product)

for(i in 1:ncol(store)) {
  store2[store[i,'product'],store[i,'shop']] <- paste0(store[i,c('tempr')],'(',store[i,'value'],')')
}

Я хотел бы создать таблицу данных с пакетом DT, окрашеннымв соответствии со значениями этого нового кадра данных.Точнее, если число в скобках положительное, ячейка должна быть зеленого цвета.В любом другом случае (отрицательный, 0 или NA, он должен быть красного цвета. Это пример:

Answer 1

Я не обязательно рекомендую этот подход, потому что я категорически против встраивания одного языка в другой, но я думаю, что он решает ваш вопрос.Вы, вероятно, можете сохранить JavaScript в файл и загрузить его в переменную, и я думаю, что это был бы лучший подход, но в интересах автономного решения я добавил его.

На основев документации DT здесь https://rstudio.github.io/DT/functions.html, ясно, что желаемый подход заключается в том, чтобы каким-то образом использовать formatStyle.

DT предоставляет несколько удобных методов, которые можно использовать с formatStyle, источник которого находится здесь: https://github.com/rstudio/DT/blob/0b9710f5a9391c634a3865961083740f1cbf657b/R/format.R,, на котором я основал свое решение.

По сути, нам нужно передать немного JavaScript в formatStyle, который будет выполнять все стили таблиц на основепеременная с именем value.Нам нужно сделать что-то вроде этого:

datatable(store2) %>% formatStyle(colnames(store2), backgroundColor=JS(jsFunc))

Где переменная jsFunc - это некоторая строка JavaScript.Поскольку источник указывает, что эта строка должна быть выражением, а не оператором, и поскольку это будет несколько сложнее, мы будем использовать анонимную функцию, которая немедленно оценивается для выполнения логики.Эта функция должна принимать значение и возвращать цвет, основанный на этом значении.Вот функция, которая нам нужна.

function(value){
  // find a number preceeded by an open parenthesis with an optional minus sign
  var matches = /\((-?\d+)/.exec(value);
  // ignore values which do not match our pattern, returning white as the background color
  if(!matches || matches.length < 2) { 
    return 'white'; 
  }
  // attempt to convert the match we found into a number
  var int = parseInt(matches[1]); 
  // if we can't ignore it and return a white color
  if(isNaN(int)) { 
    return 'white';
  } 
  // if the value is negative, return red
  if(int < 0) { 
    return 'red' 
  }
  // otherwise, by default, return green
  return 'green';
}

Мы хотим немедленно вызвать эту функцию, поэтому мы заключаем ее в скобки и передаем ей аргумент значения.

(function(value){
  // find a number preceeded by an open parenthesis with an optional minus sign
  var matches = /\((-?\d+)/.exec(value);
  // ignore values which do not match our pattern, returning white as the background color
  if(!matches || matches.length < 2) { 
    return 'white'; 
  }
  // attempt to convert the match we found into a number
  var int = parseInt(matches[1]); 
  // if we can't ignore it and return a white color
  if(isNaN(int)) { 
    return 'white';
  } 
  // if the value is negative, return red
  if(int < 0) { 
    return 'red';
  }
  // otherwise, by default, return green
  return 'green';
})(value)

Мы переносимэто значение в многострочном R -строке, экранировании от обратной косой черты и двойных кавычек (я избегал их использования) и присвоение ему значения jsFunc.

jsFunc <- "(function(value){
  // find a number preceeded by an open parenthesis with an optional minus sign
  var matches = /\\((-?\\d+)/.exec(value);
  // ignore values which do not match our pattern, returning white as the background color
  if(!matches || matches.length < 2) { 
    return 'white'; 
  }
  // attempt to convert the match we found into a number
  var int = parseInt(matches[1]); 
  // if we can't ignore it and return a white color
  if(isNaN(int)) { 
    return 'white';
  } 
  // if the value is negative, return red
  if(int < 0) { 
    return 'red' 
  }
  // otherwise, by default, return green
  return 'green';
})(value)"

Наконец, мы можем вызватьformatStyle с использованием этой переменной

datatable(store2) %>% formatStyle(colnames(store2), backgroundColor=JS(jsFunc))

Это должно дать нам такой результат:

Answer 2

У меня есть ответ, используя data.table и DT, это немного сложно.Вот оно:

library(data.table)
library(DT)

store <- setDT(store)
store[,plouf := paste0(tempr,"(",value,")")]
store[,color := ifelse(value > 0,1,0)]

table1 <- dcast(store[,.SD[1],.SDcols = c("product","shop"),by = plouf],product ~ shop,value.var = "plouf")
table2 <- dcast(store[,.SD[1],.SDcols = c("product","shop","color"),by = plouf],product ~ shop,value.var = "color")
table2[,names(table2)[-1] :=  lapply(.SD,function(x){ifelse(is.na(x),0,x)}),.SDcols = names(table2)[-1] ]
setnames(table2,paste0(names(table1),"_col"))

plouf <- cbind(table1,table2[,-1])

datatable(plouf) %>% 
  formatStyle(names(table1)[-1],paste0(names(table1)[-1],"_col"), backgroundColor = styleEqual(c(0, 1), c('red', 'green')))

Объяснение: во-первых, я переделываю вашу таблицу store2, используя dacst (переход к большому формату), что более удобно, и которое я буду использовать повторно для определения цветов:

store <- setDT(store)
store[,plouf := paste0(tempr,"(",value,")")]
table1 <- dcast(store[,.SD[1],.SDcols = c("product","shop"),by = plouf],product ~ shop,value.var = "plouf")

   product  fghj    sad sadas xzzv
1:      ab    NA  35(0)    NA   NA
2:      ac 14(4) 14(-6) 24(8) 5(0)

Здесь store[,.SD[1],.SDcols = c("product","shop"),by = plouf] позволяют иметь только одну строку на данные, которые вы хотите, чтобы избежать реплики

Затем я делаю то же самое, но с переменной, которая дает цвет (1для зеленого, 0 для красного):

store[,color := ifelse(value > 0,1,0)]
table2 <- dcast(store[,.SD[1],.SDcols = c("product","shop","color"),by = plouf],product ~ shop,value.var = "color")

   product fghj sad sadas xzzv
1:      ab   NA   0    NA   NA
2:      ac    1   0     1    0

Я преобразую Nas в 0 во всех столбцах, кроме первого:

table2[,names(table2)[-1] :=  lapply(.SD,function(x){ifelse(is.na(x),0,x)}),.SDcols = names(table2)[-1] ]

   product fghj sad sadas xzzv
1:      ab    0   0     0    0
2:      ac    1   0     1    0

и изменяю имена второй таблицы (даваяцвета):

setnames(table2,paste0(names(table1),"_col"))

затем вы связываете два

plouf <- cbind(table1,table2[,-1])

и используете DT, где вы указываете другой столбец: один для цели, один для цвета фона

datatable(plouf) %>% 
  formatStyle(names(table1)[-1],paste0(names(table1)[-1],"_col"), backgroundColor = styleEqual(c(0, 1), c('red', 'green')))

Мне пришлось изменить ваши данные, потому что не было уникального набора для каждого магазина.Вот данные:

product<-c("ab","ab","ac","ac","ac","ac")
shop<-c("sad","sad","sad","sadas","fghj","xzzv")
category<-c("a","a","a","b","b","b")
tempr<-c(35,35,14,24,14,5)
value<-c(0,0,-6,8,4,0)
store<-data.frame(product,shop,category,tempr,value)