WIP

.github/workflows/playwright.yml → .github/workflows/tests.yml

@@ -3,6 +3,16 @@ on:
   pull_request:
   push:
 jobs:
+  unit_tests:
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v4
+    - uses: cachix/install-nix-action@v25
+      with:
+        github_access_token: ${{ secrets.GITHUB_TOKEN }}
+    - uses: DeterminateSystems/magic-nix-cache-action@v2
+    - run: nix develop -c -- nix run .\#unit_tests
+
   ui_test:
     runs-on: ubuntu-latest
     steps:

flake.nix

@@ -98,6 +98,18 @@
             program = "${test_ui}/bin/test_ui";
           };
 
+          unit_tests = let
+            unit_tests = pkgs.writeShellApplication {
+              name = "unit_tests";
+              text = ''
+                Rscript --vanilla ${./tests/testthat.R}
+              '';
+            };
+          in {
+            type = "app";
+            program = "${unit_tests}/bin/unit_tests";
+          };
+
           initialise-data = let
             initialise-data = pkgs.writeShellApplication {
               name = "initialise-data";

plantbreedgame_setup.Rmd

@@ -1522,11 +1522,11 @@ if (tbl %in% dbListTables(db)) {
 }
 query <- paste0(
   "CREATE TABLE ", tbl,
-  " (num INT",
+  " (id INT",
   ", start TEXT",
   ", end TEXT",
-  ", year_time INT)"
-) # in minutes
+  ", year_time INT", # in minute
+  ", time_zone TEXT)")
 res <- dbExecute(conn = db, query)
 ```
 
@@ -1537,23 +1537,26 @@ query <- paste0(
   " ('1'",
   ", '2018-02-15 09:00:00'",
   ", '2018-02-15 12:00:00'",
-  ", '60')"
+  ", '60'",
+  ", 'UTC')"
 )
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
   " ('2'",
   ", '2018-02-15 14:00:00'",
   ", '2018-02-15 17:00:00'",
-  ", '60')"
+  ", '60'",
+  ", 'UTC')"
 )
 res <- dbExecute(conn = db, query)
 query <- paste0(
   "INSERT INTO ", tbl, " VALUES",
   " ('3'",
   ", '2018-02-16 09:00:00'",
   ", '2018-02-16 11:40:00'",
-  ", '40')"
+  ", '40'",
+  ", 'UTC')"
 )
 res <- dbExecute(conn = db, query)
 ```

server.R

@@ -28,7 +28,7 @@ shinyServer(function(input, output, session) {
     ## send a "tic" message to the client to get information about the server status (busy or not)
     invalidateLater(250)
     session$sendCustomMessage("serverTic", "tic")
-    getGameTime(setup)
+    getGameTime()
   })
 
   values <- reactiveValues(

src/fun/func_dbRequests.R

@@ -39,6 +39,21 @@ db_execute_request <- function(query, dbname = DATA_DB) {
   })
   return(TRUE)
 }
+db_execute_request_safe <- function(query, dbname = DATA_DB, ...) {
+  conn <- dbConnect(SQLite(), dbname = dbname)
+  tryCatch({
+    safe_query <- DBI::sqlInterpolate(conn, query, ...)
+    dbExecute(conn = conn, safe_query)
+  }, error = function(err) {
+    stop(err)
+  }, finally = {
+    dbDisconnect(conn)
+  })
+  return(TRUE)
+
+
+}
+
 
 db_list_tables <- function(dbname = DATA_DB) {
   conn <- dbConnect(SQLite(), dbname = dbname)
@@ -264,3 +279,34 @@ clean_data_root <- function(data_root = DATA_ROOT) {
     stop(paste("can't remove", data_root, "folder not empty."))
   }
 }
+
+
+getGameSessions <- function() {
+  query <- paste0("SELECT * FROM sessions")
+  res <- db_get_request(query)
+  return(res)
+}
+
+addGameSession <- function(id, startDate, endDate, yearTime, timeZone) {
+
+    query <- paste0(
+      "INSERT INTO sessions", " VALUES",
+      # " ('", id, "','", startDate, "','", endDate, "','", yearTime, "','", timeZone,"')"
+      "(?id,?startDate,?endDate,?yearTime,?timeZone)"
+    )
+  db_execute_request_safe(query,
+    id = id,
+    startDate = startDate,
+    endDate = endDate,
+    yearTime = yearTime,
+    timeZone = timeZone
+  )
+
+
+}
+
+delGameSession <- function(id) {
+  query <- "DELETE FROM sessions WHERE id = ?id"
+  db_execute_request_safe(query, id = id)
+}
+

src/fun/func_time.R

@@ -22,49 +22,61 @@
 
 
 
-getGameTime <- function(setup) {
-  ## function to convert real time into game time
-
-  # get current time
-  now <- Sys.time()
+getGameTime <- function(time_irl = Sys.time(),
+                        gameSessions = getGameSessions(),
+                        first_year = getBreedingGameConstants()["first.year"]) {
 
+  first_game_day <- strptime(paste0(first_year, "-01-01"), format = "%Y-%m-%d")
 
-  ## get sessions informations
-  query <- paste0("SELECT * FROM sessions")
-  res <- db_get_request(query)
 
-  res$start <- strptime(res$start, format = "%Y-%m-%d %H:%M")
-  res$end <- strptime(res$end, format = "%Y-%m-%d %H:%M")
-  res <- res[order(res$start), ]
+  if (nrow(gameSessions) == 0) {
+    return(first_game_day)
+  }
 
+  # get current time
+  gameSessions$start <- apply(gameSessions, 1, function(line){
+    lubridate::parse_date_time(line["start"], orders = "%Y-%m-%d %H:%M:%S", tz = line["time_zone"])
+  }, simplify = TRUE)
+  gameSessions$end <- apply(gameSessions, 1, function(line){
+    lubridate::parse_date_time(line["end"], orders = "%Y-%m-%d %H:%M:%S", tz = line["time_zone"])
+  }, simplify = TRUE)
+  gameSessions$order <- order(gameSessions$start)
 
+  # sort gameSession in ascending order
+  gameSessions <- gameSessions[gameSessions$order, ]
 
   ## get the current session
-  currentSesion <- which(now >= res$start & now < res$end)
-  if (length(currentSesion) == 0) {
-    ## out of game session
-    previousSession <- which(now >= res$start)
-    currentSesion <- max(previousSession)
-    if (length(previousSession) != 0) {
-      now <- res$end[max(previousSession)] # end date of the laste session
-    } else {
-      return(strptime("2015-01-01", format = "%Y-%m-%d"))
+
+  currentSesion <- gameSessions[which(time_irl >= gameSessions$start & time_irl < gameSessions$end), ]
+  if (nrow(currentSesion) == 0) {
+    # we are between 2 sessions
+    previousSessions <- gameSessions[which(time_irl >= gameSessions$start),]
+
+    if (nrow(previousSessions) == 0) {
+      # no previous session means the game didn't start yet
+      return(first_game_day)
     }
-  }
 
+    # Then we set the "current time" at the end of the previous session so that
+    # the game time do not pass.
+    previousSession <- previousSessions[max(previousSessions$order),]
+    time_irl <- previousSession$end
+    currentSesion <- previousSession
+  }
 
   ## calculation
   elapsTime <- 0
-  for (i in 1:currentSesion) {
-    if (i != currentSesion) {
-      elapsTime <- as.double(elapsTime + difftime(res$end[i], res$start[i], units = "mins") / res$year_time[i])
+  for (i in seq(1:currentSesion$order)) {
+    if (i != currentSesion$order) {
+      elapsTime <- as.double(elapsTime + difftime(gameSessions$end[i], gameSessions$start[i], units = "mins") / gameSessions$year_time[i])
     } else {
-      elapsTime <- as.double(elapsTime + difftime(now, res$start[i], units = "mins") / res$year_time[i])
+      elapsTime <- as.double(elapsTime + difftime(time_irl, gameSessions$start[i], units = "mins") / gameSessions$year_time[i])
     }
   }
-  elapsTime <- as.difftime(elapsTime * 365.25, units = "days")
+  elapsTime <- as.difftime(elapsTime * 365.2425, units = "days")
 
   # result
-  gameTime <- strptime("2015-01-01", format = "%Y-%m-%d") + elapsTime
+  gameTime <- first_game_day + elapsTime
   return(gameTime)
 }
+