R / Rshiny добавляет пункт в список факторов - PullRequest
Новая
       1

R / Rshiny добавляет пункт в список факторов

0 голосов
/ 09 июля 2020

Почему это так сложно ?! У меня есть (я считаю, что это факторный вектор), и я хочу добавить элемент в список, чтобы использовать его в дальнейшем.

Я хочу добавить «memo.txt» в факторный вектор имена файлов.

Я понял, как добавить факторный уровень в список, но не сам элемент. 

levels(filenames) <- c(levels(filenames), "memo.txt")

Специфический раздел c, в котором я работаю, находится здесь: 

observeEvent(input$download, {
    filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
    
#I need to add items to "filenames" here. I then display "test" to make sure those items exist in "filenames" - ie, i want to add "memo.txt" to filenames.

    output$test <- renderTable(filenames)
   
    files <- file.path(".", "www", filenames)
    URIs <- lapply(seq_along(files), function(i){
      URI <- dataURI(file = files[i])
      list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
    })
    table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
    session$sendCustomMessage(
      "download",
      list(table = table, URIs = URIs)
    )
  })

Весь код: 

library(shiny)
library(timevis)
library(lubridate)
library(dplyr)
library(jsonlite)
library(base64enc)

starthour <- 8
today <- as.character(Sys.Date())
todayzero <- paste(today, "00:00:00")
todayAM <- paste(today, "07:00:00")
todayPM <- paste(today, "18:00:00")

items <- data.frame(
  category = c("Room", "IceBreaker", "Activity", "Break"),
  group = c(1, 2, 3, 4),
  className   = c ("red_point", "blue_point", "green_point", "purple_point"),
  content = c("Big Room", "Introductions", "Red Rover", "Lunch"),
  length = c(480, 60, 120, 90),
  file_name = c("Toolkit_placeholder.pdf", NA, "Placeholder.txt", "Toolkit_placeholder.pdf")
)

groups <- data.frame(id = items$group, content = items$category)

data <- items %>% mutate(
  id = 1:4,
  start = as.POSIXct(todayzero) + hours(starthour),
  end   = as.POSIXct(todayzero) + hours(starthour) + minutes(items$length)
)

js <- "
function downloadZIP(x){
  var csv = Papa.unparse(x.table);
  var URIs = x.URIs;
  domtoimage.toPng(document.getElementById('appts'), {bgcolor: 'white'})
    .then(function (dataUrl) {
      var zip = new JSZip();
      var idx = dataUrl.indexOf('base64,') + 'base64,'.length;
      var content = dataUrl.substring(idx);
      zip.file('timeline.png', content, {base64: true})
       .file('timeline.csv', btoa(csv), {base64: true});
      for(let i=0; i < URIs.length; ++i){
        zip.file(URIs[i].filename, URIs[i].uri, {base64: true});
      }
      zip.generateAsync({type:'base64'}).then(function (b64) {
        var link = document.createElement('a');
        link.download = 'mytimeline.zip';
        link.href = 'data:application/zip;base64,' + b64;
        link.click();
      });
    });
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('download', downloadZIP);
});"

ui <- fluidPage(
  tags$head(
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/dom-to-image/2.6.0/dom-to-image.min.js"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.5.0/jszip.min.js"),
    tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/PapaParse/5.2.0/papaparse.min.js"),
    tags$script(HTML(js)),
    tags$style(
      HTML(
        "
        .red_point  { border-color: red; border-width: 2px;   }
        .blue_point { border-color: blue; border-width: 2px;  }
        .green_point  { border-color: green; border-width: 2px;   }
        .purple_point { border-color: purple; border-width: 2px;  }
        "
      )
      )
      ),
  DT::dataTableOutput("tbl1"),
  conditionalPanel(
    condition = "typeof input.tbl1_rows_selected  !== 'undefined' && input.tbl1_rows_selected.length > 1",
    actionButton(class = "btn-success",
                 "button2",
                 "GENERATE TIMELINE")
  ),
  
  conditionalPanel(
    condition = "input.button2 > 0",
    
    timevisOutput("appts"),
    
    actionButton("download", "Download timeline", class = "btn-success"),
    
    conditionalPanel(
      condition = "input.download > 0",
    tableOutput("test")
    )
    
    
  )
 
      )

server <- function(input, output, session) {
  output$tbl1 <- DT::renderDataTable({
    data
  },
  caption = 'Select desired options and scroll down to continue.',
  selection = 'multiple',
  class = "display nowrap compact",
  extensions = 'Scroller',
  options = list(
    dom = 'Bfrtip',
    paging = FALSE,
    columnDefs = list(list(visible = FALSE))
  ))
  
  
  observeEvent(input$button2, {
    row_data <- data[input$tbl1_rows_selected, ]
    
    
    
    output$appts <- renderTimevis(timevis(
      data = row_data,
      groups = groups,
      fit = TRUE,
      options = list(
        editable = TRUE,
        multiselect = TRUE,
        align = "center",
        stack = TRUE,
        start = todayAM,
        end = todayPM,
        showCurrentTime = FALSE,
        showMajorLabels = FALSE
      )
    ))
    file_list <- as.data.frame(row_data$file_name)
    
   
      })
  
  observeEvent(input$download, {
    filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
    


    #levels(filenames) <- c(levels(filenames), "memo.txt")
    #test <- "memo.txt"
    #browser()
    #filenames <- append(filenames,test)
    # levels(filenames) <- c(levels(filenames), "memo.txt")
    
    
    
    output$test <- renderTable(filenames)
   
    
    files <- file.path(".", "www", filenames)
    URIs <- lapply(seq_along(files), function(i){
      URI <- dataURI(file = files[i])
      list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
    })
    table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
    session$sendCustomMessage(
      "download",
      list(table = table, URIs = URIs)
    )
  })
  
}

shinyApp(ui, server)

РЕДАКТИРОВАТЬ с ответом (i sh) После попытки (и неудачи), как и многие другие, чтобы справиться с учетом факторов, я поумнел и установил исходный фрейм данных "items" на stringAsFactors = FALSE, это, безусловно, самое простое решение. Оттуда работает: 

items <- data.frame(
  category = c("Room", "IceBreaker", "Activity", "Break"),
  group = c(1, 2, 3, 4),
  className   = c ("red_point", "blue_point", "green_point", 
"purple_point"),
  content = c("Big Room", "Introductions", "Red Rover", "Lunch"),
  length = c(480, 60, 120, 90),
  file_name = c("Toolkit_placeholder.pdf", NA, "Placeholder.txt", 
"Toolkit_placeholder.pdf"), stringsAsFactors = FALSE
)



observeEvent(input$download, {
    
   filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
    static_files <- "memo.txt"
    filenames <- append(filenames,static_files)
    
    output$test <- renderTable(filenames)

    files <- file.path(".", "www", filenames)
    URIs <- lapply(seq_along(files), function(i){
      URI <- dataURI(file = files[i])
      list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
    })

    table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
    session$sendCustomMessage(
      "download",
      list(table = table, URIs = URIs)
    )
  })

Ответы [ 2 ]

1 голос
/ 10 июля 2020

Вместо того, чтобы пытаться манипулировать факторами, самым простым ответом было установить stringsToFactors как FALSE. Я использую R версии 3.6, в R 4.0 это теперь поведение по умолчанию.

Я обновил исходный вопрос, чтобы включить ответ.

0 голосов
/ 09 июля 2020

Попробуйте этот код: 

 observeEvent(input$download, {
    filenames <- na.omit(data[input$tbl1_rows_selected, "file_name"])
    ## added the next seven lines; no other modifications to your code.
    filez <- file.path(".", "www", filenames)
    fnamez <- lapply(seq_along(filez), function(i){
      list(filename = filenames[i])
    })
    f2namez <- list(fnamez,"memo.txt")
    filenamez <- unlist(f2namez)
    filenamez2 <- data.frame(filenamez)
    
    output$test <- renderTable(filenamez2)

    files <- file.path(".", "www", filenames)
    URIs <- lapply(seq_along(files), function(i){
      URI <- dataURI(file = files[i])
      list(filename = filenames[i], uri = substr(URI, 14, nchar(URI)))
    })
    table <- fromJSON(toJSON(input$appts_data), simplifyDataFrame = FALSE)
    session$sendCustomMessage(
      "download",
      list(table = table, URIs = URIs)
    )
  })

Никаких других изменений в оставшейся части вашего кода. Это дает следующий результат:

вывод

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...