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

时间:2016-06-02 16:09:41

标签: shiny

我正在为体育比赛创建一个闪亮的应用程序。我有一个玩家列表作为输入。使用roundrubin算法(https://en.wikipedia.org/wiki/Round-robin_tournament)我创建一个圆形匹配列表。此处显示算法的代码。 (对于guyroot函数,需要" 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)
}

在我的闪亮应用程序中,我能够显示要与textinput一起完成的匹配列表,用户可以在其中编写分数。打印具有要评估的排名的表。

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

以下是该应用的代码。

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

  }
)

两个调优函数&#34; textInputLeft&#34;和&#34; textInputRight&#34;在这里显示。

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中,而不在侧栏中。

1 个答案:

答案 0 :(得分:0)

确实是一个很老的问题,但我还是会回答。

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

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是非常对称的。