表对Shiny / R中的动态输入作出反应

Question

我正在为体育比赛创建一个闪亮的应用程序。我有一个球员名单作为输入。使用Roundrubin算法（https://en.wikipedia.org/wiki/Round-robin_tournament），我创建了一个列表，并逐个匹配。该算法的代码显示在此处。 （Guyroot功能需要“ wavethresh”软件包。）

library(wavethresh)
roundrubin <- function(listplayer){
  n <- length(listplayer)
  if(n%%2==1){
    listplayer <- append(listplayer,"dummy")
    n <- n+1
  }
  listround <- list()
  round1 <- list()
  for(i in 1:(n/2)){
    round1[[i]] <- c(listplayer[i],listplayer[n+1-i])
  }
  ind <- which(!is.na(lapply(1:(n/2),function(i){
    match("dummy",round1[[i]])})))
  if(length(ind)!=0){
    round1 <- round1[-ind]
  }
  listround[[1]] <- round1
  for(i in 2:n-1){
    listplayer <- append(guyrot(listplayer[-1],1),listplayer[1],after=0)
    listround[[i]] <- list()
    for(j in 1:(n/2)){
      listround[[i]][[j]] <- c(listplayer[j],listplayer[n+1-j])
    }
    ind <- which(!is.na(lapply(1:(n/2),function(k){
      match("dummy",listround[[i]][[k]])})))
    if(length(ind)!=0){
      listround[[i]] <- listround[[i]][-ind]
    }
  }
  return(listround)
}

在我闪亮的应用程序中，我能够显示要进行的比赛列表以及文本输入，用户可以在其中输入分数。将打印出具有正在评估的排名的表。

我的问题是在实际打印表格之前出现错误。

这是我的应用代码。

library(shiny)
library(dplyr)

listplayer <- LETTERS[1:8]
listround <- roundrubin(listplayer)

shinyApp(
  ui=fluidPage(
    titlePanel("title"),
    sidebarLayout(
      sidebarPanel(uiOutput("scoreboard")),
      mainPanel(uiOutput("round"))
    )
  ),
  server=function(input, output){

    lengthlistplayer <- length(listplayer)
    lengthlistround <- length(listround)
    lengthround <- length(listround[[1]])

    output$scoreboard <- renderTable({
      player <- vector("list",lengthlistplayer)
      for(i in 1:lengthlistplayer){
        player[[i]] <- data.frame("point"=0,"diff"=0)
        for(j in 1:lengthlistround){
          k <- 1
          while(k<=lengthround){
            playerinput1 <- listround[[j]][[k]][1]
            playerinput2 <- listround[[j]][[k]][2]
            if(playerinput1==listplayer[i]){
              winner <- ifelse(as.numeric(input[[paste(playerinput1,j,sep="")]])>
                                 as.numeric(input[[paste(playerinput2,j,sep="")]]),
                               TRUE,FALSE)
              diff <- as.numeric(input[[paste(playerinput1,j,sep="")]])-
                as.numeric(input[[paste(playerinput2,j,sep="")]])
              point <- ifelse(winner,3,0)
              value <- c(point,diff)
              player[[i]] <- player[[i]] + value
              k <- lengthround+1
            } else if(playerinput2==listplayer[i]){
              winner <- ifelse(as.numeric(input[[paste(playerinput2,j,sep="")]])>
                                 as.numeric(input[[paste(playerinput1,j,sep="")]]),
                               TRUE,FALSE)
              diff <- as.numeric(input[[paste(playerinput2,j,sep="")]])-
                as.numeric(input[[paste(playerinput1,j,sep="")]])
              point <- ifelse(winner,3,0)
              value <- c(point,diff)
              player[[i]] <- player[[i]] + value
              k <- lengthround+1
            } else {
              k <- k+1
            }
          }
        }
      }
      scoreboard <- do.call(rbind,player)
      scoreboard <- cbind("Player"=listplayer,scoreboard)
      scoreboard <- scoreboard %>% arrange(desc(point),desc(diff))
      scoreboard
    },digits=0,include.rownames=FALSE)

    output$round <- renderUI({
      listobject <- lapply(1:lengthlistround,
                           function(i){
                             roundoutput <- paste("roundoutput",i,sep="")
                             fluidRow(uiOutput(roundoutput),
                                      hr())
                           })
      listobject <- lapply(split(listobject,
                                 (seq.int(lengthlistround)-1)%/%2),function(x){ 
                                   column(12/2, x) 
                                 })
      do.call(tagList,listobject)
    })

    for(i in 1:lengthlistround){
      local({
        my_i <- i
        list <- listround[[my_i]]
        roundoutput <- paste("roundoutput",my_i,sep="")
        output[[roundoutput]] <- renderUI({
          listobject <- lapply(1:lengthround,function(i){
            fluidRow(tags$style("display: inline-block;"),
                     textInputLeft(inputId=paste(list[[i]][1],my_i,sep=""),
                                   label=list[[i]][1],value=0),
                     textInputRight(inputId=paste(list[[i]][2],my_i,sep=""),
                                    label=list[[i]][2],value=0)
            )
          })
          do.call(tagList,listobject)
        })
      })
    }

  }
)

