R/mod_clean-data.R
In brentscott93/lasertrapr: Automating the Analysis of Laser Trap Data
Defines functions
mod_clean_data_server
mod_clean_data_ui
#' clean_data UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#' @importFrom shiny NS tagList
mod_clean_data_ui <- function(id){
ns <- NS(id)
tagList(
# fluidRow(
# box(width = 12, title = "Selected Folders",
# verbatimTextOutput(ns('selected_folders'))
# ),
# # box(width = 2, title = 'Load Data',
# # actionButton(ns('graph'), 'Graph', width = '100%')
# # )
# ),
fluidRow(
box(width = 9, title = "Graph Options",
fluidRow(
column(6,
shinyWidgets::radioGroupButtons(
inputId = ns("mode"),
label = 'View Mode',
choices = c("Nanometers" = "nm",## ,
"Detrend" = "detrend"),
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"))
)
), #col close
column(4,
uiOutput(ns("nm_conversion")),
## numericInput(ns('mv2nm'),
## 'Step Cal (nm/mV)',
## value = 1,
## width = '100%')
),
column(2,
actionButton(ns('graph'),
'Graph',
width = '100%',
icon = icon('chart-line'),
style="margin-top: 25px;")
),
),
fluidRow(
column(12,
uiOutput(ns("trap_filter")
)
)
)
), #boxclose
box(title = "Cleaning Tools", width = 3,
fluidRow(
column(12,
textOutput(ns("move_files")),
actionButton(ns("trap_move_sheets_actionButton"),
"Move",
icon=icon("suitcase"),
width = "100%"),
) #col close
) ,
br(),
fluidRow(
column(12,
textOutput(ns("trim_files")),
actionButton(ns("trap_trim_dygraph_actionButton"),
"Cut",
icon = icon("cut"),
width = "100%")
)#col close
)#row close
) #ox close
),#row close
fluidRow(
box(title = "Data Trace", width = 12,
fluidRow(column(12,
dygraphs::dygraphOutput(ns("dygraph_clean")) |> shinycssloaders::withSpinner(type = 8, color = "#373B38"),
)))), #col, row, box close
fluidRow(
uiOutput(ns("baseline_range_box")),
box(width = 4, title = "Save Processed Data",
fluidRow(
column(12,
shinyWidgets::radioGroupButtons(
inputId = ns("how_to_process"),
label = "How do you want to process this obs?",
choices = c("None" = "none",
"Detrend" = "detrend"),
selected = "none",
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
shinyWidgets::radioGroupButtons(
inputId = ns("include"),
label = "Do you want to include this obs in analysis?",
choices = c('No', 'Yes'),
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
uiOutput(ns("save_options")),
actionButton(ns('save'),
'Save',
width = '100%',
icon = icon('save'),
style="margin-top: 25px;")
) # col close
) # row close
) #box close
), #rowclose
fluidRow(
box(width = 12, title = "Status Table",
column(12,
actionButton(ns('status_graph'), 'Update Info table'),
DT::DTOutput(ns('info')) |> shinycssloaders::withSpinner(type = 8, color = "#373B38")
)
),
)
)
}
#' clean_data Server Function
#' @import hexbin stringr data.table ggplot2
#' @noRd
mod_clean_data_server <- function(input, output, session, f){
ns <- session$ns
o <- reactiveValues()
observeEvent(f$obs_input, {
req(f$obs_input)
req(substring(f$obs_input, 1, 3) == 'obs')
## print("here-172")
req(f$obs$path)
o_data <- fread(file = file.path(f$obs$path, "options.csv"))
if(is.null(o_data$channels)) o_data$channels <- 1
if(is.null(o_data$lab)) o_data$lab <- "not"
o$data <- o_data
})
# save options for single channel data
output$save_options <- renderUI({
req(substring(f$obs_input, 1, 3) == 'obs')
req(o$data)
## if(is.null(o$data$channels))o$data$channels <- 1
if(o$data$channels == 1){
if(!file.exists(file.path(f$obs$path, "header.csv"))){
tagList(
numericInput(ns('nm2pn'),
label = 'Trap Stiffness (pN/nm)',
value = 1)
## verbatimTextOutput(ns('current_mv2nm'))
)
} else {
tagList(
verbatimTextOutput(ns('pn_nm1'))
)
}
} else if(o$data$channels == 2){
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
tagList(
shinyWidgets::radioGroupButtons(
inputId = ns("preferred_channel"),
label = "What is the preferred channel?",
choices = c("1" = 1,
"2" = 2),
selected = "1",
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
numericInput(ns('nm2pn'),
label = 'Trap Stiffness 1 (pN/nm)',
value = 1),
numericInput(ns('nm2pn2'),
label = 'Trap Stiffness 2 (pN/nm)',
value = 1)
)
} else {
tagList(
shinyWidgets::radioGroupButtons(
inputId = ns("preferred_channel"),
label = "What is the preferred channel?",
choices = c("1" = 1,
"2" = 2),
selected = "1",
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
)
}
}
## if(o$data$lab == "lu")
})
# decide which nm conversion input to draw
# depending on options listed in options.csv
output$nm_conversion <- renderUI({
req(substring(f$obs_input, 1, 3) == 'obs')
req(o$data)
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
tagList(
h5(),
h5("Lumick's data default unit is pN", style = "padding-top: 25px")
## column(6,
## numericInput(ns('mv2nm'),
## 'Step Cal (nm/mV)',
## value = 1,
## width = '100%')
## ),
## column(6,
## numericInput(ns('nm2pn'),
## 'Stiffness (pN/nm)',
## value = 1,
## width = '100%')
## )
)
} else {
if(file.exists(file.path(f$obs$path, "header.csv"))){
if(o$data$channels == 2){
tagList(
fluidRow(style = "padding-top: 23px;",
column(4, style = "padding-left: 5px; padding-right: 5px;",
verbatimTextOutput(ns("options_hz"))
),
column(4, style = "padding-left: 5px; padding-right: 5px;",
verbatimTextOutput(ns("nm_v1"))
),
column(4, style = "padding-left: 5px; padding-right: 5px;",
verbatimTextOutput(ns("nm_v2"))
)
)
)
} else {
tagList(
fluidRow(
column(6,
verbatimTextOutput(ns("options_hz"))
),
column(6,
verbatimTextOutput(ns("nm_v1"))
)
)
)
}
} else {
tagList(
numericInput(ns('mv2nm'),
'Step Cal (nm/V)',
value = 1,
width = '100%')
)
}
}
})
output$nm_v1 <- renderText({
req(o$data)
paste0("nm/V1: ", round(as.numeric(o$data$mv2nm), 1))
})
output$nm_v2 <- renderText({
req(o$data)
paste0("nm/V2: ", round(as.numeric(o$data$mv2nm2), 1))
})
output$pn_nm1 <- renderText({
req(o$data)
paste0("pN/nm1: ", round(as.numeric(o$data$nm2pn), 3))
})
output$pn_nm2 <- renderText({
req(o$data)
paste0("pN/nm2: ", round(as.numeric(o$data$nm2pn2), 3))
})
output$baseline_range_box <- renderUI({
if(o$data$channels == 1 || is.null(o$data$channels)){
tagList(
tabBox(id = ns('baseline_tab_box'), width = 8,
side = 'right',
title = "Remove Baseline",
# The id lets us use input$tabset1 on the server to find the current tab
tabPanel("Range",
fluidRow(column(3, actionButton(ns('baseline_graph_range'), 'Baseline Range', width = '100%'))),
fluidRow(column(12,
plotOutput(ns('range')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
verbatimTextOutput(ns('range_mean'))
))),#tabPanel close
tabPanel("MV",
fluidRow(column(3,actionButton(ns('baseline_graph_mv'), 'Baseline MV', width = '100%'))),
fluidRow(
column(6,
plotOutput(ns('mv'), brush = ns('mv_brush')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
), #col close
column(6,
# actionButton(ns('measure'), 'Calculate average of selection', width = '100%'),
plotOutput(ns('baseline_histo')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
) #col close
), #row close
fluidRow(
column(12,
verbatimTextOutput(ns('baseline_avg'))
)
)#rowclose
)
) #tabBox close
)
} else {
tagList(
tabBox(id = ns('baseline_tab_box'), width = 8,
side = 'right',
title = "Remove Baseline",
# The id lets us use input$tabset1 on the server to find the current tab
tabPanel("Range",
fluidRow(column(3, actionButton(ns('baseline_graph_range'), 'Baseline Range', width = '100%'))),
fluidRow(column(12,
plotOutput(ns('range')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
verbatimTextOutput(ns('range_mean'))
))),#tabPanel close
) #tabBox close
)
}
})
# when switching observation, reset all buttons
# only triggers after selected and viewed one trace
observeEvent(f$obs_input, ignoreNULL = T, ignoreInit = T, {
req(input$graph > 0)
showNotification('Switched obs',
type = 'message',
duration = 2)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("None" = "none",
"Detrend" = "detrend"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "include",
choices = c('No', 'Yes'),
selected = 'No',
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyjs::hide('dygraph_clean')
base$show_range <- NA
base$range <- NA
base$baseline_fit$estimate[1] <- NA
base$show_mv <- NA
})
## observe({ golem::print_dev(f$project_ns) })
## output$selected_folders <- renderPrint({
## validate(need(substring(f$obs_input, 1, 3) == 'obs', message = 'Please select folders'))
## cat('Project:', f$project$name, ' | Conditions:', f$conditions$name, ' | Date:', f$date$name, ' | Observation:', f$obs$name)
## })
rv <- reactiveValues(wait = FALSE, update_filter = 0)
## trap_files <- reactive({
## list_files(f$obs$path) %>%
## dplyr::filter(str_detect(name, "Data"))
## })
#END obtain filenames/paths for trap file selectors
#------------------------------------------------------------------------------------------------------------
#Start prepare/clean data
rv$update_graph <- 0
observeEvent(input$trap_move_sheets_actionButton, {
showModal(modalDialog(
tagList(
h4("Select an option to continue.")
),
title="Do you really want to move these file?",
footer = tagList(actionButton(ns("confirm_trap_move_sheets_actionButton"), "Yes, move."),
modalButton("Cancel")
)
))
})
rv$move_trap <- 0
observeEvent(input$confirm_trap_move_sheets_actionButton, {
req(substring(f$obs_input, 1, 3) == 'obs')
removeModal()
all_obs <- list_dir(f$date$path) %>%
dplyr::filter(str_detect(name, 'obs')) %>%
nrow()
has_header <- file.exists(file.path(f$obs$path, "header.csv"))
move_obs(trap_selected_date = f$date$path,
trap_selected_obs = f$obs$path,
trim_from = trim_from(),
trim_to = trim_to(),
f = f,
trap_obs = all_obs,
hz = hz(),
has_header = has_header)
rv$update_filter <- rv$update_filter + 1
f$current_obs <- f$obs$name
f$new_obs <- f$new_obs + 1
shinyjs::hide('dygraph_clean')
})
#the move obs will create a new folder and observatrion data
#this will trigger theh obs selectInput to retrigger to update inlcuding the new folder and select the
#current user selection
#this will bounce back here and update the graph by simuating a click of the button
observeEvent(f$new_obs_refresh_graph, ignoreNULL = T, ignoreInit = T, {
shinyjs::click('graph')
})
#watch the obs input
# when it updates get length of data trace for filter
observeEvent(f$obs_input, {
req(substring(f$obs_input, 1, 3) == 'obs')
trap_path <- file.path(f$obs$path, 'trap-data.csv')
rv$filter_max <- nrow(data.table::fread(trap_path, select = "project"))
})
#recaculates the length of trace when update_filter is triggered
observeEvent(rv$update_filter, ignoreInit = T, {
trap_path <- file.path(f$obs$path, 'trap-data.csv')
rv$filter_max <- nrow(data.table::fread(trap_path, select = "project"))
})
# draw the filter
output$trap_filter <- renderUI({
req(substring(f$obs_input, 1, 3) == 'obs')
if(is.null(o$data$lab)) o$data$lab <- "not"
if(file.exists(file.path(f$obs$path, "header.csv")) || o$data$lab == "lumicks"){
tagList(
column(9,
sliderInput(ns("trap_filter_sliderInput"),
label = "Filter large dataset",
value = c(1, rv$filter_max),
min = 1,
max = rv$filter_max,
ticks = F,
width = "100%")
),
column(3,
shinyWidgets::radioGroupButtons(
inputId = ns("flip_trace"),
label = 'Flip Trace?',
choices = c("N" = "n",## ,
"Y" = "y"),
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"))
)
)
)
} else {
sliderInput(ns("trap_filter_sliderInput"),
label = "Filter large dataset",
value = c(1, rv$filter_max),
min = 1,
max = rv$filter_max,
ticks = F,
width = "100%")
}
})
## observeEvent(f$obs_input, ignoreInit = T, {
## req(substring(f$obs_input, 1, 3) == 'obs')
## rv$update_graph <- rv$update_graph + 1
## })
# read the data to mak the dygraph
dg_data <- reactiveValues(make_graph = 0)
observeEvent(input$graph, {
defend_if_empty(f$obs_input,
ui = 'No observation folder selected.',
type = 'error')
defend_if_not_equal(substring(f$obs_input, 1, 3), 'obs',
ui = 'No observation folder selected.', type = 'error')
trap_data <- fread(file.path(f$obs$path, "trap-data.csv"), sep = ",")
has_header <- file.exists(file.path(f$obs$path, "header.csv"))
if(is.null(o$data$channels)){
o$data$channels <- 1
}
if(o$data$channels == 1){
## data <- data.table::fread(trap_data, sep = ",") %>%
## dplyr::mutate(bead = raw_bead*as.numeric(input$mv2nm),
## time_sec = 1:nrow(.)/hz()) %>%
## dplyr::select(time_sec, bead)
if(has_header){
mv2nm <- o$data$mv2nm
} else {
mv2nm <- input$mv2nm
}
trap_data <- trap_data[, .(time_sec = .I/hz(),
bead = raw_bead*as.numeric(mv2nm))
]
if(!is.null(input$flip_trace)){
if(input$flip_trace == "y"){
trap_data$bead <- trap_data$bead*-1
}
}
} else if(o$data$channels == 2){
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
## mv2nm <- input$mv2nm
## mv2nm2 <- input$mv2nm
## nm2pn <- input$nm2pn2
## nm2pn2 <- input$nm2pn2
# the lumicks data is uploaded in force (pN)
# the "raw data" column is initially in pN, not mV
# so will just display in Force
trap_data <- trap_data[, .(
time_sec = .I/hz(),
bead_1 = raw_bead_1,
bead_2 = raw_bead_2)
]
if(input$flip_trace == "y"){
trap_data$bead_1 <- trap_data$bead_1*-1
trap_data$bead_2 <- trap_data$bead_2*-1
}
} else {
if(has_header){
mv2nm <- o$data$mv2nm
mv2nm2 <- o$data$mv2nm2
} else {
stop("App only supports 2 channel datasets that contain calibrations in header file")
}
trap_data <- trap_data[, .(
time_sec = .I/hz(),
bead_1 = raw_bead_1*as.numeric(mv2nm),
bead_2 = raw_bead_2*as.numeric(mv2nm2)
)
]
if(input$flip_trace == "y"){
trap_data$bead_1 <- trap_data$bead_1*-1
trap_data$bead_2 <- trap_data$bead_2*-1
}
}
}
f1 <- input$trap_filter_sliderInput[[1]]
f2 <- input$trap_filter_sliderInput[[2]]
dg_data$channels <- o$data$channels
#dygraph kept refreshing on change file
#but only the title was changing and data wasnt
#this will keep the dygraph from refreshing until input$graph is clicked again
dg_data$title <- f$obs$name
dg_data$data <- trap_data[f1:f2,]
dg_data$make_graph <- dg_data$make_graph + 1
shinyjs::show('dygraph_clean')
})
# once the data is read above initiate graph options and make dygraph
trap_data_trace <- eventReactive(dg_data$make_graph, ignoreNULL = T, ignoreInit = T, {
## print(paste0("dg_data: ", head(dg_data$data)))
## print(paste0("number channels: ", dg_data$channels))
## print(paste0("make graph: ", dg_data$make_graph))
## browser()
if(dg_data$channels == 1){
if(isolate(input$mode) == 'nm'){
data <- dg_data$data
} else if(isolate(input$mode) == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
data <- isolate(dg_data$data)
data[, bead := as.vector(pracma::detrend(bead, tt = "linear", bp = break_pts)) ]
} else if(isolate(input$mode) == 'range'){
data <- isolate(dg_data$data)
data[, bead := bead - base$range]
} else if(isolate(input$mode) == 'mv'){
data <- isolate(dg_data$data)
data[, bead := bead - base$baseline_fit$estimate[1] ]
}
if(isolate(input$mv2nm) == 1){
dg <- dygraphs::dygraph(data = data, ylab = "V", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead", color = "black") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
} else {
dg <- dygraphs::dygraph(data = data, ylab = "nm", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead", color = "black") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
}
} else if(dg_data$channels == 2){
if(isolate(input$mode) == 'nm'){
data <- dg_data$data
} else if(isolate(input$mode) == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
data <- dg_data$data[, `:=`(bead_1 = as.vector(pracma::detrend(bead_1, tt = "linear", bp = break_pts)),
bead_2 = as.vector(pracma::detrend(bead_2, tt = "linear", bp = break_pts)))]
## }
} else if(isolate(input$mode) == 'range'){
data <- dg_data$data[, `:=`(bead_1 = bead_1 - base$range_1,
bead_2 = bead_2 - base$range_2)]
}
## } else if(isolate(input$mode) == 'mv'){
## data <- dg_data$data %>%
## mutate(bead_1 = bead_1 - base$baseline_fit$estimate[1],
## bead_2 = bead_2 - base$baseline_fit$estimate[1])
## }
#auatomatic downsample to avoid laggy
if(nrow(data) >= 1000000 & nrow(data) <= 2000000){
ds <- seq(1, nrow(data), by = 2)
data <- data[ds]
} else if(nrow(data) >= 2000000 & nrow(data) <= 3000000){
ds <- seq(1, nrow(data), by = 3)
data <- data[ds]
} else if(nrow(data) >= 4000000){
ds <- seq(1, nrow(data), by = 4)
data <- data[ds]
}
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
dg <- dygraphs::dygraph(data, ylab = "pN", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead_1", color = "black") |>
dygraphs::dySeries("bead_2", color = "red") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
} else {
dg <- dygraphs::dygraph(data, ylab = "nm", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead_1", color = "black") |>
dygraphs::dySeries("bead_2", color = "red") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
}
}
dg
})
output$dygraph_clean <- dygraphs::renderDygraph({
req(trap_data_trace())
## req(nrow(trap_data_trace())==rv$filter_max)
## validate(need(names(trap_data_trace$dygraph) %in% c("bead", "time_sec")), "Please select an obs and click graph to update.")
trap_data_trace()
})
output$move_files <- renderText({
validate(need(trim_from(), 'Please load data to clean'))
req(length(input$dygraph_clean_date_window)==2)
## req(input$dygraph_clean_date_window[[2]] <= nrow(dg_data$data))
paste0("Move data from ",
trim_from(),
"s",
" to ",
trim_to(),
"s"
)
})
hz <- reactive({
req(f)
req(f$obs$path)
o <- list.files(path = f$obs$path,
pattern = "options.csv",
full.names = TRUE)
o <- data.table::fread(o, select = "hz")
as.integer(o$hz)
})
output$options_hz <- renderText({
req(hz())
paste0("Hz: ", hz())
})
trim_from <- reactive({
req(hz())
req(input$dygraph_clean_date_window[[1]])
try(as.numeric(round_any(input$dygraph_clean_date_window[[1]], 1/hz(), f = round)))
})
trim_to <- reactive({
req(hz())
req(length(input$dygraph_clean_date_window)==2)
## req(dg_data$data)
try(as.numeric(round_any(input$dygraph_clean_date_window[[2]], 1/hz(), f = round)))
})
output$trim_files <- renderText({
validate(need(trim_from(), 'Please load data to clean'))
req(length(input$dygraph_clean_date_window)==2)
paste0("Delete data from ",
trim_from(),
"s",
" to ",
trim_to(),
"s"
)
})
observeEvent(input$trap_trim_dygraph_actionButton, {
showModal(modalDialog(
tagList(
h4("This will delete the selected data.")
),
title="Do you really want to ERASE the selection?",
footer = tagList(actionButton(ns("confirm_trap_trim_dygraph_actionButton"), "Yes, cut."),
modalButton("Cancel")
)
))
})
observeEvent(input$confirm_trap_trim_dygraph_actionButton, {
removeModal()
trim_obs(trap_selected_obs = f$obs$path,
trim_from = trim_from(),
trim_to = trim_to(),
f = f,
hz = hz())
## rv$update_filter <- rv$update_filter + 1
showNotification("Data trimmed. Graph will refresh.")
shinyjs::hide('dygraph_clean')
rv$update_filter <- rv$update_filter + 1
f$current_obs <- f$obs$name
f$new_obs <- f$new_obs + 1
})
#### Process Data ####
observeEvent(input$baseline_graph_mv, {
base$show_mv <- 'yes'
#shinyjs::show('mv')
})
base_mv_graph <- eventReactive(input$baseline_graph_mv, {
defend_if_empty(input$dygraph_clean_date_window[[1]],
ui = 'Graph/Upload data before calculating baseline',
type = 'error')
defend_if_not_equal(substring(f$obs_input, 1, 3),
'obs',
ui = 'No obs selected',
type = 'error' )
defend_if_empty(dg_data$data, ui = 'Graph obs before continuing', type = 'error')
base$mv_df <- data.frame(mean = RcppRoll::roll_mean(dg_data$data$bead, n = 30, align = 'left', fill = NULL),
var = RcppRoll::roll_var(dg_data$data$bead, n = 30, align = 'left', fill = NULL))
if(input$mv2nm == 1) showNotification('Current mV-to-nm is 1. Do you need to enter a conversion value?', type = 'warning')
#req(input$mv2nm > 1)
ggplot(base$mv_df)+
geom_hex(aes(mean, var), bins = 75)+
ggtitle('Select area on plot to set baseline population')+
ylab('Variance')+
xlab('Mean')+
scale_fill_gradient(low = 'green', high = 'red')+
theme_classic(base_size = 12)+
theme(legend.position = 'none',
panel.background = element_rect(colour = "black", size=2))
})
observeEvent(input$baseline_graph_range, {
defend_if_empty(input$dygraph_clean_date_window[[1]],
ui = 'Graph/Upload data before calculating baseline',
type = 'error')
defend_if_not_equal(substring(f$obs_input, 1, 3),
'obs',
ui = 'No obs selected',
type = 'error' )
## a <- attempt::attempt(is.numeric(input$dygraph_clean_date_window[[1]]))
allow_if(is.numeric(input$dygraph_clean_date_window[[1]]), ui = showNotification('Load data before calculating baseline range'), type = 'error')
if(length(input$dygraph_clean_date_window[[1]]:input$dygraph_clean_date_window[[2]]) > 10){
showNotification('Baseline range selection too long. Make a selection less than 10 seconds.', type = 'error')
}
req(length(input$dygraph_clean_date_window[[1]]:input$dygraph_clean_date_window[[2]]) <= 10)
#browser()
## if(var(dg_data$data$bead) == 1) showNotification('Current mV-to-nm is 1. Do you need to enter a conversion value?', type = 'warning')
if(o$data$channels == 1){
# req(var(dg_data$data$bead) > 5)
base$range_df <- dg_data$data |>
dplyr::filter(dplyr::between(time_sec, as.numeric(trim_from()), as.numeric(trim_to())))
base$range <- mean(base$range_df$bead)
base$range_update_graph <- base$range_update_graph + 1
base$show_range <- 'yes'
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend",
"Remove base" = "range"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
#update saving options
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("Detrend" = "detrend",
"Remove base" = "remove_base"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
} else if(o$data$channels == 2){
base$range_df <- dg_data$data |>
dplyr::filter(dplyr::between(time_sec, as.numeric(trim_from()), as.numeric(trim_to())))|>
dplyr::mutate(bead = bead_1)
base$range <- mean(base$range_df$bead_1)
base$range_1 <- mean(base$range_df$bead_1)
base$range_2 <- mean(base$range_df$bead_2)
base$range_update_graph <- base$range_update_graph + 1
base$show_range <- 'yes'
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend",
"Remove base" = "range"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
#update saving options
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("None" = "none",
"Detrend" = "detrend",
"Remove base" = "remove_base"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
}
})
observeEvent(input$baseline_graph_mv, {
#update saving options
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("Detrend" = "detrend",
"Remove MV" = "remove_mv"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend",
"Remove MV" = "mv"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
})
output$range_mean <- renderPrint({
validate(need(base$range, 'Press button to calculate mean of selected range'))
cat('The selected baseline range has a mean of ', base$range, ' nm')
})
ggrange <- eventReactive(base$range_update_graph, {
req(base$range_df)
ggplot(isolate(base$range_df))+
geom_line(aes(x = time_sec, y = bead), color = 'black')+
geom_hline(yintercept = isolate(base$range), color = 'firebrick', size = 2)+
ylab('nm')+
xlab('Seconds')+
ggtitle('Baseline range selected with mean')+
theme_classic(base_size = 16)#+
})
output$range <- renderPlot({
req(!is.na(base$show_range))
req(base$range_df, base$range)
ggrange()
})
output$mv <- renderPlot({
req(!is.na(base$show_mv))
req(is.ggplot(base_mv_graph()))
base_mv_graph()
})
base <- reactiveValues(done = 0, range_update_graph = 0, show_range = NA, show_mv = NA)
observe({
#req(!is.na(base$show_mv))
req(input$mv_brush)
#baseline_pop <- input$mv_brush
mv_df <- base$mv_df
#baseline data and fit to density fit
baseline <- dplyr::filter(mv_df, dplyr::between(mean, input$mv_brush$xmin, input$mv_brush$xmax) & dplyr::between(var, input$mv_brush$ymin, input$mv_brush$ymax))
req(!rlang::is_empty(baseline$mean))
baseline_fit <- MASS::fitdistr(baseline$mean, 'normal')
#return values to reactive list
base$baseline <- baseline
base$baseline_fit <- baseline_fit
})
output$baseline_histo <- renderPlot({
req(not_null(base$baseline), not_null(base$baseline_fit))
req(base$baseline_fit$estimate[1])
hist(base$baseline$mean,
pch=20,
breaks=25,
prob=T,
main="Baseline Population",
xlab = 'Nanometers')
curve(dnorm(x, base$baseline_fit$estimate[1], base$baseline_fit$estimate[2]),
col='firebrick', lwd=2, add=T)
})
output$baseline_avg <- renderPrint({
validate(need(base$baseline_fit$estimate[1], 'Baseline MV not measured'))
cat('Baseline average = ', base$baseline_fit$estimate[1], 'mV')
})
logger <- reactiveValues()
status <- reactiveValues()
observeEvent(input$save, ignoreInit = T, {
defend_if_not_equal(substring(f$obs_input, 1, 3),
'obs',
'No obs selected', type = 'error')
if(input$include == 'No'){
input_include <- FALSE
} else {
input_include <- TRUE
}
withProgress(message = 'Saving Data', {
if(is.null(o$data$channels)){
o$data$channels <- 1
}
## browser()
if(o$data$channels == 1){
defend_if_blank(input$mv2nm, ui = 'Enter step cal', type = 'error')
defend_if_blank(input$nm2pn, ui = 'Enter trap stiffness', type = 'error')
}
current_obs <- f$obs$path
trap_data <- file.path(f$obs$path, "trap-data.csv")
data <- data.table::fread(trap_data, sep = ",")
setProgress(0.3)
if(o$data$channels == 1){
data[, processed_bead := raw_bead*as.numeric(input$mv2nm) ]
if(!is.null(input$flip_trace)){
if(input$flip_trace == "y"){
data$processed_bead <- data$processed_bead*-1
}
}
if(input$how_to_process == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
data[, processed_bead := as.vector(pracma::detrend(processed_bead, tt = "linear", bp = break_pts)) ]
} else if(input$how_to_process == 'remove_base'){
data[, processed_bead := processed_bead - base$range ]
} else if(input$how_to_process == 'remove_mv'){
data[, processed_bead := processed_bead - base$baseline_fit$estimate[1] ]
}
opt <- list.files(path = f$obs$path,
pattern = "options.csv",
full.names = TRUE)
opt <- fread(opt)
opt[, `:=`(processor = input$how_to_process,
mv2nm = as.numeric(input$mv2nm),
nm2pn = as.numeric(input$nm2pn),
include = input_include)
]
setProgress(0.5)
data.table::fwrite(data, file = file.path(f$obs$path, 'trap-data.csv'), sep = ",")
data.table::fwrite(opt, file = file.path(f$obs$path, 'options.csv'), sep = ",")
setProgress(0.75)
} else if(o$data$channels == 2){
## browser()
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
pb1 <- data$raw_bead_1
pb2 <- data$raw_bead_2
} else {
pb1 <- data$raw_bead_1*o$data$mv2nm[1]
pb2 <- data$raw_bead_2*o$data$mv2nm2[1]
}
if(!is.null(input$flip_trace)){
if(input$flip_trace == "y"){
pb1 <- pb1*-1
pb2 <- pb2*-1
}
}
if(input$how_to_process == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
pb1 <- as.vector(pracma::detrend(pb1, tt = "linear", bp = break_pts))
pb2 <- as.vector(pracma::detrend(pb2, tt = "linear", bp = break_pts))
} else if(input$how_to_process == 'remove_base'){
## data <- dplyr::mutate(data, processed_bead = processed_bead - base$range)
pb1 <- pb1-base$range_1
pb2 <- pb2-base$range_2
} else if(input$how_to_process == 'remove_mv'){
## data <- dplyr::mutate(data, processed_bead = processed_bead - base$baseline_fit$estimate[1])
} else {
}
setProgress(0.5)
opt <- list.files(path = f$obs$path,
pattern = "options.csv",
full.names = TRUE)
opt <- fread(opt)
## if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
# lumicks data comes in force, convert to nm for processed bead
# by dividing by the step cal/nm2pn
data[, `:=`(processed_bead_1 = pb1/input$nm2pn,
processed_bead_2 = pb2/input$nm2pn2) ]
opt[, `:=`(processor = input$how_to_process,
include = input_include,
preferred_channel = as.numeric(input$preferred_channel),
nm2pn = input$nm2pn,
nm2pn2 = input$nm2pn2)
]
} else {
data[, `:=`(processed_bead_1 = pb1,
processed_bead_2 = pb2) ]
opt[, `:=`(processor = input$how_to_process,
include = input_include,
preferred_channel = as.numeric(input$preferred_channel))
]
}
data.table::fwrite(data, file = file.path(f$obs$path, 'trap-data.csv'), sep = ",")
data.table::fwrite(opt, file = file.path(f$obs$path, 'options.csv'), sep = ",")
setProgress(0.75)
}
## golem::print_dev( logger[[as.character(input$save)]] )
all_trap_paths <- list_files(f$date$path, pattern = 'options.csv', recursive = T)
setProgress(0.9)
status$df <- purrr::map_df(all_trap_paths$path, ~data.table::fread(.,
sep = ",",
select = c("obs", "processor", "mv2nm", "nm2pn", "include"),
nrows = 1))
setProgress(1)
})
showNotification(paste(f$conditions$name, f$obs$name, 'successfully processed and saved.'), type = 'message')
})
observeEvent(input$status_graph, {
defend_if_null(f$date_input, ui = 'Whoops. You forgot to select a date folder.', type = 'error')
defend_if_blank(f$date_input, ui = 'Whoops. You forgot to select a date folder.', type = 'error')
all_trap_paths <- list_files(f$date$path, pattern = 'options.csv', recursive = T)
defend_if_empty(all_trap_paths, ui = "No 'options.csv' files in date folder yet. Start by loading date with 'Upload Data'", type = 'error')
golem::print_dev(all_trap_paths$path)
status$df <- purrr::map_df(all_trap_paths$path, ~data.table::fread(.,
sep = ",",
select = c("obs", "processor", "mv2nm", "nm2pn", "include"),
nrows = 1))
showNotification('Status table refreshed', type = 'message')
})
output$current_mv2nm <- renderPrint({
cat('mV to nm conversion: ', input$mv2nm)
})
output$info <- DT::renderDT({
req(status$df)
status$df |>
dplyr::rename('Obs' = obs,
'Processor' = processor,
'mV-to-nm' = mv2nm,
'nm-to-pN' = nm2pn,
'Include' = include) |>
DT::datatable() |>
DT::formatStyle('Include',
color = DT::styleEqual(c(F, T), c('red', 'black'))
)
})
}
## To be copied in the UI
# mod_clean_data_ui("clean_data_ui")
## To be copied in the server
# callModule(mod_clean_data_server, "clean_data_ui")
brentscott93/lasertrapr documentation built on March 26, 2024, 4:26 p.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_clean_data_server mod_clean_data_ui
#' clean_data UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#' @importFrom shiny NS tagList
mod_clean_data_ui <- function(id){
ns <- NS(id)
tagList(
# fluidRow(
# box(width = 12, title = "Selected Folders",
# verbatimTextOutput(ns('selected_folders'))
# ),
# # box(width = 2, title = 'Load Data',
# # actionButton(ns('graph'), 'Graph', width = '100%')
# # )
# ),
fluidRow(
box(width = 9, title = "Graph Options",
fluidRow(
column(6,
shinyWidgets::radioGroupButtons(
inputId = ns("mode"),
label = 'View Mode',
choices = c("Nanometers" = "nm",## ,
"Detrend" = "detrend"),
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"))
)
), #col close
column(4,
uiOutput(ns("nm_conversion")),
## numericInput(ns('mv2nm'),
## 'Step Cal (nm/mV)',
## value = 1,
## width = '100%')
),
column(2,
actionButton(ns('graph'),
'Graph',
width = '100%',
icon = icon('chart-line'),
style="margin-top: 25px;")
),
),
fluidRow(
column(12,
uiOutput(ns("trap_filter")
)
)
)
), #boxclose
box(title = "Cleaning Tools", width = 3,
fluidRow(
column(12,
textOutput(ns("move_files")),
actionButton(ns("trap_move_sheets_actionButton"),
"Move",
icon=icon("suitcase"),
width = "100%"),
) #col close
) ,
br(),
fluidRow(
column(12,
textOutput(ns("trim_files")),
actionButton(ns("trap_trim_dygraph_actionButton"),
"Cut",
icon = icon("cut"),
width = "100%")
)#col close
)#row close
) #ox close
),#row close
fluidRow(
box(title = "Data Trace", width = 12,
fluidRow(column(12,
dygraphs::dygraphOutput(ns("dygraph_clean")) |> shinycssloaders::withSpinner(type = 8, color = "#373B38"),
)))), #col, row, box close
fluidRow(
uiOutput(ns("baseline_range_box")),
box(width = 4, title = "Save Processed Data",
fluidRow(
column(12,
shinyWidgets::radioGroupButtons(
inputId = ns("how_to_process"),
label = "How do you want to process this obs?",
choices = c("None" = "none",
"Detrend" = "detrend"),
selected = "none",
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
shinyWidgets::radioGroupButtons(
inputId = ns("include"),
label = "Do you want to include this obs in analysis?",
choices = c('No', 'Yes'),
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
uiOutput(ns("save_options")),
actionButton(ns('save'),
'Save',
width = '100%',
icon = icon('save'),
style="margin-top: 25px;")
) # col close
) # row close
) #box close
), #rowclose
fluidRow(
box(width = 12, title = "Status Table",
column(12,
actionButton(ns('status_graph'), 'Update Info table'),
DT::DTOutput(ns('info')) |> shinycssloaders::withSpinner(type = 8, color = "#373B38")
)
),
)
)
}
#' clean_data Server Function
#' @import hexbin stringr data.table ggplot2
#' @noRd
mod_clean_data_server <- function(input, output, session, f){
ns <- session$ns
o <- reactiveValues()
observeEvent(f$obs_input, {
req(f$obs_input)
req(substring(f$obs_input, 1, 3) == 'obs')
## print("here-172")
req(f$obs$path)
o_data <- fread(file = file.path(f$obs$path, "options.csv"))
if(is.null(o_data$channels)) o_data$channels <- 1
if(is.null(o_data$lab)) o_data$lab <- "not"
o$data <- o_data
})
# save options for single channel data
output$save_options <- renderUI({
req(substring(f$obs_input, 1, 3) == 'obs')
req(o$data)
## if(is.null(o$data$channels))o$data$channels <- 1
if(o$data$channels == 1){
if(!file.exists(file.path(f$obs$path, "header.csv"))){
tagList(
numericInput(ns('nm2pn'),
label = 'Trap Stiffness (pN/nm)',
value = 1)
## verbatimTextOutput(ns('current_mv2nm'))
)
} else {
tagList(
verbatimTextOutput(ns('pn_nm1'))
)
}
} else if(o$data$channels == 2){
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
tagList(
shinyWidgets::radioGroupButtons(
inputId = ns("preferred_channel"),
label = "What is the preferred channel?",
choices = c("1" = 1,
"2" = 2),
selected = "1",
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
numericInput(ns('nm2pn'),
label = 'Trap Stiffness 1 (pN/nm)',
value = 1),
numericInput(ns('nm2pn2'),
label = 'Trap Stiffness 2 (pN/nm)',
value = 1)
)
} else {
tagList(
shinyWidgets::radioGroupButtons(
inputId = ns("preferred_channel"),
label = "What is the preferred channel?",
choices = c("1" = 1,
"2" = 2),
selected = "1",
justified = T,
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
),
)
}
}
## if(o$data$lab == "lu")
})
# decide which nm conversion input to draw
# depending on options listed in options.csv
output$nm_conversion <- renderUI({
req(substring(f$obs_input, 1, 3) == 'obs')
req(o$data)
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
tagList(
h5(),
h5("Lumick's data default unit is pN", style = "padding-top: 25px")
## column(6,
## numericInput(ns('mv2nm'),
## 'Step Cal (nm/mV)',
## value = 1,
## width = '100%')
## ),
## column(6,
## numericInput(ns('nm2pn'),
## 'Stiffness (pN/nm)',
## value = 1,
## width = '100%')
## )
)
} else {
if(file.exists(file.path(f$obs$path, "header.csv"))){
if(o$data$channels == 2){
tagList(
fluidRow(style = "padding-top: 23px;",
column(4, style = "padding-left: 5px; padding-right: 5px;",
verbatimTextOutput(ns("options_hz"))
),
column(4, style = "padding-left: 5px; padding-right: 5px;",
verbatimTextOutput(ns("nm_v1"))
),
column(4, style = "padding-left: 5px; padding-right: 5px;",
verbatimTextOutput(ns("nm_v2"))
)
)
)
} else {
tagList(
fluidRow(
column(6,
verbatimTextOutput(ns("options_hz"))
),
column(6,
verbatimTextOutput(ns("nm_v1"))
)
)
)
}
} else {
tagList(
numericInput(ns('mv2nm'),
'Step Cal (nm/V)',
value = 1,
width = '100%')
)
}
}
})
output$nm_v1 <- renderText({
req(o$data)
paste0("nm/V1: ", round(as.numeric(o$data$mv2nm), 1))
})
output$nm_v2 <- renderText({
req(o$data)
paste0("nm/V2: ", round(as.numeric(o$data$mv2nm2), 1))
})
output$pn_nm1 <- renderText({
req(o$data)
paste0("pN/nm1: ", round(as.numeric(o$data$nm2pn), 3))
})
output$pn_nm2 <- renderText({
req(o$data)
paste0("pN/nm2: ", round(as.numeric(o$data$nm2pn2), 3))
})
output$baseline_range_box <- renderUI({
if(o$data$channels == 1 || is.null(o$data$channels)){
tagList(
tabBox(id = ns('baseline_tab_box'), width = 8,
side = 'right',
title = "Remove Baseline",
# The id lets us use input$tabset1 on the server to find the current tab
tabPanel("Range",
fluidRow(column(3, actionButton(ns('baseline_graph_range'), 'Baseline Range', width = '100%'))),
fluidRow(column(12,
plotOutput(ns('range')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
verbatimTextOutput(ns('range_mean'))
))),#tabPanel close
tabPanel("MV",
fluidRow(column(3,actionButton(ns('baseline_graph_mv'), 'Baseline MV', width = '100%'))),
fluidRow(
column(6,
plotOutput(ns('mv'), brush = ns('mv_brush')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
), #col close
column(6,
# actionButton(ns('measure'), 'Calculate average of selection', width = '100%'),
plotOutput(ns('baseline_histo')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
) #col close
), #row close
fluidRow(
column(12,
verbatimTextOutput(ns('baseline_avg'))
)
)#rowclose
)
) #tabBox close
)
} else {
tagList(
tabBox(id = ns('baseline_tab_box'), width = 8,
side = 'right',
title = "Remove Baseline",
# The id lets us use input$tabset1 on the server to find the current tab
tabPanel("Range",
fluidRow(column(3, actionButton(ns('baseline_graph_range'), 'Baseline Range', width = '100%'))),
fluidRow(column(12,
plotOutput(ns('range')) %>%
shinycssloaders::withSpinner(type = 8, color = "#373B38"),
verbatimTextOutput(ns('range_mean'))
))),#tabPanel close
) #tabBox close
)
}
})
# when switching observation, reset all buttons
# only triggers after selected and viewed one trace
observeEvent(f$obs_input, ignoreNULL = T, ignoreInit = T, {
req(input$graph > 0)
showNotification('Switched obs',
type = 'message',
duration = 2)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("None" = "none",
"Detrend" = "detrend"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "include",
choices = c('No', 'Yes'),
selected = 'No',
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyjs::hide('dygraph_clean')
base$show_range <- NA
base$range <- NA
base$baseline_fit$estimate[1] <- NA
base$show_mv <- NA
})
## observe({ golem::print_dev(f$project_ns) })
## output$selected_folders <- renderPrint({
## validate(need(substring(f$obs_input, 1, 3) == 'obs', message = 'Please select folders'))
## cat('Project:', f$project$name, ' | Conditions:', f$conditions$name, ' | Date:', f$date$name, ' | Observation:', f$obs$name)
## })
rv <- reactiveValues(wait = FALSE, update_filter = 0)
## trap_files <- reactive({
## list_files(f$obs$path) %>%
## dplyr::filter(str_detect(name, "Data"))
## })
#END obtain filenames/paths for trap file selectors
#------------------------------------------------------------------------------------------------------------
#Start prepare/clean data
rv$update_graph <- 0
observeEvent(input$trap_move_sheets_actionButton, {
showModal(modalDialog(
tagList(
h4("Select an option to continue.")
),
title="Do you really want to move these file?",
footer = tagList(actionButton(ns("confirm_trap_move_sheets_actionButton"), "Yes, move."),
modalButton("Cancel")
)
))
})
rv$move_trap <- 0
observeEvent(input$confirm_trap_move_sheets_actionButton, {
req(substring(f$obs_input, 1, 3) == 'obs')
removeModal()
all_obs <- list_dir(f$date$path) %>%
dplyr::filter(str_detect(name, 'obs')) %>%
nrow()
has_header <- file.exists(file.path(f$obs$path, "header.csv"))
move_obs(trap_selected_date = f$date$path,
trap_selected_obs = f$obs$path,
trim_from = trim_from(),
trim_to = trim_to(),
f = f,
trap_obs = all_obs,
hz = hz(),
has_header = has_header)
rv$update_filter <- rv$update_filter + 1
f$current_obs <- f$obs$name
f$new_obs <- f$new_obs + 1
shinyjs::hide('dygraph_clean')
})
#the move obs will create a new folder and observatrion data
#this will trigger theh obs selectInput to retrigger to update inlcuding the new folder and select the
#current user selection
#this will bounce back here and update the graph by simuating a click of the button
observeEvent(f$new_obs_refresh_graph, ignoreNULL = T, ignoreInit = T, {
shinyjs::click('graph')
})
#watch the obs input
# when it updates get length of data trace for filter
observeEvent(f$obs_input, {
req(substring(f$obs_input, 1, 3) == 'obs')
trap_path <- file.path(f$obs$path, 'trap-data.csv')
rv$filter_max <- nrow(data.table::fread(trap_path, select = "project"))
})
#recaculates the length of trace when update_filter is triggered
observeEvent(rv$update_filter, ignoreInit = T, {
trap_path <- file.path(f$obs$path, 'trap-data.csv')
rv$filter_max <- nrow(data.table::fread(trap_path, select = "project"))
})
# draw the filter
output$trap_filter <- renderUI({
req(substring(f$obs_input, 1, 3) == 'obs')
if(is.null(o$data$lab)) o$data$lab <- "not"
if(file.exists(file.path(f$obs$path, "header.csv")) || o$data$lab == "lumicks"){
tagList(
column(9,
sliderInput(ns("trap_filter_sliderInput"),
label = "Filter large dataset",
value = c(1, rv$filter_max),
min = 1,
max = rv$filter_max,
ticks = F,
width = "100%")
),
column(3,
shinyWidgets::radioGroupButtons(
inputId = ns("flip_trace"),
label = 'Flip Trace?',
choices = c("N" = "n",## ,
"Y" = "y"),
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"))
)
)
)
} else {
sliderInput(ns("trap_filter_sliderInput"),
label = "Filter large dataset",
value = c(1, rv$filter_max),
min = 1,
max = rv$filter_max,
ticks = F,
width = "100%")
}
})
## observeEvent(f$obs_input, ignoreInit = T, {
## req(substring(f$obs_input, 1, 3) == 'obs')
## rv$update_graph <- rv$update_graph + 1
## })
# read the data to mak the dygraph
dg_data <- reactiveValues(make_graph = 0)
observeEvent(input$graph, {
defend_if_empty(f$obs_input,
ui = 'No observation folder selected.',
type = 'error')
defend_if_not_equal(substring(f$obs_input, 1, 3), 'obs',
ui = 'No observation folder selected.', type = 'error')
trap_data <- fread(file.path(f$obs$path, "trap-data.csv"), sep = ",")
has_header <- file.exists(file.path(f$obs$path, "header.csv"))
if(is.null(o$data$channels)){
o$data$channels <- 1
}
if(o$data$channels == 1){
## data <- data.table::fread(trap_data, sep = ",") %>%
## dplyr::mutate(bead = raw_bead*as.numeric(input$mv2nm),
## time_sec = 1:nrow(.)/hz()) %>%
## dplyr::select(time_sec, bead)
if(has_header){
mv2nm <- o$data$mv2nm
} else {
mv2nm <- input$mv2nm
}
trap_data <- trap_data[, .(time_sec = .I/hz(),
bead = raw_bead*as.numeric(mv2nm))
]
if(!is.null(input$flip_trace)){
if(input$flip_trace == "y"){
trap_data$bead <- trap_data$bead*-1
}
}
} else if(o$data$channels == 2){
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
## mv2nm <- input$mv2nm
## mv2nm2 <- input$mv2nm
## nm2pn <- input$nm2pn2
## nm2pn2 <- input$nm2pn2
# the lumicks data is uploaded in force (pN)
# the "raw data" column is initially in pN, not mV
# so will just display in Force
trap_data <- trap_data[, .(
time_sec = .I/hz(),
bead_1 = raw_bead_1,
bead_2 = raw_bead_2)
]
if(input$flip_trace == "y"){
trap_data$bead_1 <- trap_data$bead_1*-1
trap_data$bead_2 <- trap_data$bead_2*-1
}
} else {
if(has_header){
mv2nm <- o$data$mv2nm
mv2nm2 <- o$data$mv2nm2
} else {
stop("App only supports 2 channel datasets that contain calibrations in header file")
}
trap_data <- trap_data[, .(
time_sec = .I/hz(),
bead_1 = raw_bead_1*as.numeric(mv2nm),
bead_2 = raw_bead_2*as.numeric(mv2nm2)
)
]
if(input$flip_trace == "y"){
trap_data$bead_1 <- trap_data$bead_1*-1
trap_data$bead_2 <- trap_data$bead_2*-1
}
}
}
f1 <- input$trap_filter_sliderInput[[1]]
f2 <- input$trap_filter_sliderInput[[2]]
dg_data$channels <- o$data$channels
#dygraph kept refreshing on change file
#but only the title was changing and data wasnt
#this will keep the dygraph from refreshing until input$graph is clicked again
dg_data$title <- f$obs$name
dg_data$data <- trap_data[f1:f2,]
dg_data$make_graph <- dg_data$make_graph + 1
shinyjs::show('dygraph_clean')
})
# once the data is read above initiate graph options and make dygraph
trap_data_trace <- eventReactive(dg_data$make_graph, ignoreNULL = T, ignoreInit = T, {
## print(paste0("dg_data: ", head(dg_data$data)))
## print(paste0("number channels: ", dg_data$channels))
## print(paste0("make graph: ", dg_data$make_graph))
## browser()
if(dg_data$channels == 1){
if(isolate(input$mode) == 'nm'){
data <- dg_data$data
} else if(isolate(input$mode) == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
data <- isolate(dg_data$data)
data[, bead := as.vector(pracma::detrend(bead, tt = "linear", bp = break_pts)) ]
} else if(isolate(input$mode) == 'range'){
data <- isolate(dg_data$data)
data[, bead := bead - base$range]
} else if(isolate(input$mode) == 'mv'){
data <- isolate(dg_data$data)
data[, bead := bead - base$baseline_fit$estimate[1] ]
}
if(isolate(input$mv2nm) == 1){
dg <- dygraphs::dygraph(data = data, ylab = "V", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead", color = "black") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
} else {
dg <- dygraphs::dygraph(data = data, ylab = "nm", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead", color = "black") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
}
} else if(dg_data$channels == 2){
if(isolate(input$mode) == 'nm'){
data <- dg_data$data
} else if(isolate(input$mode) == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
data <- dg_data$data[, `:=`(bead_1 = as.vector(pracma::detrend(bead_1, tt = "linear", bp = break_pts)),
bead_2 = as.vector(pracma::detrend(bead_2, tt = "linear", bp = break_pts)))]
## }
} else if(isolate(input$mode) == 'range'){
data <- dg_data$data[, `:=`(bead_1 = bead_1 - base$range_1,
bead_2 = bead_2 - base$range_2)]
}
## } else if(isolate(input$mode) == 'mv'){
## data <- dg_data$data %>%
## mutate(bead_1 = bead_1 - base$baseline_fit$estimate[1],
## bead_2 = bead_2 - base$baseline_fit$estimate[1])
## }
#auatomatic downsample to avoid laggy
if(nrow(data) >= 1000000 & nrow(data) <= 2000000){
ds <- seq(1, nrow(data), by = 2)
data <- data[ds]
} else if(nrow(data) >= 2000000 & nrow(data) <= 3000000){
ds <- seq(1, nrow(data), by = 3)
data <- data[ds]
} else if(nrow(data) >= 4000000){
ds <- seq(1, nrow(data), by = 4)
data <- data[ds]
}
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
dg <- dygraphs::dygraph(data, ylab = "pN", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead_1", color = "black") |>
dygraphs::dySeries("bead_2", color = "red") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
} else {
dg <- dygraphs::dygraph(data, ylab = "nm", xlab = "Seconds", main = dg_data$title) |>
dygraphs::dySeries("bead_1", color = "black") |>
dygraphs::dySeries("bead_2", color = "red") |>
dygraphs::dyRangeSelector(fillColor ="", strokeColor = "black") |>
dygraphs::dyUnzoom() |>
dygraphs::dyOptions(axisLabelColor = "black",
gridLineColor = "black",
axisLineColor = "black",
axisLineWidth = 3,
axisLabelFontSize = 15,
drawGrid = FALSE)
}
}
dg
})
output$dygraph_clean <- dygraphs::renderDygraph({
req(trap_data_trace())
## req(nrow(trap_data_trace())==rv$filter_max)
## validate(need(names(trap_data_trace$dygraph) %in% c("bead", "time_sec")), "Please select an obs and click graph to update.")
trap_data_trace()
})
output$move_files <- renderText({
validate(need(trim_from(), 'Please load data to clean'))
req(length(input$dygraph_clean_date_window)==2)
## req(input$dygraph_clean_date_window[[2]] <= nrow(dg_data$data))
paste0("Move data from ",
trim_from(),
"s",
" to ",
trim_to(),
"s"
)
})
hz <- reactive({
req(f)
req(f$obs$path)
o <- list.files(path = f$obs$path,
pattern = "options.csv",
full.names = TRUE)
o <- data.table::fread(o, select = "hz")
as.integer(o$hz)
})
output$options_hz <- renderText({
req(hz())
paste0("Hz: ", hz())
})
trim_from <- reactive({
req(hz())
req(input$dygraph_clean_date_window[[1]])
try(as.numeric(round_any(input$dygraph_clean_date_window[[1]], 1/hz(), f = round)))
})
trim_to <- reactive({
req(hz())
req(length(input$dygraph_clean_date_window)==2)
## req(dg_data$data)
try(as.numeric(round_any(input$dygraph_clean_date_window[[2]], 1/hz(), f = round)))
})
output$trim_files <- renderText({
validate(need(trim_from(), 'Please load data to clean'))
req(length(input$dygraph_clean_date_window)==2)
paste0("Delete data from ",
trim_from(),
"s",
" to ",
trim_to(),
"s"
)
})
observeEvent(input$trap_trim_dygraph_actionButton, {
showModal(modalDialog(
tagList(
h4("This will delete the selected data.")
),
title="Do you really want to ERASE the selection?",
footer = tagList(actionButton(ns("confirm_trap_trim_dygraph_actionButton"), "Yes, cut."),
modalButton("Cancel")
)
))
})
observeEvent(input$confirm_trap_trim_dygraph_actionButton, {
removeModal()
trim_obs(trap_selected_obs = f$obs$path,
trim_from = trim_from(),
trim_to = trim_to(),
f = f,
hz = hz())
## rv$update_filter <- rv$update_filter + 1
showNotification("Data trimmed. Graph will refresh.")
shinyjs::hide('dygraph_clean')
rv$update_filter <- rv$update_filter + 1
f$current_obs <- f$obs$name
f$new_obs <- f$new_obs + 1
})
#### Process Data ####
observeEvent(input$baseline_graph_mv, {
base$show_mv <- 'yes'
#shinyjs::show('mv')
})
base_mv_graph <- eventReactive(input$baseline_graph_mv, {
defend_if_empty(input$dygraph_clean_date_window[[1]],
ui = 'Graph/Upload data before calculating baseline',
type = 'error')
defend_if_not_equal(substring(f$obs_input, 1, 3),
'obs',
ui = 'No obs selected',
type = 'error' )
defend_if_empty(dg_data$data, ui = 'Graph obs before continuing', type = 'error')
base$mv_df <- data.frame(mean = RcppRoll::roll_mean(dg_data$data$bead, n = 30, align = 'left', fill = NULL),
var = RcppRoll::roll_var(dg_data$data$bead, n = 30, align = 'left', fill = NULL))
if(input$mv2nm == 1) showNotification('Current mV-to-nm is 1. Do you need to enter a conversion value?', type = 'warning')
#req(input$mv2nm > 1)
ggplot(base$mv_df)+
geom_hex(aes(mean, var), bins = 75)+
ggtitle('Select area on plot to set baseline population')+
ylab('Variance')+
xlab('Mean')+
scale_fill_gradient(low = 'green', high = 'red')+
theme_classic(base_size = 12)+
theme(legend.position = 'none',
panel.background = element_rect(colour = "black", size=2))
})
observeEvent(input$baseline_graph_range, {
defend_if_empty(input$dygraph_clean_date_window[[1]],
ui = 'Graph/Upload data before calculating baseline',
type = 'error')
defend_if_not_equal(substring(f$obs_input, 1, 3),
'obs',
ui = 'No obs selected',
type = 'error' )
## a <- attempt::attempt(is.numeric(input$dygraph_clean_date_window[[1]]))
allow_if(is.numeric(input$dygraph_clean_date_window[[1]]), ui = showNotification('Load data before calculating baseline range'), type = 'error')
if(length(input$dygraph_clean_date_window[[1]]:input$dygraph_clean_date_window[[2]]) > 10){
showNotification('Baseline range selection too long. Make a selection less than 10 seconds.', type = 'error')
}
req(length(input$dygraph_clean_date_window[[1]]:input$dygraph_clean_date_window[[2]]) <= 10)
#browser()
## if(var(dg_data$data$bead) == 1) showNotification('Current mV-to-nm is 1. Do you need to enter a conversion value?', type = 'warning')
if(o$data$channels == 1){
# req(var(dg_data$data$bead) > 5)
base$range_df <- dg_data$data |>
dplyr::filter(dplyr::between(time_sec, as.numeric(trim_from()), as.numeric(trim_to())))
base$range <- mean(base$range_df$bead)
base$range_update_graph <- base$range_update_graph + 1
base$show_range <- 'yes'
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend",
"Remove base" = "range"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
#update saving options
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("Detrend" = "detrend",
"Remove base" = "remove_base"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
} else if(o$data$channels == 2){
base$range_df <- dg_data$data |>
dplyr::filter(dplyr::between(time_sec, as.numeric(trim_from()), as.numeric(trim_to())))|>
dplyr::mutate(bead = bead_1)
base$range <- mean(base$range_df$bead_1)
base$range_1 <- mean(base$range_df$bead_1)
base$range_2 <- mean(base$range_df$bead_2)
base$range_update_graph <- base$range_update_graph + 1
base$show_range <- 'yes'
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend",
"Remove base" = "range"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
#update saving options
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("None" = "none",
"Detrend" = "detrend",
"Remove base" = "remove_base"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
}
})
observeEvent(input$baseline_graph_mv, {
#update saving options
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "how_to_process",
choices = c("Detrend" = "detrend",
"Remove MV" = "remove_mv"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
shinyWidgets::updateRadioGroupButtons(
session = session,
inputId = "mode",
choices = c("Nanometers" = "nm",
"Detrend" = "detrend",
"Remove MV" = "mv"),
checkIcon = list(
yes = tags$i(class = "fa fa-check-square",
style = "color: black"),
no = tags$i(class = "fa fa-square-o",
style = "color: black"))
)
})
output$range_mean <- renderPrint({
validate(need(base$range, 'Press button to calculate mean of selected range'))
cat('The selected baseline range has a mean of ', base$range, ' nm')
})
ggrange <- eventReactive(base$range_update_graph, {
req(base$range_df)
ggplot(isolate(base$range_df))+
geom_line(aes(x = time_sec, y = bead), color = 'black')+
geom_hline(yintercept = isolate(base$range), color = 'firebrick', size = 2)+
ylab('nm')+
xlab('Seconds')+
ggtitle('Baseline range selected with mean')+
theme_classic(base_size = 16)#+
})
output$range <- renderPlot({
req(!is.na(base$show_range))
req(base$range_df, base$range)
ggrange()
})
output$mv <- renderPlot({
req(!is.na(base$show_mv))
req(is.ggplot(base_mv_graph()))
base_mv_graph()
})
base <- reactiveValues(done = 0, range_update_graph = 0, show_range = NA, show_mv = NA)
observe({
#req(!is.na(base$show_mv))
req(input$mv_brush)
#baseline_pop <- input$mv_brush
mv_df <- base$mv_df
#baseline data and fit to density fit
baseline <- dplyr::filter(mv_df, dplyr::between(mean, input$mv_brush$xmin, input$mv_brush$xmax) & dplyr::between(var, input$mv_brush$ymin, input$mv_brush$ymax))
req(!rlang::is_empty(baseline$mean))
baseline_fit <- MASS::fitdistr(baseline$mean, 'normal')
#return values to reactive list
base$baseline <- baseline
base$baseline_fit <- baseline_fit
})
output$baseline_histo <- renderPlot({
req(not_null(base$baseline), not_null(base$baseline_fit))
req(base$baseline_fit$estimate[1])
hist(base$baseline$mean,
pch=20,
breaks=25,
prob=T,
main="Baseline Population",
xlab = 'Nanometers')
curve(dnorm(x, base$baseline_fit$estimate[1], base$baseline_fit$estimate[2]),
col='firebrick', lwd=2, add=T)
})
output$baseline_avg <- renderPrint({
validate(need(base$baseline_fit$estimate[1], 'Baseline MV not measured'))
cat('Baseline average = ', base$baseline_fit$estimate[1], 'mV')
})
logger <- reactiveValues()
status <- reactiveValues()
observeEvent(input$save, ignoreInit = T, {
defend_if_not_equal(substring(f$obs_input, 1, 3),
'obs',
'No obs selected', type = 'error')
if(input$include == 'No'){
input_include <- FALSE
} else {
input_include <- TRUE
}
withProgress(message = 'Saving Data', {
if(is.null(o$data$channels)){
o$data$channels <- 1
}
## browser()
if(o$data$channels == 1){
defend_if_blank(input$mv2nm, ui = 'Enter step cal', type = 'error')
defend_if_blank(input$nm2pn, ui = 'Enter trap stiffness', type = 'error')
}
current_obs <- f$obs$path
trap_data <- file.path(f$obs$path, "trap-data.csv")
data <- data.table::fread(trap_data, sep = ",")
setProgress(0.3)
if(o$data$channels == 1){
data[, processed_bead := raw_bead*as.numeric(input$mv2nm) ]
if(!is.null(input$flip_trace)){
if(input$flip_trace == "y"){
data$processed_bead <- data$processed_bead*-1
}
}
if(input$how_to_process == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
data[, processed_bead := as.vector(pracma::detrend(processed_bead, tt = "linear", bp = break_pts)) ]
} else if(input$how_to_process == 'remove_base'){
data[, processed_bead := processed_bead - base$range ]
} else if(input$how_to_process == 'remove_mv'){
data[, processed_bead := processed_bead - base$baseline_fit$estimate[1] ]
}
opt <- list.files(path = f$obs$path,
pattern = "options.csv",
full.names = TRUE)
opt <- fread(opt)
opt[, `:=`(processor = input$how_to_process,
mv2nm = as.numeric(input$mv2nm),
nm2pn = as.numeric(input$nm2pn),
include = input_include)
]
setProgress(0.5)
data.table::fwrite(data, file = file.path(f$obs$path, 'trap-data.csv'), sep = ",")
data.table::fwrite(opt, file = file.path(f$obs$path, 'options.csv'), sep = ",")
setProgress(0.75)
} else if(o$data$channels == 2){
## browser()
if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
pb1 <- data$raw_bead_1
pb2 <- data$raw_bead_2
} else {
pb1 <- data$raw_bead_1*o$data$mv2nm[1]
pb2 <- data$raw_bead_2*o$data$mv2nm2[1]
}
if(!is.null(input$flip_trace)){
if(input$flip_trace == "y"){
pb1 <- pb1*-1
pb2 <- pb2*-1
}
}
if(input$how_to_process == 'detrend'){
break_pts <- seq(hz()*5, nrow(dg_data$data), by = hz()*5)
pb1 <- as.vector(pracma::detrend(pb1, tt = "linear", bp = break_pts))
pb2 <- as.vector(pracma::detrend(pb2, tt = "linear", bp = break_pts))
} else if(input$how_to_process == 'remove_base'){
## data <- dplyr::mutate(data, processed_bead = processed_bead - base$range)
pb1 <- pb1-base$range_1
pb2 <- pb2-base$range_2
} else if(input$how_to_process == 'remove_mv'){
## data <- dplyr::mutate(data, processed_bead = processed_bead - base$baseline_fit$estimate[1])
} else {
}
setProgress(0.5)
opt <- list.files(path = f$obs$path,
pattern = "options.csv",
full.names = TRUE)
opt <- fread(opt)
## if(is.null(o$data$lab)) o$data$lab <- "not"
if(o$data$lab == "lumicks"){
# lumicks data comes in force, convert to nm for processed bead
# by dividing by the step cal/nm2pn
data[, `:=`(processed_bead_1 = pb1/input$nm2pn,
processed_bead_2 = pb2/input$nm2pn2) ]
opt[, `:=`(processor = input$how_to_process,
include = input_include,
preferred_channel = as.numeric(input$preferred_channel),
nm2pn = input$nm2pn,
nm2pn2 = input$nm2pn2)
]
} else {
data[, `:=`(processed_bead_1 = pb1,
processed_bead_2 = pb2) ]
opt[, `:=`(processor = input$how_to_process,
include = input_include,
preferred_channel = as.numeric(input$preferred_channel))
]
}
data.table::fwrite(data, file = file.path(f$obs$path, 'trap-data.csv'), sep = ",")
data.table::fwrite(opt, file = file.path(f$obs$path, 'options.csv'), sep = ",")
setProgress(0.75)
}
## golem::print_dev( logger[[as.character(input$save)]] )
all_trap_paths <- list_files(f$date$path, pattern = 'options.csv', recursive = T)
setProgress(0.9)
status$df <- purrr::map_df(all_trap_paths$path, ~data.table::fread(.,
sep = ",",
select = c("obs", "processor", "mv2nm", "nm2pn", "include"),
nrows = 1))
setProgress(1)
})
showNotification(paste(f$conditions$name, f$obs$name, 'successfully processed and saved.'), type = 'message')
})
observeEvent(input$status_graph, {
defend_if_null(f$date_input, ui = 'Whoops. You forgot to select a date folder.', type = 'error')
defend_if_blank(f$date_input, ui = 'Whoops. You forgot to select a date folder.', type = 'error')
all_trap_paths <- list_files(f$date$path, pattern = 'options.csv', recursive = T)
defend_if_empty(all_trap_paths, ui = "No 'options.csv' files in date folder yet. Start by loading date with 'Upload Data'", type = 'error')
golem::print_dev(all_trap_paths$path)
status$df <- purrr::map_df(all_trap_paths$path, ~data.table::fread(.,
sep = ",",
select = c("obs", "processor", "mv2nm", "nm2pn", "include"),
nrows = 1))
showNotification('Status table refreshed', type = 'message')
})
output$current_mv2nm <- renderPrint({
cat('mV to nm conversion: ', input$mv2nm)
})
output$info <- DT::renderDT({
req(status$df)
status$df |>
dplyr::rename('Obs' = obs,
'Processor' = processor,
'mV-to-nm' = mv2nm,
'nm-to-pN' = nm2pn,
'Include' = include) |>
DT::datatable() |>
DT::formatStyle('Include',
color = DT::styleEqual(c(F, T), c('red', 'black'))
)
})
}
## To be copied in the UI
# mod_clean_data_ui("clean_data_ui")
## To be copied in the server
# callModule(mod_clean_data_server, "clean_data_ui")
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.