Commit c5f04281 authored by Loup's avatar Loup
Browse files

change output in video (for AUDPC_rel)

parent ff43b568
...@@ -450,7 +450,7 @@ epid_output <- function(types = "all", time_param, Npatho, area, rotation, cropt ...@@ -450,7 +450,7 @@ epid_output <- function(types = "all", time_param, Npatho, area, rotation, cropt
ylab_output <- expression("Equivalent nb of diseased hosts / time step / m"^2) ## expression('title'^2) ylab_output <- expression("Equivalent nb of diseased hosts / time step / m"^2) ## expression('title'^2)
round_ylab_output <- 2 round_ylab_output <- 2
}, "audpc_rel" = { }, "audpc_rel" = {
main_output <- expression("Relative AUDPC") main_output <- "Relative AUDPC"
ylab_output <- "Proportion of diseased hosts: (I+R)/N" ylab_output <- "Proportion of diseased hosts: (I+R)/N"
round_ylab_output <- 2 round_ylab_output <- 2
}, "gla" = { }, "gla" = {
...@@ -873,7 +873,6 @@ evol_output <- function(types = "all", time_param, Npoly, cultivars_param, genes ...@@ -873,7 +873,6 @@ evol_output <- function(types = "all", time_param, Npoly, cultivars_param, genes
#' as if cultivated in pure crops, #' as if cultivated in pure crops,
#' \item cultivars_genes_list = a list containing, for each host genotype, the indices of carried resistance genes. #' \item cultivars_genes_list = a list containing, for each host genotype, the indices of carried resistance genes.
#' } #' }
#' @param audpc100S AUDPC of a 100% susceptible landscape, used as a reference.
#' @param keyDates a vector of times (in time steps) where to draw vertical lines in the AUDPC graphic. Usually #' @param keyDates a vector of times (in time steps) where to draw vertical lines in the AUDPC graphic. Usually
#' used to delimit durabilities of the resistance genes. No line is drawn if keyDates=NULL (default). #' used to delimit durabilities of the resistance genes. No line is drawn if keyDates=NULL (default).
#' @param nMapPY an integer specifying the number of epidemic maps per year to generate. #' @param nMapPY an integer specifying the number of epidemic maps per year to generate.
...@@ -895,66 +894,85 @@ evol_output <- function(types = "all", time_param, Npoly, cultivars_param, genes ...@@ -895,66 +894,85 @@ evol_output <- function(types = "all", time_param, Npoly, cultivars_param, genes
#' @importFrom parallel detectCores #' @importFrom parallel detectCores
#' @importFrom grDevices colorRampPalette dev.off graphics.off gray png tiff #' @importFrom grDevices colorRampPalette dev.off graphics.off gray png tiff
#' @export #' @export
video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptypes, croptype_names = c(), cultivars_param, audpc100S, keyDates = NULL, video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptypes, croptype_names = c(), cultivars_param
nMapPY = 5, path = getwd()) { # , audpc100S
, keyDates = NULL,nMapPY = 5, path = getwd()) {
if (system("ffmpeg -version", ignore.stdout = TRUE) == 127) { if (system("ffmpeg -version", ignore.stdout = TRUE) == 127) {
stop("You need to install ffmpeg before generating videos. Go to https://ffmpeg.org/download.html") stop("You need to install ffmpeg before generating videos. Go to https://ffmpeg.org/download.html")
} }
## Time & graphic parameters ## Time & graphic parameters
Nyears <- time_param$Nyears Nyears <- time_param$Nyears
nTSpY <- time_param$nTSpY nTSpY <- time_param$nTSpY
nTS <- Nyears * nTSpY ## Total number of time-steps nTS <- Nyears * nTSpY ## Total number of time-steps
## Landscape ## Landscape
rotation <- data.frame(rotation) rotation <- data.frame(rotation)
Npoly <- length(area) Npoly <- length(area)
## croptype parameters (for legend) ## croptype parameters (for legend)
if (length(croptype_names) == 0) { if (length(croptype_names) == 0) {
croptype_names <- paste("Croptype", unique(croptypes$croptypeID)) croptype_names <- paste("Croptype", unique(croptypes$croptypeID))
} }
Ncroptypes <- length(croptype_names) Ncroptypes <- length(croptype_names)
## Host parameters ## Host parameters
cultivar_names <- cultivars_param$name cultivar_names <- cultivars_param$name
cultivars_genes_list <- cultivars_param$cultivars_genes_list # cultivars_genes_list <- cultivars_param$cultivars_genes_list
max_density <- cultivars_param$max_density # max_density <- cultivars_param$max_density
Nhost <- length(max_density) Nhost <- length(cultivar_names)
## Calculation of the carrying capacity ## Calculation of the carrying capacity
K <- array(dim = c(Npoly, Nhost, Nyears)) # K <- array(dim = c(Npoly, Nhost, Nyears))
for (y in 1:Nyears) { # for (y in 1:Nyears) {
if (ncol(rotation) == 1) { # if (ncol(rotation) == 1) {
index_year <- 1 # index_year <- 1
} else { # } else {
index_year <- y # index_year <- y
} # }
ts_year <- ((y - 1) * nTSpY + 1):(y * nTSpY) # ts_year <- ((y - 1) * nTSpY + 1):(y * nTSpY)
#
for (poly in 1:Npoly) { # for (poly in 1:Npoly) {
indices_croptype <- grep(rotation[poly, index_year], croptypes$croptypeID) # indices_croptype <- grep(rotation[poly, index_year], croptypes$croptypeID)
for (i in indices_croptype) { # for (i in indices_croptype) {
index_host <- croptypes[i, "cultivarID"] + 1 ## +1 because C indices start at 0 # index_host <- croptypes[i, "cultivarID"] + 1 ## +1 because C indices start at 0
prop <- croptypes[i, "proportion"] # prop <- croptypes[i, "proportion"]
K[poly, index_host, y] <- floor(area[poly] * max_density[index_host] * prop) # K[poly, index_host, y] <- floor(area[poly] * max_density[index_host] * prop)
} # }
} ## for poly # } ## for poly
} ## for y # } ## for y
#### IMPORTATION OF THE SIMULATION OUTPUT #### IMPORTATION OF THE SIMULATION OUTPUT
H <- as.list(1:nTS)
L <- as.list(1:nTS)
I <- as.list(1:nTS) I <- as.list(1:nTS)
R <- as.list(1:nTS) R <- as.list(1:nTS)
index <- 0 index <- 0
# print("Reading binary files to compute epidemiological model outputs")
for (year in 1:Nyears) { for (year in 1:Nyears) {
binfileH <- file(paste(path, sprintf("/H-%02d", year), ".bin", sep = ""), "rb")
H.tmp <- readBin(con = binfileH, what = "int", n = Npoly * Nhost * nTSpY, size = 4, signed = T, endian = "little")
close(binfileH)
binfileL <- file(paste(path, sprintf("/L-%02d", year), ".bin", sep = ""), "rb")
L.tmp <- readBin(con = binfileL, what = "int", n = Npoly * Npatho * Nhost * nTSpY, size = 4, signed = T, endian = "little")
close(binfileL)
binfileI <- file(paste(path, sprintf("/I-%02d", year), ".bin", sep = ""), "rb") binfileI <- file(paste(path, sprintf("/I-%02d", year), ".bin", sep = ""), "rb")
I.tmp <- readBin(con = binfileI, what = "int", n = Npoly * Npatho * Nhost * nTSpY, size = 4, signed = T, endian = "little") I.tmp <- readBin(con = binfileI, what = "int", n = Npoly * Npatho * Nhost * nTSpY, size = 4, signed = T, endian = "little")
close(binfileI)
binfileR <- file(paste(path, sprintf("/R-%02d", year), ".bin", sep = ""), "rb") binfileR <- file(paste(path, sprintf("/R-%02d", year), ".bin", sep = ""), "rb")
R.tmp <- readBin(con = binfileR, what = "int", n = Npoly * Npatho * Nhost * nTSpY, size = 4, signed = T, endian = "little") R.tmp <- readBin(con = binfileR, what = "int", n = Npoly * Npatho * Nhost * nTSpY, size = 4, signed = T, endian = "little")
close(binfileR)
for (t in 1:nTSpY) { for (t in 1:nTSpY) {
H[[t + index]] <- matrix(H.tmp[((Nhost * Npoly) * (t - 1) + 1):(t * (Nhost * Npoly))], ncol = Nhost, byrow = T)
L[[t + index]] <- array(
data = L.tmp[((Npatho * Npoly * Nhost) * (t - 1) + 1):(t * (Npatho * Npoly * Nhost))],
dim = c(Nhost, Npatho, Npoly)
)
I[[t + index]] <- array( I[[t + index]] <- array(
data = I.tmp[((Npatho * Npoly * Nhost) * (t - 1) + 1):(t * (Npatho * Npoly * Nhost))], data = I.tmp[((Npatho * Npoly * Nhost) * (t - 1) + 1):(t * (Npatho * Npoly * Nhost))],
dim = c(Nhost, Npatho, Npoly) dim = c(Nhost, Npatho, Npoly)
...@@ -963,12 +981,10 @@ video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptype ...@@ -963,12 +981,10 @@ video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptype
data = R.tmp[((Npatho * Npoly * Nhost) * (t - 1) + 1):(t * (Npatho * Npoly * Nhost))], data = R.tmp[((Npatho * Npoly * Nhost) * (t - 1) + 1):(t * (Npatho * Npoly * Nhost))],
dim = c(Nhost, Npatho, Npoly) dim = c(Nhost, Npatho, Npoly)
) )
} } ## for t
index <- index + nTSpY index <- index + nTSpY
close(binfileI) } ## for year
close(binfileR)
}
print("Generate video (and create directory maps)") print("Generate video (and create directory maps)")
...@@ -1008,17 +1024,21 @@ video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptype ...@@ -1008,17 +1024,21 @@ video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptype
index_year <- y index_year <- y
} }
K_poly <- apply(as.data.frame(K[, , index_year]), 1, sum, na.rm = TRUE) ## as.data.frame in case Nhost==1 & Npatho==1 # K_poly <- apply(as.data.frame(K[, , index_year]), 1, sum, na.rm = TRUE) ## as.data.frame in case Nhost==1 & Npatho==1
for (d in round(seq(1, nTSpY, length.out = nMapPY))) { for (d in round(seq(1, nTSpY, length.out = nMapPY))) {
subtitle <- paste("Year =", y, " Day =", d) subtitle <- paste("Year =", y, " Day =", d)
## Proportion of each type of host relative to carrying capacity ## Proportion of each type of host relative to carrying capacity
ts <- (y - 1) * nTSpY + d ts <- (y - 1) * nTSpY + d
propI <- apply(I[[ts]], 3, sum) / K_poly # propI <- apply(I[[ts]], 3, sum) / K_poly
propR <- apply(R[[ts]], 3, sum) / K_poly # propR <- apply(R[[ts]], 3, sum) / K_poly
propIR <- (propI + propR) # propIR <- (propI + propR)
intvlsIR <- findInterval(propIR, intvls) # intvlsIR <- findInterval(propIR, intvls)
IR_poly <- apply(I[[ts]], 3, sum) + apply(R[[ts]], 3, sum)
N_poly <- apply(H[[ts]], 1, sum) + apply(L[[ts]], 3, sum) + apply(I[[ts]], 3, sum) + apply(R[[ts]], 3, sum)
intvlsIR <- findInterval(IR_poly / N_poly, intvls)
png( png(
filename = paste(path, "/maps/HLIR_", sprintf("%02d", y), "-", sprintf("%03d", d), ".png", sep = ""), filename = paste(path, "/maps/HLIR_", sprintf("%02d", y), "-", sprintf("%03d", d), ".png", sep = ""),
width = 700, height = 350, units = "mm", res = 72, type = "cairo", bg = "white", antialias = "default" width = 700, height = 350, units = "mm", res = 72, type = "cairo", bg = "white", antialias = "default"
...@@ -1027,17 +1047,20 @@ video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptype ...@@ -1027,17 +1047,20 @@ video <- function(audpc, time_param, Npatho, landscape, area, rotation, croptype
## moving AUDPC ## moving AUDPC
plot(0, 0, plot(0, 0,
type = "n", bty = "n", xlim = c(1, Nyears), ylim = c(0, 1), xaxt = "n", yaxt = "n", xlab = "", ylab = "", type = "n", bty = "n", xlim = c(1, Nyears), ylim = c(0, 1), xaxt = "n", yaxt = "n"
main = "Disease severity relative to a fully susceptible landscape" , xlab = "", ylab = "", main = "Average disease severity"
) )
axis(1, at = seq(1, Nyears, by = (Nyears - 1) %/% 10 + 1)) axis(1, at = seq(1, Nyears, by = (Nyears - 1) %/% 10 + 1))
ticksMarks <- round(seq(0, 1, length.out = 5), 2) ticksMarks <- round(seq(0, 1, length.out = 5), 2)
axis(2, at = ticksMarks, labels = paste(100 * ticksMarks, "%"), las = 1) axis(2, at = ticksMarks, labels = paste(100 * ticksMarks, "%"), las = 1)
title(xlab = "Years", mgp = c(2, 1, 0)) title(xlab = "Years", mgp = c(2, 1, 0))
title(ylab = "Proportion of diseased hosts: (I+R)/N", mgp = c(3.5, 1, 0))
for (host in 1:Nhost) { for (host in 1:Nhost) {
lines(1:y, audpc[1:y, host] / audpc100S, type = "o", lwd = 2, lty = host, pch = PCH[host], col = GRAY[host]) # lines(1:y, audpc[1:y, host] / audpc100S, type = "o", lwd = 2, lty = host, pch = PCH[host], col = GRAY[host])
lines(1:y, audpc[1:y, host], type = "o", lwd = 2, lty = host, pch = PCH[host], col = GRAY[host])
} }
lines(1:y, audpc[1:y, "total"] / audpc100S, type = "o", lwd = 2, lty = LTY.tot, pch = PCH.tot, col = COL.tot) # lines(1:y, audpc[1:y, "total"] / audpc100S, type = "o", lwd = 2, lty = LTY.tot, pch = PCH.tot, col = COL.tot)
lines(1:y, audpc[1:y, "total"], type = "o", lwd = 2, lty = LTY.tot, pch = PCH.tot, col = COL.tot)
## Add lines for durability ## Add lines for durability
if (!is.null(keyDates)) { if (!is.null(keyDates)) {
for (k in 1:length(keyDates)) { for (k in 1:length(keyDates)) {
......
...@@ -348,8 +348,10 @@ simul_landsepi <- function(seed = 12345, time_param = list(Nyears = 20, nTSpY = ...@@ -348,8 +348,10 @@ simul_landsepi <- function(seed = 12345, time_param = list(Nyears = 20, nTSpY =
## Video ## Video
if (videoMP4 & !is.null(epid_res[["audpc"]])) { if (videoMP4 & !is.null(epid_res[["audpc"]])) {
video( video(
epid_res[["audpc"]], time_param, Npatho, landscape, area, rotation, croptypes_cultivars_prop, epid_res[["audpc_rel"]], time_param, Npatho, landscape, area, rotation, croptypes_cultivars_prop,
croptype_names, cultivars_param, audpc100S, evol_res$durability croptype_names, cultivars_param
# , audpc100S
, evol_res$durability
) )
} }
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment