Как добиться базовой статистики с Shiny?Ошибка в tapply: аргументы должны иметь одинаковую длину - PullRequest
Новая
       1

Как добиться базовой статистики с Shiny?Ошибка в tapply: аргументы должны иметь одинаковую длину

0 голосов
/ 26 сентября 2018

Я разрабатываю блестящее приложение, чтобы экспериментаторы могли быстро визуализировать и взаимодействовать со своими данными.В настоящее время приложение Shiny запрограммировано на выполнение трех действий:

  1. Печать информации заголовка.загруженного файла (успешно)
  2. Печать сводки по загруженному файлу (успешно)
  3. Печать основной статистики выбранных идентификаторов (не успешно) (я изменил следующий код и вставилОбновленный код ниже старой версии.

В приложении Shiny я могу загружать и выбирать имена столбцов из загруженного файла, но я не получаю основной вывод статистики, который мне нужен. Для справки., это вектор, который я назвал 'bs ()'.

Когда я запускаю приложение, даже перед загрузкой тестового файла, я получаю следующее сообщение об ошибке: 

Error in tapply: arguments must have same length.

Когда явыполнить базовую статистику независимо от Shiny, она работает, и моя выходная таблица выглядит следующим образом: 

trt factor1  factor2  x.mean     x.sd       x.length    x.se
 0      NC      DR   36.00000   1.322876        9     0.4409586
 0      NC      ST   36.42857   2.760262        7     1.0432811
 0   t186673    DR   35.55556   2.068279        9     0.6894263
 0   t186673    SD   39.44444   2.962731        9     0.9875772

Начиная с этого исходного поста, я изменил 'bs' и теперь получаю новую ошибку: "Ошибка:выбраны неопределенные столбцы ". Я не удалял первоначально отправленный код, а вместо этого просто скопировал и вставил обновленную версию в конце и аннотировал обновление.

HВот некоторые данные, которые я использую для тестирования приложения Shiny: 

data <- structure(list(Strain = structure(c(2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 
4L, 4L, 4L, 4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), .Label = c("NC", "t186673", 
"t186674", "t186675"), class = "factor"), N_level = c(0L, 0L, 
0L, 0L, 0L, 0L, 0L, 0L, 0L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 
56L, 56L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 56L, 56L, 56L, 
56L, 56L, 56L, 56L, 56L, 56L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
0L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 0L, 0L, 0L, 
0L, 0L, 0L, 0L, 0L, 0L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 
56L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 56L, 56L, 56L, 56L, 
56L, 56L, 56L, 56L, 56L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 0L, 0L, 0L, 0L, 
0L, 0L, 0L, 0L, 0L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 56L, 
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 56L, 56L, 56L, 56L, 56L, 
56L, 56L, 56L, 56L), inoc_met = structure(c(2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), .Label = c("DR", 
"ST"), class = "factor"), phenotype1 = c(40L, 36L, 36L, 39L, 
36L, 35L, 34L, 37L, 36L, 44L, 40L, 42L, 44L, 43L, 43L, 46L, 47L, 
44L, 35L, 42L, 37L, 38L, 37L, 38L, 38L, 36L, 38L, 42L, 35L, 45L, 
46L, 48L, 47L, 45L, 43L, 44L, 40L, NA, 37L, 39L, 40L, 38L, 37L, 
38L, 39L, 40L, 43L, 50L, 40L, 41L, 40L, 44L, 50L, 46L, 35L, NA, 
34L, 36L, 42L, 37L, 37L, 34L, NA, 38L, 42L, 42L, 28L, 32L, 33L, 
43L, 44L, 44L, 36L, 37L, 38L, 38L, 33L, 37L, 34L, 33L, 34L, 35L, 
42L, 38L, 42L, 40L, 44L, 45L, 42L, 41L, 43L, 41L, 41L, 42L, 47L, 
46L, 43L, 42L, 40L, 45L, 45L, 42L, 44L, 43L, 45L, 42L, 39L, 42L, 
35L, 37L, 34L, 38L, 43L, 45L, 33L, 36L, 35L, 46L, 44L, 42L, 42L, 
40L, 48L, 40L, 50L, 45L, 35L, 37L, 34L, 37L, 35L, 38L, 36L, 37L, 
35L, 40L, 39L, 39L, 35L, 32L, 33L, NA, 46L, 43L)), row.names = c(NA, 
-144L), class = "data.frame")

Ниже приведена версия 1 - опубликовано 25.09.18. Буду признателен, если кто-нибудь сможет взглянуть на пользовательский интерфейс икод сервера, который я собрал и помог мне решить проблему (я также был бы признателен за альтернативные подходы): 

library(shiny)
library(doBy)

# Define UI for data upload app ----
ui <- fluidPage(

  # App title ----
  titlePanel("Uploading Files"),

  # Sidebar layout with input and output definitions ----
  sidebarLayout(

    # Sidebar panel for inputs ----
    sidebarPanel(

      # Input: Select a file ----
      fileInput("file1", "Choose CSV File",
                multiple = FALSE,
                accept = c("text/csv",
                           "text/comma-separated-values,text/plain",
                           ".csv")),

      # Selection for the drop down menus given the colnames 
      uiOutput('phenotype'), 
      uiOutput('treatment'), 
      uiOutput('factor1'), 
      uiOutput('factor2'),  

      # Horizontal line ----
      tags$hr(),

      # Input: Checkbox if file has header ----
      checkboxInput("header", "Header", TRUE),

      # Input: Select separator ----
      radioButtons("sep", "Separator",
                   choices = c(Comma = ",",
                               Semicolon = ";",
                               Tab = "\t"),
                   selected = ","),

      # Horizontal line ----
      tags$hr(),

      # Input: Select number of rows to display ----
      radioButtons("disp", "Display",
                   choices = c(Head = "head",
                               All = "all"),
                   selected = "head")#,

      #selectInput("phenotype","Phenotype:", choices = NULL),
      #selectInput("treatment","Treatment:", choices = NULL)


  ),

    # Main panel for displaying outputs ----
    mainPanel(
      img(src = "Logo.jpeg", height = 150, width = 150),
      # Output: Data file ----
      tableOutput("contents"), # in order to view the header
      verbatimTextOutput('summary'), # summary for uploaded DF
      verbatimTextOutput('BasicStats')
    )
  )
  )

# Define server logic to read selected file ----
server <- function(input, output, session) {

  # print out the summary ----
  # define the dataset that you will get a summary output for 
    myData <- reactive({
    inFile <- input$file1
    if (is.null(inFile)) return(NULL)
    data <- read.csv(inFile$datapath, header = TRUE)
    data
  }) 

########## Attempt to make a vector to output basic stats ###########  
    bs <- reactive({
        inFile <- input$file1
        x <- inFile$phenotype
        trt <- as.factor(inFile$treatment)
        factor1 <- as.factor(inFile$factor1)
        factor2 <- as.factor(inFile$factor2)
        #
        # make a new data frame with the information needed to get the 
          summary stats
        newDF <- data.frame(x,trt,factor1, factor2)
        newDF <- newDF[complete.cases(newDF),]
        result <- summaryBy( x ~ trt + factor1 + factor2, 
                  FUN = c(mean, sd, length), data = newDF)
        result$x.se <- result$x.sd/sqrt(result$x.length)
    })
###################### Table output info #########################
  output$summary <- renderPrint({
    summary(myData())
    })

  output$BasicStats <- renderPrint({
    bs()
  })

######## Make Drop down menus of header contents###############      
  output$phenotype <- renderUI({
    df <- myData()
    selectInput("phenotype", "Phenotype:",c("",names(df)))
  })

  output$treatment <- renderUI({
    df <- myData()
    selectInput("treatment", "Treatment:",c("",names(df)))
  })

  output$factor1 <- renderUI({
    df <- myData()
    selectInput("factor1", "Factor_1:",c("",names(df)))
  })

  output$factor2 <- renderUI({
    df <- myData()
    selectInput("factor2", "Factor_2:",c("",names(df)))
  })

  #output$factor3 <- renderUI({
  #  df <- myData()
   # selectInput("factor3", "Factor_3:",c("",names(df)))
 # })

 ##############To view header###########################  
  output$contents <- renderTable({

    # input$file1 will be NULL initially. After the user selects
    # and uploads a file, head of that data file by default,
    # or all rows if selected, will be shown.

    req(input$file1)

    # when reading semicolon separated files,
    # having a comma separator causes `read.csv` to error
    tryCatch(
      {
        df <- read.csv(input$file1$datapath,
                       header = input$header,
                       sep = input$sep,
                       quote = input$quote)
      },
      error = function(e) {
        # return a safeError if a parsing error occurs
        stop(safeError(e))
      }
    )

    if(input$disp == "head") {
      return(head(df))
    }
    else {
      return(df)
    }

  })
}
###########################################################################
# Create Shiny app ----
shinyApp(ui, server)
#########################################################################

Версия 2 обновлена ​​9/27/18: 

library(shiny)
library(doBy)
library(dplyr)

# Define UI for data upload app ----
ui <- fluidPage(

  # App title ----
  titlePanel("Uploading Files"),

  # Sidebar layout with input and output definitions ----
  sidebarLayout(

    # Sidebar panel for inputs ----
    sidebarPanel(

      # Input: Select a file ----
      fileInput("file1", "Choose CSV File",
                multiple = FALSE,
                accept = c("text/csv",
                           "text/comma-separated-values,text/plain",
                           ".csv")),

      # Selection for the drop down menus given the colnames 
      uiOutput('phenotype'), 
      uiOutput('treatment'), 
      uiOutput('factor1'), 
      uiOutput('factor2'), 
      #uiOutput('factor3'), 

      # Horizontal line ----
      tags$hr(),

      # Input: Checkbox if file has header ----
      checkboxInput("header", "Header", TRUE),

      # Input: Select separator ----
      radioButtons("sep", "Separator",
                   choices = c(Comma = ",",
                               Semicolon = ";",
                               Tab = "\t"),
                   selected = ","),

      # Horizontal line ----
      tags$hr(),

      # Input: Select number of rows to display ----
      radioButtons("disp", "Display",
                   choices = c(Head = "head",
                               All = "all"),
                   selected = "head")#,

      #selectInput("phenotype","Phenotype:", choices = NULL),
      #selectInput("treatment","Treatment:", choices = NULL)


  ),

    # Main panel for displaying outputs ----
    mainPanel(
      img(src = "joynLogo.jpeg", height = 150, width = 150),
      # Output: Data file ----
      tableOutput("contents"), # in order to view the header
      #tableOutput("BasicStats"),
      verbatimTextOutput('summary'), # summary statistics for data frame as a whole
      tableOutput('BasicStats')
    )
  )
  )


# Define server logic to read selected file ----
server <- function(input, output, session) {

  # print out the summary ----
  # define the dataset that you will get a summary output for 
    myData <- reactive({
              inFile <- input$file1
              if (is.null(inFile)) return(NULL)
              data <- read.csv(inFile$datapath, header = TRUE)
              data
  }) 


########## Attempt to make a vector to output basic stats ###########  
    # 9/27 I modified this code to subset the data given the selected 
    # variables
    # this code gives me the following error: "undefined columns 
    # selected". I suppose this gets me close, but no cigar! 

    #bs <- observeEvent(input$file1, { 
    bs <- reactive({
        req(input$file1)
        inFile <- input$file1
        x <- input$phenotype
        trt <- as.factor(input$treatment)
        factor1 <- as.factor(input$factor1)
        factor2 <- as.factor(input$factor2)
        #
        # make a new data frame with the information needed to get the summary stats
        subsetBy <- c(x,trt,factor1, factor2)
        newDF <- inFile[,subsetBy]
        newDF <- as.data.frame(newDF[complete.cases(newDF),])
        result <- summaryBy( x ~ trt + factor1 + factor2, FUN = c(mean, sd, length), data = newDF)
        result$x.se <- result$x.sd/sqrt(result$x.length)
        return(result)
    })

    # bs <- reactive({
    #   req(input$file1)
    #   inFile <- input$file1
    #   x <- input$phenotype
    #   trt <- as.factor(input$treatment)
    #   factor1 <- as.factor(input$factor1)
    #   factor2 <- as.factor(input$factor2)
    #   #newDF <-inFile[,c("x","trt","factor1","factor2")]
    #   #newDF <- select(inFile, input$x, as.factor(input$trt), as.factor(input$factor1), as.factor(input$factor2))
    #   newDF <- select(inFile, x, trt, factor1, factor2)
    #   #
    #   # make a new data frame with the information needed to get the summary stats
    #   #newDF <- data.frame(x,trt,factor1, factor2)
    #   newDF <- as.data.frame(newDF[complete.cases(newDF),])
    #   result <- summaryBy( x ~ trt + factor1 + factor2, FUN = c(mean, sd, length), data = newDF)
    #   result$x.se <- result$x.sd/sqrt(result$x.length)
    #   return(result)
    # })
###################### Table output info #########################
  output$summary <- renderPrint({
    summary(myData())
    })

  output$BasicStats <- renderTable(bs())

######### Make Drop down menus of header contents###############      
  output$phenotype <- renderUI({
    df <- myData()
    selectInput("phenotype", "Phenotype:",c("",names(df)))
  })

  output$treatment <- renderUI({
    df <- myData()
    selectInput("treatment", "Treatment:",c("",names(df)))
  })

  output$factor1 <- renderUI({
    df <- myData()
    selectInput("factor1", "Factor_1:",c("",names(df)))
  })

  output$factor2 <- renderUI({
    df <- myData()
    selectInput("factor2", "Factor_2:",c("",names(df)))
  })

  #output$factor3 <- renderUI({
  #  df <- myData()
   # selectInput("factor3", "Factor_3:",c("",names(df)))
 # })

 #########To view header#####################  
  output$contents <- renderTable({

    # input$file1 will be NULL initially. After the user selects
    # and uploads a file, head of that data file by default,
    # or all rows if selected, will be shown.

    req(input$file1)

    # when reading semicolon separated files,
    # having a comma separator causes `read.csv` to error
    tryCatch(
      {
        df <- read.csv(input$file1$datapath,
                       header = input$header,
                       sep = input$sep,
                       quote = input$quote)
      },
      error = function(e) {
        # return a safeError if a parsing error occurs
        stop(safeError(e))
      }
    )

    if(input$disp == "head") {
      return(head(df))
    }
    else {
      return(df)
    }

  })
}
###########################################################################
# Create Shiny app ----
shinyApp(ui, server)

1 Ответ

0 голосов
/ 28 сентября 2018

Вы получили это по большей части.Вам нужно использовать myData() вместо input$file1 для создания данных для сводной статистики.Измените bs() на следующее: 

bs <- reactive({

    # Require all 4 input parameters be selected by the user
    req(input$phenotype, input$treatment, input$factor1, input$factor2)

    # Make a new data frame with the information needed to get the summary stats
    d <- data.frame(myData()[, input$phenotype], as.factor(myData()[, input$treatment]),
                    as.factor(myData()[, input$factor1]), as.factor(myData()[, input$factor2]))

    # Keep only non NA cases
    newDF <- as.data.frame(d[complete.cases(d),])

    # Rename columns
    colnames(newDF) <- c("x", "trt", "factor1", "factor2")

    # Extract summary stats
    result <- summaryBy( x ~ trt + factor1 + factor2, FUN = c(mean, sd, length), data = newDF)
    result$x.se <- result$x.sd/sqrt(result$x.length)

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

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

...