inst/yupana/server.R
In Flavjack/fieldbook: Tools and Statistical Procedures in Plant Science
# -------------------------------------------------------------------------
# Yupana ------------------------------------------------------------------
# -------------------------------------------------------------------------
#> open https://flavjack.github.io/inti/
#> open https://flavjack.shinyapps.io/yupanapro/
#> author .: Flavio Lozano-Isla (lozanoisla.com)
#> date .: 2024-02-05
# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# packages ----------------------------------------------------------------
# -------------------------------------------------------------------------
#> devtools::install_github("flavjack/inti")
suppressPackageStartupMessages({source("pkgs.R")})
# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
options("googleAuthR.scopes.selected" = c("https://www.googleapis.com/auth/spreadsheets"
, "https://www.googleapis.com/auth/userinfo.email"
))
options(gargle_oob_default = TRUE)
options(shiny.port = 1221)
if (file.exists("www/cloud.json")) gar_set_client(web_json = "www/cloud.json", activate = "web")
# -------------------------------------------------------------------------
# app ---------------------------------------------------------------------
# -------------------------------------------------------------------------
shinyServer(function(input, output, session) {
# close auto local session ------------------------------------------------
observe({
if(Sys.getenv('SHINY_PORT') == "") {
session$onSessionEnded(stopApp)
}
})
# auth --------------------------------------------------------------------
source("www/auth.R")
if(file.exists("www/analytics.r")) {source("www/analytics.r", local = T)}
gar_shiny_auth(session)
# longin vs local ---------------------------------------------------------
access_token <- moduleServer(id = "js_token"
, module = googleAuth_js)
# -------------------------------------------------------------------------
output$login <- renderUI({
if (file.exists("www/cloud.json")) {
googleAuth_jsUI("js_token"
, login_text = "LogIn"
, logout_text = "LogOut"
)
} else {
actionButton("local_user", "Local", class = "btn-success")
}
})
gs <- reactive({
if(Sys.getenv('SHINY_PORT') == "") {
gs4_auth(email = TRUE)
} else {
gs4_auth(scopes = "https://www.googleapis.com/auth/spreadsheets"
, cache = FALSE
, use_oob = TRUE
, token = access_token()
)
}
validate( need( gs4_has_token(), "LogIn and insert a url" ) )
as_sheets_id( fieldbook_url() )
})
# -------------------------------------------------------------------------
fieldbook_url <- reactive({
validate( need( input$fieldbook_url, "LogIn and insert a url" ) )
if ( input$fieldbook_url != "" ) {
fieldbook_url <- input$fieldbook_url
}
})
output$fieldbook_gsheet <- renderUI({
validate(need(fieldbook_url(), "LogIn and insert a url") )
info <- gs4_get(gs())
names <- info$sheets$name
selectInput(inputId = "fieldbook_gsheet"
, label = NULL
, choices = c("choose" = ""
, names)
)
})
# open url ----------------------------------------------------------------
output$open_url <- renderUI({
if ( input$fieldbook_url == "" ) {
link <- "https://docs.google.com/spreadsheets/u/0/"
} else {
link <- fieldbook_url()
}
open <- paste0("window.open('", link, "', '_blank')")
actionButton(inputId = "open_sheet"
, label = "Open"
, class = "btn btn-success"
, onclick = open
, width = "100%"
)
})
# -------------------------------------------------------------------------
fb_url <- reactive({
info <- gs4_get(gs())
url <- info$spreadsheet_url
id <- info$sheets %>%
filter(name == input$fieldbook_gsheet) %>%
pluck("id")
fb_url <- paste(url, id, sep = "#gid=")
})
# -------------------------------------------------------------------------
fieldbook <- reactive({
validate(need(input$fieldbook_gsheet, "Choose you fb sheet"))
gs() %>%
range_read(input$fieldbook_gsheet) %>%
select(!starts_with("[") | !ends_with("]"))
})
# -------------------------------------------------------------------------
output$fb_last_factor <- renderUI({
validate(need(fieldbook(), "LogIn and insert a url") )
names <- fieldbook() %>% names()
selectInput(inputId = "fb_last_factor"
, label = NULL
, choices = c("choose" = ""
, names)
)
})
# Yupana: Exploratory -----------------------------------------------------
# -------------------------------------------------------------------------
output$raw_response <- renderUI({
validate(need(fieldbook(), "LogIn and create or insert a url"))
variable_names <- fieldbook() %>%
names()
selectInput(
inputId = "raw_y"
, label = "Response variable"
, choices = c("choose" = ""
, variable_names)
)
})
output$raw_x <- renderUI({
validate(need(fieldbook(), "LogIn and create or insert a url"))
factor_names <- fieldbook() %>%
names()
selectInput(
inputId = "raw_x"
, label = "Axis X"
, choices = c("choose" = ""
, factor_names)
)
})
output$raw_group <- renderUI({
validate(need(fieldbook(), "LogIn and create or insert a url"))
factor_names <- fieldbook() %>%
names()
selectInput(
inputId = "raw_group"
, label = "Grouped"
, choices = c("choose" = ""
, factor_names)
)
})
plotraw <- reactive({
validate(need(fieldbook(), "LogIn and create or insert a url"))
validate(need(input$raw_x, "Choose your parameters"))
validate(need(input$raw_y, "Choose your parameters"))
fieldbook() %>%
plot_raw(type = input$raw_type
, x = input$raw_x
, y = input$raw_y
, group = input$raw_group
, xlab = if(input$raw_xlab == "") input$raw_x else input$raw_xlab
, ylab = if(input$raw_ylab == "") input$raw_y else input$raw_ylab
, glab = if(input$raw_glab == "") NULL else input$raw_glab
, ylimits = input$raw_ylimits
, xrotation = input$raw_xrotation
, legend = input$raw_legend
, color = input$raw_color
, opt = input$raw_opt
, xtext = input$raw_xtext
, gtext = input$raw_gtext
) +
{if(input$raw_type == "scatterplot") {
ggpmisc::stat_poly_eq(aes(label = paste(stat(eq.label), stat(adj.rr.label), sep = "*\", \"*")))
} }
})
output$plotraw <- renderImage({
validate(need(fieldbook(), "LogIn and create or insert a url"))
dim <- input$raw_dimension %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
print(plotraw())
dev.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$plot_raw <- renderUI({
validate(need(plotraw(), "Choose your parameters"))
tagList( div(imageOutput("plotraw"), align = "center") )
})
# Yupana: Fieldbook -------------------------------------------------------
# -------------------------------------------------------------------------
output$fieldbook_preview <- renderUI({
tags$iframe(src = fb_url()
, style="height:580px; width:100%; scrolling=no")
})
# Yupana: Analysis --------------------------------------------------------
# -------------------------------------------------------------------------
output$analysis_last_factor <- renderUI({
validate(need(fieldbook(), "LogIn and insert a url") )
names <- fieldbook() %>% names()
selectInput(inputId = "analysis_last_factor"
, label = "Last factor"
, selected = input$fb_last_factor
, choices = c("choose" = ""
, names)
)
})
output$analysis_response <- renderUI({
validate(need(input$analysis_last_factor, "Select your last factor") )
names <- fieldbook() %>%
select(!1:input$analysis_last_factor) %>%
names()
selectInput(inputId = "analysis_response"
, label = "Response variable"
, choices = c("choose" = ""
, names)
)
})
output$analysis_comparison <- renderUI({
validate(need(input$analysis_last_factor, "Select your last factor") )
names <- fieldbook() %>%
select(1:input$analysis_last_factor) %>%
names()
selectInput(inputId = "analysis_comparison"
, label = "Factor comparison"
, multiple = TRUE
, choices = c("choose" = ""
, names)
)
})
output$analysis_model_factors <- renderUI({
textInput(
inputId = "analysis_model_factors"
, label = "Model factors"
, value = input$fb_model_factors
, placeholder = "e.g. block + factor1*factor2"
, width = "100%"
)
})
observe({
comparison <- input$analysis_comparison %>%
paste(., collapse = " + ")
if( input$fb_model_factors == "" ) {
updateTextInput(session
, inputId = "analysis_model_factors"
, value = comparison)
}
})
# results -----------------------------------------------------------------
# -------------------------------------------------------------------------
analysis <- reactive({
validate(need(input$analysis_response, "Choose your variable"))
validate(need(input$analysis_model_factors, "Include your model factors"))
validate(need(input$analysis_comparison, "Include your model comparison"))
validate(need(input$analysis_last_factor, "Select your last factor") )
factors <- input$analysis_model_factors %>%
gsub("[[:space:]]", "", .)
model_factors <- all.vars(parse(text= factors)) %>% as.vector()
validate(need(all(model_factors %in% names(fieldbook()))
, "Factors not found in dataframe"))
rslt <- yupana_analysis(data = fieldbook()
, response = input$analysis_response
, last_factor = input$analysis_last_factor
, model_factors = input$analysis_model_factors
, comparison = input$analysis_comparison
, test_comp = input$analysis_test_comparison
, sig_level = input$analysis_sig_level
, plot_dist = "boxplot"
, plot_diag = FALSE
, digits = input$analysis_digits
)
})
# -------------------------------------------------------------------------
output$anova <- renderPrint({
anova(analysis()$anova)
})
output$plotdiag <- renderPlot({
diag <- analysis()$plotdiag
plot_grid(plotlist = diag, ncol = 2)
})
output$plotdist <- renderPlot({
analysis()$plotdist
})
# -------------------------------------------------------------------------
output$meancomp <- DT::renderDataTable(server = FALSE, {
inti::web_table(data = analysis()$meancomp
, digits = input$analysis_digits
, file_name = input$analysis_response
, scrolly = "50vh"
, columnwidth = "50px"
)
})
output$smrstats <- DT::renderDataTable(server = FALSE, {
mc <- analysis()$stats %>%
inti::web_table(buttons = "copy", scrolly = "10vh", columnwidth = NULL)
})
# -------------------------------------------------------------------------
output$analysis_preview <- renderUI({
if ( input$analysis_preview_opt == "Gsheet" ) {
tags$iframe(src = fb_url(),
style="height:580px; width:100%; scrolling=no")
} else if ( input$analysis_preview_opt == "Model" ) {
validate( need( input$analysis_model_factors, "Choose your variable") )
tagList(
fluidRow(
column(width = 5,
HTML('<h4><strong>ANOVA</strong></h4>'),
verbatimTextOutput("anova"),
br(),
HTML('<h4><strong>Statistics</strong></h4>'),
DT::dataTableOutput("smrstats")
),
column(width = 7,
HTML('<h4><strong>Mean Comparison</strong></h4>'),
DT::dataTableOutput("meancomp")
)
)
)
} else if ( input$analysis_preview_opt == "Diagnostic" ) {
tagList(
fluidRow(
column(width = 5,
HTML('<h4><strong>Model Diagnostic</strong></h4>'),
plotOutput("plotdiag", width = "auto", height = "500px")
),
column(width = 7,
HTML('<h4><strong>Variable Distribution</strong></h4>'),
plotOutput("plotdist", width = "auto", height = "500px")
)
)
)
}
})
# Yupana: Graphics --------------------------------------------------------
# -------------------------------------------------------------------------
# load --------------------------------------------------------------------
# -------------------------------------------------------------------------
observeEvent(input$graph_smr_load, {
names <- gs() %>% sheet_names()
import <- modalDialog(size = "s", easyClose = T,
title = div(h3("Select your sheet", icon("cloud-upload-alt"))
, align = "left"),
selectInput(
inputId = "smr_load_sheet"
, label = NULL
, choices = c("choose" = ""
, names)
),
footer = tagList(
actionButton("import_sheet", "Import", class = "btn-success")
)
)
showModal(import)
})
observeEvent(input$import_sheet, { removeModal() })
imp_opt <- NULL
makeReactiveBinding("imp_opt")
observeEvent(input$import_sheet, {
validate(need(input$smr_load_sheet, "Select your sheet"))
dt <- gs() %>% range_read(input$smr_load_sheet)
imp_opt <<- dt
})
observeEvent(input$analysis_response, {
imp_opt <<- NULL
})
plot_opt <- reactive({
if(is.null(imp_opt)) {
yupana_import(analysis())
} else if(!is.null(imp_opt)) {
yupana_import(imp_opt)
}
})
output$smr_type <- renderUI({
plot_opt <- plot_opt()
opts <- c("bar", "line")
selection <- plot_opt$plot_args$type
selectInput(
inputId = "smr_type"
, label = "Type"
, choices = opts
, selected = selection
)
})
output$smr_response <- renderUI({
plot_opt <- plot_opt()
opts <- plot_opt$plot_args$y
selectInput(
inputId = "smr_response"
, label = "Response variable"
, choices = opts
)
})
output$smr_x <- renderUI({
plot_opt <- plot_opt()
opts <- plot_opt$factors
selection <- plot_opt$plot_args$x
selectInput(
inputId = "smr_x"
, label = "Axis X"
, choices = opts
, selected = selection
)
})
output$smr_group <- renderUI({
plot_opt <- plot_opt()
opts <- plot_opt$factors
selection <- plot_opt$plot_args$group
selectInput(
inputId = "smr_group"
, label = "Grouped"
, choices = opts
, selected = selection
)
})
output$smr_sig <- renderUI({
plot_opt <- plot_opt()
opts <- c(plot_opt$factors, plot_opt$tabvar, "none")
selection <- if(all(is.na(plot_opt$smr$sig))) {"none"} else {plot_opt$plot_args$sig}
selectInput(
inputId = "smr_sig"
, label = "Significance"
, choices = opts
, selected = selection
)
})
output$smr_error <- renderUI({
plot_opt <- plot_opt()
opts <- c("ste", "std", "none")
selection <- if(all(is.na(plot_opt$smr$ste))) {"none"} else {plot_opt$plot_args$error}
selectInput(
inputId = "smr_error"
, label = "Error bar"
, choices = opts
, selected = selection
)
})
output$plot_error <- renderUI({
plot_opt <- plot_opt()
opts <- c("top", "bottom", "left", "right", "none")
selection <- plot_opt$plot_args$legend
selectInput(
inputId = "smr_legend"
, label = "Legend"
, choices = opts
, selected = selection
)
})
output$smr_ylimits <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$ylimits)) "" else plot_opt$plot_args$ylimits
textInput(
inputId ="smr_ylimits"
, label = "Y limits"
, placeholder = "0*100*20"
, value = selection
)
})
output$smr_xrotation <- renderUI({
plot_opt <- plot_opt()
selection <- ifelse(is.na(plot_opt$plot_args$xrotation)
, "0*0.5*0.5"
, paste(plot_opt$plot_args$xrotation, collapse = "*")
) %>% pluck(1)
textInput(
inputId ="smr_xrotation"
, label = "X rotation"
, placeholder = "angle*h*v"
, value = selection
)
})
output$smr_dimension <- renderUI({
plot_opt <- plot_opt()
selection <- ifelse(is.na(plot_opt$plot_args$dimension)
, "20*10*100"
, paste(plot_opt$plot_args$dimension, collapse = "*")
) %>%
pluck(1)
textInput(
inputId = "smr_dimension"
, label = "Dimensions (W*H*dpi)"
, placeholder = "W*H*dpi"
, value = selection
)
})
output$analysis_model <- renderText({
plot_opt <- plot_opt()
plot_opt$stats_args$model
})
output$plot_ylab <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$ylab)) "" else plot_opt$plot_args$ylab
textInput(
inputId ="smr_ylab"
, label = "Y label"
, value = selection
)
})
output$plot_xlab <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$xlab)) "" else plot_opt$plot_args$xlab
textInput(
inputId ="smr_xlab"
, label = "X label"
, value = selection
)
})
output$plot_glab <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$glab)) "" else plot_opt$plot_args$glab
textInput(
inputId ="smr_glab"
, label = "Group label"
, value = selection
)
})
output$plot_gtext <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$gtext)) "" else plot_opt$plot_args$gtext
textInput(
inputId ="smr_gtext"
, label = "Group brake labels (,)"
, value = selection
)
})
output$plot_xtext <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$xtext)) "" else plot_opt$plot_args$xtext
textInput(
inputId ="smr_xtext"
, label = "X brake labels (,)"
, value = selection
)
})
output$plot_opt <- renderUI({
plot_opt <- plot_opt()
# check!
groups <- plot_opt$stats_args$comparison %>%
strsplit(., "[*]")
if(length(groups) == 3) {
selection <- paste0("facet_grid(. ~", groups[3], ")")
} else {
selection <- if(is.na(plot_opt$plot_args$opt)) "" else plot_opt$plot_args$opt
}
textInput(
inputId ="smr_opt"
, label = "Opt"
, placeholder = "extra layers"
, value = selection
)
})
output$plot_color <- renderUI({
if(is.null(imp_opt)) {
opts <- c("yes", "no")
} else {
opts <- c("manual", "yes", "no")
}
selectInput(
inputId ="smr_color"
, label = "Color"
, choices = opts
)
})
# plot --------------------------------------------------------------------
# -------------------------------------------------------------------------
plotsmr <- reactive({
plot_opt <- plot_opt()
color <- if(input$smr_color == "yes") { TRUE
} else if (input$smr_color == "no") { FALSE
} else if (input$smr_color == "manual"){ plot_opt$plot_args$color }
plot_smr(data = plot_opt$smr
, type = input$smr_type
, x = input$smr_x
, y = input$smr_response
, group = input$smr_group
, xlab = if(input$smr_xlab == "") input$smr_x else input$smr_xlab
, ylab = if(input$smr_ylab == "") input$smr_response else input$smr_ylab
, glab = if(input$smr_glab == "") NULL else input$smr_glab
, ylimits = input$smr_ylimits
, xrotation = input$smr_xrotation
, error = input$smr_error
, sig = input$smr_sig
, legend = input$smr_legend
, opt = input$smr_opt
, gtext = input$smr_gtext
, xtext = input$smr_xtext
, color = color
)
})
# -------------------------------------------------------------------------
output$plotsmr <- renderImage({
validate(need(plotsmr(), "Choose your parameters"))
dim <- input$smr_dimension %>%
strsplit(., "[*]") %>%
unlist() %>%
as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
print(plotsmr())
dev.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
graph_url <- reactive({
sheet_name <- input$graph_smr_name %>% gsub("[[:space:]]", "_", .)
info <- gs4_get(gs())
url <- info$spreadsheet_url
id <- info$sheets %>%
filter(name %in% sheet_name) %>%
pluck("id")
url_preview <- paste(url, id, sep = "#gid=")
})
output$plot_smr <- renderUI({
if ( input$smr_preview_opt == "Gsheet" ) {
tags$iframe(src = graph_url(),
style="height:580px; width:100%; scrolling=no")
} else if (input$smr_preview_opt == "Plots" ) {
tagList(
div(imageOutput("plotsmr"), align = "center")
)
}
})
# export graph options ---------------------------------------------
output$graph_sheet_save <- renderUI({
if(is.null(imp_opt)) {
selection <- input$analysis_response
} else if (!is.null(imp_opt)) {
selection <- input$smr_load_sheet
}
textInput(inputId = "graph_smr_name"
, label = NULL
, value = selection
, placeholder = "Sheet to export"
, width = "100%"
)
})
# -------------------------------------------------------------------------
graph_save_info <- reactive({
if(is.null(imp_opt)) {
dt <- analysis()
} else if(!is.null(imp_opt)) {
dt <- plot_opt()
}
color <- if(input$smr_color == "yes") { TRUE
} else if (input$smr_color == "no") { FALSE
} else { imp_opt$plot$color }
yupana_export(data = dt
#> reactive
, type = input$smr_type
, xlab = input$smr_xlab
, ylab = input$smr_ylab
, glab = input$smr_glab
, ylimits = input$smr_ylimits
, xrotation = input$smr_xrotation
, xtext = input$smr_xtext
, gtext = input$smr_gtext
, legend = input$smr_legend
, sig = input$smr_sig
, error = input$smr_error
, opt = input$smr_opt
, dimension = input$smr_dimension
#>
, color = color
)
})
# -------------------------------------------------------------------------
observeEvent(input$graph_smr_save, {
validate(need(graph_save_info(), "Some paremeter are missing") )
sheet_export <- input$graph_smr_name %>% gsub("[[:space:]]", "_", .)
if ( input$graph_smr_overwrite == "no" & !sheet_export %in% sheet_names(gs())) {
sheet_add(ss = gs(), sheet = sheet_export)
graph_save_info() %>%
sheet_write(ss = gs(), sheet = sheet_export )
} else if(input$graph_smr_overwrite == "yes") {
graph_save_info() %>%
sheet_write(ss = gs(), sheet = sheet_export )
} else { print ("sheet already exist") }
})
# Yupana: Multivariate-----------------------------------------------------
# -------------------------------------------------------------------------
output$mvr_last_factor <- renderUI({
validate(need(fieldbook(), "LogIn and insert a url"))
last_factor <- fieldbook() %>% names()
selectInput(inputId = "mvr_last_factor"
, label = "Last Factor"
, selected = input$fb_last_factor
, choices = c("choose" = ""
, last_factor)
)
})
output$mvr_facts <- renderUI({
validate(need(input$mvr_last_factor, "Choose your factors"))
mvr_factors <- fieldbook() %>%
select(1:input$mvr_last_factor) %>%
names()
selectInput(inputId = "mvr_factors"
, label = "Factors"
, multiple = T
, choices = c("choose" = ""
, mvr_factors)
)
})
# -------------------------------------------------------------------------
output$mvr_groups <- renderUI({
validate(need(input$mvr_factors, "Insert group factor"))
selectInput(inputId = "mvr_groups"
, label = "Groups"
, choices = input$mvr_factors
)
})
output$mvr_variables <- renderUI({
validate(need(input$mvr_last_factor, "Insert variables"))
mvr_variables <- fieldbook() %>%
select(!1:input$mvr_last_factor) %>%
names()
selectInput(inputId = "mvr_variables"
, label = "Variables"
, multiple = TRUE
, choices = c("all"
, mvr_variables)
)
})
# -------------------------------------------------------------------------
mvr <- reactive({
validate(need(input$mvr_variables, "Select your variables"))
yupana_mvr(
data = fieldbook()
, last_factor = input$mvr_last_factor
, summary_by = input$mvr_factors
, groups = input$mvr_groups
, variables = input$mvr_variables
)
})
# -------------------------------------------------------------------------
output$pca_var <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_pca_var %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
mvr()$plots$pca_var %>% print()
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$pca_ind <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_pca_ind %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1]} else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2]} else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3]} else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
mvr()$plots$pca_ind %>% print()
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$hcpc_tree <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_hcp_tree %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
plot.HCPC(x = mvr()$hcpc
, choice = "tree"
)
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$hcpc_map <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_hcp_map %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1]} else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2]} else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3]} else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
plot.HCPC(x = mvr()$hcpc
, choice = "map"
, legend = list(x = "topright"
, cex = 0.6
, inset = 0.001
, box.lty=0
)
, draw.tree = F
)
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$correlation <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_cor %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1]} else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2]} else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3]} else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi, pointsize = 9)
mvr()$data %>%
select(where(is.numeric)) %>%
pairs.panels(x = .
, hist.col="red"
, pch = 21
, method = input$mvr_cor_method
, stars = TRUE
, scale = input$mvr_cor_scale
, lm = TRUE
)
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$mvr_preview <- renderUI({
validate(need(mvr(), "Choose your factors"))
if ( input$mvr_module == "PCA" ) {
tagList(
fluidRow(
box(width = 6,
div(imageOutput("pca_var"), align = "center"),
),
box(width = 6,
div(imageOutput("pca_ind"), align = "center")
)
)
)
} else if ( input$mvr_module == "HCPC" ) {
tagList(
fluidRow(
box(width = 6,
div(imageOutput("hcpc_tree", width = "100%"), align = "center"),
),
box(width = 6,
div(imageOutput("hcpc_map", width = "100%"), align = "center")
)
)
)
} else if (input$mvr_module == "CORR" ) {
tagList(
fluidRow(
box(width = 12,
div(imageOutput("correlation", width = "100%"), align = "center")
)
)
)
}
})
# reshape module ----------------------------------------------------------
# -------------------------------------------------------------------------
# select sheet to reshape -------------------------------------------------
output$reshape_sheet <- renderUI({
validate(need(fieldbook_url(), "LogIn and insert a url") )
info <- gs4_get(gs())
names <- info$sheets$name
selectInput(inputId = "reshape_sheet"
, label = NULL
, choices = c("choose" = ""
, names)
)
})
# reshape preview sheet ---------------------------------------------------
reshape_sheet_url <- reactive({
validate(need(input$reshape_sheet, "LogIn and insert a url") )
info <- gs4_get(gs())
url <- info$spreadsheet_url
id <- info$sheets %>%
filter(name == input$reshape_sheet) %>%
pluck("id")
fb_url <- paste(url, id, sep = "#gid=")
})
output$fieldbook_preview <- renderUI({
validate(need(reshape_sheet_url(), "LogIn and insert a url") )
tags$iframe(src = reshape_sheet_url()
, style="height:580px; width:100%; scrolling=no")
})
# import sheet to reshape -------------------------------------------------
fb2reshape <- reactive({
validate(need(input$reshape_sheet, "Choose you fb sheet"))
gs() %>%
range_read(input$reshape_sheet) %>%
select(!starts_with("[") | !ends_with("]"))
})
# -------------------------------------------------------------------------
output$last_factor_rs <- renderUI({
if ( !is.null(fb2reshape()) ) {
fieldbook_names <- fb2reshape() %>%
names()
selectInput(inputId = "last_factor_rs"
, label = "Last factor"
, choices = c("choose" = ""
, fieldbook_names)
)
} else { print ("Insert sheet name") }
})
output$from_var_rs <- renderUI({
validate( need( input$last_factor_rs, "Insert last factor" ) )
if ( !is.null(fb2reshape()) && input$last_factor_rs != "" ) {
fieldbook_varnames <- fb2reshape() %>%
select( !c(1:input$last_factor_rs) ) %>%
names()
selectInput(inputId = "from_var_rs"
, label = "From variable (optional)"
, choices = c("choose" = ""
, fieldbook_varnames)
)
} else { print ("Insert last factor") }
})
output$to_var_rs <- renderUI({
validate( need( input$last_factor_rs, "Insert last factor" ) )
if ( !is.null(fb2reshape()) && input$last_factor_rs != "" ) {
fieldbook_varnames <- fb2reshape() %>%
select( !c(1:input$last_factor_rs) ) %>%
names()
selectInput(inputId = "to_var_rs"
, label = "To variable (optional)"
, choices = c("choose" = ""
, fieldbook_varnames)
)
} else { print ("Insert last factor") }
})
output$exc_fact_rs <- renderUI({
validate( need( input$last_factor_rs, "Insert last factor" ) )
if ( !is.null( fb2reshape() ) && input$last_factor_rs != "" ) {
exc_fact_rs <- fb2reshape() %>%
select( 1:input$last_factor_rs ) %>%
names()
selectInput(inputId = "exc_fact_rs"
, label = "Exclude Factors (optional)"
, multiple = TRUE
, choices = c("choose" = ""
, exc_fact_rs)
)
} else { print("Insert last factor") }
})
# save reshaped sheet -----------------------------------------------------
output$reshape4save <- renderUI({
textInput(inputId = "reshape4save"
, label = "Sheet export"
, value = "reshaped"
, width = "100%"
)
})
observeEvent(input$fbrs_generate, {
validate( need( input$fieldbook_url, "LogIn and insert a url" ) )
if ( !is.null( fb2reshape() ) && input$last_factor_rs != "" ) {
fbrs <- yupana_reshape(data = fb2reshape()
, last_factor = input$last_factor_rs
, sep = input$fbrs_sep
, new_colname = input$fbrs_newcol
, from_var = input$from_var_rs
, to_var = input$to_var_rs
, exc_factors = input$exc_fact_rs
)
if ( !input$reshape4save %in% sheet_names(gs()) ) {
sheet_add(ss = gs(), sheet = input$reshape4save)
fbrs %>% sheet_write(ss = gs(), sheet = input$reshape4save)
} else { print ("sheet already exist") }
}
})
# module interface --------------------------------------------------------
output$reshape_ui <- renderUI({
tagList(
uiOutput("reshape_sheet"),
uiOutput("last_factor_rs"),
textInput(inputId = "fbrs_sep"
, label = "Separator"
, value = ""
, placeholder = "e.g: var_flw --> '_'"
),
textInput(inputId = "fbrs_newcol"
, label = "New column"
, value = ""
, placeholder = "Column name"
)
, uiOutput("from_var_rs")
, uiOutput("to_var_rs")
, uiOutput("exc_fact_rs")
, uiOutput("reshape4save")
, actionButton(inputId = "fbrs_generate"
, label = "Generate"
, class = "btn btn-warning"
)
)
})
output$fb_modules <- renderUI({ uiOutput("reshape_ui") })
# end yupana --------------------------------------------------------------
# -------------------------------------------------------------------------
})
Flavjack/fieldbook documentation built on May 17, 2024, 12:50 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.
# -------------------------------------------------------------------------
# Yupana ------------------------------------------------------------------
# -------------------------------------------------------------------------
#> open https://flavjack.github.io/inti/
#> open https://flavjack.shinyapps.io/yupanapro/
#> author .: Flavio Lozano-Isla (lozanoisla.com)
#> date .: 2024-02-05
# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
# packages ----------------------------------------------------------------
# -------------------------------------------------------------------------
#> devtools::install_github("flavjack/inti")
suppressPackageStartupMessages({source("pkgs.R")})
# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
options("googleAuthR.scopes.selected" = c("https://www.googleapis.com/auth/spreadsheets"
, "https://www.googleapis.com/auth/userinfo.email"
))
options(gargle_oob_default = TRUE)
options(shiny.port = 1221)
if (file.exists("www/cloud.json")) gar_set_client(web_json = "www/cloud.json", activate = "web")
# -------------------------------------------------------------------------
# app ---------------------------------------------------------------------
# -------------------------------------------------------------------------
shinyServer(function(input, output, session) {
# close auto local session ------------------------------------------------
observe({
if(Sys.getenv('SHINY_PORT') == "") {
session$onSessionEnded(stopApp)
}
})
# auth --------------------------------------------------------------------
source("www/auth.R")
if(file.exists("www/analytics.r")) {source("www/analytics.r", local = T)}
gar_shiny_auth(session)
# longin vs local ---------------------------------------------------------
access_token <- moduleServer(id = "js_token"
, module = googleAuth_js)
# -------------------------------------------------------------------------
output$login <- renderUI({
if (file.exists("www/cloud.json")) {
googleAuth_jsUI("js_token"
, login_text = "LogIn"
, logout_text = "LogOut"
)
} else {
actionButton("local_user", "Local", class = "btn-success")
}
})
gs <- reactive({
if(Sys.getenv('SHINY_PORT') == "") {
gs4_auth(email = TRUE)
} else {
gs4_auth(scopes = "https://www.googleapis.com/auth/spreadsheets"
, cache = FALSE
, use_oob = TRUE
, token = access_token()
)
}
validate( need( gs4_has_token(), "LogIn and insert a url" ) )
as_sheets_id( fieldbook_url() )
})
# -------------------------------------------------------------------------
fieldbook_url <- reactive({
validate( need( input$fieldbook_url, "LogIn and insert a url" ) )
if ( input$fieldbook_url != "" ) {
fieldbook_url <- input$fieldbook_url
}
})
output$fieldbook_gsheet <- renderUI({
validate(need(fieldbook_url(), "LogIn and insert a url") )
info <- gs4_get(gs())
names <- info$sheets$name
selectInput(inputId = "fieldbook_gsheet"
, label = NULL
, choices = c("choose" = ""
, names)
)
})
# open url ----------------------------------------------------------------
output$open_url <- renderUI({
if ( input$fieldbook_url == "" ) {
link <- "https://docs.google.com/spreadsheets/u/0/"
} else {
link <- fieldbook_url()
}
open <- paste0("window.open('", link, "', '_blank')")
actionButton(inputId = "open_sheet"
, label = "Open"
, class = "btn btn-success"
, onclick = open
, width = "100%"
)
})
# -------------------------------------------------------------------------
fb_url <- reactive({
info <- gs4_get(gs())
url <- info$spreadsheet_url
id <- info$sheets %>%
filter(name == input$fieldbook_gsheet) %>%
pluck("id")
fb_url <- paste(url, id, sep = "#gid=")
})
# -------------------------------------------------------------------------
fieldbook <- reactive({
validate(need(input$fieldbook_gsheet, "Choose you fb sheet"))
gs() %>%
range_read(input$fieldbook_gsheet) %>%
select(!starts_with("[") | !ends_with("]"))
})
# -------------------------------------------------------------------------
output$fb_last_factor <- renderUI({
validate(need(fieldbook(), "LogIn and insert a url") )
names <- fieldbook() %>% names()
selectInput(inputId = "fb_last_factor"
, label = NULL
, choices = c("choose" = ""
, names)
)
})
# Yupana: Exploratory -----------------------------------------------------
# -------------------------------------------------------------------------
output$raw_response <- renderUI({
validate(need(fieldbook(), "LogIn and create or insert a url"))
variable_names <- fieldbook() %>%
names()
selectInput(
inputId = "raw_y"
, label = "Response variable"
, choices = c("choose" = ""
, variable_names)
)
})
output$raw_x <- renderUI({
validate(need(fieldbook(), "LogIn and create or insert a url"))
factor_names <- fieldbook() %>%
names()
selectInput(
inputId = "raw_x"
, label = "Axis X"
, choices = c("choose" = ""
, factor_names)
)
})
output$raw_group <- renderUI({
validate(need(fieldbook(), "LogIn and create or insert a url"))
factor_names <- fieldbook() %>%
names()
selectInput(
inputId = "raw_group"
, label = "Grouped"
, choices = c("choose" = ""
, factor_names)
)
})
plotraw <- reactive({
validate(need(fieldbook(), "LogIn and create or insert a url"))
validate(need(input$raw_x, "Choose your parameters"))
validate(need(input$raw_y, "Choose your parameters"))
fieldbook() %>%
plot_raw(type = input$raw_type
, x = input$raw_x
, y = input$raw_y
, group = input$raw_group
, xlab = if(input$raw_xlab == "") input$raw_x else input$raw_xlab
, ylab = if(input$raw_ylab == "") input$raw_y else input$raw_ylab
, glab = if(input$raw_glab == "") NULL else input$raw_glab
, ylimits = input$raw_ylimits
, xrotation = input$raw_xrotation
, legend = input$raw_legend
, color = input$raw_color
, opt = input$raw_opt
, xtext = input$raw_xtext
, gtext = input$raw_gtext
) +
{if(input$raw_type == "scatterplot") {
ggpmisc::stat_poly_eq(aes(label = paste(stat(eq.label), stat(adj.rr.label), sep = "*\", \"*")))
} }
})
output$plotraw <- renderImage({
validate(need(fieldbook(), "LogIn and create or insert a url"))
dim <- input$raw_dimension %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
print(plotraw())
dev.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$plot_raw <- renderUI({
validate(need(plotraw(), "Choose your parameters"))
tagList( div(imageOutput("plotraw"), align = "center") )
})
# Yupana: Fieldbook -------------------------------------------------------
# -------------------------------------------------------------------------
output$fieldbook_preview <- renderUI({
tags$iframe(src = fb_url()
, style="height:580px; width:100%; scrolling=no")
})
# Yupana: Analysis --------------------------------------------------------
# -------------------------------------------------------------------------
output$analysis_last_factor <- renderUI({
validate(need(fieldbook(), "LogIn and insert a url") )
names <- fieldbook() %>% names()
selectInput(inputId = "analysis_last_factor"
, label = "Last factor"
, selected = input$fb_last_factor
, choices = c("choose" = ""
, names)
)
})
output$analysis_response <- renderUI({
validate(need(input$analysis_last_factor, "Select your last factor") )
names <- fieldbook() %>%
select(!1:input$analysis_last_factor) %>%
names()
selectInput(inputId = "analysis_response"
, label = "Response variable"
, choices = c("choose" = ""
, names)
)
})
output$analysis_comparison <- renderUI({
validate(need(input$analysis_last_factor, "Select your last factor") )
names <- fieldbook() %>%
select(1:input$analysis_last_factor) %>%
names()
selectInput(inputId = "analysis_comparison"
, label = "Factor comparison"
, multiple = TRUE
, choices = c("choose" = ""
, names)
)
})
output$analysis_model_factors <- renderUI({
textInput(
inputId = "analysis_model_factors"
, label = "Model factors"
, value = input$fb_model_factors
, placeholder = "e.g. block + factor1*factor2"
, width = "100%"
)
})
observe({
comparison <- input$analysis_comparison %>%
paste(., collapse = " + ")
if( input$fb_model_factors == "" ) {
updateTextInput(session
, inputId = "analysis_model_factors"
, value = comparison)
}
})
# results -----------------------------------------------------------------
# -------------------------------------------------------------------------
analysis <- reactive({
validate(need(input$analysis_response, "Choose your variable"))
validate(need(input$analysis_model_factors, "Include your model factors"))
validate(need(input$analysis_comparison, "Include your model comparison"))
validate(need(input$analysis_last_factor, "Select your last factor") )
factors <- input$analysis_model_factors %>%
gsub("[[:space:]]", "", .)
model_factors <- all.vars(parse(text= factors)) %>% as.vector()
validate(need(all(model_factors %in% names(fieldbook()))
, "Factors not found in dataframe"))
rslt <- yupana_analysis(data = fieldbook()
, response = input$analysis_response
, last_factor = input$analysis_last_factor
, model_factors = input$analysis_model_factors
, comparison = input$analysis_comparison
, test_comp = input$analysis_test_comparison
, sig_level = input$analysis_sig_level
, plot_dist = "boxplot"
, plot_diag = FALSE
, digits = input$analysis_digits
)
})
# -------------------------------------------------------------------------
output$anova <- renderPrint({
anova(analysis()$anova)
})
output$plotdiag <- renderPlot({
diag <- analysis()$plotdiag
plot_grid(plotlist = diag, ncol = 2)
})
output$plotdist <- renderPlot({
analysis()$plotdist
})
# -------------------------------------------------------------------------
output$meancomp <- DT::renderDataTable(server = FALSE, {
inti::web_table(data = analysis()$meancomp
, digits = input$analysis_digits
, file_name = input$analysis_response
, scrolly = "50vh"
, columnwidth = "50px"
)
})
output$smrstats <- DT::renderDataTable(server = FALSE, {
mc <- analysis()$stats %>%
inti::web_table(buttons = "copy", scrolly = "10vh", columnwidth = NULL)
})
# -------------------------------------------------------------------------
output$analysis_preview <- renderUI({
if ( input$analysis_preview_opt == "Gsheet" ) {
tags$iframe(src = fb_url(),
style="height:580px; width:100%; scrolling=no")
} else if ( input$analysis_preview_opt == "Model" ) {
validate( need( input$analysis_model_factors, "Choose your variable") )
tagList(
fluidRow(
column(width = 5,
HTML('<h4><strong>ANOVA</strong></h4>'),
verbatimTextOutput("anova"),
br(),
HTML('<h4><strong>Statistics</strong></h4>'),
DT::dataTableOutput("smrstats")
),
column(width = 7,
HTML('<h4><strong>Mean Comparison</strong></h4>'),
DT::dataTableOutput("meancomp")
)
)
)
} else if ( input$analysis_preview_opt == "Diagnostic" ) {
tagList(
fluidRow(
column(width = 5,
HTML('<h4><strong>Model Diagnostic</strong></h4>'),
plotOutput("plotdiag", width = "auto", height = "500px")
),
column(width = 7,
HTML('<h4><strong>Variable Distribution</strong></h4>'),
plotOutput("plotdist", width = "auto", height = "500px")
)
)
)
}
})
# Yupana: Graphics --------------------------------------------------------
# -------------------------------------------------------------------------
# load --------------------------------------------------------------------
# -------------------------------------------------------------------------
observeEvent(input$graph_smr_load, {
names <- gs() %>% sheet_names()
import <- modalDialog(size = "s", easyClose = T,
title = div(h3("Select your sheet", icon("cloud-upload-alt"))
, align = "left"),
selectInput(
inputId = "smr_load_sheet"
, label = NULL
, choices = c("choose" = ""
, names)
),
footer = tagList(
actionButton("import_sheet", "Import", class = "btn-success")
)
)
showModal(import)
})
observeEvent(input$import_sheet, { removeModal() })
imp_opt <- NULL
makeReactiveBinding("imp_opt")
observeEvent(input$import_sheet, {
validate(need(input$smr_load_sheet, "Select your sheet"))
dt <- gs() %>% range_read(input$smr_load_sheet)
imp_opt <<- dt
})
observeEvent(input$analysis_response, {
imp_opt <<- NULL
})
plot_opt <- reactive({
if(is.null(imp_opt)) {
yupana_import(analysis())
} else if(!is.null(imp_opt)) {
yupana_import(imp_opt)
}
})
output$smr_type <- renderUI({
plot_opt <- plot_opt()
opts <- c("bar", "line")
selection <- plot_opt$plot_args$type
selectInput(
inputId = "smr_type"
, label = "Type"
, choices = opts
, selected = selection
)
})
output$smr_response <- renderUI({
plot_opt <- plot_opt()
opts <- plot_opt$plot_args$y
selectInput(
inputId = "smr_response"
, label = "Response variable"
, choices = opts
)
})
output$smr_x <- renderUI({
plot_opt <- plot_opt()
opts <- plot_opt$factors
selection <- plot_opt$plot_args$x
selectInput(
inputId = "smr_x"
, label = "Axis X"
, choices = opts
, selected = selection
)
})
output$smr_group <- renderUI({
plot_opt <- plot_opt()
opts <- plot_opt$factors
selection <- plot_opt$plot_args$group
selectInput(
inputId = "smr_group"
, label = "Grouped"
, choices = opts
, selected = selection
)
})
output$smr_sig <- renderUI({
plot_opt <- plot_opt()
opts <- c(plot_opt$factors, plot_opt$tabvar, "none")
selection <- if(all(is.na(plot_opt$smr$sig))) {"none"} else {plot_opt$plot_args$sig}
selectInput(
inputId = "smr_sig"
, label = "Significance"
, choices = opts
, selected = selection
)
})
output$smr_error <- renderUI({
plot_opt <- plot_opt()
opts <- c("ste", "std", "none")
selection <- if(all(is.na(plot_opt$smr$ste))) {"none"} else {plot_opt$plot_args$error}
selectInput(
inputId = "smr_error"
, label = "Error bar"
, choices = opts
, selected = selection
)
})
output$plot_error <- renderUI({
plot_opt <- plot_opt()
opts <- c("top", "bottom", "left", "right", "none")
selection <- plot_opt$plot_args$legend
selectInput(
inputId = "smr_legend"
, label = "Legend"
, choices = opts
, selected = selection
)
})
output$smr_ylimits <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$ylimits)) "" else plot_opt$plot_args$ylimits
textInput(
inputId ="smr_ylimits"
, label = "Y limits"
, placeholder = "0*100*20"
, value = selection
)
})
output$smr_xrotation <- renderUI({
plot_opt <- plot_opt()
selection <- ifelse(is.na(plot_opt$plot_args$xrotation)
, "0*0.5*0.5"
, paste(plot_opt$plot_args$xrotation, collapse = "*")
) %>% pluck(1)
textInput(
inputId ="smr_xrotation"
, label = "X rotation"
, placeholder = "angle*h*v"
, value = selection
)
})
output$smr_dimension <- renderUI({
plot_opt <- plot_opt()
selection <- ifelse(is.na(plot_opt$plot_args$dimension)
, "20*10*100"
, paste(plot_opt$plot_args$dimension, collapse = "*")
) %>%
pluck(1)
textInput(
inputId = "smr_dimension"
, label = "Dimensions (W*H*dpi)"
, placeholder = "W*H*dpi"
, value = selection
)
})
output$analysis_model <- renderText({
plot_opt <- plot_opt()
plot_opt$stats_args$model
})
output$plot_ylab <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$ylab)) "" else plot_opt$plot_args$ylab
textInput(
inputId ="smr_ylab"
, label = "Y label"
, value = selection
)
})
output$plot_xlab <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$xlab)) "" else plot_opt$plot_args$xlab
textInput(
inputId ="smr_xlab"
, label = "X label"
, value = selection
)
})
output$plot_glab <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$glab)) "" else plot_opt$plot_args$glab
textInput(
inputId ="smr_glab"
, label = "Group label"
, value = selection
)
})
output$plot_gtext <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$gtext)) "" else plot_opt$plot_args$gtext
textInput(
inputId ="smr_gtext"
, label = "Group brake labels (,)"
, value = selection
)
})
output$plot_xtext <- renderUI({
plot_opt <- plot_opt()
selection <- if(is.na(plot_opt$plot_args$xtext)) "" else plot_opt$plot_args$xtext
textInput(
inputId ="smr_xtext"
, label = "X brake labels (,)"
, value = selection
)
})
output$plot_opt <- renderUI({
plot_opt <- plot_opt()
# check!
groups <- plot_opt$stats_args$comparison %>%
strsplit(., "[*]")
if(length(groups) == 3) {
selection <- paste0("facet_grid(. ~", groups[3], ")")
} else {
selection <- if(is.na(plot_opt$plot_args$opt)) "" else plot_opt$plot_args$opt
}
textInput(
inputId ="smr_opt"
, label = "Opt"
, placeholder = "extra layers"
, value = selection
)
})
output$plot_color <- renderUI({
if(is.null(imp_opt)) {
opts <- c("yes", "no")
} else {
opts <- c("manual", "yes", "no")
}
selectInput(
inputId ="smr_color"
, label = "Color"
, choices = opts
)
})
# plot --------------------------------------------------------------------
# -------------------------------------------------------------------------
plotsmr <- reactive({
plot_opt <- plot_opt()
color <- if(input$smr_color == "yes") { TRUE
} else if (input$smr_color == "no") { FALSE
} else if (input$smr_color == "manual"){ plot_opt$plot_args$color }
plot_smr(data = plot_opt$smr
, type = input$smr_type
, x = input$smr_x
, y = input$smr_response
, group = input$smr_group
, xlab = if(input$smr_xlab == "") input$smr_x else input$smr_xlab
, ylab = if(input$smr_ylab == "") input$smr_response else input$smr_ylab
, glab = if(input$smr_glab == "") NULL else input$smr_glab
, ylimits = input$smr_ylimits
, xrotation = input$smr_xrotation
, error = input$smr_error
, sig = input$smr_sig
, legend = input$smr_legend
, opt = input$smr_opt
, gtext = input$smr_gtext
, xtext = input$smr_xtext
, color = color
)
})
# -------------------------------------------------------------------------
output$plotsmr <- renderImage({
validate(need(plotsmr(), "Choose your parameters"))
dim <- input$smr_dimension %>%
strsplit(., "[*]") %>%
unlist() %>%
as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
print(plotsmr())
dev.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
graph_url <- reactive({
sheet_name <- input$graph_smr_name %>% gsub("[[:space:]]", "_", .)
info <- gs4_get(gs())
url <- info$spreadsheet_url
id <- info$sheets %>%
filter(name %in% sheet_name) %>%
pluck("id")
url_preview <- paste(url, id, sep = "#gid=")
})
output$plot_smr <- renderUI({
if ( input$smr_preview_opt == "Gsheet" ) {
tags$iframe(src = graph_url(),
style="height:580px; width:100%; scrolling=no")
} else if (input$smr_preview_opt == "Plots" ) {
tagList(
div(imageOutput("plotsmr"), align = "center")
)
}
})
# export graph options ---------------------------------------------
output$graph_sheet_save <- renderUI({
if(is.null(imp_opt)) {
selection <- input$analysis_response
} else if (!is.null(imp_opt)) {
selection <- input$smr_load_sheet
}
textInput(inputId = "graph_smr_name"
, label = NULL
, value = selection
, placeholder = "Sheet to export"
, width = "100%"
)
})
# -------------------------------------------------------------------------
graph_save_info <- reactive({
if(is.null(imp_opt)) {
dt <- analysis()
} else if(!is.null(imp_opt)) {
dt <- plot_opt()
}
color <- if(input$smr_color == "yes") { TRUE
} else if (input$smr_color == "no") { FALSE
} else { imp_opt$plot$color }
yupana_export(data = dt
#> reactive
, type = input$smr_type
, xlab = input$smr_xlab
, ylab = input$smr_ylab
, glab = input$smr_glab
, ylimits = input$smr_ylimits
, xrotation = input$smr_xrotation
, xtext = input$smr_xtext
, gtext = input$smr_gtext
, legend = input$smr_legend
, sig = input$smr_sig
, error = input$smr_error
, opt = input$smr_opt
, dimension = input$smr_dimension
#>
, color = color
)
})
# -------------------------------------------------------------------------
observeEvent(input$graph_smr_save, {
validate(need(graph_save_info(), "Some paremeter are missing") )
sheet_export <- input$graph_smr_name %>% gsub("[[:space:]]", "_", .)
if ( input$graph_smr_overwrite == "no" & !sheet_export %in% sheet_names(gs())) {
sheet_add(ss = gs(), sheet = sheet_export)
graph_save_info() %>%
sheet_write(ss = gs(), sheet = sheet_export )
} else if(input$graph_smr_overwrite == "yes") {
graph_save_info() %>%
sheet_write(ss = gs(), sheet = sheet_export )
} else { print ("sheet already exist") }
})
# Yupana: Multivariate-----------------------------------------------------
# -------------------------------------------------------------------------
output$mvr_last_factor <- renderUI({
validate(need(fieldbook(), "LogIn and insert a url"))
last_factor <- fieldbook() %>% names()
selectInput(inputId = "mvr_last_factor"
, label = "Last Factor"
, selected = input$fb_last_factor
, choices = c("choose" = ""
, last_factor)
)
})
output$mvr_facts <- renderUI({
validate(need(input$mvr_last_factor, "Choose your factors"))
mvr_factors <- fieldbook() %>%
select(1:input$mvr_last_factor) %>%
names()
selectInput(inputId = "mvr_factors"
, label = "Factors"
, multiple = T
, choices = c("choose" = ""
, mvr_factors)
)
})
# -------------------------------------------------------------------------
output$mvr_groups <- renderUI({
validate(need(input$mvr_factors, "Insert group factor"))
selectInput(inputId = "mvr_groups"
, label = "Groups"
, choices = input$mvr_factors
)
})
output$mvr_variables <- renderUI({
validate(need(input$mvr_last_factor, "Insert variables"))
mvr_variables <- fieldbook() %>%
select(!1:input$mvr_last_factor) %>%
names()
selectInput(inputId = "mvr_variables"
, label = "Variables"
, multiple = TRUE
, choices = c("all"
, mvr_variables)
)
})
# -------------------------------------------------------------------------
mvr <- reactive({
validate(need(input$mvr_variables, "Select your variables"))
yupana_mvr(
data = fieldbook()
, last_factor = input$mvr_last_factor
, summary_by = input$mvr_factors
, groups = input$mvr_groups
, variables = input$mvr_variables
)
})
# -------------------------------------------------------------------------
output$pca_var <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_pca_var %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
mvr()$plots$pca_var %>% print()
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$pca_ind <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_pca_ind %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1]} else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2]} else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3]} else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
mvr()$plots$pca_ind %>% print()
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$hcpc_tree <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_hcp_tree %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1] } else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2] } else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3] } else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
plot.HCPC(x = mvr()$hcpc
, choice = "tree"
)
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$hcpc_map <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_hcp_map %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1]} else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2]} else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3]} else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi)
plot.HCPC(x = mvr()$hcpc
, choice = "map"
, legend = list(x = "topright"
, cex = 0.6
, inset = 0.001
, box.lty=0
)
, draw.tree = F
)
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$correlation <- renderImage({
validate(need(mvr(), "Choose your factors"))
dim <- input$mvr_dimension_cor %>%
strsplit(., "[*]") %>%
pluck(1) %>% as.numeric()
if(!is.na(dim[1])) { ancho <- dim[1]} else {ancho <- input$graph_width}
if(!is.na(dim[2])) { alto <- dim[2]} else {alto <- input$graph_height}
if(!is.na(dim[3])) { dpi <- dim[3]} else {dpi <- input$graph_dpi}
outfile <- tempfile(fileext = ".png")
png(outfile, width = ancho, height = alto, units = "cm", res = dpi, pointsize = 9)
mvr()$data %>%
select(where(is.numeric)) %>%
pairs.panels(x = .
, hist.col="red"
, pch = 21
, method = input$mvr_cor_method
, stars = TRUE
, scale = input$mvr_cor_scale
, lm = TRUE
)
graphics.off()
list(src = outfile)
}, deleteFile = TRUE)
# -------------------------------------------------------------------------
output$mvr_preview <- renderUI({
validate(need(mvr(), "Choose your factors"))
if ( input$mvr_module == "PCA" ) {
tagList(
fluidRow(
box(width = 6,
div(imageOutput("pca_var"), align = "center"),
),
box(width = 6,
div(imageOutput("pca_ind"), align = "center")
)
)
)
} else if ( input$mvr_module == "HCPC" ) {
tagList(
fluidRow(
box(width = 6,
div(imageOutput("hcpc_tree", width = "100%"), align = "center"),
),
box(width = 6,
div(imageOutput("hcpc_map", width = "100%"), align = "center")
)
)
)
} else if (input$mvr_module == "CORR" ) {
tagList(
fluidRow(
box(width = 12,
div(imageOutput("correlation", width = "100%"), align = "center")
)
)
)
}
})
# reshape module ----------------------------------------------------------
# -------------------------------------------------------------------------
# select sheet to reshape -------------------------------------------------
output$reshape_sheet <- renderUI({
validate(need(fieldbook_url(), "LogIn and insert a url") )
info <- gs4_get(gs())
names <- info$sheets$name
selectInput(inputId = "reshape_sheet"
, label = NULL
, choices = c("choose" = ""
, names)
)
})
# reshape preview sheet ---------------------------------------------------
reshape_sheet_url <- reactive({
validate(need(input$reshape_sheet, "LogIn and insert a url") )
info <- gs4_get(gs())
url <- info$spreadsheet_url
id <- info$sheets %>%
filter(name == input$reshape_sheet) %>%
pluck("id")
fb_url <- paste(url, id, sep = "#gid=")
})
output$fieldbook_preview <- renderUI({
validate(need(reshape_sheet_url(), "LogIn and insert a url") )
tags$iframe(src = reshape_sheet_url()
, style="height:580px; width:100%; scrolling=no")
})
# import sheet to reshape -------------------------------------------------
fb2reshape <- reactive({
validate(need(input$reshape_sheet, "Choose you fb sheet"))
gs() %>%
range_read(input$reshape_sheet) %>%
select(!starts_with("[") | !ends_with("]"))
})
# -------------------------------------------------------------------------
output$last_factor_rs <- renderUI({
if ( !is.null(fb2reshape()) ) {
fieldbook_names <- fb2reshape() %>%
names()
selectInput(inputId = "last_factor_rs"
, label = "Last factor"
, choices = c("choose" = ""
, fieldbook_names)
)
} else { print ("Insert sheet name") }
})
output$from_var_rs <- renderUI({
validate( need( input$last_factor_rs, "Insert last factor" ) )
if ( !is.null(fb2reshape()) && input$last_factor_rs != "" ) {
fieldbook_varnames <- fb2reshape() %>%
select( !c(1:input$last_factor_rs) ) %>%
names()
selectInput(inputId = "from_var_rs"
, label = "From variable (optional)"
, choices = c("choose" = ""
, fieldbook_varnames)
)
} else { print ("Insert last factor") }
})
output$to_var_rs <- renderUI({
validate( need( input$last_factor_rs, "Insert last factor" ) )
if ( !is.null(fb2reshape()) && input$last_factor_rs != "" ) {
fieldbook_varnames <- fb2reshape() %>%
select( !c(1:input$last_factor_rs) ) %>%
names()
selectInput(inputId = "to_var_rs"
, label = "To variable (optional)"
, choices = c("choose" = ""
, fieldbook_varnames)
)
} else { print ("Insert last factor") }
})
output$exc_fact_rs <- renderUI({
validate( need( input$last_factor_rs, "Insert last factor" ) )
if ( !is.null( fb2reshape() ) && input$last_factor_rs != "" ) {
exc_fact_rs <- fb2reshape() %>%
select( 1:input$last_factor_rs ) %>%
names()
selectInput(inputId = "exc_fact_rs"
, label = "Exclude Factors (optional)"
, multiple = TRUE
, choices = c("choose" = ""
, exc_fact_rs)
)
} else { print("Insert last factor") }
})
# save reshaped sheet -----------------------------------------------------
output$reshape4save <- renderUI({
textInput(inputId = "reshape4save"
, label = "Sheet export"
, value = "reshaped"
, width = "100%"
)
})
observeEvent(input$fbrs_generate, {
validate( need( input$fieldbook_url, "LogIn and insert a url" ) )
if ( !is.null( fb2reshape() ) && input$last_factor_rs != "" ) {
fbrs <- yupana_reshape(data = fb2reshape()
, last_factor = input$last_factor_rs
, sep = input$fbrs_sep
, new_colname = input$fbrs_newcol
, from_var = input$from_var_rs
, to_var = input$to_var_rs
, exc_factors = input$exc_fact_rs
)
if ( !input$reshape4save %in% sheet_names(gs()) ) {
sheet_add(ss = gs(), sheet = input$reshape4save)
fbrs %>% sheet_write(ss = gs(), sheet = input$reshape4save)
} else { print ("sheet already exist") }
}
})
# module interface --------------------------------------------------------
output$reshape_ui <- renderUI({
tagList(
uiOutput("reshape_sheet"),
uiOutput("last_factor_rs"),
textInput(inputId = "fbrs_sep"
, label = "Separator"
, value = ""
, placeholder = "e.g: var_flw --> '_'"
),
textInput(inputId = "fbrs_newcol"
, label = "New column"
, value = ""
, placeholder = "Column name"
)
, uiOutput("from_var_rs")
, uiOutput("to_var_rs")
, uiOutput("exc_fact_rs")
, uiOutput("reshape4save")
, actionButton(inputId = "fbrs_generate"
, label = "Generate"
, class = "btn btn-warning"
)
)
})
output$fb_modules <- renderUI({ uiOutput("reshape_ui") })
# end yupana --------------------------------------------------------------
# -------------------------------------------------------------------------
})
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.