I am creating a shiny app for a sport tournament. I have a list of players as input. Using the roundrubin algorithm (https://en.wikipedia.org/wiki/Round-robin_tournament) I create a list a matches by round. The code for the algorithm is displayed here. (The "wavethresh" package is needed for the guyroot function.)
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)
}
In my shiny app I am able to display the list of matches to be done along with textinput where the user can write the score. A table with the ranking being evaluated is printed.
My problem is that I have an error before the table is actually printed.
Here is my code for the app.
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)
})
})
}
}
)
The two tuned functions "textInputLeft" and "textInputRight" are displayed here.
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;",...))
}
It is for now not critical for my app since the table is printed anyway. But when I try to have the name of the players given by the user in textInput the table is not printed at all.
I cannot find the reason of this error happening. I do not understand what is wrong in the way I create the table in the renderTable.
Do you have any suggestions?
My session info:
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
Edit 1
The table is updated without any error with this script.
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)
}
)
The difference is that the table is in a tabPanel and not in the sidebar.
