inst/apps/column-buttons/app.R

In MayaGans/TableGenerator: Drag and Drop Elements in 'Shiny' using 'Dragula Javascript Library'

library(shiny)
library(dragulaR)
# devtools::install_github("hazybluedot/dragulaR")
library(shinyjs)
library(data.table)
library(tidyverse)
library(janitor)
library(shinyWidgets)

source("CSS.R")
source("global.R")

# create total variable to be used when row is dragged in
total <- dummy %>% summarise(n = n())

test <- c("mean/sd", "frequency")

columnBlocks <- function(data, name)
{
  div(style = "
      text-align: center;
      font-size: 12px;
      background-color: #A9A9A9;
      border-radius: 10px;
      color: black;
      float: left;
      min-width: 80px;
      margin: 10px;
      display: inline-block;
      "
      ,
      drag = name,
      div(class = "active-title", id = "columnBlock", tabindex = "-1", name ))
}


rowBlocks <- function(data, name)
{
  div(style = "
      text-align: center;
      font-size: 12px;
      background-color: #A9A9A9;
      border-radius: 10px;
 min-width: 80px;
      color: black;",
      drag = name,
      div(class = "active-title", name))
}

aggBlocks <- function(data, name)
{
  div(style = "
      text-align: center;
      font-size: 12px;
      background-color: #A9A9A9;
      border-radius: 10px;
 min-width: 80px;
      color: black;",
      drag = name,
      div(class = "active-title", name))
}

ui <- fluidPage(

  inlineCSS(css),

  sidebarPanel(

  fluidRow(style = "margin: 15px;",

           fluidRow(
             h3("Click on Grouping Factor:"),
             column(12,
                    radioGroupButtons(
                      inputId = "COLUMN",
                      choiceNames =  c("Treatment", "Dose", "none"),
                      individual = TRUE,
                      choiceValues = c("treatment", "dose", "none"), selected = "none"))
           ),

           fluidRow(
             h3("Drag and Drop:"),

             column(3,
                    h5("Rows:"),
                    div(id = "Available2", style = "min-height: 600px;",
                        lapply(colnames(dummy[,1:3]), rowBlocks, data = dummy))
             ),

             column(6,
                    fluidRow(
                      column(6,offset=0,
                             div(id = "rowOutput",
                                 style = "min-height: 500px;
                                  border-style: dotted;
                                 border-color: #A9A9A9;
                                 border-width: 2px;
                                 margin-top: 0.5em;
                                 margin-right:-1em;")
                             ),
                      column(6,
                             div(id = "aggOutput",
                                 style = "min-height: 500px;
                                 margin-top: 0.5em; margin-left:-1em;
                                 border-style: dotted;
                                 border-color: #A9A9A9;
                                   border-width: 2px;")
                      )
                             )

                    ),

             column(3,
                    h5("Aggregate:"),
                    div(id = "Available3", style = "min-height: 600px;",
                        lapply(test, aggBlocks, data = test))
             )

           )

  ),

  dragulaOutput("dragula2"),
  dragulaOutput("dragula3")

  ),
  mainPanel(tableOutput("table")))

server <- function(input, output) {

  # get the 'row' block inputs
  output$dragula2 <- renderDragula({
    dragula(c("Available2", "rowOutput"))
  })

  # get the summarization functions the user want's to perform on data
  output$dragula3 <- renderDragula({
    dragula(c("Available3", "aggOutput"),
            #copy = JS("function(el, source) { return source === document.getElementById('Available'); }"),
            #accepts = JS("function(el, target) { return target !== document.getElementById('Available'); }"),
            copyOnly = 'Available3', # shortcut for allowing copy from only a single container, i.e. implements commented options above.
            removeOnSpill = TRUE)
  })

  ##########
  # STEP 1:
  ##########
  # Combine Row and Agg functions into a third list


  # create reactive lists based on block inputs
  row_list <- reactive({
    unlist(purrr::transpose(input$dragula2$rowOutput), recursive = FALSE)
  })

  agg_list <- reactive({
    unlist(purrr::transpose(input$dragula3$aggOutput), recursive = FALSE)
  })

  column <- reactive ({ ifelse(input$column == "none", "", sym(input$COLUMN)) })


  # Check if column_list is empty
  combinedList <- reactive({
      mapply(c, row_list(), agg_list(), SIMPLIFY = FALSE)
  })

  ##################
  # The Table
  ##################

  datalist = list()

  output$table <- renderTable ({

    column <- ifelse(input$COLUMN == "none", "", sym(input$COLUMN))
    print(column)

    for (i in 1:length(combinedList())) {
      # convert to symbols so we can use in tidy eval
      row <- sym(combinedList()[[i]][1])
      agg <- sym(combinedList()[[i]][2])

      if (combinedList()[[i]][2] == "mean/sd") {
        df <-
          dummy %>%
          # this will still run when column is set to ""
          group_by(!!column) %>%
          summarise(N = n(),
                    `Mean (SD)` = paste0(mean(!!row), " (", round(sd(!!row), 2), ")"),
                    Median = median(!!row),
                    `Q1 | Q3` = paste(quantile(!!row, 0.25) , "|", (quantile(!!row, 0.75))),
                    `Min | Max` = paste0(min(!!row), " | ", max(!!row)))

        tdf = setNames(data.frame(t(df[,-1])), lapply(as.character(unlist(df[,1])), CapStr))
        insert <- data.frame(t(data.frame("X" = c(rep(" ", length(tdf))))))
        row.names(insert) <- paste(CapStr(as.character(row)))
        colnames(insert) <- colnames(tdf)
        datalist[[i]] <- rbind(insert, tdf)

      } else {

        # either tabulate using column or not
        ifelse(column == "", grouping <- row, grouping <- c(row, column))

        exp1 <- expr(dummy %>%
                       tabyl(!!!grouping) %>%
                       adorn_pct_formatting(rounding = "half up", digits = 0) %>%
                       adorn_ns(position = "front"))
        d <- rlang::eval_tidy(exp1)

        d2 <- d[,-1]
        rownames(d2) <- d[,1]
        insert <- data.frame(t(data.frame("X" = c(rep(" ", length(d2))))))
        row.names(insert) <- CapStr(as.character(row))
        colnames(insert) <- colnames(d2)
        data <- rbind(insert, d2)
        colnames(data) <- lapply(colnames(data), CapStr)
        datalist[[i]] <- data
      }

      if (column != "") {
        big_data = do.call(rbind, datalist)
      } else {

        cols <- max(sapply(datalist, ncol))
        # This is the length of the NA vectors that make the cbinding dfs:
        lengths <- (cols - sapply(datalist, ncol))*sapply(datalist, nrow)
        newdf <- list()
        rownames <- list()

        for (i in 1:length(datalist)) {
          rownames[[i]] <- rownames(datalist[[i]])
        }

        rn <- unlist(rownames)

        for (i in 1:length(datalist)){
          if (ncol(datalist[[i]]) != cols){
            newdf[[i]] <- cbind(datalist[[i]],
                                as.data.frame(matrix(rep(NA, lengths[i]),
                                                     ncol = lengths[i] / nrow(datalist[[i]]))))
          } else {
            newdf[[i]] <- datalist[[i]]
          }
        }

        n <- rbindlist(newdf)
        n <- data.frame(n)
        row.names(n) <- unlist(rownames)
        big_data <- n
      }
    }
    big_data
  }, rownames = TRUE)

}

shinyApp(ui = ui, server = server)