inst/apps/dragdrop/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(column(12,
                           h5("Columns:"),
                           div(id = "Available1",
                               style = "min-height: 10px;",
                               lapply(colnames(dummy[,4:5]), columnBlocks, data = dummy)))
           ),

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

             column(6,
                    fluidRow(
                      column(12,
                             div(id = "colOutput",
                                 style = "min-height: 30px;
                                 border-style: dotted;
                                 border-color: #A9A9A9;
                                 border-width: 2px;
                                 "),
                             dragulaOutput("dragula1")
                      )
                    ),

                    fluidRow(
                      column(6,offset=0,
                             div(id = "rowOutput",
                                 style = "min-height: 500px;
                                  border-style: dotted;
                                 border-color: #A9A9A9;
                                 border-width: 2px;
                                 margin-top:-3.5em;
                                 margin-right:-1em;")
                             ),
                      column(6,
                             div(id = "aggOutput",
                                 style = "min-height: 500px;
                                 margin-top:-3.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 column block input
  output$dragula1 <- renderDragula({
    dragula(c("Available1", "colOutput"))
  })

  # 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_list <- reactive({
    unlist(purrr::transpose(input$dragula1$colOutput), recursive = FALSE)
  })


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


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

  datalist = list()

  output$table <- renderTable ({
    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])
      column <- ifelse(is.na(combinedList()[[i]][3]), "", sym(combinedList()[[i]][3]))

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