Блог

Главная - Вопросы по программированию - Вложенная конкатенация применения

Вложенная конкатенация применения

#r #shiny

Вопрос:

Я пытаюсь создать цикл для создания пользовательской таблицы HTML. У меня возникли проблемы с вложенными лапами.

Код

 library(htmltools)
dataframe <- iris[1:5,]
tags$tbody(
  apply(dataframe,1, function(x) { tags$tr(list('class = "Row"',
                                                lapply(colnames(dataframe), function(x1) glue::glue("data-{x1}="))),
                                           lapply(x, function(y) tags$td(y)))})
)

Желаемый Результат

  <tr class = "Row"
    data-Sepal.Length=5.1
    data-Sepal.Width="3.5"
    data-Petal.Length="1.4"
    data-Petal.Width="0.2"
    data-Species= "setosa">
    <td>5.1</td>
    <td>3.5</td>
    <td>1.4</td>
    <td>0.2</td>
    <td>setosa</td>
  </tr>

Что я получаю на данный момент —

  <tr>
    class = "Row"
    data-Sepal.Length=
    data-Sepal.Width=
    data-Petal.Length=
    data-Petal.Width=
    data-Species=
    <td>5.1</td>
    <td>3.5</td>
    <td>1.4</td>
    <td>0.2</td>
    <td>setosa</td>
  </tr>

Комментарии:

1. Могу я спросить, какова мотивация для этого? Как вы, наверное, знаете renderTable , создает HTML-таблицы из data.frames.

Ответ №1:

 library(htmltools)
dataframe <- iris[1:5,]
tags$tbody(
  apply(dataframe,1, function(x){
    attributesNames <-
      c("class", paste0("data-", colnames(dataframe)))
    attributes <- setNames(c("rovv", as.character(x)), attributesNames)
    cells <- unname(lapply(x, function(y) tags$td(y)))
    args <- c(attributes, cells)
    do.call(tags$tr, args)
  })
)

Ответ №2:

Вот возможное решение paste0 с использованием sprtinf и.

 dataframe <- iris[1:5,]

htmltools::HTML(apply(dataframe, 1, function(x) {
  sprintf('n<tr class = "Row" n %s n </tr>', 
         paste0(c(paste0(
           sprintf('tdata-%s="%s"', names(dataframe), x), collapse = 'n'),
         paste0(
           sprintf('<td>%s</td>', x), collapse = 'n')), collapse = 'n'))
  
}))

#<tr class = "Row" 
#   data-Sepal.Length="5.1"
#   data-Sepal.Width="3.5"
#   data-Petal.Length="1.4"
#   data-Petal.Width="0.2"
#   data-Species="setosa"
#<td>5.1</td>
#<td>3.5</td>
#<td>1.4</td>
#<td>0.2</td>
#<td>setosa</td> 
# </tr> 
#<tr class = "Row" 
#  data-Sepal.Length="4.9"
#...
#...

Ответ №3:

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

Решение добавляет все эти аргументы в список, который мы хотим передать tags$tr , и их использование do.call .

 library(htmltools)

GenerateAttributes <- function(xNames, x) {
  names(x) <- paste("data", xNames, sep = "-")
  x
}

GenerateRow <- function(x, xNames) {
  Args <- list(lapply(x, function(y) tags$td(y)))
  Args <- c(Args, class = "Row")
  Args <- c(Args, GenerateAttributes(xNames, x))
  do.call(tags$tr, Args)
}

dataframe <- iris[1:5,]
tags$tbody(
  apply(dataframe, 1, GenerateRow, names(dataframe))
)
 
 <tbody>
<tr class="Row" data-Sepal.Length="5.1" data-Sepal.Width="3.5" data-Petal.Length="1.4" data-Petal.Width="0.2" data-Species="setosa">
<td>5.1</td>
<td>3.5</td>
<td>1.4</td>
<td>0.2</td>
<td>setosa</td>
</tr>
...
</tbody>

Создано 2021-10-09 пакетом reprex (v2.0.1)

Метки: