Skip to content

Commit

Permalink
🐛 misc fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
@ecoisilva
ecoisilva committed Apr 22, 2024
1 parent 58950fc commit 16eff47
Show file tree
Hide file tree
Showing 12 changed files with 552 additions and 268 deletions.
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,7 @@ Imports:
ggpubr,
ggtext,
golem (>= 0.3.2),
grDevices,
parallel,
parsedate,
plyr,
Expand Down
4 changes: 4 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,20 +16,24 @@ importFrom(golem,add_resource_path)
importFrom(golem,bundle_resources)
importFrom(golem,favicon)
importFrom(golem,with_golem_options)
importFrom(grDevices,colorRampPalette)
importFrom(plyr,.)
importFrom(rlang,":=")
importFrom(shiny,NS)
importFrom(shiny,shinyApp)
importFrom(shiny,tagList)
importFrom(stats,median)
importFrom(stats,qt)
importFrom(stats,rbinom)
importFrom(stats,reorder)
importFrom(stats,runif)
importFrom(stats,sd)
importFrom(stats,setNames)
importFrom(stringr,str_pad)
importFrom(utils,capture.output)
importFrom(utils,data)
importFrom(utils,head)
importFrom(utils,packageVersion)
importFrom(utils,read.csv)
importFrom(utils,read.table)
importFrom(utils,tail)
3 changes: 3 additions & 0 deletions R/global.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ utils::globalVariables(

"id",
"x", "y",
"x0", "y0", "x1", "y1",
"long", "lat",
"longitude", "latitude",
"time", "timestamp", "lag",
Expand Down Expand Up @@ -57,6 +58,8 @@ utils::globalVariables(
"subpop",
"overlaps",

"var_color",

"buffalo",
"coati",
"pelican",
Expand Down
131 changes: 105 additions & 26 deletions R/mod_comp_m.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -161,11 +161,11 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
}
}

rv$modList <- list(fit)
# rv$modList <- list(fit)
}

if (rv$grouped) {
rv$modList_groups <- list(A = fitA, B = fitB)
# rv$modList_groups <- list(A = fitA, B = fitB)
simA <- ctmm::simulate(fitA, t = t_new, seed = rv$seed0)
simB <- ctmm::simulate(fitB, t = t_new, seed = rv$seed0 + 1)
simA <- pseudonymize(simA)
Expand Down Expand Up @@ -368,6 +368,7 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
req("compare" %in% rv$which_meta)
req(rv$metaList_groups[[1]],
rv$set_analysis)
req(rv$set_analysis == set_analysis)

meta <- rv$metaList_groups[[1]][[rv$set_analysis]]
req(meta)
Expand All @@ -386,8 +387,6 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
txt_diff <- c("slower", "faster")
}

req(txt_diff[[1]], txt_diff[[2]])

if (ratio == 1) {
out_txt <- paste0(
"Group A's ", var, " should be equal to Group B's.")
Expand Down Expand Up @@ -496,7 +495,7 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
to_keep_vec <- rep(1, nrow(x))
if (failure_occurred) {
to_keep_vec <- c(rep(1, 10), cumprod(
1 - rbinom(nrow(x) - 10, 1, prob = 0.01)))
1 - stats::rbinom(nrow(x) - 10, 1, prob = 0.01)))
if (!any(to_keep_vec == 0))
failure_occurred <- FALSE

Expand Down Expand Up @@ -704,13 +703,44 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {

lapply(seq_along(simList), function(x) {
nm <- names(rv$simList)[[(rv$nsims - num_sims) + x]]

group <- 1
if (rv$grouped) {
group <- ifelse(nm %in% rv$groups[[2]]$A, "A", "B")
}

if (rv$is_emulate) {
tau_p <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[(rv$nsims - num_sims) + x]]),
"position")[[1]]
tau_v <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[(rv$nsims - num_sims) + x]]),
"velocity")[[1]]
sigma <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[(rv$nsims - num_sims) + x]]),
"sigma")[[1]]

} else {
tau_p <- rv$tau_p[[group]]
tau_v <- rv$tau_v[[group]]
sigma <- rv$sigma[[group]]
}

newrow <- devRow(
seed = rv$seedList[[(rv$nsims - num_sims) + x]],
group = if (rv$grouped)
ifelse(nm %in% rv$groups[[2]]$A, "A", "B") else NA,
device = rv$device_type,
group = if (rv$grouped) group else NA,

data = simList[[x]],
fit = simfitList[[x]])
seed = rv$seedList[[(rv$nsims - num_sims) + x]],
fit = simfitList[[x]],

tau_p = tau_p,
tau_v = tau_v,
sigma = sigma)

rv$dev$tbl <<- rbind(rv$dev$tbl, newrow)
})

Expand All @@ -732,14 +762,45 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
rv$dev$N2 <- c(rv$dev$N2, extract_dof(fit, "speed"))

nm <- names(rv$simList)[[(rv$nsims - num_sims) + i]]

group <- 1
if (rv$grouped) {
group <- ifelse(nm %in% rv$groups[[2]]$A, "A", "B")
}

if (rv$is_emulate) {
tau_p <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[(rv$nsims - num_sims) + x]]),
"position")[[1]]
tau_v <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[(rv$nsims - num_sims) + x]]),
"velocity")[[1]]
sigma <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[(rv$nsims - num_sims) + x]]),
"sigma")[[1]]

} else {
tau_p <- rv$tau_p[[group]]
tau_v <- rv$tau_v[[group]]
sigma <- rv$sigma[[group]]
}


newrow <- devRow(
seed = rv$seedList[[(rv$nsims - num_sims) + i]],
group = if (rv$grouped)
ifelse(nm %in% rv$groups[[2]]$A, "A", "B") else NA,
device = rv$device_type,
# dur = rv$dur, dti = rv$dti,
group = if (rv$grouped) group else NA,

data = simList[[i]],
fit = fit)
seed = rv$seedList[[(rv$nsims - num_sims) + i]],
fit = fit,

tau_p = tau_p,
tau_v = tau_v,
sigma = sigma)

rv$dev$tbl <<- rbind(rv$dev$tbl, newrow)

msg_log(
Expand Down Expand Up @@ -907,7 +968,7 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
rv$seedList <- c(rv$seedList, rv$seed0)
return(out)
})
seedList <- tail(rv$seedList, m)
seedList <- utils::tail(rv$seedList, m)
}
}

Expand All @@ -927,7 +988,7 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
to_keep_vec <- rep(1, nrow(x))
if (failure_occurred) {
to_keep_vec <- c(rep(1, 10), cumprod(
1 - rbinom(nrow(x) - 10, 1, prob = 0.01)))
1 - stats::rbinom(nrow(x) - 10, 1, prob = 0.01)))
if (!any(to_keep_vec == 0))
failure_occurred <- FALSE

Expand Down Expand Up @@ -1224,15 +1285,24 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
est = out_err[[2]],
uci = out_err[[3]])

if (rv$is_emulate) {
tau_p <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[i]]),
"position")[[1]]
} else {
tau_p <- rv$tau_p[[group]]
}

rv$hr$tbl <<- rbind(
rv$hr$tbl,
hrRow(seed = rv$seedList[[i]],
group = if (rv$grouped) group else NA,
hrRow(group = if (rv$grouped) group else NA,

data = rv$simList[[i]],
tau_p = rv$tau_p[[group]],
dur = rv$dur,
dti = rv$dti,
seed = rv$seedList[[i]],
fit = rv$simfitList[[i]],
tau_p = tau_p,

area = out_est_df,
error = out_err_df))
}
Expand Down Expand Up @@ -1392,7 +1462,7 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
rv$seedList <- c(rv$seedList, rv$seed0)
return(out)
})
seedList <- tail(rv$seedList, m)
seedList <- utils::tail(rv$seedList, m)
}
}

Expand All @@ -1412,7 +1482,7 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
to_keep_vec <- rep(1, nrow(x))
if (failure_occurred) {
to_keep_vec <- c(rep(1, 10), cumprod(
1 - rbinom(nrow(x) - 10, 1, prob = 0.01)))
1 - stats::rbinom(nrow(x) - 10, 1, prob = 0.01)))
if (!any(to_keep_vec == 0))
failure_occurred <- FALSE

Expand Down Expand Up @@ -1820,12 +1890,21 @@ mod_comp_m_server <- function(id, rv, set_analysis = NULL) {
rv$distEst <<- rbind(rv$distEst, out_dist_est_df)
rv$distErr <<- rbind(rv$distErr, out_dist_err_df)

if (rv$is_emulate) {
tau_v <- extract_pars(
emulate_seeded(rv$meanfitList[[group]],
rv$seedList[[i]]),
"velocity")[[1]]
} else {
tau_v <- rv$tau_v[[group]]
}

rv$sd$tbl <<- rbind(
rv$sd$tbl,
sdRow(seed = rv$seedList[[i]],
group = if (rv$grouped) group else NA,
sdRow(group = if (rv$grouped) group else NA,
data = rv$simList[[i]],
tau_v = rv$tau_v[[group]],
seed = rv$seedList[[i]],
tau_v = tau_v,
fit = rv$simfitList[[i]],
speed = rv$speedEst[i, ],
speed_error = rv$speedErr[i, ],
Expand Down
20 changes: 10 additions & 10 deletions R/mod_tab_about.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,16 +38,16 @@ mod_tab_about_ui <- function(id) {
wrap_none(span("speed and distance traveled",
class = "cl-sea-d"), ".")),
br(),
# p(style = "max-width: 685px;",
# span(class = "help-block",
# style = "text-align: center !important;",
#
# fontawesome::fa("circle-exclamation", fill = "#dd4b39"),
# span("Note:", class = "help-block-note"),
# "This is the", span( "development", class = "cl-dgr"),
# "version of the application, currently undergoing",
# "testing. Use with caution, as it may crash",
# "or behave unexpectedly.")),
p(style = "max-width: 685px;",
span(class = "help-block",
style = "text-align: center !important;",

fontawesome::fa("circle-exclamation", fill = "#dd4b39"),
span("Note:", class = "help-block-note"),
"This is the", span( "development", class = "cl-dgr"),
"version of the application, currently undergoing",
"testing. Use with caution, as it may crash",
"or behave unexpectedly.")),
p(style = "margin-bottom: 35px;")

) # end of column (text)
Expand Down
Loading

0 comments on commit 16eff47

Please sign in to comment.