R/mod_split-obs.R
In brentscott93/lasertrapr: Automating the Analysis of Laser Trap Data
Defines functions
mod_split_obs_server
mod_split_obs_ui
#' split_obs UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#' @import shinyFiles
#' @importFrom shiny NS tagList
mod_split_obs_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(box(width = 3,
collapsible = TRUE, collapsed = FALSE,
title = "Upload Data",
shinyWidgets::radioGroupButtons(
inputId = ns("upload_method"),
label = 'Method',
choices = c("Upload" = "upload",
"Lumicks" = "lumicks",
"Split Obs" = "split_obs"),
direction = "horizontal",
width = "100%",
justified = TRUE,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
conditionalPanel(
condition = " input.upload_method == 'upload'", ns = ns,
fluidRow(
column(12,
shinyFiles::shinyFilesButton(ns("file_input"),
label = "Browse for file...",
title = "Select one or more file",
multiple = TRUE,
style = "width: 100%; margin-bottom: 5px;"),
)
),
fluidRow(
column(6,
shinyWidgets::radioGroupButtons(
inputId = ns("channels"),
label = 'Number of Channels',
choices = c(1, 2),
direction = "horizontal",
width = "100%",
justified = TRUE,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)),
column(6,style = "padding-top: 32px;",
shinyWidgets::prettyCheckbox(ns("in_header"),
"Cal in header?",
value = FALSE,
outline = TRUE,
shape = "curve",
status = "primary" ))
),
conditionalPanel(
condition = "input.in_header == true", ns = ns,
fluidRow(
column(6,
numericInput(ns("header_size"),
label = "Header Size",
value = 68,
step = 1)),
column(6,
numericInput(ns("header_hz"),
label = "Hz",
value = 15,
step = 1))
),
fluidRow(
column(6,
numericInput(ns("header_nm_v1"),
label = "nm/V",
value = 22,
step = 1,
width = "100%")),
column(6,
numericInput(ns("header_pn_nm1"),
label = "pN/nm",
value = 18,
step = 1,
width = "100%")
)
),
conditionalPanel(
condition = "input.channels == 2", ns = ns,
fluidRow(
column(6,
numericInput(ns("header_nm_v2"),
label = "nm/V 2",
value = 24,
step = 1,
width = "100%"),
),
column(6,
numericInput(ns("header_pn_nm2"),
label = "pN/nm 2",
value = 20,
step = 1,
width = "100%")
)
),
fluidRow(
column(6,
numericInput(ns("trap1_col"),
label = "Trap 1 Col",
value = 1,
step = 1,
width = "100%"),
),
column(6,
numericInput(ns("trap2_col"),
label = "Trap 2 Col",
value = 3,
step = 1,
width = "100%")
)
),
fluidRow(
column(6,
numericInput(
inputId = ns("feedback_motor_bead"),
label = "Feedback Motor Bead",
value = 30
)
)
)
) # conditional panel input.channels ==2
), # conditional panel header
conditionalPanel(
condition = "input.in_header == false", ns = ns,
fluidRow(
column(6,
numericInput(ns("hz"), "Hz", 0)
),
column(6,
div(style = "padding-top: 32px;",
shinyWidgets::prettyCheckbox(ns("ready_for_analysis"),
"Ready for analysis?",
value = FALSE,
outline = TRUE,
shape = "curve",
status = "primary" )
))
),
conditionalPanel(
condition = " input.ready_for_analysis == true", ns = ns,
numericInput(ns("nm_to_pn"), "Stiffness Conversion (pN/nm)", value = 0.04)
)
),
numericInput(ns("downsample_by"), "Downsample By (factor)", value = 1),
actionButton(ns("simple_upload_button"),
"Initialize Data",
width = "100%",
icon = icon("play-circle"),
style = 'margin-top: 25px;')
), #conditional close
conditionalPanel(
condition = " input.upload_method == 'lumicks'", ns = ns,
fluidRow(
column(12,
shinyFiles::shinyFilesButton(ns("file_input_lumicks"),
label = "Browse for H5...",
title = "Select one or more file",
multiple = TRUE,
style = "width: 100%; margin-bottom: 5px;"),
)
),
fluidRow(
column(6,
numericInput(ns("downsample_lumicks"), "Downsample By (factor)", value = 1),
checkboxInput(ns("has_stage_position"), "Stage Position?"),
checkboxInput(ns("round_stage"), "Round Stage?")
),
column(6,
actionButton(ns("lumicks_upload"),
"Initialize Data",
width = "100%",
icon = icon("play-circle"),
style = 'margin-top: 25px;')
)
)
), #conditional close
conditionalPanel(
condition = " input.upload_method == 'split_obs'", ns = ns,
fileInput(ns("trap_txt_upload"),
'Upload Data Files (.txt)',
multiple = TRUE,
accept = ".txt",
buttonLabel = "Browse...",
placeholder = "Data.txt"),
# strong( h5("2) Choose number of seconds to split by")),
shinyWidgets::knobInput(inputId = ns("threshold"),
label = 'Set Threshold to Split',
value = 20,
min = 10,
max = 30),
actionButton(inputId = ns("split_obs_button"),
label = "Make Observations",
icon = icon("eye"),
width = "100%",
style = 'margin-top: 25px;')
) #conditional close
), #box close,
box(title = "Simulate Data", width = 9, collapsible = T, collapsed = T,
fluidRow(
column(2,
numericInput(ns("sim_n_events"), "Events", value = 100, min = 10, max = 200, step = 1)
),
column(2,
numericInput(ns("sim_signal"), "Signal", value = 2.5, min = 1.5, max = 10, step = 0.1)
),
column(2,
numericInput(ns("sim_hz"), "Hz", value = 5000, min = 0, max = 20000)
),
column(2,
actionButton(ns("sim_options"), "Options", width = "100%", style = "margin-top: 25px;")
),
column(2,
actionButton(ns("sim_go"), "Simulate Data", width = "100%", style = "margin-top: 25px;")
),
column(2,
actionButton(ns("sim_save"), "Save", width = "100%", style = "margin-top: 25px;")
)
),
fluidRow(
column(3,
h6("Current Simulation Parameters:"),
verbatimTextOutput(ns("sim_parameters"))
),
column(9,
dygraphs::dygraphOutput(ns('sim')) |> shinycssloaders::withSpinner(type = 8, color = "#373B38")
)
)
)
),
fluidRow(
box(title = 'Step Calibration', width = 6, collapsible = T, collapsed = T,
fluidRow(column(3, fileInput(ns('step_files'),
'Upload Step File (.txt)',
accept = 'text/plain',
multiple = T,
width = '100%',
placeholder = 'Step.txt'),
#shinyWidgets::setSliderColor('#ff41c8', c(1, 2)),
numericInput(ns('step_cal_stepsize'),
'Step Cal Step Size',
min = NA,
max = NA,
value = 50,
step = 1,
width = '100%'),
actionButton(ns('step_button'), 'Step Cal', width = '100%', style = 'margin-top: 25px;'),
tags$style(".small-box.bg-yellow { background-color: #1B9E77 !important; color: #f2f2f2 !important; }"),
valueBoxOutput(ns("step_cal_valueBox"), width = 2),
),
column(9,
plotOutput(ns('step'), width = '100%', height = '275px') |>
shinycssloaders::withSpinner(type = 8, color = "#373B38"))
)
), #box close
box(title = 'Equipartition', width = 6, collapsible = T, collapsed = T,
fluidRow(
column(3, fileInput(ns('equi_file'),
'Upload Equi File (.txt)',
placeholder = 'Equi.txt',
accept = '.txt'),
numericInput(ns('equi_mv2nm'),
'mV to nm conversion',
min = NA,
max = NA,
value = 30,
step = 1,
width = '100%'),
withMathJax(helpText("$$\\alpha_{trap}=\\frac{k_B*T_k}{\\sigma^2}$$")),
actionButton(ns('equi_button'),
'Equi Cal',
width = '100%',
style = 'margin-top: 25px;'),
valueBoxOutput(ns("equipartition_valueBox"), width = 2)),
column(9,
plotOutput(ns('equi'), width = '100%', height = '275px') |>
shinycssloaders::withSpinner(type = 8, color = "#373B38"))
)
)
) #row close
) #tagList
}
#' split_obs Server Function
#'
#' @noRd
#' @import shinyFiles
mod_split_obs_server <- function(input, output, session, f){
ns <- session$ns
shinyFileChoose(input = input,
id = "file_input",
roots = c(home=dirname(path.expand("~"))),
defaultRoot = "home",
defaultPath = "",
session = session)
shinyFileChoose(input = input,
id = "file_input_lumicks",
roots = c(home=dirname(path.expand("~"))),
defaultRoot = "home",
defaultPath = "",
session = session)
## header cal info
## these values correspond to the LINE NUMBERS where the info can be found in the headers of the data files
h <- reactiveValues(header_size = 0,
hz = 0,
nm_v1 = 0,
nm_v2 = 0,
pn_nm1 = 0,
pn_nm2 = 0,
trap1_col = 0,
trap2_col = 0,
feedback_motor_bead = 0)
observe({
h$header_size <- input$header_size
h$hz <- input$header_hz
h$nm_v1 <- input$header_nm_v1
h$nm_v2 <- input$header_nm_v2
h$pn_nm1 <- input$header_pn_nm1
h$pn_nm2 <- input$header_pn_nm2
h$trap1_col <- input$trap1_col
h$trap2_col <- input$trap2_col
h$feedback_motor_bead <- input$feedback_motor_bead
})
observeEvent(input$simple_upload_button, {
defend_if_empty(f$project, "No 'Project' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$conditions, "No 'Conditions' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$date, "No 'Date' folder selected. Please select a folder with the folder chooser above.")
## defend_if_equal(input$hz == 0, "Please enter sampling frequency, Hz.")
req(nchar(f$date$path>0))
input_data <- parseFilePaths(c(home=dirname(path.expand("~"))), input$file_input)
if(input$in_header){
upload_data_cal_in_header(input_data = input_data,
h = h,
project = f$project,
conditions = f$conditions,
date = f$date,
number_of_channels = input$channels,
downsample_by = input$downsample_by)
} else {
simple_upload(input_data = input_data,
project = f$project,
conditions = f$conditions,
date = f$date,
nm2pn = input$nm_to_pn,
ready_for_analysis = input$ready_for_analysis,
hz = input$hz,
number_of_channels = input$channels,
downsample_by = input$downsample_by)
}
f$new_obs_from_split <- f$new_obs_from_split + 1
})
#check if a date folder is properly selected
observeEvent(input$split_obs_button, {
## golem::print_dev("go")
if(rlang::is_empty(f$date) == TRUE){
showNotification("No 'Date' folder selected. Please select a folder with the folder chooser above. ",
type = "error")
} else if(rlang::is_empty(input$trap_txt_upload)){
showNotification("No data uploaded",
type = "error")
} else {
req(nchar(f$date$path>0))
req(input$trap_txt_upload)
all_data <- purrr::map(input$trap_txt_upload$name, ~substring(.x, 1, 4) == 'Data')
if(all(all_data != TRUE)){
showNotification("Not all files are valid 'Data' files. Only upload files starting with 'Data'.",
type = "error")
} else {
## golem::print_dev('before split_obs call')
split_obs(input_data = input$trap_txt_upload,
project = f$project,
conditions = f$conditions,
date = f$date,
threshold = input$threshold)
f$new_obs_from_split <- f$new_obs_from_split + 1
}
}
})
####cal####
#Start trap calibrations
e <- reactiveValues()
observeEvent(input$equi_button, {
if(rlang::is_empty(input$equi_file)){
showNotification('No data uploaded', type = 'error')
## } else if(substring(input$equi_file$name, 1, 4) != 'Equi') {
## showNotification("Not a valid 'Equi' file.", type = 'error')
} else {
withProgress(message = "Equipartition Calibration", min= 0, max = 1, value = 0.01, {
incProgress(0.25, detail = "Reading Data")
files <- data.table::fread(input$equi_file$datapath, col.names = c('bead', 'trap')) |>
dplyr::mutate(bead = bead * input$equi_mv2nm) |>
dplyr::pull(bead)
mean_equi <- mean(files)
equi_data <- files - mean_equi
e$vector <- equi_data
incProgress(0.75, detail = "Calculating")
e$cal <- equipartition(equi_data)
})
}
})
output$equi <- renderPlot( {
req(e$vector)
plot(e$vector, ylab = 'nm', xlab = 'Datapoints', type = 'l')
})
output$equipartition_valueBox <- renderValueBox({
req(e$cal)
valueBox(
value = round(e$cal, 3),
subtitle = "Trap Stiffness (pN/nm)",
icon = icon("ruler-vertical"),
width = "100%",
color = 'yellow'
)
})
observeEvent(input$step_button, {
if(rlang::is_empty(input$step_files)){
showNotification('No data uploaded', type = 'error')
} else if(substring(input$step_files$name, 1, 4) != 'Step') {
showNotification("Not a valid 'Step' file.", type = 'error')
}
})
step_calibration <- eventReactive(input$step_button, {
req(input$step_files$datapath)
## req(substring(input$step_files$name, 1, 4) == 'Step')
withProgress(message = "Step Calibration", min= 0, max = 1, value = 0.01, {
incProgress(0.4, detail = "Reading Data")
files <- purrr::map(input$step_files$datapath, fread, col.names = c('bead', 'trap')) |>
purrr::map(dplyr::pull, bead)
incProgress(0.75, detail = "Calculating...This may take a while...")
steps <- purrr::map(files, step_cal, step = input$step_cal_stepsize)
incProgress(1, detail = "Done!")
})
return(steps)
})
conversion <- reactive({
conv1 <- purrr::map(step_calibration(), "mv2nm_conversion")
conv2 <- round(mean(abs(unlist(conv1))), 2)
})
output$step_cal_valueBox <- renderValueBox({
valueBox(
value = conversion(),
subtitle = "Step Calibration (nm/mV)",
icon = icon("ruler-horizontal"),
width = "100%",
color = "yellow"
)
})
step_calibration_plot <- reactive({
grobs <- purrr::map(step_calibration(), "plot")
p <- gridExtra::grid.arrange(grobs = grobs, ncol = 1)
return(p)
})
output$step <- renderPlot({
step_calibration_plot()
})
sim <- reactiveValues(baseline_mean = 0,
baseline_sd = 8,
step = 5,
step_sd = 8,
pi_release = "after",
pi_release_rate = 200,
pi_release_lower = 1/1000,
pi_release_upper = 1,
adp_release = "set_time",
adp_release_rate = 20,
adp_release_lower = 1/1000,
adp_release_upper = 1,
hitch_size = 2,
atp_binding = "set_time",
atp_binding_rate = 50,
atp_binding_upper = 1,
atp_binding_lower = 20/1000,
time_off_rate = 1,
time_off_upper = 10000/1000,
time_off_lower = 100/1000)
observeEvent(input$sim_ok, {
sim$baseline_mean = input$sim_baseline_mean
sim$baseline_sd = input$sim_baseline_sd
sim$step = input$sim_displacement_mean
sim$step_sd = input$sim_displacement_sd
sim$pi_release = input$sim_pi_release_occurs
sim$pi_release_rate = input$sim_pi_release_rate
sim$pi_release_lower = input$sim_pi_release_lower
sim$pi_release_upper = input$sim_pi_release_upper
# sim$adp_release = sim_adp_release_type
sim$adp_release_rate = input$sim_adp_release_rate
sim$adp_release_lower = input$sim_adp_release_lower
sim$adp_release_upper = input$sim_adp_release_upper
sim$hitch_size = input$sim_hitch_size
sim$atp_binding_rate = input$sim_atp_binding_rate
sim$atp_binding_upper = input$sim_atp_binding_upper
sim$atp_binding_lower = input$sim_atp_binding_lower
sim$time_off_rate = input$sim_time_off_rate
sim$time_off_upper = input$sim_time_off_upper
sim$time_off_lower = input$sim_time_off_lower
removeModal()
})
observeEvent(input$sim_options, {
showModal(
modalDialog(
size = "l",
title = "Define Simulation Parameters",
footer = tagList(modalButton("Cancel"), actionButton(ns("sim_ok"), "OK")),
tabsetPanel(
tabPanel("Baseline",
sliderInput(ns("sim_baseline_mean"), "Mean", value = sim$baseline_mean, step = 1, round = TRUE, min = -50, max = 50, width = "100%"),
sliderInput(ns("sim_baseline_sd"), "SD", value = sim$baseline_sd, step = 1, round = TRUE, min = 0, max = 15, width = "100%"),
plotOutput(ns("sim_baseline_histogram"))
),
tabPanel("Displacements",
sliderInput(ns("sim_displacement_mean"), "Mean", value = sim$step, step = 1, round = TRUE, min = -50, max = 50, width = "100%"),
sliderInput(ns("sim_displacement_sd"), "SD", value = sim$step_sd, step = 1, round = TRUE, min = 0, max = 15, width = "100%"),
plotOutput(ns("sim_displacement_histogram"))
),
tabPanel("Pi Release",
br(),
shinyWidgets::radioGroupButtons(
inputId = ns('sim_pi_release_occurs'),
label = "Pi release before or after stroke?",
choices = c("Before" = "before",
"After" = "after",
"Uncoupled" = "uncoupled"),
justified = TRUE,
selected = sim$pi_release,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
conditionalPanel(condition = "input.sim_pi_release_occurs != 'uncoupled'", ns = ns,
fluidRow(
column(6,
numericInput(ns("sim_pi_release_rate"), "Avg Rate (Hz)", value = sim$pi_release_rate, max = 500, min = 0, step = 5, width = "100%")
),
column(6,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_pi_release_rate_conversion")))
)
),
sliderInput(ns("sim_pi_release_lower"),
"Lower (ms)",
value = sim$pi_release_lower,
step = 1/1000,
round = TRUE,
min = 1/1000,
max = 50/1000,
width = "100%"),
sliderInput(ns("sim_pi_release_upper"), "Upper (ms)",
value = sim$pi_release_upper,
step = 1/1000,
round = TRUE,
min = 0/1000,
max = round(max(rexp(10000, sim$pi_release_rate)), 3),
width = "100%"),
plotOutput(ns("sim_pi_release_histogram"))
)
),
tabPanel("ADP Release",
# shinyWidgets::radioGroupButtons(
# inputId = ns('sim_adp_release_type'),
# label = "",
# choices = c("Use Distribution" = "distribution",
# "Set Time" = "set_time"),
# justified = TRUE,
# selected = sim$adp_release,
# checkIcon = list(
# yes = tags$i(class = "fa fa-check-square",
# style = "color: black"),
# no = tags$i(class = "fa fa-square-o",
# style = "color: black"))
# ),
fluidRow(
# conditionalPanel(condition = "input.sim_adp_release_type == 'distribution'", ns = ns,
column(4,
numericInput(ns("sim_adp_release_rate"), "Avg Rate (Hz)", value = sim$adp_release_rate, max = 500, min = 0, step = 5, width = "100%"),
),
column(4,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_adp_release_conversion")))
),
# ),
# conditionalPanel(condition = "input.sim_adp_release_type == 'set_time'", ns = ns,
# column(8,
# sliderInput(ns("sim_adp_release_set_time"), label = "Set Time", min = 0, max = 1000, value = sim$adp_release_rate, width = "100%")
#
# )
# ),
column(4,
numericInput(ns("sim_hitch_size"), "Hitch Size (nm)", value = sim$hitch_size, step = 0.5, min = 0, max = 10, width = "100%")
)
),
# conditionalPanel(condition = "input.sim_adp_release_type == 'distribution'", ns = ns,
sliderInput(ns("sim_adp_release_lower"),
"Lower (ms)",
value = sim$adp_release_lower,
step = 1/1000,
round = TRUE,
min = 0,
max = 50/1000,
width = "100%"),
sliderInput(ns("sim_adp_release_upper"),
"Upper (ms)",
value = sim$adp_release_upper,
step = 10/1000,
round = TRUE,
min = 0,
max = round(max(rexp(10000,sim$adp_release_rate)), 3),
width = "100%"),
plotOutput(ns("sim_adp_release_histogram"))
# )
),
tabPanel("ATP Binding",
# shinyWidgets::radioGroupButtons(
# inputId = ns('sim_atp_binding_type'),
# label = "",
# choices = c("Use Distribution" = "distribution",
# "Set Time" = "set_time"),
# justified = TRUE,
# selected = sim$atp_binding,
# checkIcon = list(
# yes = tags$i(class = "fa fa-check-square",
# style = "color: black"),
# no = tags$i(class = "fa fa-square-o",
# style = "color: black"))
# ),
# conditionalPanel(condition = "input.sim_atp_binding_type == 'distribution'", ns = ns,
fluidRow(
column(6,
numericInput(ns("sim_atp_binding_rate"),
"Rate (1/mean)",
value = sim$atp_binding_rate,
max = 1000,
min = 0,
step = 5,
width = "100%")
),
column(6,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_atp_binding_conversion")))
),
),
sliderInput(ns("sim_atp_binding_lower"),
"Lower (ms)",
value = sim$atp_binding_lower,
step = 1/1000,
round = TRUE,
min = 0,
max = 100/1000,
width = "100%"),
sliderInput(ns("sim_atp_binding_upper"),
"Upper (ms)",
value = sim$atp_binding_upper,
step = 10/1000,
round = TRUE,
min = 0,
max = round(max(rexp(10000, sim$atp_binding_rate)), 3),
width = "100%"),
plotOutput(ns("sim_atp_binding_histogram"))
# ),
# conditionalPanel(condition = "input.sim_atp_binding_type == 'set_time'", ns = ns,
# sliderInput(ns("sim_atp_binding_set_time"), label = "Set Rate", min = 1, max = 5000, value = sim$atp_binding_rate, width = "100%")
# )
),
tabPanel("Time Off",
fluidRow(
column(6,
numericInput(ns("sim_time_off_rate"),
"Rate (1/mean)",
value = sim$time_off_rate,
max = 10,
min = 0,
step = 0.5,
width = "100%")
),
column(6,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_time_off_conversion")))
)
),
sliderInput(ns("sim_time_off_lower"),
"Lower (ms)",
value = sim$time_off_lower,
step = 1/1000,
round = TRUE,
min = 0,
max = 100/1000,
width = "100%"),
sliderInput(ns("sim_time_off_upper"),
"Upper (ms)",
value = sim$time_off_upper,
step = 100/1000,
round = TRUE,
min = 0,
max = round(max(rexp(10000, sim$time_off_rate)), 3),
width = "100%"),
plotOutput(ns("sim_time_off_histogram"))
)
)
)
)
})
output$sim_baseline_histogram <- renderPlot({
x <- rnorm(100000, input$sim_baseline_mean, input$sim_baseline_sd)
hist(x, xlab = "nm", main = "Simulated Baseline Distribution (n = 100k)", breaks = (min(x)-1):(max(x)+1), freq = F)
curve(dnorm(x, input$sim_baseline_mean, input$sim_baseline_sd), add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_displacement_histogram <- renderPlot({
x <- rnorm(100000, mean = input$sim_displacement_mean, sd = input$sim_displacement_sd)
hist(x, xlab = "nm", main = "Simulated Displacement Distribution (n = 100k)", breaks = (min(x)-1):(max(x)+1), freq = F)
curve(dnorm(x, input$sim_displacement_mean, input$sim_displacement_sd), add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_adp_release_histogram <- renderPlot({
rate <- input$sim_adp_release_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_adp_release_lower,
b = input$sim_adp_release_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated ADP Release Rate (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
a = input$sim_adp_release_lower,
b = input$sim_adp_release_upper,
rate = rate),
add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_time_off_histogram <- renderPlot({
rate <- input$sim_time_off_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_time_off_lower,
b = input$sim_time_off_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated Time Off Distribution (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
a = input$sim_time_off_lower,
b = input$sim_time_off_upper,
rate = rate),
add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_atp_binding_histogram <- renderPlot({
rate <- input$sim_atp_binding_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_atp_binding_lower,
b = input$sim_atp_binding_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated Hitch Duration Distribution (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
rate = rate,
a = input$sim_atp_binding_lower,
b = input$sim_atp_binding_upper),
add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_pi_release_histogram <- renderPlot({
rate <- input$sim_pi_release_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_pi_release_lower,
b = input$sim_pi_release_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated Pi Release Duration Distribution (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
rate = rate,
a = input$sim_pi_release_lower,
b = input$sim_pi_release_upper),
add = T, col = "red")
graphics::box(bty = "l")
})
params <- reactive({
list('Baseline Population' = list(Mean = sim$baseline_mean,
SD = sim$baseline_sd),
'Event Population' = list(Count = input$sim_n_events,
'Mean Displacement' = sim$step,
SD = sim$step_sd),
'Pi Release' = list(Occurs = sim$pi_release,
Rate = sim$pi_release_rate,
Lower = sim$pi_release_lower,
Upper = sim$pi_release_upper),
'ADP Release' = list(Rate = sim$adp_release_rate,
Lower = sim$adp_release_lower,
Upper = sim$adp_release_upper),
Hitch = paste0(sim$hitch_size, ' nm'),
'ATP Binding' = list(Rate = sim$atp_binding_rate,
Lower = sim$atp_binding_lower,
Upper = sim$atp_binding_upper),
'Time Off' = list(Rate = sim$time_off_rate,
Lower = sim$time_off_lower,
Upper = sim$time_off_upper),
Hz = input$sim_hz,
Signal = input$sim_signal
)
})
output$sim_parameters <- renderPrint({
# cat("Current Simulation Parameters: \n",
# "Baseline: \n",
# " Mean = ", paste0(input$sim_baseline_mean), "\n",
# " SD = ", paste0(input$sim_baseline_sd)
str(params())
})
output$sim_pi_release_rate_conversion <- renderText({
rate <- 1/input$sim_pi_release_rate
paste0("1/Hz = ", rate)
})
output$sim_adp_release_conversion <- renderText({
rate <- 1/input$sim_adp_release_rate
paste0("1/Hz = ", rate)
})
output$sim_atp_binding_conversion <- renderText({
rate <- 1/input$sim_atp_binding_rate
paste0("1/Hz = ", rate)
})
output$sim_time_off_conversion <- renderText({
rate <- 1/input$sim_time_off_rate
paste0("1/Hz = ", rate)
})
sim_data <- eventReactive(input$sim_go, {
# browser()
if(input$sim_pi_release_occurs == "uncoupled"){
pi_release <- "uncoupled"
} else {
pi_release <- list(rate = sim$pi_release_rate,
lower = sim$pi_release_lower,
upper = sim$pi_release_upper,
occurs = sim$pi_release)
}
# if(input$sim_adp_release_type == "set_time"){
# adp_release <- list(set_time = input$sim_adp_release_set_time,
# hitch = input$sim_hitch_size)
# } else {
adp_release <- list(rate = sim$adp_release_rate,
lower = sim$adp_release_lower,
upper = sim$adp_release_upper,
hitch = sim$hitch_size)
#}
# if(input$sim_atp_binding_type == "set_time"){
# atp_binding <- list(set_time = input$sim_atp_binding_set_time)
# } else {
atp_binding <- list(rate = sim$atp_binding_rate,
lower = sim$atp_binding_lower,
upper = sim$atp_binding_upper)
# }
simulate_single_molecule_trap_data(n = input$sim_n_events,
hz = input$sim_hz,
signal_to_noise = input$sim_signal,
baseline = list(mean = sim$baseline_mean,
sd = sim$baseline_sd),
displacement = list(mean = sim$step,
sd = sim$step_sd),
pi_release = pi_release,
adp_release = adp_release,
atp_binding = atp_binding,
time_off = list(rate = sim$time_off_rate,
lower = sim$time_off_lower,
upper = sim$time_off_upper))
})
output$sim <- dygraphs::renderDygraph({
dygraphs::dygraph(data.frame(Datapoints = sim_data()$time, nm = sim_data()$data)) |>
dygraphs::dySeries("nm", color = "black") |>
dygraphs::dyRangeSelector()
})
observeEvent(input$sim_save, {
defend_if_empty(f$project_input, ui = "Please select a 'Project' folder.", type = "error")
defend_if_blank(f$project_input, ui = "Please select a 'Project' folder.", type = "error")
allow_if(grepl("simulation", tolower(f$project_input)), ui = "The 'Project' folder must have 'simulation' in its name to save simulated data to it.")
defend_if_blank(f$conditions_input, ui = "Please select a 'Conditions folder.", type = "error")
allow_if(grepl("simulation", tolower(f$conditions_input)), ui = "The 'Conditions' folder must have 'simulation' in its name to save simulated data to it.")
defend_if_blank(f$date_input, ui = "Please select a 'Date' Folder.", type = "error")
allow_if(is.data.frame(sim_data()), ui = "No simulation data to save")
withProgress(message = "Saving Simulation Data", {
num_obs_folders <- nrow(list_files(f$date$path)) + 1
if(num_obs_folders < 10){
obs_name <- paste0("obs-0", num_obs_folders)
} else {
obs_name <- paste0("obs-", num_obs_folders)
}
setProgress(0.5, detail = "Preparing Data")
trap_data_to_save <- sim_data() |>
dplyr::mutate(project = f$project_input,
conditions = f$conditions_input,
date = f$date_input,
obs = obs_name,
raw_bead = data,
processed_bead = data)
options_to_save <- data.frame(
project = f$project_input,
conditions = f$conditions_input,
date = f$date_input,
obs = obs_name,
mv2nm = 1,
nm2pn = 1,
include = TRUE,
processor = "sim",
report = "not run",
analyzer = NA,
review = NA,
channels = 1,
hz = input$sim_hz,
sim_baseline_mean = sim$baseline_mean,
sim_baseline_sd = sim$baseline_sd,
sim_step = sim$step,
sim_step_sd = sim$step_sd,
sim_pi_release = sim$pi_release,
sim_pi_release_rate = sim$pi_release_rate ,
sim_pi_release_lower = sim$pi_release_lower,
sim_pi_release_upper = sim$pi_release_upper,
sim_adp_release = sim$adp_release,
sim_adp_release_rate = sim$adp_release_rate,
sim_adp_release_lower = sim$adp_release_lower,
sim_adp_release_upper = sim$adp_release_upper,
sim_hitch_size = sim$hitch_size,
sim_atp_binding_rate = sim$atp_binding_rate,
sim_atp_binding_upper = sim$atp_binding_upper,
sim_atp_binding_lower = sim$atp_binding_lower,
sim_time_off_rate = sim$time_off_rate,
sim_time_off_upper = sim$time_off_upper,
sim_time_off_lower = sim$time_off_lower)
sim_save_folder <- file.path(f$date$path, obs_name)
setProgress(0.9, detail = "Writing")
dir.create(sim_save_folder)
filenames <- c("trap-data.csv", "options.csv")
data_to_save <- list(trap_data_to_save, options_to_save)
purrr::walk2(data_to_save, filenames, ~data.table::fwrite(.x, file = file.path(sim_save_folder, .y)))
})
showNotification(ui = "Simulation data saved", type = "message")
})
############## read lumicks
observeEvent(input$lumicks_upload, {
defend_if_empty(f$project, "No 'Project' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$conditions, "No 'Conditions' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$date, "No 'Date' folder selected. Please select a folder with the folder chooser above.")
## defend_if_equal(input$hz == 0, "Please enter sampling frequency, Hz.")
req(nchar(f$date$path>0))
input_data <- parseFilePaths(c(home=dirname(path.expand("~"))), input$file_input_lumicks)
read_lumicks(input_data = input_data,
project = f$project,
conditions = f$conditions,
date = f$date,
downsample_by = input$downsample_lumicks,
has_stage_position = input$has_stage_position,
round_stage = input$round_stage)
print("Marangatang strikes again")
f$new_obs_from_split <- f$new_obs_from_split + 1
})
#### file choose ####
# shinyFiles::shinyFileChoose(
# input = input,
# id = "file_select",
# roots= shinyFiles::getVolumes(),
# filetypes=c('', 'txt', 'csv'),
# session = session)
#
#
#
# output$selected_files_to_upload <- renderPrint({
# cat(input$file_select)
# })
}
## To be copied in the UI
# mod_split_obs_ui("split_obs")
## To be copied in the server
# callModule(mod_split_obs_server, "split_obs")
brentscott93/lasertrapr documentation built on Aug. 29, 2024, 6:47 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions mod_split_obs_server mod_split_obs_ui
#' split_obs UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#' @import shinyFiles
#' @importFrom shiny NS tagList
mod_split_obs_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(box(width = 3,
collapsible = TRUE, collapsed = FALSE,
title = "Upload Data",
shinyWidgets::radioGroupButtons(
inputId = ns("upload_method"),
label = 'Method',
choices = c("Upload" = "upload",
"Lumicks" = "lumicks",
"Split Obs" = "split_obs"),
direction = "horizontal",
width = "100%",
justified = TRUE,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
conditionalPanel(
condition = " input.upload_method == 'upload'", ns = ns,
fluidRow(
column(12,
shinyFiles::shinyFilesButton(ns("file_input"),
label = "Browse for file...",
title = "Select one or more file",
multiple = TRUE,
style = "width: 100%; margin-bottom: 5px;"),
)
),
fluidRow(
column(6,
shinyWidgets::radioGroupButtons(
inputId = ns("channels"),
label = 'Number of Channels',
choices = c(1, 2),
direction = "horizontal",
width = "100%",
justified = TRUE,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)),
column(6,style = "padding-top: 32px;",
shinyWidgets::prettyCheckbox(ns("in_header"),
"Cal in header?",
value = FALSE,
outline = TRUE,
shape = "curve",
status = "primary" ))
),
conditionalPanel(
condition = "input.in_header == true", ns = ns,
fluidRow(
column(6,
numericInput(ns("header_size"),
label = "Header Size",
value = 68,
step = 1)),
column(6,
numericInput(ns("header_hz"),
label = "Hz",
value = 15,
step = 1))
),
fluidRow(
column(6,
numericInput(ns("header_nm_v1"),
label = "nm/V",
value = 22,
step = 1,
width = "100%")),
column(6,
numericInput(ns("header_pn_nm1"),
label = "pN/nm",
value = 18,
step = 1,
width = "100%")
)
),
conditionalPanel(
condition = "input.channels == 2", ns = ns,
fluidRow(
column(6,
numericInput(ns("header_nm_v2"),
label = "nm/V 2",
value = 24,
step = 1,
width = "100%"),
),
column(6,
numericInput(ns("header_pn_nm2"),
label = "pN/nm 2",
value = 20,
step = 1,
width = "100%")
)
),
fluidRow(
column(6,
numericInput(ns("trap1_col"),
label = "Trap 1 Col",
value = 1,
step = 1,
width = "100%"),
),
column(6,
numericInput(ns("trap2_col"),
label = "Trap 2 Col",
value = 3,
step = 1,
width = "100%")
)
),
fluidRow(
column(6,
numericInput(
inputId = ns("feedback_motor_bead"),
label = "Feedback Motor Bead",
value = 30
)
)
)
) # conditional panel input.channels ==2
), # conditional panel header
conditionalPanel(
condition = "input.in_header == false", ns = ns,
fluidRow(
column(6,
numericInput(ns("hz"), "Hz", 0)
),
column(6,
div(style = "padding-top: 32px;",
shinyWidgets::prettyCheckbox(ns("ready_for_analysis"),
"Ready for analysis?",
value = FALSE,
outline = TRUE,
shape = "curve",
status = "primary" )
))
),
conditionalPanel(
condition = " input.ready_for_analysis == true", ns = ns,
numericInput(ns("nm_to_pn"), "Stiffness Conversion (pN/nm)", value = 0.04)
)
),
numericInput(ns("downsample_by"), "Downsample By (factor)", value = 1),
actionButton(ns("simple_upload_button"),
"Initialize Data",
width = "100%",
icon = icon("play-circle"),
style = 'margin-top: 25px;')
), #conditional close
conditionalPanel(
condition = " input.upload_method == 'lumicks'", ns = ns,
fluidRow(
column(12,
shinyFiles::shinyFilesButton(ns("file_input_lumicks"),
label = "Browse for H5...",
title = "Select one or more file",
multiple = TRUE,
style = "width: 100%; margin-bottom: 5px;"),
)
),
fluidRow(
column(6,
numericInput(ns("downsample_lumicks"), "Downsample By (factor)", value = 1),
checkboxInput(ns("has_stage_position"), "Stage Position?"),
checkboxInput(ns("round_stage"), "Round Stage?")
),
column(6,
actionButton(ns("lumicks_upload"),
"Initialize Data",
width = "100%",
icon = icon("play-circle"),
style = 'margin-top: 25px;')
)
)
), #conditional close
conditionalPanel(
condition = " input.upload_method == 'split_obs'", ns = ns,
fileInput(ns("trap_txt_upload"),
'Upload Data Files (.txt)',
multiple = TRUE,
accept = ".txt",
buttonLabel = "Browse...",
placeholder = "Data.txt"),
# strong( h5("2) Choose number of seconds to split by")),
shinyWidgets::knobInput(inputId = ns("threshold"),
label = 'Set Threshold to Split',
value = 20,
min = 10,
max = 30),
actionButton(inputId = ns("split_obs_button"),
label = "Make Observations",
icon = icon("eye"),
width = "100%",
style = 'margin-top: 25px;')
) #conditional close
), #box close,
box(title = "Simulate Data", width = 9, collapsible = T, collapsed = T,
fluidRow(
column(2,
numericInput(ns("sim_n_events"), "Events", value = 100, min = 10, max = 200, step = 1)
),
column(2,
numericInput(ns("sim_signal"), "Signal", value = 2.5, min = 1.5, max = 10, step = 0.1)
),
column(2,
numericInput(ns("sim_hz"), "Hz", value = 5000, min = 0, max = 20000)
),
column(2,
actionButton(ns("sim_options"), "Options", width = "100%", style = "margin-top: 25px;")
),
column(2,
actionButton(ns("sim_go"), "Simulate Data", width = "100%", style = "margin-top: 25px;")
),
column(2,
actionButton(ns("sim_save"), "Save", width = "100%", style = "margin-top: 25px;")
)
),
fluidRow(
column(3,
h6("Current Simulation Parameters:"),
verbatimTextOutput(ns("sim_parameters"))
),
column(9,
dygraphs::dygraphOutput(ns('sim')) |> shinycssloaders::withSpinner(type = 8, color = "#373B38")
)
)
)
),
fluidRow(
box(title = 'Step Calibration', width = 6, collapsible = T, collapsed = T,
fluidRow(column(3, fileInput(ns('step_files'),
'Upload Step File (.txt)',
accept = 'text/plain',
multiple = T,
width = '100%',
placeholder = 'Step.txt'),
#shinyWidgets::setSliderColor('#ff41c8', c(1, 2)),
numericInput(ns('step_cal_stepsize'),
'Step Cal Step Size',
min = NA,
max = NA,
value = 50,
step = 1,
width = '100%'),
actionButton(ns('step_button'), 'Step Cal', width = '100%', style = 'margin-top: 25px;'),
tags$style(".small-box.bg-yellow { background-color: #1B9E77 !important; color: #f2f2f2 !important; }"),
valueBoxOutput(ns("step_cal_valueBox"), width = 2),
),
column(9,
plotOutput(ns('step'), width = '100%', height = '275px') |>
shinycssloaders::withSpinner(type = 8, color = "#373B38"))
)
), #box close
box(title = 'Equipartition', width = 6, collapsible = T, collapsed = T,
fluidRow(
column(3, fileInput(ns('equi_file'),
'Upload Equi File (.txt)',
placeholder = 'Equi.txt',
accept = '.txt'),
numericInput(ns('equi_mv2nm'),
'mV to nm conversion',
min = NA,
max = NA,
value = 30,
step = 1,
width = '100%'),
withMathJax(helpText("$$\\alpha_{trap}=\\frac{k_B*T_k}{\\sigma^2}$$")),
actionButton(ns('equi_button'),
'Equi Cal',
width = '100%',
style = 'margin-top: 25px;'),
valueBoxOutput(ns("equipartition_valueBox"), width = 2)),
column(9,
plotOutput(ns('equi'), width = '100%', height = '275px') |>
shinycssloaders::withSpinner(type = 8, color = "#373B38"))
)
)
) #row close
) #tagList
}
#' split_obs Server Function
#'
#' @noRd
#' @import shinyFiles
mod_split_obs_server <- function(input, output, session, f){
ns <- session$ns
shinyFileChoose(input = input,
id = "file_input",
roots = c(home=dirname(path.expand("~"))),
defaultRoot = "home",
defaultPath = "",
session = session)
shinyFileChoose(input = input,
id = "file_input_lumicks",
roots = c(home=dirname(path.expand("~"))),
defaultRoot = "home",
defaultPath = "",
session = session)
## header cal info
## these values correspond to the LINE NUMBERS where the info can be found in the headers of the data files
h <- reactiveValues(header_size = 0,
hz = 0,
nm_v1 = 0,
nm_v2 = 0,
pn_nm1 = 0,
pn_nm2 = 0,
trap1_col = 0,
trap2_col = 0,
feedback_motor_bead = 0)
observe({
h$header_size <- input$header_size
h$hz <- input$header_hz
h$nm_v1 <- input$header_nm_v1
h$nm_v2 <- input$header_nm_v2
h$pn_nm1 <- input$header_pn_nm1
h$pn_nm2 <- input$header_pn_nm2
h$trap1_col <- input$trap1_col
h$trap2_col <- input$trap2_col
h$feedback_motor_bead <- input$feedback_motor_bead
})
observeEvent(input$simple_upload_button, {
defend_if_empty(f$project, "No 'Project' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$conditions, "No 'Conditions' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$date, "No 'Date' folder selected. Please select a folder with the folder chooser above.")
## defend_if_equal(input$hz == 0, "Please enter sampling frequency, Hz.")
req(nchar(f$date$path>0))
input_data <- parseFilePaths(c(home=dirname(path.expand("~"))), input$file_input)
if(input$in_header){
upload_data_cal_in_header(input_data = input_data,
h = h,
project = f$project,
conditions = f$conditions,
date = f$date,
number_of_channels = input$channels,
downsample_by = input$downsample_by)
} else {
simple_upload(input_data = input_data,
project = f$project,
conditions = f$conditions,
date = f$date,
nm2pn = input$nm_to_pn,
ready_for_analysis = input$ready_for_analysis,
hz = input$hz,
number_of_channels = input$channels,
downsample_by = input$downsample_by)
}
f$new_obs_from_split <- f$new_obs_from_split + 1
})
#check if a date folder is properly selected
observeEvent(input$split_obs_button, {
## golem::print_dev("go")
if(rlang::is_empty(f$date) == TRUE){
showNotification("No 'Date' folder selected. Please select a folder with the folder chooser above. ",
type = "error")
} else if(rlang::is_empty(input$trap_txt_upload)){
showNotification("No data uploaded",
type = "error")
} else {
req(nchar(f$date$path>0))
req(input$trap_txt_upload)
all_data <- purrr::map(input$trap_txt_upload$name, ~substring(.x, 1, 4) == 'Data')
if(all(all_data != TRUE)){
showNotification("Not all files are valid 'Data' files. Only upload files starting with 'Data'.",
type = "error")
} else {
## golem::print_dev('before split_obs call')
split_obs(input_data = input$trap_txt_upload,
project = f$project,
conditions = f$conditions,
date = f$date,
threshold = input$threshold)
f$new_obs_from_split <- f$new_obs_from_split + 1
}
}
})
####cal####
#Start trap calibrations
e <- reactiveValues()
observeEvent(input$equi_button, {
if(rlang::is_empty(input$equi_file)){
showNotification('No data uploaded', type = 'error')
## } else if(substring(input$equi_file$name, 1, 4) != 'Equi') {
## showNotification("Not a valid 'Equi' file.", type = 'error')
} else {
withProgress(message = "Equipartition Calibration", min= 0, max = 1, value = 0.01, {
incProgress(0.25, detail = "Reading Data")
files <- data.table::fread(input$equi_file$datapath, col.names = c('bead', 'trap')) |>
dplyr::mutate(bead = bead * input$equi_mv2nm) |>
dplyr::pull(bead)
mean_equi <- mean(files)
equi_data <- files - mean_equi
e$vector <- equi_data
incProgress(0.75, detail = "Calculating")
e$cal <- equipartition(equi_data)
})
}
})
output$equi <- renderPlot( {
req(e$vector)
plot(e$vector, ylab = 'nm', xlab = 'Datapoints', type = 'l')
})
output$equipartition_valueBox <- renderValueBox({
req(e$cal)
valueBox(
value = round(e$cal, 3),
subtitle = "Trap Stiffness (pN/nm)",
icon = icon("ruler-vertical"),
width = "100%",
color = 'yellow'
)
})
observeEvent(input$step_button, {
if(rlang::is_empty(input$step_files)){
showNotification('No data uploaded', type = 'error')
} else if(substring(input$step_files$name, 1, 4) != 'Step') {
showNotification("Not a valid 'Step' file.", type = 'error')
}
})
step_calibration <- eventReactive(input$step_button, {
req(input$step_files$datapath)
## req(substring(input$step_files$name, 1, 4) == 'Step')
withProgress(message = "Step Calibration", min= 0, max = 1, value = 0.01, {
incProgress(0.4, detail = "Reading Data")
files <- purrr::map(input$step_files$datapath, fread, col.names = c('bead', 'trap')) |>
purrr::map(dplyr::pull, bead)
incProgress(0.75, detail = "Calculating...This may take a while...")
steps <- purrr::map(files, step_cal, step = input$step_cal_stepsize)
incProgress(1, detail = "Done!")
})
return(steps)
})
conversion <- reactive({
conv1 <- purrr::map(step_calibration(), "mv2nm_conversion")
conv2 <- round(mean(abs(unlist(conv1))), 2)
})
output$step_cal_valueBox <- renderValueBox({
valueBox(
value = conversion(),
subtitle = "Step Calibration (nm/mV)",
icon = icon("ruler-horizontal"),
width = "100%",
color = "yellow"
)
})
step_calibration_plot <- reactive({
grobs <- purrr::map(step_calibration(), "plot")
p <- gridExtra::grid.arrange(grobs = grobs, ncol = 1)
return(p)
})
output$step <- renderPlot({
step_calibration_plot()
})
sim <- reactiveValues(baseline_mean = 0,
baseline_sd = 8,
step = 5,
step_sd = 8,
pi_release = "after",
pi_release_rate = 200,
pi_release_lower = 1/1000,
pi_release_upper = 1,
adp_release = "set_time",
adp_release_rate = 20,
adp_release_lower = 1/1000,
adp_release_upper = 1,
hitch_size = 2,
atp_binding = "set_time",
atp_binding_rate = 50,
atp_binding_upper = 1,
atp_binding_lower = 20/1000,
time_off_rate = 1,
time_off_upper = 10000/1000,
time_off_lower = 100/1000)
observeEvent(input$sim_ok, {
sim$baseline_mean = input$sim_baseline_mean
sim$baseline_sd = input$sim_baseline_sd
sim$step = input$sim_displacement_mean
sim$step_sd = input$sim_displacement_sd
sim$pi_release = input$sim_pi_release_occurs
sim$pi_release_rate = input$sim_pi_release_rate
sim$pi_release_lower = input$sim_pi_release_lower
sim$pi_release_upper = input$sim_pi_release_upper
# sim$adp_release = sim_adp_release_type
sim$adp_release_rate = input$sim_adp_release_rate
sim$adp_release_lower = input$sim_adp_release_lower
sim$adp_release_upper = input$sim_adp_release_upper
sim$hitch_size = input$sim_hitch_size
sim$atp_binding_rate = input$sim_atp_binding_rate
sim$atp_binding_upper = input$sim_atp_binding_upper
sim$atp_binding_lower = input$sim_atp_binding_lower
sim$time_off_rate = input$sim_time_off_rate
sim$time_off_upper = input$sim_time_off_upper
sim$time_off_lower = input$sim_time_off_lower
removeModal()
})
observeEvent(input$sim_options, {
showModal(
modalDialog(
size = "l",
title = "Define Simulation Parameters",
footer = tagList(modalButton("Cancel"), actionButton(ns("sim_ok"), "OK")),
tabsetPanel(
tabPanel("Baseline",
sliderInput(ns("sim_baseline_mean"), "Mean", value = sim$baseline_mean, step = 1, round = TRUE, min = -50, max = 50, width = "100%"),
sliderInput(ns("sim_baseline_sd"), "SD", value = sim$baseline_sd, step = 1, round = TRUE, min = 0, max = 15, width = "100%"),
plotOutput(ns("sim_baseline_histogram"))
),
tabPanel("Displacements",
sliderInput(ns("sim_displacement_mean"), "Mean", value = sim$step, step = 1, round = TRUE, min = -50, max = 50, width = "100%"),
sliderInput(ns("sim_displacement_sd"), "SD", value = sim$step_sd, step = 1, round = TRUE, min = 0, max = 15, width = "100%"),
plotOutput(ns("sim_displacement_histogram"))
),
tabPanel("Pi Release",
br(),
shinyWidgets::radioGroupButtons(
inputId = ns('sim_pi_release_occurs'),
label = "Pi release before or after stroke?",
choices = c("Before" = "before",
"After" = "after",
"Uncoupled" = "uncoupled"),
justified = TRUE,
selected = sim$pi_release,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
conditionalPanel(condition = "input.sim_pi_release_occurs != 'uncoupled'", ns = ns,
fluidRow(
column(6,
numericInput(ns("sim_pi_release_rate"), "Avg Rate (Hz)", value = sim$pi_release_rate, max = 500, min = 0, step = 5, width = "100%")
),
column(6,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_pi_release_rate_conversion")))
)
),
sliderInput(ns("sim_pi_release_lower"),
"Lower (ms)",
value = sim$pi_release_lower,
step = 1/1000,
round = TRUE,
min = 1/1000,
max = 50/1000,
width = "100%"),
sliderInput(ns("sim_pi_release_upper"), "Upper (ms)",
value = sim$pi_release_upper,
step = 1/1000,
round = TRUE,
min = 0/1000,
max = round(max(rexp(10000, sim$pi_release_rate)), 3),
width = "100%"),
plotOutput(ns("sim_pi_release_histogram"))
)
),
tabPanel("ADP Release",
# shinyWidgets::radioGroupButtons(
# inputId = ns('sim_adp_release_type'),
# label = "",
# choices = c("Use Distribution" = "distribution",
# "Set Time" = "set_time"),
# justified = TRUE,
# selected = sim$adp_release,
# checkIcon = list(
# yes = tags$i(class = "fa fa-check-square",
# style = "color: black"),
# no = tags$i(class = "fa fa-square-o",
# style = "color: black"))
# ),
fluidRow(
# conditionalPanel(condition = "input.sim_adp_release_type == 'distribution'", ns = ns,
column(4,
numericInput(ns("sim_adp_release_rate"), "Avg Rate (Hz)", value = sim$adp_release_rate, max = 500, min = 0, step = 5, width = "100%"),
),
column(4,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_adp_release_conversion")))
),
# ),
# conditionalPanel(condition = "input.sim_adp_release_type == 'set_time'", ns = ns,
# column(8,
# sliderInput(ns("sim_adp_release_set_time"), label = "Set Time", min = 0, max = 1000, value = sim$adp_release_rate, width = "100%")
#
# )
# ),
column(4,
numericInput(ns("sim_hitch_size"), "Hitch Size (nm)", value = sim$hitch_size, step = 0.5, min = 0, max = 10, width = "100%")
)
),
# conditionalPanel(condition = "input.sim_adp_release_type == 'distribution'", ns = ns,
sliderInput(ns("sim_adp_release_lower"),
"Lower (ms)",
value = sim$adp_release_lower,
step = 1/1000,
round = TRUE,
min = 0,
max = 50/1000,
width = "100%"),
sliderInput(ns("sim_adp_release_upper"),
"Upper (ms)",
value = sim$adp_release_upper,
step = 10/1000,
round = TRUE,
min = 0,
max = round(max(rexp(10000,sim$adp_release_rate)), 3),
width = "100%"),
plotOutput(ns("sim_adp_release_histogram"))
# )
),
tabPanel("ATP Binding",
# shinyWidgets::radioGroupButtons(
# inputId = ns('sim_atp_binding_type'),
# label = "",
# choices = c("Use Distribution" = "distribution",
# "Set Time" = "set_time"),
# justified = TRUE,
# selected = sim$atp_binding,
# checkIcon = list(
# yes = tags$i(class = "fa fa-check-square",
# style = "color: black"),
# no = tags$i(class = "fa fa-square-o",
# style = "color: black"))
# ),
# conditionalPanel(condition = "input.sim_atp_binding_type == 'distribution'", ns = ns,
fluidRow(
column(6,
numericInput(ns("sim_atp_binding_rate"),
"Rate (1/mean)",
value = sim$atp_binding_rate,
max = 1000,
min = 0,
step = 5,
width = "100%")
),
column(6,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_atp_binding_conversion")))
),
),
sliderInput(ns("sim_atp_binding_lower"),
"Lower (ms)",
value = sim$atp_binding_lower,
step = 1/1000,
round = TRUE,
min = 0,
max = 100/1000,
width = "100%"),
sliderInput(ns("sim_atp_binding_upper"),
"Upper (ms)",
value = sim$atp_binding_upper,
step = 10/1000,
round = TRUE,
min = 0,
max = round(max(rexp(10000, sim$atp_binding_rate)), 3),
width = "100%"),
plotOutput(ns("sim_atp_binding_histogram"))
# ),
# conditionalPanel(condition = "input.sim_atp_binding_type == 'set_time'", ns = ns,
# sliderInput(ns("sim_atp_binding_set_time"), label = "Set Rate", min = 1, max = 5000, value = sim$atp_binding_rate, width = "100%")
# )
),
tabPanel("Time Off",
fluidRow(
column(6,
numericInput(ns("sim_time_off_rate"),
"Rate (1/mean)",
value = sim$time_off_rate,
max = 10,
min = 0,
step = 0.5,
width = "100%")
),
column(6,
div(style = 'margin-top: 22px;', verbatimTextOutput(ns("sim_time_off_conversion")))
)
),
sliderInput(ns("sim_time_off_lower"),
"Lower (ms)",
value = sim$time_off_lower,
step = 1/1000,
round = TRUE,
min = 0,
max = 100/1000,
width = "100%"),
sliderInput(ns("sim_time_off_upper"),
"Upper (ms)",
value = sim$time_off_upper,
step = 100/1000,
round = TRUE,
min = 0,
max = round(max(rexp(10000, sim$time_off_rate)), 3),
width = "100%"),
plotOutput(ns("sim_time_off_histogram"))
)
)
)
)
})
output$sim_baseline_histogram <- renderPlot({
x <- rnorm(100000, input$sim_baseline_mean, input$sim_baseline_sd)
hist(x, xlab = "nm", main = "Simulated Baseline Distribution (n = 100k)", breaks = (min(x)-1):(max(x)+1), freq = F)
curve(dnorm(x, input$sim_baseline_mean, input$sim_baseline_sd), add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_displacement_histogram <- renderPlot({
x <- rnorm(100000, mean = input$sim_displacement_mean, sd = input$sim_displacement_sd)
hist(x, xlab = "nm", main = "Simulated Displacement Distribution (n = 100k)", breaks = (min(x)-1):(max(x)+1), freq = F)
curve(dnorm(x, input$sim_displacement_mean, input$sim_displacement_sd), add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_adp_release_histogram <- renderPlot({
rate <- input$sim_adp_release_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_adp_release_lower,
b = input$sim_adp_release_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated ADP Release Rate (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
a = input$sim_adp_release_lower,
b = input$sim_adp_release_upper,
rate = rate),
add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_time_off_histogram <- renderPlot({
rate <- input$sim_time_off_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_time_off_lower,
b = input$sim_time_off_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated Time Off Distribution (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
a = input$sim_time_off_lower,
b = input$sim_time_off_upper,
rate = rate),
add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_atp_binding_histogram <- renderPlot({
rate <- input$sim_atp_binding_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_atp_binding_lower,
b = input$sim_atp_binding_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated Hitch Duration Distribution (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
rate = rate,
a = input$sim_atp_binding_lower,
b = input$sim_atp_binding_upper),
add = T, col = "red")
graphics::box(bty = "l")
})
output$sim_pi_release_histogram <- renderPlot({
rate <- input$sim_pi_release_rate
x <- truncdist::rtrunc(100000,
spec = "exp",
a = input$sim_pi_release_lower,
b = input$sim_pi_release_upper,
rate = rate)
hist(x, xlab = "Seconds", main = "Simulated Pi Release Duration Distribution (n = 100k)", freq = F)
curve(truncdist::dtrunc(x,
spec = "exp",
rate = rate,
a = input$sim_pi_release_lower,
b = input$sim_pi_release_upper),
add = T, col = "red")
graphics::box(bty = "l")
})
params <- reactive({
list('Baseline Population' = list(Mean = sim$baseline_mean,
SD = sim$baseline_sd),
'Event Population' = list(Count = input$sim_n_events,
'Mean Displacement' = sim$step,
SD = sim$step_sd),
'Pi Release' = list(Occurs = sim$pi_release,
Rate = sim$pi_release_rate,
Lower = sim$pi_release_lower,
Upper = sim$pi_release_upper),
'ADP Release' = list(Rate = sim$adp_release_rate,
Lower = sim$adp_release_lower,
Upper = sim$adp_release_upper),
Hitch = paste0(sim$hitch_size, ' nm'),
'ATP Binding' = list(Rate = sim$atp_binding_rate,
Lower = sim$atp_binding_lower,
Upper = sim$atp_binding_upper),
'Time Off' = list(Rate = sim$time_off_rate,
Lower = sim$time_off_lower,
Upper = sim$time_off_upper),
Hz = input$sim_hz,
Signal = input$sim_signal
)
})
output$sim_parameters <- renderPrint({
# cat("Current Simulation Parameters: \n",
# "Baseline: \n",
# " Mean = ", paste0(input$sim_baseline_mean), "\n",
# " SD = ", paste0(input$sim_baseline_sd)
str(params())
})
output$sim_pi_release_rate_conversion <- renderText({
rate <- 1/input$sim_pi_release_rate
paste0("1/Hz = ", rate)
})
output$sim_adp_release_conversion <- renderText({
rate <- 1/input$sim_adp_release_rate
paste0("1/Hz = ", rate)
})
output$sim_atp_binding_conversion <- renderText({
rate <- 1/input$sim_atp_binding_rate
paste0("1/Hz = ", rate)
})
output$sim_time_off_conversion <- renderText({
rate <- 1/input$sim_time_off_rate
paste0("1/Hz = ", rate)
})
sim_data <- eventReactive(input$sim_go, {
# browser()
if(input$sim_pi_release_occurs == "uncoupled"){
pi_release <- "uncoupled"
} else {
pi_release <- list(rate = sim$pi_release_rate,
lower = sim$pi_release_lower,
upper = sim$pi_release_upper,
occurs = sim$pi_release)
}
# if(input$sim_adp_release_type == "set_time"){
# adp_release <- list(set_time = input$sim_adp_release_set_time,
# hitch = input$sim_hitch_size)
# } else {
adp_release <- list(rate = sim$adp_release_rate,
lower = sim$adp_release_lower,
upper = sim$adp_release_upper,
hitch = sim$hitch_size)
#}
# if(input$sim_atp_binding_type == "set_time"){
# atp_binding <- list(set_time = input$sim_atp_binding_set_time)
# } else {
atp_binding <- list(rate = sim$atp_binding_rate,
lower = sim$atp_binding_lower,
upper = sim$atp_binding_upper)
# }
simulate_single_molecule_trap_data(n = input$sim_n_events,
hz = input$sim_hz,
signal_to_noise = input$sim_signal,
baseline = list(mean = sim$baseline_mean,
sd = sim$baseline_sd),
displacement = list(mean = sim$step,
sd = sim$step_sd),
pi_release = pi_release,
adp_release = adp_release,
atp_binding = atp_binding,
time_off = list(rate = sim$time_off_rate,
lower = sim$time_off_lower,
upper = sim$time_off_upper))
})
output$sim <- dygraphs::renderDygraph({
dygraphs::dygraph(data.frame(Datapoints = sim_data()$time, nm = sim_data()$data)) |>
dygraphs::dySeries("nm", color = "black") |>
dygraphs::dyRangeSelector()
})
observeEvent(input$sim_save, {
defend_if_empty(f$project_input, ui = "Please select a 'Project' folder.", type = "error")
defend_if_blank(f$project_input, ui = "Please select a 'Project' folder.", type = "error")
allow_if(grepl("simulation", tolower(f$project_input)), ui = "The 'Project' folder must have 'simulation' in its name to save simulated data to it.")
defend_if_blank(f$conditions_input, ui = "Please select a 'Conditions folder.", type = "error")
allow_if(grepl("simulation", tolower(f$conditions_input)), ui = "The 'Conditions' folder must have 'simulation' in its name to save simulated data to it.")
defend_if_blank(f$date_input, ui = "Please select a 'Date' Folder.", type = "error")
allow_if(is.data.frame(sim_data()), ui = "No simulation data to save")
withProgress(message = "Saving Simulation Data", {
num_obs_folders <- nrow(list_files(f$date$path)) + 1
if(num_obs_folders < 10){
obs_name <- paste0("obs-0", num_obs_folders)
} else {
obs_name <- paste0("obs-", num_obs_folders)
}
setProgress(0.5, detail = "Preparing Data")
trap_data_to_save <- sim_data() |>
dplyr::mutate(project = f$project_input,
conditions = f$conditions_input,
date = f$date_input,
obs = obs_name,
raw_bead = data,
processed_bead = data)
options_to_save <- data.frame(
project = f$project_input,
conditions = f$conditions_input,
date = f$date_input,
obs = obs_name,
mv2nm = 1,
nm2pn = 1,
include = TRUE,
processor = "sim",
report = "not run",
analyzer = NA,
review = NA,
channels = 1,
hz = input$sim_hz,
sim_baseline_mean = sim$baseline_mean,
sim_baseline_sd = sim$baseline_sd,
sim_step = sim$step,
sim_step_sd = sim$step_sd,
sim_pi_release = sim$pi_release,
sim_pi_release_rate = sim$pi_release_rate ,
sim_pi_release_lower = sim$pi_release_lower,
sim_pi_release_upper = sim$pi_release_upper,
sim_adp_release = sim$adp_release,
sim_adp_release_rate = sim$adp_release_rate,
sim_adp_release_lower = sim$adp_release_lower,
sim_adp_release_upper = sim$adp_release_upper,
sim_hitch_size = sim$hitch_size,
sim_atp_binding_rate = sim$atp_binding_rate,
sim_atp_binding_upper = sim$atp_binding_upper,
sim_atp_binding_lower = sim$atp_binding_lower,
sim_time_off_rate = sim$time_off_rate,
sim_time_off_upper = sim$time_off_upper,
sim_time_off_lower = sim$time_off_lower)
sim_save_folder <- file.path(f$date$path, obs_name)
setProgress(0.9, detail = "Writing")
dir.create(sim_save_folder)
filenames <- c("trap-data.csv", "options.csv")
data_to_save <- list(trap_data_to_save, options_to_save)
purrr::walk2(data_to_save, filenames, ~data.table::fwrite(.x, file = file.path(sim_save_folder, .y)))
})
showNotification(ui = "Simulation data saved", type = "message")
})
############## read lumicks
observeEvent(input$lumicks_upload, {
defend_if_empty(f$project, "No 'Project' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$conditions, "No 'Conditions' folder selected. Please select a folder with the folder chooser above.")
defend_if_empty(f$date, "No 'Date' folder selected. Please select a folder with the folder chooser above.")
## defend_if_equal(input$hz == 0, "Please enter sampling frequency, Hz.")
req(nchar(f$date$path>0))
input_data <- parseFilePaths(c(home=dirname(path.expand("~"))), input$file_input_lumicks)
read_lumicks(input_data = input_data,
project = f$project,
conditions = f$conditions,
date = f$date,
downsample_by = input$downsample_lumicks,
has_stage_position = input$has_stage_position,
round_stage = input$round_stage)
print("Marangatang strikes again")
f$new_obs_from_split <- f$new_obs_from_split + 1
})
#### file choose ####
# shinyFiles::shinyFileChoose(
# input = input,
# id = "file_select",
# roots= shinyFiles::getVolumes(),
# filetypes=c('', 'txt', 'csv'),
# session = session)
#
#
#
# output$selected_files_to_upload <- renderPrint({
# cat(input$file_select)
# })
}
## To be copied in the UI
# mod_split_obs_ui("split_obs")
## To be copied in the server
# callModule(mod_split_obs_server, "split_obs")
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.