这里显示了两个调整的功能“ textInputLeft”和“ textInputRight”。

textInputLeft<-function (inputId, label, value = "",...){
  div(style="display:inline-block;",
      tags$label(label, `for` = inputId,style="text-align:right; width:80px"),
      tags$input(id=inputId, type="text",size=2, value=value,
                 style="text-align:center;",...))
}

textInputRight<-function (inputId, label, value = "",...){
  div(style="display:inline-block",
      tags$label(label, `for` = inputId,style="float:right; text-align:left;"),
      tags$input(id=inputId, type="text",size=2, value=value,
                 style="text-align:center;",...))
}

由于我的应用程序仍然可以打印表格，因此对于我的应用程序而言，这并不重要。但是，当我尝试在textInput中输入用户给出的玩家名称时，根本不会打印该表。

我找不到发生此错误的原因。我不明白在renderTable中创建表的方式有什么问题。

您有什么建议吗？

我的会话信息：

R version 3.2.4 Revised (2016-03-16 r70336)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 7 x64 (build 7601) Service Pack 1

locale:
[1] LC_COLLATE=French_France.1252  LC_CTYPE=French_France.1252   
[3] LC_MONETARY=French_France.1252 LC_NUMERIC=C                  
[5] LC_TIME=French_France.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] dplyr_0.4.3      shiny_0.13.2     wavethresh_4.6.6 MASS_7.3-45

编辑1

此表已更新，此脚本没有任何错误。

shinyApp(
  ui=fluidPage(
    uiOutput("output")),
  server=function(input, output){

    lengthlistnom <- length(listnom)
    lengthlistround <- length(listround)
    lengthround <- length(listround[[1]])

    output$output <- renderUI({
      tabsetPanel(
        tabPanel("round",uiOutput("round")),
        tabPanel("score",uiOutput("scoreboard"))
      )
    })

    output$round <- renderUI({
      listobject <- lapply(1:lengthlistround,
                           function(i){
                             roundoutput <- paste("roundoutput",i,sep="")
                             fluidRow(uiOutput(roundoutput),
                                      hr())
                           })
      listobject <- lapply(split(listobject,
                                 (seq.int(lengthlistround)-1)%/%2),function(x){ 
                                   column(12/2, x) 
                                 })
      do.call(tagList,listobject)
    })

    for(i in 1:lengthlistround){
      local({
        my_i <- i
        list <- listround[[my_i]]
        roundoutput <- paste("roundoutput",my_i,sep="")
        output[[roundoutput]] <- renderUI({
          listobject <- lapply(1:lengthround,function(i){
            fluidRow(tags$style("display: inline-block;"),
                     textInputLeft(inputId=paste(list[[i]][1],my_i,sep=""),
                                   label=list[[i]][1],value=0),
                     textInputRight(inputId=paste(list[[i]][2],my_i,sep=""),
                                    label=list[[i]][2],value=0)
            )
          })
          do.call(tagList,listobject)
        })
      })
    }

    output$scoreboard <- renderTable({
      player <- vector("list",lengthlistround)
      for(i in 1:lengthlistnom){
        player[[i]] <- data.frame("point"=0,"diff"=0)
        for(j in 1:lengthlistround){
          k <- 1
          while(k<=lengthround){
            nominput1 <- listround[[j]][[k]][1]
            nominput2 <- listround[[j]][[k]][2]
            if(nominput1==listnom[i]){
              winner <- ifelse(as.numeric(input[[paste(nominput1,j,sep="")]])>
                                 as.numeric(input[[paste(nominput2,j,sep="")]]),
                               TRUE,FALSE)
              diff <- as.numeric(input[[paste(nominput1,j,sep="")]])-
                as.numeric(input[[paste(nominput2,j,sep="")]])
              point <- ifelse(winner,3,0)
              value <- c(point,diff)
              player[[i]] <- player[[i]] + value
              k <- lengthround+1
            } else if(nominput2==listnom[i]){
              winner <- ifelse(as.numeric(input[[paste(nominput2,j,sep="")]])>
                                 as.numeric(input[[paste(nominput1,j,sep="")]]),
                               TRUE,FALSE)
              diff <- as.numeric(input[[paste(nominput2,j,sep="")]])-
                as.numeric(input[[paste(nominput1,j,sep="")]])
              point <- ifelse(winner,3,0)
              value <- c(point,diff)
              player[[i]] <- player[[i]] + value
              k <- lengthround+1
            } else {
              k <- k+1
            }
          }
        }
      }
      scoreboard <- do.call(rbind,player)
      scoreboard <- cbind("Player"=listnom,scoreboard)
      scoreboard <- scoreboard %>% arrange(desc(point),desc(diff))
      scoreboard
    },digits=0,include.rownames=FALSE)

  }
)

区别在于该表位于tabPanel中，而不位于侧边栏中。

Answer 1

确实是很老的问题，但我还是会回答。

问题是，在首次调用renderTable时，尚未创建输入。正是出于这个目的，可以使用req（根据需要）。因此，您需要将对input[[<whatever>]]的第一个调用包装在req中，以确保它不是NULL。在您当前的实现中，输入为NULL，并且ifs返回logical(0)，而不是TRUE或FALSE

output$scoreboard <- renderTable({
      player <- vector("list",lengthlistplayer)
      for(i in 1:lengthlistplayer){
        player[[i]] <- data.frame("point"=0,"diff"=0)
        for(j in 1:lengthlistround){
          k <- 1
          while(k<=lengthround){
            playerinput1 <- listround[[j]][[k]][1]
            playerinput2 <- listround[[j]][[k]][2]
            score1 <- as.numeric(req(input[[paste(playerinput1,j,sep="")]]))
            score2 <- as.numeric(req(input[[paste(playerinput2,j,sep="")]]))

            if(playerinput1==listplayer[i]){
              winner <- score1 > score2
              diff <- score1 - score2
              point <- ifelse(winner,3,0)
              value <- c(point, diff)
              player[[i]] <- player[[i]] + value
              k <- lengthround+1
            } else if(playerinput2==listplayer[i]){
              winner <- score2 > score1
              diff <- score2 - score1
              point <- ifelse(winner,3,0)
              value <- c(point,diff)
              player[[i]] <- player[[i]] + value
              k <- lengthround+1
            } else {
              k <- k+1
            }
          }
        }
      }
      scoreboard <- do.call(rbind,player)
      scoreboard <- cbind("Player"=listplayer,scoreboard)
      scoreboard <- scoreboard %>% arrange(desc(point),desc(diff))
      scoreboard
    },digits=0,include.rownames=FALSE)

应该做到这一点。

---

注意。您的代码可以简化，因为ifs非常对称。