Skip to content

Commit d43015b

Browse files
phgrosjeanphgrosjean
committed
B07Ca_multi challenge Shiny app added
1 parent 8f32a85 commit d43015b

File tree

1 file changed

+208
-0
lines changed
  • inst/shiny/B07Ca_multi

1 file changed

+208
-0
lines changed

‎inst/shiny/B07Ca_multi/app.R

Lines changed: 208 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,208 @@
1+
# Input solution for the challenge and get ranking
2+
# ================================================
3+
# Note: the shared folder is created like this using SSH onto the server
4+
# cd /data1
5+
# sudo mkdir B07_challenge
6+
# sudo chown rstudio-connect: B07_challenge
7+
8+
# We also need flipdown from:
9+
#remotes::install_github("feddelegrand7/flipdownr")
10+
11+
library(data.io)
12+
library(RSQLite)
13+
library(flipdownr)
14+
15+
# Indicate title and deadline here
16+
title <- "Challenge analyses multivariées"
17+
# Note: define real deadline in environment variables in RStudio Connect
18+
deadline <- Sys.getenv("CHALLENGE_DEADLINE",
19+
unset = "2024-02-23 00:00:00")
20+
21+
# Read data from the SQLite database
22+
dir <- "/data1/B07_challenge"
23+
if (!file.exists(dir))
24+
dir <- "~/Desktop/B07_challenge" # Alternate dir for local tests
25+
database <- file.path(dir, "multi.sqlite")
26+
table <- "multi"
27+
28+
# Is the countdown over?
29+
is_done <- function()
30+
as.POSIXct(deadline) < Sys.time()
31+
32+
# If the time difference between current date and countdown
33+
# is more than 100 days, we consider the next challenge has not started yet
34+
not_started_yet <- function()
35+
difftime(Sys.time(), as.POSIXct(deadline), units = "days") > 100
36+
37+
# The function that calculates score and returns also a message
38+
score_multi <- function(x) {
39+
if (!is.numeric(x) | length(x) != 10)
40+
return(structure(NA,
41+
message = "Le fichier doit contenir un vecteur numérique de longueur 10. Corrigez et resoumettez !"))
42+
x[x < 0] <- 0
43+
x[x > 1] <- 1
44+
#if (any(x < 0) | any(x > 1))
45+
# return(structure(NA,
46+
# message = paste("Le r\u00e9sultat doit contenir des valeurs entre 0 et 1 uniquement. Corrigez et resoumettez !")))
47+
score <- as.numeric(sum(x)) # Score is the sum of all the 20 individual scores for the different charts
48+
structure(score,
49+
message = paste0("Votre proposition est accept\u00e9e. Son score est de ",
50+
round(score, 1), "."))
51+
}
52+
53+
# Manage results into the SQLite database
54+
empty_data <- function()
55+
data.frame(project = character(0), model = character(0),
56+
date = as.POSIXct(character(0)), score = numeric(0))
57+
58+
save_data <- function(data) {
59+
# Connect to the database
60+
db <- dbConnect(SQLite(), database)
61+
# Make sure table exists in the database
62+
try(dbWriteTable(db, table, empty_data()), silent = TRUE)
63+
# Construct the update query by looping over the data fields
64+
query <- sprintf(
65+
"INSERT INTO %s (%s) VALUES ('%s')",
66+
table,
67+
paste(names(data), collapse = ", "),
68+
paste(data, collapse = "', '")
69+
)
70+
# Submit the update query and disconnect
71+
dbSendStatement(db, query)
72+
dbDisconnect(db)
73+
}
74+
75+
load_data <- function() {
76+
# Connect to the database
77+
db <- dbConnect(SQLite(), database)
78+
# Construct the fetching query
79+
query <- sprintf("SELECT * FROM %s", table)
80+
# Submit the fetch query and disconnect
81+
data <- try(dbGetQuery(db, query), silent = TRUE)
82+
dbDisconnect(db)
83+
if (inherits(data, "try-error")) {
84+
empty_data()
85+
} else {
86+
data
87+
}
88+
}
89+
90+
ui <- fluidPage(
91+
titlePanel(title),
92+
93+
sidebarLayout(
94+
sidebarPanel(
95+
fileInput("file", "Votre proposition (fichier RDS)", accept = ".rds"),
96+
textOutput("message"),
97+
hr(),
98+
actionButton("refresh", "Actualiser le classement")
99+
),
100+
mainPanel(
101+
h3("Temps restant pour le challenge :"),
102+
flipdown(downto = deadline, id = "csfrench", theme = "dark",
103+
headings = c("jours", "heures", "minutes", "secondes")),
104+
hr(),
105+
h3("Classement :"),
106+
tableOutput("ranking")
107+
)
108+
)
109+
)
110+
111+
server <- function(input, output) {
112+
output$message <- renderText({
113+
file <- input$file
114+
ext <- tools::file_ext(file$datapath)
115+
req(file)
116+
validate(need(ext == "rds", "Vous devez indiquer un fichier RDS"))
117+
# Check that there is still time remaining
118+
if (is_done()) {
119+
if (not_started_yet()) {
120+
"Ce challenge n'a pas encore commenc\u00e9, attendez le d\u00e9part !"
121+
} else {
122+
"Ce challenge est fini, vous ne pouvez plus soumettre de proposition !"
123+
}
124+
} else {
125+
# Check that filename is correct (repos__model.rds)
126+
if (!grepl("^.+__.+\\.rds", file$name)) {
127+
"Le nom de votre fichier est incorrect : il faut <repos>__<iteration>.rds. Corrigez et resoumettez."
128+
} else {
129+
#solution <- data.io::read$rds(file$datapath)$value
130+
solution <- data.io::read$rds(file$datapath)
131+
# Check if a model of the same name already exists
132+
name <- file$name
133+
project <- sub("(^.+)__.+$", "\\1", name)
134+
model <- sub(("^.+__(.+)\\.rds$"), "\\1", name)
135+
ranking <- load_data()
136+
if (NROW(ranking[ranking$project == project & ranking$model == model, ])) {
137+
"Cette it\u00e9ration existe dans le classement, recompilez le document avant de soumettre une nouvelle variante."
138+
} else {
139+
attr(score_multi(solution), "message")
140+
}
141+
}
142+
}
143+
})
144+
145+
output$ranking <- renderTable({
146+
input$refresh # Trigger this code when the refresh button is clicked
147+
file <- input$file
148+
if (!is.null(file$datapath) && grepl("^.+__.+\\.rds", file$name) &&
149+
!is_done()) {
150+
#solution <- data.io::read$rds(file$datapath)$value
151+
solution <- data.io::read$rds(file$datapath)
152+
message("data read")
153+
score <- score_multi(solution)
154+
message("score is ", score)
155+
name <- file$name
156+
message("name is ", name)
157+
project <- sub("(^.+)__.+$", "\\1", name)
158+
model <- sub(("^.+__(.+)\\.rds$"), "\\1", name)
159+
if (project == name) {
160+
message("Wrong name!")
161+
score <- NA
162+
}
163+
} else {
164+
score <- NA
165+
}
166+
ranking <- load_data()
167+
message("Data loaded")
168+
# Record an entry in the mongoDB database
169+
# But we need the login of *all* members of the team, and we don't have them
170+
# right now => leave this to a post-process task instead!
171+
if (!is.na(score)) {
172+
# Check if it is not submitted yet
173+
if (!NROW(ranking[ranking$project == project & ranking$model == model, ])) {
174+
save_data(list(
175+
project = project, model = model, date = Sys.time(),
176+
score = as.numeric(score)
177+
))
178+
# Reload the full dataset
179+
ranking <- load_data()
180+
}
181+
}
182+
# Rework the ranking table
183+
if (NROW(ranking)) {
184+
ranking <- ranking[order(-ranking$score, as.numeric(ranking$date)), ]
185+
ranking$date <- as.POSIXct(ranking$date, origin = "1960-01-01")
186+
ranking$date <- format(ranking$date, "%Y-%m-%d %H:%M:%S")
187+
}
188+
message("Date reworked")
189+
# Add a column with medals for the three first results
190+
n <- NROW(ranking)
191+
if (n == 0) {
192+
medals <- character(0)
193+
} else {
194+
medals <- c("\U1F947", "\U1F948", "\U1F949")
195+
if (n < 4) {
196+
medals <- medals[1:n]
197+
} else {
198+
medals <- c(medals, rep("", n - 3))
199+
}
200+
}
201+
ranking <- data.frame(rank = medals, ranking)
202+
message("Ranking done")
203+
names(ranking) <- c("", "Projet", "It\u00e9ration", "Date", "Score")
204+
ranking
205+
})
206+
}
207+
208+
shinyApp(ui, server)

0 commit comments

Comments
 (0)