Nested apply concatenation

user_8528899 0
Viewed 41

I am trying to create loop for building custom HTML Table. I am having issue in nested lapply.

Code

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

Desired Output

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

What I am getting as of now -

 <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>
shiny r
3 Answers

Here is a possible solution using paste0 and 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"
#...
#...
user_39629140 
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)
  })
)
user_11001070

The attributed of the tags have to be an extra argument while you supplied them as if they were supposed to be a new tag. The solution tried to isolate the different parts so that one can see how it works.

The solution adds all those arguments to a list that we want to pass over to tags$tr and the uses 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>

Created on 2021-10-09 by the reprex package (v2.0.1)

user_132415450
Related