In charlottesirot/isoHelpR: Help to handle TCD and CNEA files
#remove leading and trailing space
trim <- function (x) gsub("^\\s+|\\s+$", "", x)
# Returns the indices in the vector that correspond to integer or floating point
getNumericIndices <- function(vect) {
return(grep("^[+-]?([0-9]*[.])?[0-9]+$", vect, value = FALSE))
}
containsCharacter <- function(vect) {
numIndices <- getNumericIndices(vect)
result = c()
if(length(numIndices) == 0) {return(result)}
for(i in 1:length(vect)){
printDebug(trim(vect[i]))
if(!is.na(trim(vect[i]))){
if(!is.element(i, numIndices) && trim(vect[i]) != ""){
result <- c(result, i)
}
}
}
return(result)
}
# Debug output function
DEBUG_FILE = "/home/cha/debug.log"
printDebug <- function(message){
write(paste("[", Sys.time(), "] ", message),file=DEBUG_FILE,append=TRUE)
#write(message,file=DEBUG_FILE,append=TRUE)
}
# function to ask for the background values
is.null.vector <- function(x) {
sapply(x, is.null)
}
separateAnalysis_CNEA <- function(data, column1, column2) {
vect1 <- which(is.na(column1))
listPlace1 <- successiveValues(vect1)
vect2 <- which(is.na(column2))
listPlace2 <- successiveValues(vect2)
if(length(listPlace1) != 0 | length(listPlace2) != 0) {
if(length(listPlace1) == length(listPlace2)) {
toReturn <- lapply(1:length(listPlace1), function(x) {
data[c(listPlace1[[x]],listPlace2[[x]]), ]
})
} else {
toReturn <- NULL
}
} else {
toReturn <- NULL
}
return(toReturn)
}
is.numeric_cha <- function(x) {
sapply(1:length(x), function(i) {
if(is.null(x[i])) {return(F)}
toTest <- as.numeric(as.character(x[i]))
if(!is.na(toTest) & is.numeric(toTest)) {
return(T)
} else {F}
})
}
successiveValues = function(vect) {
if(length(vect) != 1) {
length.vect <- length(vect)
i <- 1
k <- 1
finalList <- list()
while(i < length.vect) {
finalList[k][[1]] <- vect[i]
while(vect[i + 1] == vect[i] +1 & i < length.vect) {
finalList[k][[1]] <- c(finalList[k][[1]], vect[i+1])
i <- i+1
}
i <- i+1
k <- k+1
}
if(length(unlist(finalList)) != length.vect) {
finalList[[k]] <- vect[length.vect]
}
} else {
finalList <- list(vect)
}
return(finalList)
}
# some helpful threads
# https://stat.ethz.ch/pipermail/r-help/2008-September/172641.html
# http://tolstoy.newcastle.edu.au/R/e4/help/08/02/4875.html
# http://tolstoy.newcastle.edu.au/R/e2/help/07/01/8598.html
# http://www.r-statistics.com/wp-content/uploads/2011/01/boxplot-add-label-for-outliers.r.txt
# last updated: 31.10.2011
# This is instead of the 20.6.11 version...
boxplot.with.outlier.label <- function(y, label_name, ..., spread_text = T, data, plot = T, range = 1.5, label.col = "blue", push_text_right = 1.3, # enlarge push_text_right in order to push the text labels further from their point
segement_width_as_percent_of_label_dist = .45, # Change this if you want to have the line closer to the label (range should be between 0 to 1
jitter_if_duplicate = T, jitter_only_positive_duplicates = F)
{
# notes - this functions doesn't work if there are any missing values in the data.
# You must pre-process the data to make sure it is "complete".
# change log:
# 19.04.2011 - added support to "names" and "at" parameters.
# jitter_if_duplicate - will jitter (Actually just add a bit of numbers) so to be able to decide on which location to plot the label when having identical variables...
require(plyr) # for is.formula and ddply
# a function to jitter data in case of ties in Y's
jitter.duplicate <- function(x, only_positive = F)
{
if(only_positive) {
ss <- x > 0
} else {
ss <- T
}
ss_dup <- duplicated(x[ss])
# ss <- ss & ss_dup
temp_length <- length(x[ss][ss_dup])
x[ss][ss_dup] <- x[ss][ss_dup] + seq(from = 0.00001, to = 0.00002, length.out = temp_length)
x
}
# jitter.duplicate(c(1:5))
# jitter.duplicate(c(1:5,5,2))
# duplicated(jitter.duplicate(c(1:5,5,2)))
# jitter.duplicate(c(0,0,1:5,5,2))
# duplicated(jitter.duplicate(c(0,0,1:5,5,2)))
# handle cases where
if(jitter_if_duplicate) {
# warning("duplicate jutter of values in y is ON")
if(!missing(data)) { #e.g: we DO have data
# if(exists("y") && is.formula(y)) { # F && NULL # F & NULL
y_name <- as.character(substitute(y)) # I could have also used as.list(match.call())
# credit to Uwe Ligges and Marc Schwartz for the help
# https://mail.google.com/mail/?shva=1#inbox/12dd7ca2f9bfbc39
if(length(y_name) > 1) { # then it is a formula (for example: "~", "y", "x"
model_frame_y <- model.frame(y, data = data)
temp_y <- model_frame_y[,1]
temp_y <- jitter.duplicate(temp_y, jitter_only_positive_duplicates) # notice that the default of the function is to work only with positive values...
# the_txt <- paste(names(model_frame_y)[1], "temp_y", sep = "<<-") # wrong...
the_txt <- paste("data['",names(model_frame_y)[1],"'] <- temp_y", sep = "")
eval(parse(text = the_txt)) # jutter out y var so to be able to handle identical values.
} else { # this isn't a formula
data[,y_name] <- jitter.duplicate(data[,y_name], jitter_only_positive_duplicates)
y <- data[,y_name] # this will make it possible for boxplot(y, data) to work later (since it is not supposed to work with data when it's not a formula, but now it does :))
}
} else { # there is no "data"
if(is.formula(y)) { # if(exists("y") && is.formula(y)) { # F && NULL # F & NULL
temp_y <- model.frame(y)[,1]
temp_y <- jitter.duplicate(temp_y, jitter_only_positive_duplicates) # notice that the default of the function is to work only with positive values...
temp_y_name <- names(model.frame(y))[1] # we must extract the "names" before introducing a new enbironment (or there will be an error)
environment(y) <- new.env()
assign(temp_y_name, temp_y, environment(y))
# Credit and thanks for doing this goes to Niels Richard Hansen (2 Jan 30, 2011)
# http://r.789695.n4.nabble.com/environment-question-changing-variables-from-a-formula-through-model-frame-td3246608.html
# warning("Your original variable (in the global environemnt) was just jittered.") # maybe I should add a user input before doing this....
# the_txt <- paste(names(model_frame_y)[1], "temp_y", sep = "<<-")
# eval(parse(text = the_txt)) # jutter out y var so to be able to handle identical values.
} else {
y <- jitter.duplicate(y, jitter_only_positive_duplicates)
}
}
}
# the_txt <- paste("print(",names(model_frame_y)[1], ")")
# eval(parse(text = the_txt)) # jutter out y var so to be able to handle identical values.
# print(ls())
# y should be a formula of the type: y~x, y~a*b
# or it could be simply y
if(missing(data)) {
boxdata <- boxplot(y, plot = plot,range = range ,...)
} else {
boxdata <- boxplot(y, plot = plot,data = data, range = range ,...)
}
if(length(boxdata$names) == 1 && boxdata$names =="") boxdata$names <- 1 # this is for cases of type: boxplot(y) (when there is no dependent group)
if(length(boxdata$out) == 0 ) {
warning("No outliers detected for this boxplot")
return(invisible())
}
if(!missing(data)) attach(data) # this might lead to problams I should check out for alternatives for using attach here...
# creating a data.frame with information from the boxplot output about the outliers (location and group)
boxdata_group_name <- factor(boxdata$group)
levels(boxdata_group_name) <- boxdata$names[as.numeric(levels(boxdata_group_name))] # the subseting is for cases where we have some sub groups with no outliers
if(!is.null(list(...)$at)) { # if the user chose to use the "at" parameter, then we would like the function to still function (added on 19.04.2011)
boxdata$group <- list(...)$at[boxdata$group]
}
boxdata_outlier_df <- data.frame(group = boxdata_group_name, y = boxdata$out, x = boxdata$group)
# Let's extract the x,y variables from the formula:
if(is.formula(y))
{
model_frame_y <- model.frame(y)
# old solution: (which caused problems if we used the names parameter when using a 2 way formula... (since the order of the names is different then the levels order we get from using factor)
# y <- model_frame_y[,1]
# x <- model_frame_y[,-1]
y <- model_frame_y[,1]
x <- model_frame_y[,-1]
if(!is.null(dim(x))) { # then x is a matrix/data.frame of the type x1*x2*..and so on - and we should merge all the variations...
x <- apply(x,1, paste, collapse = ".")
}
} else {
# if(missing(x)) x <- rep(1, length(y))
x <- rep(1, length(y)) # we do this in case y comes as a vector and without x
}
# and put all the variables (x, y, and outlier label name) into one data.frame
DATA <- data.frame(label_name, x ,y)
if(!is.null(list(...)$names)) { # if the user chose to use the names parameter, then we would like the function to still function (added on 19.04.2011)
DATA$x <- factor(DATA$x, levels = unique(DATA$x))
levels(DATA$x) = list(...)$names # enable us to handle when the user adds the "names" parameter # fixed on 19.04.11 # notice that DATA$x must be of the "correct" order (that's why I used split above
# warning("Careful, the use of the 'names' parameter is experimental. If you notice any errors please e-mail me at: tal.galili@gmail.com")
}
if(!missing(data)) detach(data) # we don't need to have "data" attached anymore.
# let's only keep the rows with our outliers
boxplot.outlier.data <- function(xx, y_name = "y")
{
y <- xx[,y_name]
boxplot_range <- range(boxplot.stats(y, coef = range )$stats)
ss <- (y < boxplot_range[1]) | (y > boxplot_range[2])
return(xx[ss,])
}
outlier_df <-ddply(DATA, .(x), boxplot.outlier.data)
# create propor x/y locations to handle over-laping dots...
if(spread_text) {
# credit: Greg Snow
require(TeachingDemos)
temp_x <- boxdata_outlier_df[,"x"]
temp_y1 <- boxdata_outlier_df[,"y"]
temp_y2 <- temp_y1
for(i in unique(temp_x))
{
tmp <- temp_x == i
temp_y2[ tmp ] <- spread.labs( temp_y2[ tmp ], 1.3*strheight('A'), maxiter=6000, stepsize = 0.05) #, min=0 )
}
}
# max(strwidth(c("asa", "a"))
# move_text_right <- max(strwidth(outlier_df[,"label_name"]))
# plotting the outlier labels :) (I wish there was a non-loop wise way for doing this)
for(i in seq_len(dim(boxdata_outlier_df)[1]))
{
# ss <- (outlier_df[,"x"] %in% boxdata_outlier_df[i,]$group) & (outlier_df[,"y"] %in% boxdata_outlier_df[i,]$y)
# if(jitter_if_duplicate) {
# ss <- (outlier_df[,"x"] %in% boxdata_outlier_df[i,]$group) & closest.number(outlier_df[,"y"] boxdata_outlier_df[i,]$y)
# } else {
ss <- (outlier_df[,"x"] %in% boxdata_outlier_df[i,]$group) & (outlier_df[,"y"] %in% boxdata_outlier_df[i,]$y)
# }
current_label <- outlier_df[ss,"label_name"]
temp_x <- boxdata_outlier_df[i,"x"]
temp_y <- boxdata_outlier_df[i,"y"]
# cbind(boxdata_outlier_df, temp_y2)
# outlier_df
if(spread_text) {
temp_y_new <- temp_y2[i] # not ss
move_text_right <- strwidth(current_label) * push_text_right
text( temp_x+move_text_right, temp_y_new, current_label, col = label.col)
# strwidth
segments( temp_x+(move_text_right/6), temp_y, temp_x+(move_text_right*segement_width_as_percent_of_label_dist), temp_y_new )
} else {
text(temp_x, temp_y, current_label, pos = 4, col = label.col)
}
}
# outputing some of the information we collected
invisible(list(boxdata = boxdata, boxdata_outlier_df = boxdata_outlier_df, outlier_df=outlier_df))
}
complementVector = function(VectR, x) {
length.VectR <- length(VectR)
length.x <- length(x)
y <- vector() #output
for(i in 1:length.VectR) {
if(is.na(match(VectR[i], x))) {
y <- c(y, i)
} else {}
}
return(VectR[y])
}
blank.correction <- function(Area.blank, Sign.blank, Area.sample, Sign.sample) {
value <- (Area.sample*Sign.sample - Area.blank*Sign.blank)/(Area.sample - Area.blank)
return(value)
}
Area.correction <- function(value.toCorrect, dilution) {
value <- value.toCorrect * (1+dilution/100)
return(value)
}
Karina.Normalisation <- function(signature, true.Values, real.Values){
coef <- (true.Values[1] - true.Values[2])/(real.Values[1]-real.Values[2])
value <- (signature - real.Values[2]) * coef + true.Values[2]
return(value)
}
Peter.Correction.d15N <- function(signature, rank, slope, intercept) {
newValue <- signature - (slope * rank + intercept - 5.4)
return(newValue)
}
Peter.Correction.d13C <- function(signature, rank, slope, intercept) {
newValue <- signature - (slope * rank + intercept + 21.8)
return(newValue)
}
max.list = function(liste) {
max.list <- 0
n <- length(liste)
for (i in 1:n) {
max.Prov <- length(liste[[i]])
if(max.Prov > max.list) {max.list <- max.Prov} else {}
}
return(max.list)
}
### Global Variables
COL_NAMES <- c("FirstRow", "Identifier.1", "Identifier.2",
"hasCorrectPattern", "d13ValIndex", "exportd13", "d15ValIndex", "exportd15", "hasOneVald15", "hasOneVald13",
"hasnoNAInDilution", "hasTwoValInDilution", "hasZeroInDilution", "dilFact",
"hasNAinAreaAll", "exportAread15", "exportAread13")
### check the equality of values even if there is an NA
equals <- function(x, y) {
if(is.na(x) && is.na(y)) {return(TRUE)}
if(is.na(x) || is.na(y)) {return(FALSE)}
return (x == y)
}
### checks whether a vector contains NA
containsNA <- function(vect) {
for(i in 1:length(vect)) {
if(is.na(vect[i])) {
return(TRUE)
}
}
return(FALSE)
}
### appends a value to an existing list
appendToList <- function(li, val) {
lenLi <- length(li)
li[[lenLi + 1]] <- val
return(li)
}
processBlock <- function(block) {
# processResultRow will contain information to build result matrix
resultRow <- c(block$Rank.Analysis[1], block$Identifier.1[1], block$Identifier.2[1])
# add the relevant informations regarding the Isotope columns
resultRow <- processIsotopeCols(block, resultRow)
# add the relevant informations regarding dilution column
resultRow <- processDilutionCol(block, resultRow)
# add the relevant informations regarding the Area.all column
resultRow <- processAreaAllCol(block, resultRow)
#give names to the resultRow
names(resultRow) <- COL_NAMES
return(resultRow)
}
processDilutionCol <- function(block, resultRow) {
# Check whether dilution column in block contains NA
# Instructions to Minus: we have a function for that!!
hasNoNA <- !containsNA(block$Sample.Dilution)
# Check that there are only two distinct values
# Instructions to Minus: We will use unique
distVal <- unique(block$Sample.Dilution)
lenDisVal <- length(distVal)
hasTwoVal <- (lenDisVal == 2)
# Check that one of the values is 0
# Instructions to Minus: Use is.element to check for 0
hasZero <- is.element(0, block$Sample.Dilution)
# Add column with (some) dilution value
# Instructions to Minus: I love you
dilFact <- block$Sample.Dilution[as.numeric(as.character(resultRow["d13ValIndex"]))]
print("######")
print(block$Sample.Dilution)
print(as.numeric(as.character(resultRow["d13ValIndex"])))
print(block$Sample.Dilution[as.numeric(as.character(resultRow["d13ValIndex"]))])
print("######")
# add column to the resultRow
resultRow <- c(resultRow, hasNoNA, hasTwoVal, hasZero, dilFact)
return(resultRow)
}
processIsotopeCols <- function(block, resultRow) {
# Check value distribution pattern (NA at correct places and correct number of rows)
# Instructions to Minus: This will add column/value to resultRow that says TRUE/FALSE whether pattern correct
d13Col <- block$d.13C.12C
d15Col <- block$d.15N.14N
hasCorrectPattern <- TRUE
if(block$Identifier.1[1] == "sucrose") {
if(nrow(block) != 5) {
hasCorrectPattern <- FALSE
}
if(!is.na(d13Col[1]) || !is.na(d13Col[2]) || !is.na(d13Col[3]) || is.na(d13Col[4]) || is.na(d13Col[5])) {
hasCorrectPattern <- FALSE
}
if(is.na(d15Col[1]) || is.na(d15Col[2]) || is.na(d15Col[3]) || !is.na(d15Col[4]) || !is.na(d15Col[5])) {
hasCorrectPattern <- FALSE
}
} else {
if(nrow(block) != 6) {
hasCorrectPattern <- FALSE
}
if(!is.na(d13Col[1]) || !is.na(d13Col[2]) || !is.na(d13Col[3]) || !is.na(d13Col[4]) || is.na(d13Col[5]) || is.na(d13Col[6])) {
hasCorrectPattern <- FALSE
}
if(is.na(d15Col[1]) || is.na(d15Col[2]) || is.na(d15Col[3]) || is.na(d15Col[4]) || !is.na(d15Col[5]) || !is.na(d15Col[6])) {
hasCorrectPattern <- FALSE
}
}
# Extract isotope value and corresponding row
d13ValIndex <- findFirstNotNAValIndex(d13Col)
if(is.na(d13ValIndex)){
exportd13 <- NA
} else {
exportd13 <- d13Col[d13ValIndex]
}
d15ValIndex <- findLastNotNAValIndex(d15Col)
if(is.na(d15ValIndex)){
exportd15 <- NA
} else {
exportd15 <- d15Col[d15ValIndex]
}
# check that d15Col and d13Col has at least one value
hasOneVald15 <- !is.na(exportd15)
hasOneVald13 <- !is.na(exportd13)
resultRow <- c(resultRow, hasCorrectPattern, d13ValIndex, exportd13, d15ValIndex, exportd15, hasOneVald15, hasOneVald13)
names(resultRow) <- c("Rank", "Id1", "Id2", "hasCorrectPattern","d13ValIndex", "exportd13", "d15ValIndex", "exportd15", "hasOneVald15", "hasOneVald13")
return(resultRow) #TODO
}
processAreaAllCol <- function(block, resultRow) {
# Check that column does not contain NA
hasNA <- containsNA(block$Area.All)
# Extract the two values that you need
d15Index <- as.numeric(resultRow[7])
d13Index <- as.numeric(resultRow[5])
exportAread15 <- block$Area.All[d15Index]
exportAread13 <- block$Area.All[d13Index]
resultRow <- c(resultRow, hasNA, exportAread15, exportAread13)
return(resultRow) #TODO
}
findFirstNotNAValIndex <- function(vect) {
for(i in 1: length(vect)){
if(!is.na(vect[i])) {return(i)}
}
return(NA)
}
findLastNotNAValIndex <- function(vect){
for(i in length(vect) : 1){
if(!is.na(vect[i])) {return(i)}
}
return(NA)
}
createResultMatrix <- function(blockList) {
resultMatrix <- data.frame(matrix(ncol = length(COL_NAMES)))
colnames(resultMatrix) <- COL_NAMES
for(i in 1:length(blockList)) {
block <- blockList[[i]]
rowToAdd <- processBlock(block)
resultMatrix <- rbind(resultMatrix, rowToAdd)
}
# Remove first row of matrix that just contains NA
resultMatrix <- resultMatrix[-1,]
return(resultMatrix)
}
To read beforhand
Aim of this document: This sheet has been created to help users to format the CN_EA file in order to upload it for further calculations.
WARNING: The aim of CN_EA.CleanR is not to correct automatically the CN_EA file, this delicated task requiring human skills. However, it is dedicated to point out errors or abnormalities of the raw CN_EA file. When the first round of correction has been finished and before uploading any file in isoSignature.creatR, please check a last time with CN_EA.CleanR that there is NO error in the required CONCLUSIONS (this task may require several rounds of CN_EA.CleanR).
WARNING: The weight file and the CNEA have to list the sample in the same order.
Cleaning and calculation settings
output$info <- renderUI({
div(column(6,
fileInput("CNEA", label = p("Select the CNEA file")),
textInput("nameSession", label = "", value = "Name of the session"),
textInput("dateProcessig", label = "", value = "Date of the analysis:"),
textInput("Responsible", label = "", value = "Responsible:"),
textInput("Temperature", label = "", value = "Lab Temperature:"),
textInput("SampleName", label = "", value = "Sample name:"),
textInput("system", label = "", value = "System:"),
textInput("Column", label = "", value = "Column:"),
textInput("temp.Owen", label = "", value = "Temp Owen:")
),
(column(6,
fileInput("weightData", label = p("Select the weight file")),
textInput("carrier.Gas", label = "", value = "Carrier gas:"),
textInput("carrier.flow", label = "", value = "Carrier flow:"),
textInput("Reference.gas1", label = "", value = "Reference gas 1:"),
textInput("Reference.flow1", label = "", value = "Reference flow1:"),
textInput("Reference.gas2", label = "", value = "Reference gas 2:"),
textInput("Reference.flow2", label = "", value = "Reference flow2:"),
textInput("Method", label = "", value = "Method:")
)
)
)
})
output$selectSample <- renderUI({
if(!is.null(input$CNEA)) {
level.identifier.1 <- levels(as.factor(CNEA()$Identifier.1))
div(column(12,
br(),
checkboxGroupInput("sample", label = p("Select the name(s) that correspond to samples"),
choices = level.identifier.1,
selected = level.identifier.1[1],
inline = T )
))
} else {}
})
r uiOutput("info")
r uiOutput("selectSample")
CNEA <- reactive({
if(!is.null(input$CNEA)) {
CNEA <- read.xls (input$CNEA$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE)
CNEA[,2] <- tolower(CNEA[,2])
Rank.Analysis <- 2: (nrow(CNEA)+ 1) # +1 to make the excel file correspond to the R file
CNEA <- cbind(Rank.Analysis, CNEA)
CNEA <- data.frame(CNEA, stringsAsFactors=FALSE)
CNEA$Area.All <- as.numeric(as.character(CNEA$Area.All))
CNEA$d.13C.12C <- as.numeric(as.character(CNEA$d.13C.12C))
CNEA$d.15N.14N <- as.numeric(as.character(CNEA$d.15N.14N))
CNEA$Sample.Dilution <- as.numeric(as.character(CNEA$Sample.Dilution))
return(CNEA)
}
})
weightData <- reactive({
if(!is.null(input$weightData)) {
weightData <- read.xls (input$weightData$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE)
weightData <- as.data.frame(weightData)
weightData$Measured.Weigth..mg. <- as.numeric(as.character(weightData$Measured.Weigth..mg.))
weightData$Box.pos <- as.character(weightData$Box.pos)
return(weightData)
}
})
############################
## Condition 1: character value in the dilution, All.Area, d13c and d15N column
############################
output$character_Error <- renderText({
if(is.null(input$CNEA)){return(NULL)}
CNEA <- read.xls (input$CNEA$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE)
weightData <- read.xls (input$weightData$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE)
errorChar_CNEA <-c(containsCharacter(CNEA$Area.All), containsCharacter(CNEA$d.13C.12C), containsCharacter(CNEA$d.15N.14N), containsCharacter(CNEA$Sample.Dilution))
errorChar_Weight <- containsCharacter(weightData$Measured.Weigth..mg.)
if(length(errorChar_CNEA) > 0) {
paste("Oups, there is a character string in your CNEA file. Check the line(s):", paste(CNEA()$Rank.Analysis[errorChar_CNEA], sep = " ", collapse = " "))
} else {
if(length(errorChar_Weight) > 0) {
paste("Oups, there is a character string in your Weight file. Check the line(s):", paste(errorChar_Weight, sep = " ", collapse = " "))
} else {}
}
})
output$character_OK <- renderText({
if(is.null(input$CNEA)){return(NULL)}
CNEA <- read.xls (input$CNEA$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE)
weightData <- read.xls (input$weightData$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE)
errorChar_CNEA <-c(containsCharacter(CNEA$Area.All), containsCharacter(CNEA$d.13C.12C), containsCharacter(CNEA$d.15N.14N), containsCharacter(CNEA$Sample.Dilution))
errorChar_Weight <- containsCharacter(weightData$Measured.Weigth..mg.)
if(length(errorChar_CNEA) == 0 & length(errorChar_Weight) == 0) {
"Perfect!! There is no character in your files"
} else {}
})
############################
## Condition 1: identifier.1
############################
output$id1_Error <- renderText({
if(is.null(input$CNEA)) {return(NULL)}
bad.Id1 <- which(CNEA()$Identifier.1 == "" | is.na(CNEA()$Identifier.1) | is.null(CNEA()$Identifier.1))
if(length(bad.Id1) != 0) {
toDisplay.1 <- paste("Some identifier.1 are empty (DO NOT IGNORE!!). Please check the line:", paste(CNEA()$Rank.Analysis[bad.Id1], sep = " ", collapse = " "))
}
})
output$id1_OK <- renderText({
if(is.null(input$CNEA)) {return(NULL)}
bad.Id1 <- which(CNEA()$Identifier.1 == "" | is.na(CNEA()$Identifier.1) | is.null(CNEA()$Identifier.1))
if(length(bad.Id1) != 0) {NULL} else {
toDisplay.1 <- "No problem in the identifier.1"
}
})
############################
## Condition 7: Any area should not be empty
############################
output$error.area_Error <- renderText({
if(is.null(input$CNEA)) {return(NULL)}
error.area <- which(resultMatrix()$hasNAinAreaAll)
if(length(error.area) != 0) {
toDisplay.1 <- paste("Some Area are empty. Please check the analysis beginning line(s):", paste(resultMatrix()$FirstRow[error.area], sep = " ", collapse = " "))
}
})
output$error.area_OK <- renderText({
if(is.null(input$CNEA)) {return(NULL)}
error.area <- which(resultMatrix()$hasNAinAreaAll)
if(length(error.area) == 0) {
toDisplay.1 <- "No problem in the Area"
}
})
############################
## Condition 2
############################
resultMatrix <- reactive({
if(is.null(input$CNEA)){return(NULL)}
blockList <- list()
currentBlock <- data.frame()
lastId <- c(CNEA()$Identifier.1[1], CNEA()$Identifier.2[1], CNEA()$Row[1])
for(i in 1:nrow(CNEA())) {
currentRow <- CNEA()[i,]
currentId <- c(CNEA()$Identifier.1[i], CNEA()$Identifier.2[i], CNEA()$Row[i])
# if row identifier changed, then we finished a block and start a new one
if(!equals(currentId[1], lastId[1]) || !equals(currentId[2], lastId[2]) || !equals(currentId[3], lastId[3])) {
# Add current block to blockList
blockList <- appendToList(blockList, currentBlock)
# Start a new empty block and add current row to it
currentBlock <- data.frame()
}
# Add current row to current block
currentBlock <- rbind(currentBlock, currentRow)
if(i == nrow(CNEA())){blockList <- appendToList(blockList, currentBlock)}
lastId <- currentId
}
resultMatrix <- createResultMatrix(blockList)
# toTransform in logical
for(i in c(4,9:13,15)) {
resultMatrix[,i] <- as.logical(resultMatrix[,i])
}
resultMatrix$exportAread15 <- as.numeric(as.character(resultMatrix$exportAread15))
resultMatrix$exportAread13 <- as.numeric(as.character(resultMatrix$exportAread13))
resultMatrix$exportd13 <- as.numeric(as.character(resultMatrix$exportd13))
resultMatrix$exportd15 <- as.numeric(as.character(resultMatrix$exportd15))
resultMatrix$dilFact <- as.numeric(as.character(resultMatrix$dilFact))
return(resultMatrix)
})
output$nbValue.C_Error <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
errorC <- which(resultMatrix()$hasOneVald13 == F)
if(length(errorC) != 0) {
paste("There is no value for C in the analysis. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[errorC], sep = " ", collapse = " "))
}
})
output$nbValue.C_OK <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
errorC <- which(resultMatrix()$hasOneVald13 == F)
if(length(errorC) == 0) {
"There is at least one C signature for all analyses"
}
})
output$nbValue.N_Error <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
errorN <- which(resultMatrix()$hasOneVald15 == F)
if(length(errorN) != 0) {
paste("There is no value for N in the analysis. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[errorN], sep = " ", collapse = " "))
}
})
output$nbValue.N_OK <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
errorN <- which(resultMatrix()$hasOneVald15 == F)
if(length(errorN) == 0) {
"There is at least one N signature for every analysis"
}
})
output$pattern_Error <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
errorPattern <- which(resultMatrix()$hasCorrectPattern == F)
if(length(errorPattern) != 0) {
paste("There is a problem of pattern. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[errorPattern], sep = " ", collapse = " "))
}
})
output$pattern_OK <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
errorPattern <- which(resultMatrix()$hasCorrectPattern == F)
if(length(errorPattern) == 0) {
paste("No problem in the pattern")
}
})
############################
## Condition 3: Identifier.2
############################
dataTables <- reactive({
if(!is.null(input$CNEA) & length(character()) ==0) {
sample <- input$sample
place <- NULL
for(x in 1:length(sample)) {
if(x == 1) {
place <- which(resultMatrix()$Identifier.1 == sample[x])
CNEA.sample <- resultMatrix()[place, ]
} else {
place <- c(place, which(resultMatrix()$Identifier.1 == sample[x]))
CNEA.sample <- rbind(CNEA.sample, resultMatrix()[which(resultMatrix()$Identifier.1 == sample[x]), ])
}
}
place <- sort(place)
PlaceBar <- complementVector(1:nrow(resultMatrix()), place)
CNEA.sample <- CNEA.sample[order(as.numeric(as.character(CNEA.sample$FirstRow))),] # data with only the sample
CNEA.standard <- resultMatrix()[PlaceBar, ] # data with only the standards
return(list(CNEA.sample, CNEA.standard))
} else {}
})
dataStandard <- reactive({
if(!is.null(input$CNEA)) {
temp <- dataTables()[[2]]
return(temp)
} else {}
})
dataSample <- reactive({
if(!is.null(input$CNEA)) {
temp <- dataTables()[[1]]
return(temp)
} else {}
})
output$dataSampleToPrint <- renderDT({
if(!is.null(input$CNEA)) {
dataSample()
} else {}
})
output$dataStandardToPrint <- renderDT({
if(!is.null(input$CNEA)) {
dataStandard()
} else {}
})
############################
## Condition 4: dilution
############################
output$dilution_Error <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
err <- which(resultMatrix()$hasnoNAInDilution == F | resultMatrix()$hasTwoValInDilution == F)
if(length(err) != 0) {
paste("There is a mistake in the dilution factor. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[err], sep = "", collapse = " "))
}
})
output$dilution_OK <- renderText({
if(is.null(input$CNEA) | length(character()) !=0){return(NULL)}
err <- which(resultMatrix()$hasnoNAInDilution == F | resultMatrix()$hasTwoValInDilution == F)
if(length(err) == 0) {
"Everything is ok regarding dilution"
}
})
############################
## Condition 6: secondary condition
############################
Data_plus_weight <- reactive({ ## for pasting the weight of the sample
if(!is.null(input$CNEA) & !is.null(input$weightData) & !is.null(resultMatrix())) {
errorToCount <- 0 # flag for error
line.flag <- NA
Data_plus_weight <- NULL
nRow.dataSample <- nrow(dataSample())
nRow.weightData <- nrow(weightData())
if(nRow.dataSample != nRow.weightData) {
errorToCount <- 1
} else {
for(i in 1:nRow.dataSample){
if(as.character(dataSample()$Identifier.2[i]) != as.character(weightData()$Box.pos[i])){
errorToCount <- 1
line.flag <- c(line.flag, dataSample()$Identifier.2[i])
} else {}
}
if(errorToCount == 0) {
Data_plus_weight <- cbind(dataSample(), weightData()$Name, weightData()$Measured.Weigth..mg.)
colnames(Data_plus_weight) <- c(colnames(dataSample()), "sampleName", "SampleWeight")
} else {}
}
return(list(c(errorToCount, line.flag), Data_plus_weight))
} else {}
})
output$weight_Error <- renderText({
if(!is.null(input$CNEA) & !is.null(input$weightData)) {
if(Data_plus_weight()[[1]][1] != 0){
if(!is.na(Data_plus_weight()[[1]][2])){
paste("Weight and CNEA files do not match on their identifier.2, check line(s):", paste(Data_plus_weight()[[1]][2], sep = " ", collapse = " "))
} else {
paste("Weight and CNEA files do not have the same number of rows")
}
} else {
NULL
}
} else {}
})
output$weight_OK <- renderText({
if(!is.null(input$CNEA) & !is.null(input$weightData)) {
if(Data_plus_weight()[[1]][1] != 0){
NULL
} else {
"The CNEA and weight file seem to match (Note that it did not check for the box name)"
}
} else {}
})
Conditions tested for cleaning
- Condition 1: Any identifier 1 should not be empty or null
r textOutput("id1_OK")
r textOutput("id1_Error")
- Condition 2: Cells from Area, dilution, d15N and d13C columns should contain any character
r textOutput("character_OK")
r textOutput("character_Error")
- Condition 3: One analysis (i.e. the ranks are following) must contain not empty Area.All cell. d13C/d12C and d15N/d14N should have each at least one value.
r textOutput("nbValue.C_OK")
r textOutput("nbValue.C_Error")
r textOutput("nbValue.N_OK")
r textOutput("nbValue.N_Error")
But also analysis should contain 4 signatures values (3 for the sucrose) for N and 2 for the carbone
r textOutput("pattern_OK")
r textOutput("pattern_Error")
- Condition 5. Identifier.2 for weight and CNEA file should be in the same order (for sample only)
r textOutput("weight_Error")
r textOutput("weight_OK")
- Condition 6. No Area.All should be empty
r textOutput("error.area_Error")
r textOutput("error.area_OK")
- Condition 7: Analysis should have exactly one dilution value
r textOutput("dilution_OK")
r textOutput("dilution_Error")
Data Samples:
r DTOutput("dataSampleToPrint")
Data Standards:
r DTOutput("dataStandardToPrint")
Graphical detection of mistakes - Outlier highlighting
output$forBoxPlot <- renderUI({
if(!is.null(input$CNEA)) {
level.identifier.1 <- levels(as.factor(CNEA()$Identifier.1))
checkboxGroupInput("toDisplay", label = "",
choices = level.identifier.1,
selected = level.identifier.1,
inline = T )
} else {}
})
output$boxplot <- renderPlot({
if(!is.null(input$CNEA) & length(character()) ==0) {
toDisplay <- input$toDisplay
for(x in 1:length(toDisplay)) {
if(x == 1) {
dataTemp <- resultMatrix()[which(resultMatrix()$Identifier.1 == toDisplay[x]), ]
} else {
dataTemp <- rbind(dataTemp, resultMatrix()[which(resultMatrix()$Identifier.1 == toDisplay[x]), ])
}
}
par(mfrow = c(1,2), mar = c(2,3,1.2,1.2))
ylim.C <- c(min(dataTemp$exportd13, na.rm = T) - abs(min(dataTemp$exportd13, na.rm = T))*0.1, max(dataTemp$exportd13, na.rm = T) + abs(max(dataTemp$exportd13, na.rm = T))*0.1)
boxplot.with.outlier.label(as.numeric(as.character(dataTemp$exportd13)), label_name = dataTemp$Identifier.2, ylim = ylim.C, cex = 1.25)
mtext("d13C", side = 1)
ylim.N <- c(min(dataTemp$exportd15, na.rm = T) - abs(min(dataTemp$exportd15, na.rm = T))*0.1, max(dataTemp$exportd15, na.rm = T) + abs(max(dataTemp$exportd15, na.rm = T))*0.1)
boxplot.with.outlier.label(as.numeric(as.character(dataTemp$exportd15)), label_name = dataTemp$Identifier.2, ylim = ylim.N, cex = 1.25)
mtext("d15N", side = 1)
return(dataTemp)
} else {}
})
r uiOutput('forBoxPlot')
r plotOutput('boxplot')
Conclusions of the cleaning
finalConclusion <- reactive({
if(!is.null(resultMatrix())) {return(TRUE)}
if(is.null(Data_plus_weight())) {return(TRUE)}
bad.Id1 <- which(CNEA()$Identifier.1 == "" | is.na(CNEA()$Identifier.1) | is.null(CNEA()$Identifier.1))
error.area <- which(resultMatrix()$hasNAinAreaAll)
errorC <- which(resultMatrix()$hasOneVald13 == F)
errorN <- which(resultMatrix()$hasOneVald15 == F)
errorPattern <- which(resultMatrix()$hasCorrectPattern == F)
err <- which(resultMatrix()$hasnoNAInDilution == F & resultMatrix()$hasTwoValInDilution == T)
if(length(character())!=0 |
length(bad.Id1) != 0 |
length(error.area) != 0 |
length(errorC) != 0 |
length(errorN) != 0 |
length(errorPattern) != 0 |
length(err) != 0 |
Data_plus_weight()[[1]][1] != 0) {
return(TRUE)
} else {return(FALSE)}
})
output$finalConclusion_error <- renderText({
if(!is.null(resultMatrix())) {
if(finalConclusion() == TRUE) {
"There is at least one mistake in your files. <br> Please correct according to previously before continuing to read this file."
} else {NULL}
} else {NULL}
})
output$finalConclusion_OK <- renderText({
if(!is.null(resultMatrix())) {
if(finalConclusion() == FALSE) {
"It seems that your files are correct."
} else {NULL}
} else {NULL}
})
r textOutput("finalConclusion_OK")
r span(htmlOutput("finalConclusion_error"), style="color:red")
Settings for "IsotopeSignature.file" creation
WARNING: Before continuing in this file, please check the conditions above do NOT contain any error in required CONCLUSIONS (this task may require several run of utilisation of the function CNEA_cleanR). If the TCD file is upload without this last verification, CNEA_cleanR CANNOT garantee the validity of the following data.
r uiOutput("info.2")
output$info.2 <- renderUI({
if(!is.null(input$CNEA)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
blank <- names(CNEA.liste)[str_detect(names(CNEA.liste), "lank")]
gelA <- weightData()$Name[(str_detect(weightData()$Name, "el") | str_detect(weightData()$Name, "EL"))]
if(length(gelA) == 0) {
gelA <- weightData()$Name[1]
}
backgroundValues <- c(0, 1167)
div(
checkboxGroupInput("blank", label = p("1. Select blanks (blank AND system blank)"),
choices = names(CNEA.liste),
selected = blank,
inline = T),
br(),
checkboxGroupInput("gelA", label = p("2. Select Gel A"),
choices = levels(as.factor(weightData()$Name)),
selected = gelA,
inline =T),
br(),
tags$b("3. Background Values"),
div(
column(6,
textInput("Area.N.background", label = "", value = "Area of the blank N")),
column(6,
textInput("signature.N.background", label = "", value = "signature of the blank N"))),
div(
column(6,
textInput("Area.C.background", label = "", value = "Area of the blank C")),
column(6,
textInput("signature.C.background", label = "", value = "signature of the blank C")))
)
} else {}
})
nameInput.C <- reactive({
if(!is.null(input$C.define)) {
nameInput <- vector()
for(i in 1:length(input$C.define)) {
nameInput[i] <- paste0(resultMatrix()$Identifier.1[which(input$C.define[i] == resultMatrix()$Identifier.1)], "_inputName.C")
}
return(nameInput)
}
})
output$chooseValue.C.stand <- renderUI({
if(!is.null(input$CNEA) & !is.null(input$C.define)) {
lapply(1:length(input$C.define), function(x){
div(
column(6, p(paste("Select the values that you want to keep for", resultMatrix()$Identifier.1[which(input$C.define[x] == resultMatrix()$Identifier.1)]))),
column(6,
checkboxGroupInput(nameInput.C()[x], label = p(""),
choices = resultMatrix()$exportd13[which(input$C.define[x] == resultMatrix()$Identifier.1)],
selected = resultMatrix()$exportd13[which(input$C.define[x] == resultMatrix()$Identifier.1)],
inline = T),
br()
)
)
})
}
})
output$checkBox.C <- renderUI({
if(!is.null(input$CNEA)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
checkboxGroupInput("C.define", label = p("3. Select carbon standards"),
choices = level.identifier.1,
selected = level.identifier.1[1],
inline = F)
} else {}
})
output$Value.C <- renderUI({
if(!is.null(input$CNEA) & !is.null(input$C.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
plot_output_list <- lapply(seq(from = 1, to = length(input$C.define), by = 1), function(i) {
V.C <- paste("value.C", i, sep="")
textInput(V.C, label = "", value = paste("Value C for ", input$C.define[i]))
})
} else {}
})
c.ToTake <- reactive({
if(!is.null(input$CNEA) & !is.null(input$C.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
c.ToTake <- sapply(1:length(input$C.define), function(x) {
which(input$C.define[x] == level.identifier.1)
})
c.ToTake <- sort(c.ToTake)
return(c.ToTake) ## rank of value to take
} else {}
})
value.C <- reactive({
if(!is.null(input$CNEA) & !is.null(input$C.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
temp <- vector()
for(i in 1:length(input$C.define)){
temp <- c(temp, eval(parse(text = paste("input$value.C", i, sep=""))))
}
return(temp)
} else {}
})
value.C.toTake <- reactive({
if(!is.null(input$CNEA) & !is.null(input$C.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
temp <- value.C()
# temp <- value.C()[c.ToTake()]
#
# names(temp) <- level.identifier.1[c.ToTake()]
return(temp)
} else {}
})
nameInput.N <- reactive({
if(!is.null(input$N.define)) {
nameInput <- vector()
for(i in 1:length(input$N.define)) {
nameInput[i] <- paste0(resultMatrix()$Identifier.1[which(input$N.define[i] == resultMatrix()$Identifier.1)], "_inputName.N")
}
return(nameInput)
}
})
output$chooseValue.N.stand <- renderUI({
if(!is.null(input$CNEA) & !is.null(input$N.define)) {
lapply(1:length(input$N.define), function(x){
div(
column(6, p(paste("Select the values that you want to keep for", resultMatrix()$Identifier.1[which(input$N.define[x] == resultMatrix()$Identifier.1)]))),
column(6,
checkboxGroupInput(nameInput.N()[x], label = p(""),
choices = resultMatrix()$exportd15[which(input$N.define[x] == resultMatrix()$Identifier.1)],
selected = resultMatrix()$exportd15[which(input$N.define[x] == resultMatrix()$Identifier.1)],
inline = T),
br()
)
)
})
}
})
output$checkBox.N <- renderUI({
if(!is.null(input$CNEA)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
checkboxGroupInput("N.define", label = p("4. Select nitrogen standards"),
choices = level.identifier.1,
selected = level.identifier.1[1],
inline = F)
} else {}
})
output$Value.N <- renderUI({
if(!is.null(input$CNEA) & !is.null(input$N.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
plot_output_list <- lapply(seq(from = 1, to = length(input$N.define), by = 1), function(i) {
V.N <- paste("value.N", i, sep="")
textInput(V.N, label = "", value = paste("Value N for ", input$N.define[i]))
})
} else {}
})
n.ToTake <- reactive({
if(!is.null(input$CNEA) & !is.null(input$N.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
n.ToTake <- sapply(1:length(input$N.define), function(x) {
which(input$N.define[x] == level.identifier.1)
})
n.ToTake <- sort(n.ToTake)
return(n.ToTake) ## rank of value to take
} else {}
})
value.N <- reactive({
if(!is.null(input$CNEA) & !is.null(input$N.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
temp <- vector()
for(i in 1:length(input$N.define)){
temp <- c(temp, eval(parse(text = paste("input$value.N", i, sep=""))))
}
return(temp)
} else {}
})
value.N.toTake <- reactive({
if(!is.null(input$CNEA) & !is.null(input$N.define)) {
CNEA.liste <- split(CNEA(), CNEA()$Identifier.1)
level.identifier.1 <- names(CNEA.liste)
temp <- value.N()
# temp <- value.N()[n.ToTake()]
# names(temp) <- level.identifier.1[n.ToTake()]
return(temp)
} else {}
})
r div(column(6, uiOutput("checkBox.N")), column(6, uiOutput("Value.N")))
r div(column(12, uiOutput("chooseValue.N.stand")))
r div(column(6, uiOutput("checkBox.C")), column(6, uiOutput("Value.C")))
r div(column(12, uiOutput("chooseValue.C.stand")))
#############################################################################################################################
### Table1 is the first table of the isotope data sheet that allow to have the average of the NItrogen and Carbon standards
#############################################################################################################################
table1 <- reactive({
if(!is.null(input$CNEA)) {
nitrogen.table1 <- list()
for(i in 1:length(input$N.define)) {
nitrogen.table1[[i]] <- eval(parse(text = paste0("input$\'", nameInput.N()[i], "\'")))
}
carbon.table1 <- list()
for(i in 1:length(input$C.define)) {
carbon.table1[[i]] <- eval(parse(text = paste0("input$\'", nameInput.C()[i], "\'")))
}
nrow.table1 <- max(max.list(nitrogen.table1), max.list(carbon.table1)) + 5
ncol.table1 <- length(input$C.define) + length(input$N.define)+1
table1 <- as.data.frame(matrix(ncol = ncol.table1, nrow = nrow.table1)) ## Blank corrected delta values for isotope standards
table1[1,] <- c("Blank corrected delta values for isotope standards", rep("Nitrogen", length(input$N.define)), rep("Carbon", length(input$C.define)))
table1[2,] <- c(" ", input$N.define, input$C.define)
for(i in 1:length(input$N.define)) {
table1[3:(2+length(nitrogen.table1[[i]])),i+1] <- as.character(nitrogen.table1[[i]])
}
for(i in 1:length(input$C.define)) {
table1[3:(2+length(carbon.table1[[i]])),i+length(input$N.define)+1] <- as.character(carbon.table1[[i]])
}
table1[3:(nrow(table1)-3),1] <- " "
table1[(nrow(table1)-2) : nrow(table1), 1] <- c("Average", "Stdev", "True.Value")
for(i in 2:(length(input$C.define) + length(input$N.define) + 1)) {
analysis <- as.numeric(as.character(table1[,i]))
table1[(nrow.table1-2),i] <- mean(analysis, na.rm = T)
table1[(nrow.table1-1),i] <- sd(analysis, na.rm = T)
}
table1[nrow.table1,(2:ncol.table1)] <- c(as.numeric(as.character(value.N.toTake())), as.numeric(as.character(value.C.toTake())))
colnames(table1) <- c("Names", paste("Nitrogen", input$N.define, sep ="."), paste("Carbon", input$C.define, sep ="."))
return(table1)
if(input$nameSession == "Name of the session") {
toAdd <- ""
} else {
toAdd <- input$nameSession
}
} else {}
})
output$table1.toDisplay <- renderDT({
table1()
})
r DTOutput("table1.toDisplay")
#############################################################################################################################
### creation of the table2: table2.standard (i.e. called Blank correction of delta value in standards) and table2.sample
#############################################################################################################################
table2 <- reactive({
if(!is.null(resultMatrix())) {
resultMatrix <- resultMatrix()[order(as.numeric(as.character(resultMatrix()$FirstRow))),]
line.sample <- lapply(1:length(input$sample), function(x) {
which(resultMatrix$Identifier.1 == input$sample [x])
}) # the line of the resultMatrix that correspond to the sample
line.sample <- unlist(line.sample)
table2.sample.Temp <- resultMatrix[line.sample,]
table2.sample.Temp <- table2.sample.Temp[order(as.numeric(as.character(table2.sample.Temp$FirstRow))),]
printDebug("########table table2.sample.Temp")
printDebug(table2.sample.Temp)
line.standard <- complementVector(1:nrow(resultMatrix), line.sample)
table2.standard.Temp <- resultMatrix[line.standard,]
table2.standard.Temp <- table2.standard.Temp[order(as.numeric(as.character(table2.standard.Temp$FirstRow))),]
printDebug("########table table2.standard.Temp")
printDebug(table2.standard.Temp)
# table2.standard final (i.e. with corrected value)
table2.standard <- as.data.frame(matrix(ncol = 16, nrow = nrow(table2.standard.Temp)))
colnames(table2.standard) <- c("Box.No", "Box.position", "sample.name", "sample.weight","Area.N", "d14N.d15N.ratio", "d14N.d15N.BlankCorrected", "Normalized.d14N.d15N", "At.N", "equipement.dilution", "Area.C", "d12C.d13C.ratio", "Area.C.Corrected", "d12C.d13C.BlankCorrected", "Normalized.d12C.d13C", "At.C")
table2.standard$Box.No <- " "
table2.standard$Box.position <- " "
table2.standard[,3] <- as.character(table2.standard.Temp$Identifier.1)
table2.standard[,5] <- as.numeric(as.character(table2.standard.Temp$exportAread15))
table2.standard[,6] <- as.numeric(as.character(table2.standard.Temp$exportd15))
table2.standard[,10] <- as.numeric(as.character(table2.standard.Temp$dilFact))
table2.standard[,11] <- as.numeric(as.character(table2.standard.Temp$exportAread13))
table2.standard[,12] <- as.numeric(as.character(table2.standard.Temp$exportd13))
blank.correction <- function(Area.blank, Sign.blank, Area.sample, Sign.sample) {
value <- (Area.sample*Sign.sample - Area.blank*Sign.blank)/(Area.sample - Area.blank)
return(value)
}
blankValue.N <- c(as.numeric(as.character(input$Area.N.background)), as.numeric(as.character(input$signature.N.background)))
if(is.na(blankValue.N)) {
blankValue.N <- c(0, 0)
}
blankValue.C <- c(as.numeric(as.character(input$Area.C.background)), as.numeric(as.character(input$signature.C.background)))
if(is.na(blankValue.C)) {
blankValue.C <- c(0, 0)
}
toConvert <- c(5,6, 10, 11, 12)
for(i in 1:length(toConvert)) {
table2.standard[,toConvert[i]] <-as.numeric(as.character(table2.standard[,toConvert[i]]))
}
## Blank correction d15N
blankCorrected.d15N <- sapply(1:nrow(table2.standard), function(x) {
blank.correction(blankValue.N[1], blankValue.N[2], table2.standard$Area.N[x],table2.standard$d14N.d15N.ratio[x])
})
table2.standard$d14N.d15N.BlankCorrected <- blankCorrected.d15N
## Area Correction d13C
Area.Corrected.d13C <- sapply(1:nrow(table2.standard), function(x) {
Area.correction(table2.standard$Area.C[x], table2.standard$equipement.dilution[x])
})
table2.standard$Area.C.Corrected <- Area.Corrected.d13C
## blank correction d13C
blankCorrected.d13C <- sapply(1:nrow(table2.standard), function(x) {
blank.correction(blankValue.C[1], blankValue.C[2], table2.standard$Area.C.Corrected[x],table2.standard$d12C.d13C.ratio[x])
})
table2.standard$d12C.d13C.BlankCorrected <- blankCorrected.d13C
# table2.sample final (i.e. with corrected value)
table2.sample <- as.data.frame(matrix(ncol = 16, nrow = nrow(table2.sample.Temp)))
colnames(table2.sample) <- c("Box.No", "Box.position", "sample.name", "sample.weight","Area.N", "d14N.d15N.ratio", "d14N.d15N.BlankCorrected", "Normalized.d14N.d15N", "At.N", "equipement.dilution", "Area.C", "d12C.d13C.ratio", "Area.C.Corrected", "d12C.d13C.BlankCorrected", "Normalized.d12C.d13C", "At.C")
table2.sample[,1] <- as.character(table2.sample.Temp$Identifier.1)
table2.sample[,2] <- as.character(table2.sample.Temp$Identifier.2)
table2.sample[,3] <- as.character(weightData()$Name)
table2.sample[,4] <- as.numeric(as.character(weightData()$Measured.Weigth..mg.))
table2.sample[,5] <- as.numeric(as.character(table2.sample.Temp$exportAread15))
table2.sample[,6] <- as.numeric(as.character(table2.sample.Temp$exportd15))
table2.sample[,10] <- as.numeric(as.character(table2.sample.Temp$dilFact))
table2.sample[,11] <- as.numeric(as.character(table2.sample.Temp$exportAread13))
table2.sample[,12] <- as.numeric(as.character(table2.sample.Temp$exportd13))
toConvert <- c(5,6, 10, 11, 12)
for(i in 1:length(toConvert)) {
table2.sample[,toConvert[i]] <-as.numeric(as.character(table2.sample[,toConvert[i]]))
}
# blank correction d15N
blankCorrected.d15N <- sapply(1:nrow(table2.sample), function(x) {
blank.correction(blankValue.N[1], blankValue.N[2], table2.sample$Area.N[x],table2.sample$d14N.d15N.ratio[x])
})
table2.sample$d14N.d15N.BlankCorrected <- blankCorrected.d15N
## Area Correction d13C
Area.Corrected.d13C <- sapply(1:nrow(table2.sample), function(x) {
Area.correction(table2.sample$Area.C[x], table2.sample$equipement.dilution[x])
})
table2.sample$Area.C.Corrected <- Area.Corrected.d13C
## blank correction d13C
blankCorrected.d13C <- sapply(1:nrow(table2.sample), function(x) {
blank.correction(blankValue.C[1], blankValue.C[2], table2.sample$Area.C.Corrected[x],table2.sample$d12C.d13C.ratio[x])
})
table2.sample$d12C.d13C.BlankCorrected <- blankCorrected.d13C
Rank.Analysis <- seq(1,nrow(table2.sample))
table2.sample <- cbind(Rank.Analysis, table2.sample)
return(list(table2.standard, table2.sample))
} else {NULL}
})
output$toCheck <- renderTable({
table2()[[1]]
})
table2.standard <- reactive({
table2()[[1]]
})
table2.sample <- reactive({
table2()[[2]]
})
dilution <- reactive ({
gelA.lines <- NULL
for(i in 1:length(input$gelA)) {
gelA.lines <- c(gelA.lines, which(table2.sample()$sample.name == input$gelA[i]))
}
gelA.table <- table2.sample()[gelA.lines,]
table.WithoutGelA <- table2.sample()[complementVector(1:nrow(table2.sample()), gelA.lines),]
## table of the dilution
dilution.Sample <- vector()
dilution.factor <- length(levels(as.factor(table.WithoutGelA$equipement.dilution)))
for(i in i:dilution.factor) {
dilution.Sample[i] <- length(which(table.WithoutGelA$equipement.dilution == as.numeric(as.character(levels(as.factor(table.WithoutGelA$equipement.dilution))[i]))))
}
names(dilution.Sample) <- levels(as.factor(table.WithoutGelA$equipement.dilution))
dilution.Sample <- t(as.matrix(dilution.Sample))
rownames(dilution.Sample) <- "Number of sample analyzed with this dilution"
return(list(dilution.Sample, gelA.table, table.WithoutGelA))
})
gelA.table <- reactive({
dilution()[[2]]
})
table.WithoutGelA <- reactive({
dilution()[[3]]
})
output$dilutionTable <- renderTable({
if(!is.null(resultMatrix())) {
dilution()[[1]]
}
}, include.rownames=TRUE)
Karina's procedure of Normalization
Normalized.signature = (Stand.1_TRUE - Stand.2_TRUE)/(Stand.1_OBS - Stand.2_OBS) * (signature - Stand.1_OBS) + Stand.1_TRUE
At (d15N) = 100/(271.872114/(1+(Normalized.signature/1000))+1)
At (d13N) = 100/(89.443838/(1+(Normalized.signature/1000))+1)
table2.sample.Karina <- reactive({
table2.sample.Karina <- table2.sample()
norm.Karina.d15N <- sapply(1:nrow(table2.sample.Karina), function(x) {
Karina.Normalisation(signature = table2.sample.Karina$d14N.d15N.BlankCorrected[x], true.Values = as.numeric(as.character(table1()[nrow(table1()),2:3])), real.Values =
as.numeric(as.character(table1()[(nrow(table1())-2),2:(length(input$N.define) +1)])))
})
table2.sample.Karina$Normalized.d14N.d15N <- norm.Karina.d15N
At.d15N <- 100/(271.872114/(1+(table2.sample.Karina$Normalized.d14N.d15N/1000))+1)
table2.sample.Karina$At.N <- At.d15N
norm.Karina.d13C <- sapply(1:nrow(table2.sample.Karina), function(x) {
Karina.Normalisation(signature = table2.sample.Karina$d12C.d13C.BlankCorrected[x], true.Values = as.numeric(as.character(table1()[nrow(table1()),4:5])), real.Values = as.numeric(as.character(table1()[(nrow(table1())-2),(length(input$N.define) +2):(length(input$N.define) +3)])))
})
table2.sample.Karina$Normalized.d12C.d13C <- norm.Karina.d13C
At.d13C <- 100/(89.443838/(1+(table2.sample.Karina$Normalized.d12C.d13C/1000))+1)
table2.sample.Karina$At.C <- At.d13C
return(table2.sample.Karina)
})
output$dataSampleKarina <- renderDT({
if(length(input$C.define) > 1 & length(input$N.define) > 1 ) {
table2.sample.Karina()
} else {}
})
output$SaveButton <- renderUI({
actionButton("save", "Save the data")
})
output$Save <- renderUI({
if(!is.null(input$save)) {
if(input$save > 0){
isolate({
if(length(input$C.define) > 1 & length(input$N.define) > 1 ) {
if(input$nameSession == "Name of the session") {
toAdd <- ""
} else {
toAdd <- paste0("_", input$nameSession)
}
table0 <- matrix("", 20, 2)
table0[,1] <- c("Total C and D Isotope Analysis",
"",
"1. Session settings",
"Date",
"Samples",
"Responsible",
"Lab. Temp",
"System",
"Column",
"Temp, Owen",
"Carrier gas",
"Carrier flow",
"Reference gas1",
"Reference flow",
"Reference gas2",
"Reference flow",
"Method",
"", "",
"2. Blank corrected delta values for isotope standards"
)
table0[,2] <- c("",
"",
"",
input$dateProcessig,
input$SampleName,
input$Responsible,
input$Temperature,
input$system,
input$Column,
input$temp.Owen,
input$carrier.Gas,
input$carrier.flow,
input$Reference.gas1,
input$Reference.flow1,
input$Reference.gas2,
input$Reference.flow2,
input$Method,
"", "",
""
)
table1_new <- table1()
lapply(2:ncol(table1_new), function(x) {
table1_new[3:nrow(table1_new),x] <- as.numeric(as.character(table1_new[3:nrow(table1_new), x]))
})
table1_new[1:2,1] <- c("Isotope", "Standard")
table2.standard_new <- table2.standard()
lapply(5:ncol(table2.standard_new), function(x) {
table2.standard_new[1:nrow(table2.standard_new), x] <- as.numeric(as.character(table2.standard_new[1:nrow(table2.standard_new), x]))
})
table2.sample.Karina_new <- table2.sample.Karina()
lapply(5:ncol(table2.sample.Karina_new), function(x) {
table2.sample.Karina_new[1:nrow(table2.sample.Karina_new), x] <- as.numeric(as.character(table2.sample.Karina_new[1:nrow(table2.sample.Karina_new), x]))
})
table.Interm1 <- matrix("3. Blank correction of delta value in standards", ncol = 1, nrow = 1)
table.Interm2 <- matrix("4. Results from samples", ncol = 1, nrow = 1)
normStyle <- createStyle(valign = "center", halign = "center", numFmt = "0.00")
GeneraltitleStyle <- createStyle(valign = "center", halign = "center", fontSize = 14, textDecoration = "bold")
titleStyle <- createStyle(valign = "center", halign = "left", fontSize = 14, textDecoration = "bold")
tableStyle <- createStyle(borderStyle = "thin", border = "TopBottomLeftRight")
colorBlue <- createStyle(fgFill = "#99ccff")
colorGreen <- createStyle(fgFill = "#00ff00")
wb <- createWorkbook("Example.xlsx")
addWorksheet(wb, "CNEA_data")
writeData(wb, sheet = 1, CNEA(), colNames = T)
addWorksheet(wb, "isotope_data")
writeData(wb, sheet = 2, table0, colNames = FALSE)
writeData(wb, sheet = 2, table1_new, startRow = nrow(table0) + 1, colNames = F)
writeData(wb, sheet = 2, table.Interm1, startRow = nrow(table0) + nrow(table1_new) + 3, colNames = F)
writeData(wb, sheet = 2, table2.standard_new, startRow = nrow(table0) + nrow(table1_new) + 4, colNames = T)
writeData(wb, sheet = 2, table.Interm2, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, colNames = F)
writeData(wb, sheet = 2, table2.sample.Karina_new, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8, colNames = T)
nbRow_FinalTable <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + nrow(table2.sample.Karina_new) + 8
lapply(1:17, function(x) {
addStyle(wb, sheet = 2, normStyle, cols = x, rows = 1:nbRow_FinalTable)
})
addStyle(wb, sheet = 2, GeneraltitleStyle, rows = 1, cols = 1, stack = T)
addStyle(wb, sheet = 2, titleStyle, rows = 20, cols = 1, stack = T)
addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + 3, cols = 1, stack = T)
addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, cols = 1, stack = T)
table1_end <- nrow(table0) + nrow(table1_new)
lapply(1:5, function(x) {
addStyle(wb, sheet = 2, tableStyle, cols = x, rows = 21:table1_end, stack = T)
})
table2_stand_begin <- nrow(table0) + nrow(table1_new) + 4
table2_stand_end <- nrow(table0) + nrow(table1_new) + 4 + nrow(table2.standard_new)
lapply(1:16, function(x) {
addStyle(wb, sheet = 2, tableStyle, rows = table2_stand_begin:table2_stand_end, cols = x, stack = T)
})
addStyle(wb, sheet = 2, colorBlue, cols = 8, rows = table2_stand_begin:table2_stand_end, stack = T)
addStyle(wb, sheet = 2, colorBlue, cols = 15, rows = table2_stand_begin:table2_stand_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 9, rows = table2_stand_begin:table2_stand_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 16, rows = table2_stand_begin:table2_stand_end, stack = T)
table2_sample_begin <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8
table2_sample_end <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8 + nrow(table2.sample.Karina_new)
lapply(1:17, function(x) {
addStyle(wb, sheet = 2, tableStyle, rows = table2_sample_begin:table2_sample_end, cols = x, stack = T)
})
addStyle(wb, sheet = 2, colorBlue, cols = 9, rows = table2_sample_begin:table2_sample_end, stack = T)
addStyle(wb, sheet = 2, colorBlue, cols = 16, rows = table2_sample_begin:table2_sample_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 10, rows = table2_sample_begin:table2_sample_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 17, rows = table2_sample_begin:table2_sample_end, stack = T)
mergeCells(wb, sheet = 2, cols = 1:18, rows = 1)
mergeCells(wb, sheet = 2, cols = 1:8, rows = 20)
mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + 3)
mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7)
mergeCells(wb, sheet = 2, cols = 2:3, rows = 21)
mergeCells(wb, sheet = 2, cols = 4:5, rows = 21)
if(Sys.info()[1] == "Windows"){
path <- choose.dir()
} else {
path <- jchoose.dir()
}
pathExport <- paste0(path, "/finalTable.Sample.Karina",toAdd, ".xlsx")
saveWorkbook(wb, file = pathExport, overwrite = TRUE)
}
})
return("Karina's results have been saved :)")
}
}
})
Final Table
r DTOutput("dataSampleKarina")
r uiOutput("SaveButton")
r uiOutput("Save")
Peter's procedure of Normalization
Here, the user has to select the relevant dilution to keep in the linear regression
r tableOutput('dilutionTable')
Define the dilution factor to consider for the normalization:
r uiOutput('choiceDilution')
output$choiceDilution <- renderUI({
if(!is.null(resultMatrix())) {
dilution.suggested <- levels(as.factor(gelA.table()$equipement.dilution))
toPick.dilution <- dilution.suggested[which(dilution.suggested != "0" & dilution.suggested != " " & dilution.suggested != "" & !is.na(dilution.suggested))]
checkboxGroupInput("dilutionPicked", label = "",
choices = toPick.dilution,
selected = toPick.dilution[1],
inline = TRUE)
}
})
gelA.table.dilution <- reactive({
if(!is.null(resultMatrix())) {
toConsider <-lapply(1:length(input$dilutionPicked), function(x) {
which(gelA.table()$equipement.dilution == input$dilutionPicked[x])
})
toConsider <- unlist(toConsider)
gelA.table.dilution <- gelA.table()[toConsider, ]
gelA.table.dilution <- gelA.table.dilution[order(gelA.table.dilution$Rank.Analysis),]
return(gelA.table.dilution)
}
})
output$GelA.tokeep.N <- renderUI({
if(!is.null(gelA.table.dilution())) {
checkboxGroupInput("GelA.tokeep.N", label = p("Select the gelA to keep for the linear regression"),
choices = gelA.table.dilution()$Box.position,
selected = gelA.table.dilution()$Box.position,
inline = T )
} else {}
})
gelA.dilution_toKeep.N <- reactive({
if(!is.null(resultMatrix()) & !is.null(input$GelA.tokeep.N)) {
toConsider <-lapply(1:length(input$GelA.tokeep.N), function(x) {
which(gelA.table.dilution()$Box.position == input$GelA.tokeep.N[x])
})
toConsider <- unlist(toConsider)
gelA.dilution_toKeep <- gelA.table.dilution()[toConsider, ]
gelA.dilution_toKeep <- gelA.dilution_toKeep[order(gelA.dilution_toKeep$Rank.Analysis),]
return(gelA.dilution_toKeep)
}
})
gelA.dilution_toKeep.C <- reactive({
if(!is.null(resultMatrix()) & !is.null(input$GelA.tokeep.C)) {
toConsider <-lapply(1:length(input$GelA.tokeep.C), function(x) {
which(gelA.table.dilution()$Box.position == input$GelA.tokeep.C[x])
})
toConsider <- unlist(toConsider)
gelA.dilution_toKeep <- gelA.table.dilution()[toConsider, ]
gelA.dilution_toKeep <- gelA.dilution_toKeep[order(gelA.dilution_toKeep$Rank.Analysis),]
return(gelA.dilution_toKeep)
}
})
output$GelA.tokeep.C <- renderUI({
if(!is.null(gelA.table.dilution())) {
checkboxGroupInput("GelA.tokeep.C", label = p("Select the gelA to keep for the linear regression"),
choices = gelA.table.dilution()$Box.position,
selected = gelA.table.dilution()$Box.position,
inline = T )
} else {}
})
model.15N <- reactive({
if(!is.null(gelA.dilution_toKeep.N())) {
model.d15N <- lm(gelA.dilution_toKeep.N()$d14N.d15N.BlankCorrected ~ gelA.dilution_toKeep.N()$Rank.Analysis)
Intercept.N <- summary(model.d15N)$coefficients[1]
Slope.N <- summary(model.d15N)$coefficients[2]
return(c(Intercept.N, Slope.N))
}
})
model.13C <- reactive({
if(!is.null(gelA.dilution_toKeep.C())) {
model.d13C <- lm(gelA.dilution_toKeep.C()$d12C.d13C.BlankCorrected ~ gelA.dilution_toKeep.C()$Rank.Analysis)
Intercept.C <- summary(model.d13C)$coefficients[1]
Slope.C <- summary(model.d13C)$coefficients[2]
return(c(Intercept.C, Slope.C))
}
})
output$linearRegression.N <- renderPlot({
if(!is.null(gelA.dilution_toKeep.N())) {
plot(gelA.dilution_toKeep.N()$d14N.d15N.BlankCorrected ~ gelA.dilution_toKeep.N()$Rank.Analysis, ylab = "d14N.d15N.BlankCorrected", xlab = "Rank.Analysis")
text(gelA.dilution_toKeep.N()$Rank.Analysis, gelA.dilution_toKeep.N()$d14N.d15N.BlankCorrected, labels=gelA.dilution_toKeep.N()$Box.position, cex= 0.7, pos=4)
abline(model.15N()[1], model.15N()[2], col = 'red')
}
})
output$linearRegression.C <- renderPlot({
if(!is.null(gelA.dilution_toKeep.C())) {
plot(gelA.dilution_toKeep.C()$d12C.d13C.BlankCorrected ~ gelA.dilution_toKeep.C()$Rank.Analysis, ylab = "d12C.d13C.BlankCorrected", xlab = "Rank.Analysis")
text(gelA.dilution_toKeep.C()$Rank.Analysis, gelA.dilution_toKeep.C()$d12C.d13C.BlankCorrected, labels=gelA.dilution_toKeep.C()$Box.position, cex= 0.7, pos=4)
abline(model.13C()[1], model.13C()[2], col = 'red')
}
})
table2.sample.Peter <- reactive({
if(!is.null(model.15N()) & !is.null(model.13C())) {
table2.sample.Peter <- table2.sample()
Norm.d15N <- Peter.Correction.d15N(table2.sample.Peter$d14N.d15N.BlankCorrected, table2.sample.Peter$Rank.Analysis, model.15N()[2], model.15N()[1])
table2.sample.Peter$Normalized.d14N.d15N <- Norm.d15N
Norm.d13C <- Peter.Correction.d13C(table2.sample.Peter$d12C.d13C.BlankCorrected, table2.sample.Peter$Rank.Analysis, model.13C()[2], model.13C()[1])
table2.sample.Peter$Normalized.d12C.d13C <- Norm.d13C
return(table2.sample.Peter)
}
})
output$modelN <- renderText({
if(!is.null(model.15N()) & !is.null(model.13C())) {
paste("For N, the parameters of the model: intercept = ", round(model.15N()[1],10), " and slope = ", round(model.15N()[2], 10))
}
})
output$modelC <- renderText({
if(!is.null(model.15N()) & !is.null(model.13C())) {
paste("For C, the parameters of the model: intercept = ", round(model.13C()[1],10), " and slope = ", round(model.13C()[2], 10))
}
})
output$FinalTable <- renderDT({
table2.sample.Peter()
})
output$SaveButton2 <- renderUI({
actionButton("save2", "Save the data")
})
output$Save2 <- renderUI({
if(!is.null(input$save2)) {
if(input$save2 > 0){
isolate({
if(!is.null(table2.sample.Peter())) {
if(input$nameSession == "Name of the session") {
toAdd <- ""
} else {
toAdd <- paste0("_", input$nameSession)
}
table0 <- matrix("", 20, 2)
table0[,1] <- c("Total C and D Isotope Analysis",
"",
"1. Session settings",
"Date",
"Samples",
"Responsible",
"Lab. Temp",
"System",
"Column",
"Temp, Owen",
"Carrier gas",
"Carrier flow",
"Reference gas1",
"Reference flow",
"Reference gas2",
"Reference flow",
"Method",
"", "",
"2. Blank corrected delta values for isotope standards"
)
table0[,2] <- c("",
"",
"",
input$dateProcessig,
input$SampleName,
input$Responsible,
input$Temperature,
input$system,
input$Column,
input$temp.Owen,
input$carrier.Gas,
input$carrier.flow,
input$Reference.gas1,
input$Reference.flow1,
input$Reference.gas2,
input$Reference.flow2,
input$Method,
"", "",
""
)
table1_new <- table1()
lapply(2:ncol(table1_new), function(x) {
table1_new[3:nrow(table1_new),x] <- as.numeric(as.character(table1_new[3:nrow(table1_new), x]))
})
table1_new[1:2,1] <- c("Isotope", "Standard")
table2.standard_new <- table2.standard()
lapply(5:ncol(table2.standard_new), function(x) {
table2.standard_new[1:nrow(table2.standard_new), x] <- as.numeric(as.character(table2.standard_new[1:nrow(table2.standard_new), x]))
})
table2.sample.Peter_new <- table2.sample.Peter()
lapply(5:ncol(table2.sample.Peter_new), function(x) {
table2.sample.Peter_new[1:nrow(table2.sample.Peter_new), x] <- as.numeric(as.character(table2.sample.Peter_new[1:nrow(table2.sample.Peter_new), x]))
})
table.Interm1 <- matrix("3. Blank correction of delta value in standards", ncol = 1, nrow = 1)
table.Interm2 <- matrix("4. Results from samples", ncol = 1, nrow = 1)
normStyle <- createStyle(valign = "center", halign = "center", numFmt = "0.00")
GeneraltitleStyle <- createStyle(valign = "center", halign = "center", fontSize = 14, textDecoration = "bold")
titleStyle <- createStyle(valign = "center", halign = "left", fontSize = 14, textDecoration = "bold")
tableStyle <- createStyle(borderStyle = "thin", border = "TopBottomLeftRight")
colorBlue <- createStyle(fgFill = "#99ccff")
colorGreen <- createStyle(fgFill = "#00ff00")
wb <- createWorkbook("Example.xlsx")
addWorksheet(wb, "CNEA_data")
writeData(wb, sheet = 1, CNEA(), colNames = T)
addWorksheet(wb, "isotope_data")
writeData(wb, sheet = 2, table0, colNames = FALSE)
writeData(wb, sheet = 2, table1_new, startRow = nrow(table0) + 1, colNames = F)
writeData(wb, sheet = 2, table.Interm1, startRow = nrow(table0) + nrow(table1_new) + 3, colNames = F)
writeData(wb, sheet = 2, table2.standard_new, startRow = nrow(table0) + nrow(table1_new) + 4, colNames = T)
writeData(wb, sheet = 2, table.Interm2, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, colNames = F)
writeData(wb, sheet = 2, table2.sample.Peter_new, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8, colNames = T)
nbRow_FinalTable <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + nrow(table2.sample.Peter_new) + 8
lapply(1:17, function(x) {
addStyle(wb, sheet = 2, normStyle, cols = x, rows = 1:nbRow_FinalTable)
})
addStyle(wb, sheet = 2, GeneraltitleStyle, rows = 1, cols = 1, stack = T)
addStyle(wb, sheet = 2, titleStyle, rows = 20, cols = 1, stack = T)
addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + 3, cols = 1, stack = T)
addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, cols = 1, stack = T)
table1_end <- nrow(table0) + nrow(table1_new)
lapply(1:5, function(x) {
addStyle(wb, sheet = 2, tableStyle, cols = x, rows = 21:table1_end, stack = T)
})
table2_stand_begin <- nrow(table0) + nrow(table1_new) + 4
table2_stand_end <- nrow(table0) + nrow(table1_new) + 4 + nrow(table2.standard_new)
lapply(1:16, function(x) {
addStyle(wb, sheet = 2, tableStyle, rows = table2_stand_begin:table2_stand_end, cols = x, stack = T)
})
addStyle(wb, sheet = 2, colorBlue, cols = 8, rows = table2_stand_begin:table2_stand_end, stack = T)
addStyle(wb, sheet = 2, colorBlue, cols = 15, rows = table2_stand_begin:table2_stand_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 9, rows = table2_stand_begin:table2_stand_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 16, rows = table2_stand_begin:table2_stand_end, stack = T)
table2_sample_begin <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8
table2_sample_end <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8 + nrow(table2.sample.Peter_new)
lapply(1:17, function(x) {
addStyle(wb, sheet = 2, tableStyle, rows = table2_sample_begin:table2_sample_end, cols = x, stack = T)
})
addStyle(wb, sheet = 2, colorBlue, cols = 9, rows = table2_sample_begin:table2_sample_end, stack = T)
addStyle(wb, sheet = 2, colorBlue, cols = 16, rows = table2_sample_begin:table2_sample_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 10, rows = table2_sample_begin:table2_sample_end, stack = T)
addStyle(wb, sheet = 2, colorGreen, cols = 17, rows = table2_sample_begin:table2_sample_end, stack = T)
mergeCells(wb, sheet = 2, cols = 1:18, rows = 1)
mergeCells(wb, sheet = 2, cols = 1:8, rows = 20)
mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + 3)
mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7)
mergeCells(wb, sheet = 2, cols = 2:3, rows = 21)
mergeCells(wb, sheet = 2, cols = 4:5, rows = 21)
if(Sys.info()[1] == "Windows"){
path <- choose.dir()
} else {
path <- jchoose.dir()
}
pathExport <- paste0(path, "/finalTable.Sample.Peter",toAdd, ".xlsx")
saveWorkbook(wb, file = pathExport, overwrite = TRUE)
}
})
return("Peter's results have been saved :)")
}
}
})
1. Linear regression d15N
r uiOutput('GelA.tokeep.N')
r textOutput('modelN')
r plotOutput('linearRegression.N')
2. Linear regression d13C
r uiOutput('GelA.tokeep.C')
r textOutput('modelC')
r plotOutput('linearRegression.C')
3. Final Table
r DTOutput("FinalTable")
r uiOutput("SaveButton2")
r uiOutput("Save2")
Data exploration
radioButtons("tableChosen",
label = "Choose the table that you want to explore",
choices = c("Karina's procedure Table", "Peter's procedure Table"),
selected = "Peter's procedure Table", inline = T
)
dataToExplore <- reactive({
if(input$tableChosen == "Karina's procedure Table") {
if(!is.null(table2.sample.Karina())) {
output <- table2.sample.Karina()
} else {NULL}
} else {
if(!is.null(table2.sample.Peter())) {
output <- table2.sample.Peter()
} else {}
}
})
output$pivot <- renderRpivotTable({
if(!is.null(dataToExplore())) {
rpivotTable(dataToExplore(),width="100%", height="400px")
} else {}
})
r rpivotTableOutput('pivot')
charlottesirot/isoHelpR documentation built on May 29, 2019, 12:05 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#remove leading and trailing space trim <- function (x) gsub("^\\s+|\\s+$", "", x) # Returns the indices in the vector that correspond to integer or floating point getNumericIndices <- function(vect) { return(grep("^[+-]?([0-9]*[.])?[0-9]+$", vect, value = FALSE)) } containsCharacter <- function(vect) { numIndices <- getNumericIndices(vect) result = c() if(length(numIndices) == 0) {return(result)} for(i in 1:length(vect)){ printDebug(trim(vect[i])) if(!is.na(trim(vect[i]))){ if(!is.element(i, numIndices) && trim(vect[i]) != ""){ result <- c(result, i) } } } return(result) } # Debug output function DEBUG_FILE = "/home/cha/debug.log" printDebug <- function(message){ write(paste("[", Sys.time(), "] ", message),file=DEBUG_FILE,append=TRUE) #write(message,file=DEBUG_FILE,append=TRUE) } # function to ask for the background values is.null.vector <- function(x) { sapply(x, is.null) } separateAnalysis_CNEA <- function(data, column1, column2) { vect1 <- which(is.na(column1)) listPlace1 <- successiveValues(vect1) vect2 <- which(is.na(column2)) listPlace2 <- successiveValues(vect2) if(length(listPlace1) != 0 | length(listPlace2) != 0) { if(length(listPlace1) == length(listPlace2)) { toReturn <- lapply(1:length(listPlace1), function(x) { data[c(listPlace1[[x]],listPlace2[[x]]), ] }) } else { toReturn <- NULL } } else { toReturn <- NULL } return(toReturn) } is.numeric_cha <- function(x) { sapply(1:length(x), function(i) { if(is.null(x[i])) {return(F)} toTest <- as.numeric(as.character(x[i])) if(!is.na(toTest) & is.numeric(toTest)) { return(T) } else {F} }) } successiveValues = function(vect) { if(length(vect) != 1) { length.vect <- length(vect) i <- 1 k <- 1 finalList <- list() while(i < length.vect) { finalList[k][[1]] <- vect[i] while(vect[i + 1] == vect[i] +1 & i < length.vect) { finalList[k][[1]] <- c(finalList[k][[1]], vect[i+1]) i <- i+1 } i <- i+1 k <- k+1 } if(length(unlist(finalList)) != length.vect) { finalList[[k]] <- vect[length.vect] } } else { finalList <- list(vect) } return(finalList) } # some helpful threads # https://stat.ethz.ch/pipermail/r-help/2008-September/172641.html # http://tolstoy.newcastle.edu.au/R/e4/help/08/02/4875.html # http://tolstoy.newcastle.edu.au/R/e2/help/07/01/8598.html # http://www.r-statistics.com/wp-content/uploads/2011/01/boxplot-add-label-for-outliers.r.txt # last updated: 31.10.2011 # This is instead of the 20.6.11 version... boxplot.with.outlier.label <- function(y, label_name, ..., spread_text = T, data, plot = T, range = 1.5, label.col = "blue", push_text_right = 1.3, # enlarge push_text_right in order to push the text labels further from their point segement_width_as_percent_of_label_dist = .45, # Change this if you want to have the line closer to the label (range should be between 0 to 1 jitter_if_duplicate = T, jitter_only_positive_duplicates = F) { # notes - this functions doesn't work if there are any missing values in the data. # You must pre-process the data to make sure it is "complete". # change log: # 19.04.2011 - added support to "names" and "at" parameters. # jitter_if_duplicate - will jitter (Actually just add a bit of numbers) so to be able to decide on which location to plot the label when having identical variables... require(plyr) # for is.formula and ddply # a function to jitter data in case of ties in Y's jitter.duplicate <- function(x, only_positive = F) { if(only_positive) { ss <- x > 0 } else { ss <- T } ss_dup <- duplicated(x[ss]) # ss <- ss & ss_dup temp_length <- length(x[ss][ss_dup]) x[ss][ss_dup] <- x[ss][ss_dup] + seq(from = 0.00001, to = 0.00002, length.out = temp_length) x } # jitter.duplicate(c(1:5)) # jitter.duplicate(c(1:5,5,2)) # duplicated(jitter.duplicate(c(1:5,5,2))) # jitter.duplicate(c(0,0,1:5,5,2)) # duplicated(jitter.duplicate(c(0,0,1:5,5,2))) # handle cases where if(jitter_if_duplicate) { # warning("duplicate jutter of values in y is ON") if(!missing(data)) { #e.g: we DO have data # if(exists("y") && is.formula(y)) { # F && NULL # F & NULL y_name <- as.character(substitute(y)) # I could have also used as.list(match.call()) # credit to Uwe Ligges and Marc Schwartz for the help # https://mail.google.com/mail/?shva=1#inbox/12dd7ca2f9bfbc39 if(length(y_name) > 1) { # then it is a formula (for example: "~", "y", "x" model_frame_y <- model.frame(y, data = data) temp_y <- model_frame_y[,1] temp_y <- jitter.duplicate(temp_y, jitter_only_positive_duplicates) # notice that the default of the function is to work only with positive values... # the_txt <- paste(names(model_frame_y)[1], "temp_y", sep = "<<-") # wrong... the_txt <- paste("data['",names(model_frame_y)[1],"'] <- temp_y", sep = "") eval(parse(text = the_txt)) # jutter out y var so to be able to handle identical values. } else { # this isn't a formula data[,y_name] <- jitter.duplicate(data[,y_name], jitter_only_positive_duplicates) y <- data[,y_name] # this will make it possible for boxplot(y, data) to work later (since it is not supposed to work with data when it's not a formula, but now it does :)) } } else { # there is no "data" if(is.formula(y)) { # if(exists("y") && is.formula(y)) { # F && NULL # F & NULL temp_y <- model.frame(y)[,1] temp_y <- jitter.duplicate(temp_y, jitter_only_positive_duplicates) # notice that the default of the function is to work only with positive values... temp_y_name <- names(model.frame(y))[1] # we must extract the "names" before introducing a new enbironment (or there will be an error) environment(y) <- new.env() assign(temp_y_name, temp_y, environment(y)) # Credit and thanks for doing this goes to Niels Richard Hansen (2 Jan 30, 2011) # http://r.789695.n4.nabble.com/environment-question-changing-variables-from-a-formula-through-model-frame-td3246608.html # warning("Your original variable (in the global environemnt) was just jittered.") # maybe I should add a user input before doing this.... # the_txt <- paste(names(model_frame_y)[1], "temp_y", sep = "<<-") # eval(parse(text = the_txt)) # jutter out y var so to be able to handle identical values. } else { y <- jitter.duplicate(y, jitter_only_positive_duplicates) } } } # the_txt <- paste("print(",names(model_frame_y)[1], ")") # eval(parse(text = the_txt)) # jutter out y var so to be able to handle identical values. # print(ls()) # y should be a formula of the type: y~x, y~a*b # or it could be simply y if(missing(data)) { boxdata <- boxplot(y, plot = plot,range = range ,...) } else { boxdata <- boxplot(y, plot = plot,data = data, range = range ,...) } if(length(boxdata$names) == 1 && boxdata$names =="") boxdata$names <- 1 # this is for cases of type: boxplot(y) (when there is no dependent group) if(length(boxdata$out) == 0 ) { warning("No outliers detected for this boxplot") return(invisible()) } if(!missing(data)) attach(data) # this might lead to problams I should check out for alternatives for using attach here... # creating a data.frame with information from the boxplot output about the outliers (location and group) boxdata_group_name <- factor(boxdata$group) levels(boxdata_group_name) <- boxdata$names[as.numeric(levels(boxdata_group_name))] # the subseting is for cases where we have some sub groups with no outliers if(!is.null(list(...)$at)) { # if the user chose to use the "at" parameter, then we would like the function to still function (added on 19.04.2011) boxdata$group <- list(...)$at[boxdata$group] } boxdata_outlier_df <- data.frame(group = boxdata_group_name, y = boxdata$out, x = boxdata$group) # Let's extract the x,y variables from the formula: if(is.formula(y)) { model_frame_y <- model.frame(y) # old solution: (which caused problems if we used the names parameter when using a 2 way formula... (since the order of the names is different then the levels order we get from using factor) # y <- model_frame_y[,1] # x <- model_frame_y[,-1] y <- model_frame_y[,1] x <- model_frame_y[,-1] if(!is.null(dim(x))) { # then x is a matrix/data.frame of the type x1*x2*..and so on - and we should merge all the variations... x <- apply(x,1, paste, collapse = ".") } } else { # if(missing(x)) x <- rep(1, length(y)) x <- rep(1, length(y)) # we do this in case y comes as a vector and without x } # and put all the variables (x, y, and outlier label name) into one data.frame DATA <- data.frame(label_name, x ,y) if(!is.null(list(...)$names)) { # if the user chose to use the names parameter, then we would like the function to still function (added on 19.04.2011) DATA$x <- factor(DATA$x, levels = unique(DATA$x)) levels(DATA$x) = list(...)$names # enable us to handle when the user adds the "names" parameter # fixed on 19.04.11 # notice that DATA$x must be of the "correct" order (that's why I used split above # warning("Careful, the use of the 'names' parameter is experimental. If you notice any errors please e-mail me at: tal.galili@gmail.com") } if(!missing(data)) detach(data) # we don't need to have "data" attached anymore. # let's only keep the rows with our outliers boxplot.outlier.data <- function(xx, y_name = "y") { y <- xx[,y_name] boxplot_range <- range(boxplot.stats(y, coef = range )$stats) ss <- (y < boxplot_range[1]) | (y > boxplot_range[2]) return(xx[ss,]) } outlier_df <-ddply(DATA, .(x), boxplot.outlier.data) # create propor x/y locations to handle over-laping dots... if(spread_text) { # credit: Greg Snow require(TeachingDemos) temp_x <- boxdata_outlier_df[,"x"] temp_y1 <- boxdata_outlier_df[,"y"] temp_y2 <- temp_y1 for(i in unique(temp_x)) { tmp <- temp_x == i temp_y2[ tmp ] <- spread.labs( temp_y2[ tmp ], 1.3*strheight('A'), maxiter=6000, stepsize = 0.05) #, min=0 ) } } # max(strwidth(c("asa", "a")) # move_text_right <- max(strwidth(outlier_df[,"label_name"])) # plotting the outlier labels :) (I wish there was a non-loop wise way for doing this) for(i in seq_len(dim(boxdata_outlier_df)[1])) { # ss <- (outlier_df[,"x"] %in% boxdata_outlier_df[i,]$group) & (outlier_df[,"y"] %in% boxdata_outlier_df[i,]$y) # if(jitter_if_duplicate) { # ss <- (outlier_df[,"x"] %in% boxdata_outlier_df[i,]$group) & closest.number(outlier_df[,"y"] boxdata_outlier_df[i,]$y) # } else { ss <- (outlier_df[,"x"] %in% boxdata_outlier_df[i,]$group) & (outlier_df[,"y"] %in% boxdata_outlier_df[i,]$y) # } current_label <- outlier_df[ss,"label_name"] temp_x <- boxdata_outlier_df[i,"x"] temp_y <- boxdata_outlier_df[i,"y"] # cbind(boxdata_outlier_df, temp_y2) # outlier_df if(spread_text) { temp_y_new <- temp_y2[i] # not ss move_text_right <- strwidth(current_label) * push_text_right text( temp_x+move_text_right, temp_y_new, current_label, col = label.col) # strwidth segments( temp_x+(move_text_right/6), temp_y, temp_x+(move_text_right*segement_width_as_percent_of_label_dist), temp_y_new ) } else { text(temp_x, temp_y, current_label, pos = 4, col = label.col) } } # outputing some of the information we collected invisible(list(boxdata = boxdata, boxdata_outlier_df = boxdata_outlier_df, outlier_df=outlier_df)) } complementVector = function(VectR, x) { length.VectR <- length(VectR) length.x <- length(x) y <- vector() #output for(i in 1:length.VectR) { if(is.na(match(VectR[i], x))) { y <- c(y, i) } else {} } return(VectR[y]) } blank.correction <- function(Area.blank, Sign.blank, Area.sample, Sign.sample) { value <- (Area.sample*Sign.sample - Area.blank*Sign.blank)/(Area.sample - Area.blank) return(value) } Area.correction <- function(value.toCorrect, dilution) { value <- value.toCorrect * (1+dilution/100) return(value) } Karina.Normalisation <- function(signature, true.Values, real.Values){ coef <- (true.Values[1] - true.Values[2])/(real.Values[1]-real.Values[2]) value <- (signature - real.Values[2]) * coef + true.Values[2] return(value) } Peter.Correction.d15N <- function(signature, rank, slope, intercept) { newValue <- signature - (slope * rank + intercept - 5.4) return(newValue) } Peter.Correction.d13C <- function(signature, rank, slope, intercept) { newValue <- signature - (slope * rank + intercept + 21.8) return(newValue) } max.list = function(liste) { max.list <- 0 n <- length(liste) for (i in 1:n) { max.Prov <- length(liste[[i]]) if(max.Prov > max.list) {max.list <- max.Prov} else {} } return(max.list) } ### Global Variables COL_NAMES <- c("FirstRow", "Identifier.1", "Identifier.2", "hasCorrectPattern", "d13ValIndex", "exportd13", "d15ValIndex", "exportd15", "hasOneVald15", "hasOneVald13", "hasnoNAInDilution", "hasTwoValInDilution", "hasZeroInDilution", "dilFact", "hasNAinAreaAll", "exportAread15", "exportAread13") ### check the equality of values even if there is an NA equals <- function(x, y) { if(is.na(x) && is.na(y)) {return(TRUE)} if(is.na(x) || is.na(y)) {return(FALSE)} return (x == y) } ### checks whether a vector contains NA containsNA <- function(vect) { for(i in 1:length(vect)) { if(is.na(vect[i])) { return(TRUE) } } return(FALSE) } ### appends a value to an existing list appendToList <- function(li, val) { lenLi <- length(li) li[[lenLi + 1]] <- val return(li) } processBlock <- function(block) { # processResultRow will contain information to build result matrix resultRow <- c(block$Rank.Analysis[1], block$Identifier.1[1], block$Identifier.2[1]) # add the relevant informations regarding the Isotope columns resultRow <- processIsotopeCols(block, resultRow) # add the relevant informations regarding dilution column resultRow <- processDilutionCol(block, resultRow) # add the relevant informations regarding the Area.all column resultRow <- processAreaAllCol(block, resultRow) #give names to the resultRow names(resultRow) <- COL_NAMES return(resultRow) } processDilutionCol <- function(block, resultRow) { # Check whether dilution column in block contains NA # Instructions to Minus: we have a function for that!! hasNoNA <- !containsNA(block$Sample.Dilution) # Check that there are only two distinct values # Instructions to Minus: We will use unique distVal <- unique(block$Sample.Dilution) lenDisVal <- length(distVal) hasTwoVal <- (lenDisVal == 2) # Check that one of the values is 0 # Instructions to Minus: Use is.element to check for 0 hasZero <- is.element(0, block$Sample.Dilution) # Add column with (some) dilution value # Instructions to Minus: I love you dilFact <- block$Sample.Dilution[as.numeric(as.character(resultRow["d13ValIndex"]))] print("######") print(block$Sample.Dilution) print(as.numeric(as.character(resultRow["d13ValIndex"]))) print(block$Sample.Dilution[as.numeric(as.character(resultRow["d13ValIndex"]))]) print("######") # add column to the resultRow resultRow <- c(resultRow, hasNoNA, hasTwoVal, hasZero, dilFact) return(resultRow) } processIsotopeCols <- function(block, resultRow) { # Check value distribution pattern (NA at correct places and correct number of rows) # Instructions to Minus: This will add column/value to resultRow that says TRUE/FALSE whether pattern correct d13Col <- block$d.13C.12C d15Col <- block$d.15N.14N hasCorrectPattern <- TRUE if(block$Identifier.1[1] == "sucrose") { if(nrow(block) != 5) { hasCorrectPattern <- FALSE } if(!is.na(d13Col[1]) || !is.na(d13Col[2]) || !is.na(d13Col[3]) || is.na(d13Col[4]) || is.na(d13Col[5])) { hasCorrectPattern <- FALSE } if(is.na(d15Col[1]) || is.na(d15Col[2]) || is.na(d15Col[3]) || !is.na(d15Col[4]) || !is.na(d15Col[5])) { hasCorrectPattern <- FALSE } } else { if(nrow(block) != 6) { hasCorrectPattern <- FALSE } if(!is.na(d13Col[1]) || !is.na(d13Col[2]) || !is.na(d13Col[3]) || !is.na(d13Col[4]) || is.na(d13Col[5]) || is.na(d13Col[6])) { hasCorrectPattern <- FALSE } if(is.na(d15Col[1]) || is.na(d15Col[2]) || is.na(d15Col[3]) || is.na(d15Col[4]) || !is.na(d15Col[5]) || !is.na(d15Col[6])) { hasCorrectPattern <- FALSE } } # Extract isotope value and corresponding row d13ValIndex <- findFirstNotNAValIndex(d13Col) if(is.na(d13ValIndex)){ exportd13 <- NA } else { exportd13 <- d13Col[d13ValIndex] } d15ValIndex <- findLastNotNAValIndex(d15Col) if(is.na(d15ValIndex)){ exportd15 <- NA } else { exportd15 <- d15Col[d15ValIndex] } # check that d15Col and d13Col has at least one value hasOneVald15 <- !is.na(exportd15) hasOneVald13 <- !is.na(exportd13) resultRow <- c(resultRow, hasCorrectPattern, d13ValIndex, exportd13, d15ValIndex, exportd15, hasOneVald15, hasOneVald13) names(resultRow) <- c("Rank", "Id1", "Id2", "hasCorrectPattern","d13ValIndex", "exportd13", "d15ValIndex", "exportd15", "hasOneVald15", "hasOneVald13") return(resultRow) #TODO } processAreaAllCol <- function(block, resultRow) { # Check that column does not contain NA hasNA <- containsNA(block$Area.All) # Extract the two values that you need d15Index <- as.numeric(resultRow[7]) d13Index <- as.numeric(resultRow[5]) exportAread15 <- block$Area.All[d15Index] exportAread13 <- block$Area.All[d13Index] resultRow <- c(resultRow, hasNA, exportAread15, exportAread13) return(resultRow) #TODO } findFirstNotNAValIndex <- function(vect) { for(i in 1: length(vect)){ if(!is.na(vect[i])) {return(i)} } return(NA) } findLastNotNAValIndex <- function(vect){ for(i in length(vect) : 1){ if(!is.na(vect[i])) {return(i)} } return(NA) } createResultMatrix <- function(blockList) { resultMatrix <- data.frame(matrix(ncol = length(COL_NAMES))) colnames(resultMatrix) <- COL_NAMES for(i in 1:length(blockList)) { block <- blockList[[i]] rowToAdd <- processBlock(block) resultMatrix <- rbind(resultMatrix, rowToAdd) } # Remove first row of matrix that just contains NA resultMatrix <- resultMatrix[-1,] return(resultMatrix) }
To read beforhand
Aim of this document: This sheet has been created to help users to format the CN_EA file in order to upload it for further calculations.
WARNING: The aim of CN_EA.CleanR is not to correct automatically the CN_EA file, this delicated task requiring human skills. However, it is dedicated to point out errors or abnormalities of the raw CN_EA file. When the first round of correction has been finished and before uploading any file in isoSignature.creatR, please check a last time with CN_EA.CleanR that there is NO error in the required CONCLUSIONS (this task may require several rounds of CN_EA.CleanR).
WARNING: The weight file and the CNEA have to list the sample in the same order.
Cleaning and calculation settings
output$info <- renderUI({ div(column(6, fileInput("CNEA", label = p("Select the CNEA file")), textInput("nameSession", label = "", value = "Name of the session"), textInput("dateProcessig", label = "", value = "Date of the analysis:"), textInput("Responsible", label = "", value = "Responsible:"), textInput("Temperature", label = "", value = "Lab Temperature:"), textInput("SampleName", label = "", value = "Sample name:"), textInput("system", label = "", value = "System:"), textInput("Column", label = "", value = "Column:"), textInput("temp.Owen", label = "", value = "Temp Owen:") ), (column(6, fileInput("weightData", label = p("Select the weight file")), textInput("carrier.Gas", label = "", value = "Carrier gas:"), textInput("carrier.flow", label = "", value = "Carrier flow:"), textInput("Reference.gas1", label = "", value = "Reference gas 1:"), textInput("Reference.flow1", label = "", value = "Reference flow1:"), textInput("Reference.gas2", label = "", value = "Reference gas 2:"), textInput("Reference.flow2", label = "", value = "Reference flow2:"), textInput("Method", label = "", value = "Method:") ) ) ) }) output$selectSample <- renderUI({ if(!is.null(input$CNEA)) { level.identifier.1 <- levels(as.factor(CNEA()$Identifier.1)) div(column(12, br(), checkboxGroupInput("sample", label = p("Select the name(s) that correspond to samples"), choices = level.identifier.1, selected = level.identifier.1[1], inline = T ) )) } else {} })
r uiOutput("info")
r uiOutput("selectSample")
CNEA <- reactive({ if(!is.null(input$CNEA)) { CNEA <- read.xls (input$CNEA$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE) CNEA[,2] <- tolower(CNEA[,2]) Rank.Analysis <- 2: (nrow(CNEA)+ 1) # +1 to make the excel file correspond to the R file CNEA <- cbind(Rank.Analysis, CNEA) CNEA <- data.frame(CNEA, stringsAsFactors=FALSE) CNEA$Area.All <- as.numeric(as.character(CNEA$Area.All)) CNEA$d.13C.12C <- as.numeric(as.character(CNEA$d.13C.12C)) CNEA$d.15N.14N <- as.numeric(as.character(CNEA$d.15N.14N)) CNEA$Sample.Dilution <- as.numeric(as.character(CNEA$Sample.Dilution)) return(CNEA) } }) weightData <- reactive({ if(!is.null(input$weightData)) { weightData <- read.xls (input$weightData$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE) weightData <- as.data.frame(weightData) weightData$Measured.Weigth..mg. <- as.numeric(as.character(weightData$Measured.Weigth..mg.)) weightData$Box.pos <- as.character(weightData$Box.pos) return(weightData) } }) ############################ ## Condition 1: character value in the dilution, All.Area, d13c and d15N column ############################ output$character_Error <- renderText({ if(is.null(input$CNEA)){return(NULL)} CNEA <- read.xls (input$CNEA$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE) weightData <- read.xls (input$weightData$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE) errorChar_CNEA <-c(containsCharacter(CNEA$Area.All), containsCharacter(CNEA$d.13C.12C), containsCharacter(CNEA$d.15N.14N), containsCharacter(CNEA$Sample.Dilution)) errorChar_Weight <- containsCharacter(weightData$Measured.Weigth..mg.) if(length(errorChar_CNEA) > 0) { paste("Oups, there is a character string in your CNEA file. Check the line(s):", paste(CNEA()$Rank.Analysis[errorChar_CNEA], sep = " ", collapse = " ")) } else { if(length(errorChar_Weight) > 0) { paste("Oups, there is a character string in your Weight file. Check the line(s):", paste(errorChar_Weight, sep = " ", collapse = " ")) } else {} } }) output$character_OK <- renderText({ if(is.null(input$CNEA)){return(NULL)} CNEA <- read.xls (input$CNEA$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE) weightData <- read.xls (input$weightData$datapath, sheet = 1, header = TRUE, stringsAsFactors=FALSE) errorChar_CNEA <-c(containsCharacter(CNEA$Area.All), containsCharacter(CNEA$d.13C.12C), containsCharacter(CNEA$d.15N.14N), containsCharacter(CNEA$Sample.Dilution)) errorChar_Weight <- containsCharacter(weightData$Measured.Weigth..mg.) if(length(errorChar_CNEA) == 0 & length(errorChar_Weight) == 0) { "Perfect!! There is no character in your files" } else {} }) ############################ ## Condition 1: identifier.1 ############################ output$id1_Error <- renderText({ if(is.null(input$CNEA)) {return(NULL)} bad.Id1 <- which(CNEA()$Identifier.1 == "" | is.na(CNEA()$Identifier.1) | is.null(CNEA()$Identifier.1)) if(length(bad.Id1) != 0) { toDisplay.1 <- paste("Some identifier.1 are empty (DO NOT IGNORE!!). Please check the line:", paste(CNEA()$Rank.Analysis[bad.Id1], sep = " ", collapse = " ")) } }) output$id1_OK <- renderText({ if(is.null(input$CNEA)) {return(NULL)} bad.Id1 <- which(CNEA()$Identifier.1 == "" | is.na(CNEA()$Identifier.1) | is.null(CNEA()$Identifier.1)) if(length(bad.Id1) != 0) {NULL} else { toDisplay.1 <- "No problem in the identifier.1" } }) ############################ ## Condition 7: Any area should not be empty ############################ output$error.area_Error <- renderText({ if(is.null(input$CNEA)) {return(NULL)} error.area <- which(resultMatrix()$hasNAinAreaAll) if(length(error.area) != 0) { toDisplay.1 <- paste("Some Area are empty. Please check the analysis beginning line(s):", paste(resultMatrix()$FirstRow[error.area], sep = " ", collapse = " ")) } }) output$error.area_OK <- renderText({ if(is.null(input$CNEA)) {return(NULL)} error.area <- which(resultMatrix()$hasNAinAreaAll) if(length(error.area) == 0) { toDisplay.1 <- "No problem in the Area" } }) ############################ ## Condition 2 ############################ resultMatrix <- reactive({ if(is.null(input$CNEA)){return(NULL)} blockList <- list() currentBlock <- data.frame() lastId <- c(CNEA()$Identifier.1[1], CNEA()$Identifier.2[1], CNEA()$Row[1]) for(i in 1:nrow(CNEA())) { currentRow <- CNEA()[i,] currentId <- c(CNEA()$Identifier.1[i], CNEA()$Identifier.2[i], CNEA()$Row[i]) # if row identifier changed, then we finished a block and start a new one if(!equals(currentId[1], lastId[1]) || !equals(currentId[2], lastId[2]) || !equals(currentId[3], lastId[3])) { # Add current block to blockList blockList <- appendToList(blockList, currentBlock) # Start a new empty block and add current row to it currentBlock <- data.frame() } # Add current row to current block currentBlock <- rbind(currentBlock, currentRow) if(i == nrow(CNEA())){blockList <- appendToList(blockList, currentBlock)} lastId <- currentId } resultMatrix <- createResultMatrix(blockList) # toTransform in logical for(i in c(4,9:13,15)) { resultMatrix[,i] <- as.logical(resultMatrix[,i]) } resultMatrix$exportAread15 <- as.numeric(as.character(resultMatrix$exportAread15)) resultMatrix$exportAread13 <- as.numeric(as.character(resultMatrix$exportAread13)) resultMatrix$exportd13 <- as.numeric(as.character(resultMatrix$exportd13)) resultMatrix$exportd15 <- as.numeric(as.character(resultMatrix$exportd15)) resultMatrix$dilFact <- as.numeric(as.character(resultMatrix$dilFact)) return(resultMatrix) }) output$nbValue.C_Error <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} errorC <- which(resultMatrix()$hasOneVald13 == F) if(length(errorC) != 0) { paste("There is no value for C in the analysis. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[errorC], sep = " ", collapse = " ")) } }) output$nbValue.C_OK <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} errorC <- which(resultMatrix()$hasOneVald13 == F) if(length(errorC) == 0) { "There is at least one C signature for all analyses" } }) output$nbValue.N_Error <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} errorN <- which(resultMatrix()$hasOneVald15 == F) if(length(errorN) != 0) { paste("There is no value for N in the analysis. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[errorN], sep = " ", collapse = " ")) } }) output$nbValue.N_OK <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} errorN <- which(resultMatrix()$hasOneVald15 == F) if(length(errorN) == 0) { "There is at least one N signature for every analysis" } }) output$pattern_Error <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} errorPattern <- which(resultMatrix()$hasCorrectPattern == F) if(length(errorPattern) != 0) { paste("There is a problem of pattern. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[errorPattern], sep = " ", collapse = " ")) } }) output$pattern_OK <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} errorPattern <- which(resultMatrix()$hasCorrectPattern == F) if(length(errorPattern) == 0) { paste("No problem in the pattern") } }) ############################ ## Condition 3: Identifier.2 ############################ dataTables <- reactive({ if(!is.null(input$CNEA) & length(character()) ==0) { sample <- input$sample place <- NULL for(x in 1:length(sample)) { if(x == 1) { place <- which(resultMatrix()$Identifier.1 == sample[x]) CNEA.sample <- resultMatrix()[place, ] } else { place <- c(place, which(resultMatrix()$Identifier.1 == sample[x])) CNEA.sample <- rbind(CNEA.sample, resultMatrix()[which(resultMatrix()$Identifier.1 == sample[x]), ]) } } place <- sort(place) PlaceBar <- complementVector(1:nrow(resultMatrix()), place) CNEA.sample <- CNEA.sample[order(as.numeric(as.character(CNEA.sample$FirstRow))),] # data with only the sample CNEA.standard <- resultMatrix()[PlaceBar, ] # data with only the standards return(list(CNEA.sample, CNEA.standard)) } else {} }) dataStandard <- reactive({ if(!is.null(input$CNEA)) { temp <- dataTables()[[2]] return(temp) } else {} }) dataSample <- reactive({ if(!is.null(input$CNEA)) { temp <- dataTables()[[1]] return(temp) } else {} }) output$dataSampleToPrint <- renderDT({ if(!is.null(input$CNEA)) { dataSample() } else {} }) output$dataStandardToPrint <- renderDT({ if(!is.null(input$CNEA)) { dataStandard() } else {} }) ############################ ## Condition 4: dilution ############################ output$dilution_Error <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} err <- which(resultMatrix()$hasnoNAInDilution == F | resultMatrix()$hasTwoValInDilution == F) if(length(err) != 0) { paste("There is a mistake in the dilution factor. Please check the analysis beginning line(s)", paste(resultMatrix()$FirstRow[err], sep = "", collapse = " ")) } }) output$dilution_OK <- renderText({ if(is.null(input$CNEA) | length(character()) !=0){return(NULL)} err <- which(resultMatrix()$hasnoNAInDilution == F | resultMatrix()$hasTwoValInDilution == F) if(length(err) == 0) { "Everything is ok regarding dilution" } }) ############################ ## Condition 6: secondary condition ############################ Data_plus_weight <- reactive({ ## for pasting the weight of the sample if(!is.null(input$CNEA) & !is.null(input$weightData) & !is.null(resultMatrix())) { errorToCount <- 0 # flag for error line.flag <- NA Data_plus_weight <- NULL nRow.dataSample <- nrow(dataSample()) nRow.weightData <- nrow(weightData()) if(nRow.dataSample != nRow.weightData) { errorToCount <- 1 } else { for(i in 1:nRow.dataSample){ if(as.character(dataSample()$Identifier.2[i]) != as.character(weightData()$Box.pos[i])){ errorToCount <- 1 line.flag <- c(line.flag, dataSample()$Identifier.2[i]) } else {} } if(errorToCount == 0) { Data_plus_weight <- cbind(dataSample(), weightData()$Name, weightData()$Measured.Weigth..mg.) colnames(Data_plus_weight) <- c(colnames(dataSample()), "sampleName", "SampleWeight") } else {} } return(list(c(errorToCount, line.flag), Data_plus_weight)) } else {} }) output$weight_Error <- renderText({ if(!is.null(input$CNEA) & !is.null(input$weightData)) { if(Data_plus_weight()[[1]][1] != 0){ if(!is.na(Data_plus_weight()[[1]][2])){ paste("Weight and CNEA files do not match on their identifier.2, check line(s):", paste(Data_plus_weight()[[1]][2], sep = " ", collapse = " ")) } else { paste("Weight and CNEA files do not have the same number of rows") } } else { NULL } } else {} }) output$weight_OK <- renderText({ if(!is.null(input$CNEA) & !is.null(input$weightData)) { if(Data_plus_weight()[[1]][1] != 0){ NULL } else { "The CNEA and weight file seem to match (Note that it did not check for the box name)" } } else {} })
Conditions tested for cleaning
- Condition 1: Any identifier 1 should not be empty or null
r textOutput("id1_OK")r textOutput("id1_Error") - Condition 2: Cells from Area, dilution, d15N and d13C columns should contain any character
r textOutput("character_OK")r textOutput("character_Error") - Condition 3: One analysis (i.e. the ranks are following) must contain not empty Area.All cell. d13C/d12C and d15N/d14N should have each at least one value.
r textOutput("nbValue.C_OK")r textOutput("nbValue.C_Error")r textOutput("nbValue.N_OK")r textOutput("nbValue.N_Error")
But also analysis should contain 4 signatures values (3 for the sucrose) for N and 2 for the carboner textOutput("pattern_OK")r textOutput("pattern_Error") - Condition 5. Identifier.2 for weight and CNEA file should be in the same order (for sample only)
r textOutput("weight_Error")r textOutput("weight_OK") - Condition 6. No Area.All should be empty
r textOutput("error.area_Error")r textOutput("error.area_OK") - Condition 7: Analysis should have exactly one dilution value
r textOutput("dilution_OK")r textOutput("dilution_Error")
Data Samples:
r DTOutput("dataSampleToPrint")
Data Standards:
r DTOutput("dataStandardToPrint")
Graphical detection of mistakes - Outlier highlighting
output$forBoxPlot <- renderUI({ if(!is.null(input$CNEA)) { level.identifier.1 <- levels(as.factor(CNEA()$Identifier.1)) checkboxGroupInput("toDisplay", label = "", choices = level.identifier.1, selected = level.identifier.1, inline = T ) } else {} }) output$boxplot <- renderPlot({ if(!is.null(input$CNEA) & length(character()) ==0) { toDisplay <- input$toDisplay for(x in 1:length(toDisplay)) { if(x == 1) { dataTemp <- resultMatrix()[which(resultMatrix()$Identifier.1 == toDisplay[x]), ] } else { dataTemp <- rbind(dataTemp, resultMatrix()[which(resultMatrix()$Identifier.1 == toDisplay[x]), ]) } } par(mfrow = c(1,2), mar = c(2,3,1.2,1.2)) ylim.C <- c(min(dataTemp$exportd13, na.rm = T) - abs(min(dataTemp$exportd13, na.rm = T))*0.1, max(dataTemp$exportd13, na.rm = T) + abs(max(dataTemp$exportd13, na.rm = T))*0.1) boxplot.with.outlier.label(as.numeric(as.character(dataTemp$exportd13)), label_name = dataTemp$Identifier.2, ylim = ylim.C, cex = 1.25) mtext("d13C", side = 1) ylim.N <- c(min(dataTemp$exportd15, na.rm = T) - abs(min(dataTemp$exportd15, na.rm = T))*0.1, max(dataTemp$exportd15, na.rm = T) + abs(max(dataTemp$exportd15, na.rm = T))*0.1) boxplot.with.outlier.label(as.numeric(as.character(dataTemp$exportd15)), label_name = dataTemp$Identifier.2, ylim = ylim.N, cex = 1.25) mtext("d15N", side = 1) return(dataTemp) } else {} })
r uiOutput('forBoxPlot')
r plotOutput('boxplot')
Conclusions of the cleaning
finalConclusion <- reactive({ if(!is.null(resultMatrix())) {return(TRUE)} if(is.null(Data_plus_weight())) {return(TRUE)} bad.Id1 <- which(CNEA()$Identifier.1 == "" | is.na(CNEA()$Identifier.1) | is.null(CNEA()$Identifier.1)) error.area <- which(resultMatrix()$hasNAinAreaAll) errorC <- which(resultMatrix()$hasOneVald13 == F) errorN <- which(resultMatrix()$hasOneVald15 == F) errorPattern <- which(resultMatrix()$hasCorrectPattern == F) err <- which(resultMatrix()$hasnoNAInDilution == F & resultMatrix()$hasTwoValInDilution == T) if(length(character())!=0 | length(bad.Id1) != 0 | length(error.area) != 0 | length(errorC) != 0 | length(errorN) != 0 | length(errorPattern) != 0 | length(err) != 0 | Data_plus_weight()[[1]][1] != 0) { return(TRUE) } else {return(FALSE)} }) output$finalConclusion_error <- renderText({ if(!is.null(resultMatrix())) { if(finalConclusion() == TRUE) { "There is at least one mistake in your files. <br> Please correct according to previously before continuing to read this file." } else {NULL} } else {NULL} }) output$finalConclusion_OK <- renderText({ if(!is.null(resultMatrix())) { if(finalConclusion() == FALSE) { "It seems that your files are correct." } else {NULL} } else {NULL} })
r textOutput("finalConclusion_OK")
r span(htmlOutput("finalConclusion_error"), style="color:red")
Settings for "IsotopeSignature.file" creation
WARNING: Before continuing in this file, please check the conditions above do NOT contain any error in required CONCLUSIONS (this task may require several run of utilisation of the function CNEA_cleanR). If the TCD file is upload without this last verification, CNEA_cleanR CANNOT garantee the validity of the following data.
r uiOutput("info.2")
output$info.2 <- renderUI({ if(!is.null(input$CNEA)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) blank <- names(CNEA.liste)[str_detect(names(CNEA.liste), "lank")] gelA <- weightData()$Name[(str_detect(weightData()$Name, "el") | str_detect(weightData()$Name, "EL"))] if(length(gelA) == 0) { gelA <- weightData()$Name[1] } backgroundValues <- c(0, 1167) div( checkboxGroupInput("blank", label = p("1. Select blanks (blank AND system blank)"), choices = names(CNEA.liste), selected = blank, inline = T), br(), checkboxGroupInput("gelA", label = p("2. Select Gel A"), choices = levels(as.factor(weightData()$Name)), selected = gelA, inline =T), br(), tags$b("3. Background Values"), div( column(6, textInput("Area.N.background", label = "", value = "Area of the blank N")), column(6, textInput("signature.N.background", label = "", value = "signature of the blank N"))), div( column(6, textInput("Area.C.background", label = "", value = "Area of the blank C")), column(6, textInput("signature.C.background", label = "", value = "signature of the blank C"))) ) } else {} }) nameInput.C <- reactive({ if(!is.null(input$C.define)) { nameInput <- vector() for(i in 1:length(input$C.define)) { nameInput[i] <- paste0(resultMatrix()$Identifier.1[which(input$C.define[i] == resultMatrix()$Identifier.1)], "_inputName.C") } return(nameInput) } }) output$chooseValue.C.stand <- renderUI({ if(!is.null(input$CNEA) & !is.null(input$C.define)) { lapply(1:length(input$C.define), function(x){ div( column(6, p(paste("Select the values that you want to keep for", resultMatrix()$Identifier.1[which(input$C.define[x] == resultMatrix()$Identifier.1)]))), column(6, checkboxGroupInput(nameInput.C()[x], label = p(""), choices = resultMatrix()$exportd13[which(input$C.define[x] == resultMatrix()$Identifier.1)], selected = resultMatrix()$exportd13[which(input$C.define[x] == resultMatrix()$Identifier.1)], inline = T), br() ) ) }) } }) output$checkBox.C <- renderUI({ if(!is.null(input$CNEA)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) checkboxGroupInput("C.define", label = p("3. Select carbon standards"), choices = level.identifier.1, selected = level.identifier.1[1], inline = F) } else {} }) output$Value.C <- renderUI({ if(!is.null(input$CNEA) & !is.null(input$C.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) plot_output_list <- lapply(seq(from = 1, to = length(input$C.define), by = 1), function(i) { V.C <- paste("value.C", i, sep="") textInput(V.C, label = "", value = paste("Value C for ", input$C.define[i])) }) } else {} }) c.ToTake <- reactive({ if(!is.null(input$CNEA) & !is.null(input$C.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) c.ToTake <- sapply(1:length(input$C.define), function(x) { which(input$C.define[x] == level.identifier.1) }) c.ToTake <- sort(c.ToTake) return(c.ToTake) ## rank of value to take } else {} }) value.C <- reactive({ if(!is.null(input$CNEA) & !is.null(input$C.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) temp <- vector() for(i in 1:length(input$C.define)){ temp <- c(temp, eval(parse(text = paste("input$value.C", i, sep="")))) } return(temp) } else {} }) value.C.toTake <- reactive({ if(!is.null(input$CNEA) & !is.null(input$C.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) temp <- value.C() # temp <- value.C()[c.ToTake()] # # names(temp) <- level.identifier.1[c.ToTake()] return(temp) } else {} }) nameInput.N <- reactive({ if(!is.null(input$N.define)) { nameInput <- vector() for(i in 1:length(input$N.define)) { nameInput[i] <- paste0(resultMatrix()$Identifier.1[which(input$N.define[i] == resultMatrix()$Identifier.1)], "_inputName.N") } return(nameInput) } }) output$chooseValue.N.stand <- renderUI({ if(!is.null(input$CNEA) & !is.null(input$N.define)) { lapply(1:length(input$N.define), function(x){ div( column(6, p(paste("Select the values that you want to keep for", resultMatrix()$Identifier.1[which(input$N.define[x] == resultMatrix()$Identifier.1)]))), column(6, checkboxGroupInput(nameInput.N()[x], label = p(""), choices = resultMatrix()$exportd15[which(input$N.define[x] == resultMatrix()$Identifier.1)], selected = resultMatrix()$exportd15[which(input$N.define[x] == resultMatrix()$Identifier.1)], inline = T), br() ) ) }) } }) output$checkBox.N <- renderUI({ if(!is.null(input$CNEA)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) checkboxGroupInput("N.define", label = p("4. Select nitrogen standards"), choices = level.identifier.1, selected = level.identifier.1[1], inline = F) } else {} }) output$Value.N <- renderUI({ if(!is.null(input$CNEA) & !is.null(input$N.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) plot_output_list <- lapply(seq(from = 1, to = length(input$N.define), by = 1), function(i) { V.N <- paste("value.N", i, sep="") textInput(V.N, label = "", value = paste("Value N for ", input$N.define[i])) }) } else {} }) n.ToTake <- reactive({ if(!is.null(input$CNEA) & !is.null(input$N.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) n.ToTake <- sapply(1:length(input$N.define), function(x) { which(input$N.define[x] == level.identifier.1) }) n.ToTake <- sort(n.ToTake) return(n.ToTake) ## rank of value to take } else {} }) value.N <- reactive({ if(!is.null(input$CNEA) & !is.null(input$N.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) temp <- vector() for(i in 1:length(input$N.define)){ temp <- c(temp, eval(parse(text = paste("input$value.N", i, sep="")))) } return(temp) } else {} }) value.N.toTake <- reactive({ if(!is.null(input$CNEA) & !is.null(input$N.define)) { CNEA.liste <- split(CNEA(), CNEA()$Identifier.1) level.identifier.1 <- names(CNEA.liste) temp <- value.N() # temp <- value.N()[n.ToTake()] # names(temp) <- level.identifier.1[n.ToTake()] return(temp) } else {} })
r div(column(6, uiOutput("checkBox.N")), column(6, uiOutput("Value.N")))
r div(column(12, uiOutput("chooseValue.N.stand")))
r div(column(6, uiOutput("checkBox.C")), column(6, uiOutput("Value.C")))
r div(column(12, uiOutput("chooseValue.C.stand")))
############################################################################################################################# ### Table1 is the first table of the isotope data sheet that allow to have the average of the NItrogen and Carbon standards ############################################################################################################################# table1 <- reactive({ if(!is.null(input$CNEA)) { nitrogen.table1 <- list() for(i in 1:length(input$N.define)) { nitrogen.table1[[i]] <- eval(parse(text = paste0("input$\'", nameInput.N()[i], "\'"))) } carbon.table1 <- list() for(i in 1:length(input$C.define)) { carbon.table1[[i]] <- eval(parse(text = paste0("input$\'", nameInput.C()[i], "\'"))) } nrow.table1 <- max(max.list(nitrogen.table1), max.list(carbon.table1)) + 5 ncol.table1 <- length(input$C.define) + length(input$N.define)+1 table1 <- as.data.frame(matrix(ncol = ncol.table1, nrow = nrow.table1)) ## Blank corrected delta values for isotope standards table1[1,] <- c("Blank corrected delta values for isotope standards", rep("Nitrogen", length(input$N.define)), rep("Carbon", length(input$C.define))) table1[2,] <- c(" ", input$N.define, input$C.define) for(i in 1:length(input$N.define)) { table1[3:(2+length(nitrogen.table1[[i]])),i+1] <- as.character(nitrogen.table1[[i]]) } for(i in 1:length(input$C.define)) { table1[3:(2+length(carbon.table1[[i]])),i+length(input$N.define)+1] <- as.character(carbon.table1[[i]]) } table1[3:(nrow(table1)-3),1] <- " " table1[(nrow(table1)-2) : nrow(table1), 1] <- c("Average", "Stdev", "True.Value") for(i in 2:(length(input$C.define) + length(input$N.define) + 1)) { analysis <- as.numeric(as.character(table1[,i])) table1[(nrow.table1-2),i] <- mean(analysis, na.rm = T) table1[(nrow.table1-1),i] <- sd(analysis, na.rm = T) } table1[nrow.table1,(2:ncol.table1)] <- c(as.numeric(as.character(value.N.toTake())), as.numeric(as.character(value.C.toTake()))) colnames(table1) <- c("Names", paste("Nitrogen", input$N.define, sep ="."), paste("Carbon", input$C.define, sep =".")) return(table1) if(input$nameSession == "Name of the session") { toAdd <- "" } else { toAdd <- input$nameSession } } else {} }) output$table1.toDisplay <- renderDT({ table1() })
r DTOutput("table1.toDisplay")
############################################################################################################################# ### creation of the table2: table2.standard (i.e. called Blank correction of delta value in standards) and table2.sample ############################################################################################################################# table2 <- reactive({ if(!is.null(resultMatrix())) { resultMatrix <- resultMatrix()[order(as.numeric(as.character(resultMatrix()$FirstRow))),] line.sample <- lapply(1:length(input$sample), function(x) { which(resultMatrix$Identifier.1 == input$sample [x]) }) # the line of the resultMatrix that correspond to the sample line.sample <- unlist(line.sample) table2.sample.Temp <- resultMatrix[line.sample,] table2.sample.Temp <- table2.sample.Temp[order(as.numeric(as.character(table2.sample.Temp$FirstRow))),] printDebug("########table table2.sample.Temp") printDebug(table2.sample.Temp) line.standard <- complementVector(1:nrow(resultMatrix), line.sample) table2.standard.Temp <- resultMatrix[line.standard,] table2.standard.Temp <- table2.standard.Temp[order(as.numeric(as.character(table2.standard.Temp$FirstRow))),] printDebug("########table table2.standard.Temp") printDebug(table2.standard.Temp) # table2.standard final (i.e. with corrected value) table2.standard <- as.data.frame(matrix(ncol = 16, nrow = nrow(table2.standard.Temp))) colnames(table2.standard) <- c("Box.No", "Box.position", "sample.name", "sample.weight","Area.N", "d14N.d15N.ratio", "d14N.d15N.BlankCorrected", "Normalized.d14N.d15N", "At.N", "equipement.dilution", "Area.C", "d12C.d13C.ratio", "Area.C.Corrected", "d12C.d13C.BlankCorrected", "Normalized.d12C.d13C", "At.C") table2.standard$Box.No <- " " table2.standard$Box.position <- " " table2.standard[,3] <- as.character(table2.standard.Temp$Identifier.1) table2.standard[,5] <- as.numeric(as.character(table2.standard.Temp$exportAread15)) table2.standard[,6] <- as.numeric(as.character(table2.standard.Temp$exportd15)) table2.standard[,10] <- as.numeric(as.character(table2.standard.Temp$dilFact)) table2.standard[,11] <- as.numeric(as.character(table2.standard.Temp$exportAread13)) table2.standard[,12] <- as.numeric(as.character(table2.standard.Temp$exportd13)) blank.correction <- function(Area.blank, Sign.blank, Area.sample, Sign.sample) { value <- (Area.sample*Sign.sample - Area.blank*Sign.blank)/(Area.sample - Area.blank) return(value) } blankValue.N <- c(as.numeric(as.character(input$Area.N.background)), as.numeric(as.character(input$signature.N.background))) if(is.na(blankValue.N)) { blankValue.N <- c(0, 0) } blankValue.C <- c(as.numeric(as.character(input$Area.C.background)), as.numeric(as.character(input$signature.C.background))) if(is.na(blankValue.C)) { blankValue.C <- c(0, 0) } toConvert <- c(5,6, 10, 11, 12) for(i in 1:length(toConvert)) { table2.standard[,toConvert[i]] <-as.numeric(as.character(table2.standard[,toConvert[i]])) } ## Blank correction d15N blankCorrected.d15N <- sapply(1:nrow(table2.standard), function(x) { blank.correction(blankValue.N[1], blankValue.N[2], table2.standard$Area.N[x],table2.standard$d14N.d15N.ratio[x]) }) table2.standard$d14N.d15N.BlankCorrected <- blankCorrected.d15N ## Area Correction d13C Area.Corrected.d13C <- sapply(1:nrow(table2.standard), function(x) { Area.correction(table2.standard$Area.C[x], table2.standard$equipement.dilution[x]) }) table2.standard$Area.C.Corrected <- Area.Corrected.d13C ## blank correction d13C blankCorrected.d13C <- sapply(1:nrow(table2.standard), function(x) { blank.correction(blankValue.C[1], blankValue.C[2], table2.standard$Area.C.Corrected[x],table2.standard$d12C.d13C.ratio[x]) }) table2.standard$d12C.d13C.BlankCorrected <- blankCorrected.d13C # table2.sample final (i.e. with corrected value) table2.sample <- as.data.frame(matrix(ncol = 16, nrow = nrow(table2.sample.Temp))) colnames(table2.sample) <- c("Box.No", "Box.position", "sample.name", "sample.weight","Area.N", "d14N.d15N.ratio", "d14N.d15N.BlankCorrected", "Normalized.d14N.d15N", "At.N", "equipement.dilution", "Area.C", "d12C.d13C.ratio", "Area.C.Corrected", "d12C.d13C.BlankCorrected", "Normalized.d12C.d13C", "At.C") table2.sample[,1] <- as.character(table2.sample.Temp$Identifier.1) table2.sample[,2] <- as.character(table2.sample.Temp$Identifier.2) table2.sample[,3] <- as.character(weightData()$Name) table2.sample[,4] <- as.numeric(as.character(weightData()$Measured.Weigth..mg.)) table2.sample[,5] <- as.numeric(as.character(table2.sample.Temp$exportAread15)) table2.sample[,6] <- as.numeric(as.character(table2.sample.Temp$exportd15)) table2.sample[,10] <- as.numeric(as.character(table2.sample.Temp$dilFact)) table2.sample[,11] <- as.numeric(as.character(table2.sample.Temp$exportAread13)) table2.sample[,12] <- as.numeric(as.character(table2.sample.Temp$exportd13)) toConvert <- c(5,6, 10, 11, 12) for(i in 1:length(toConvert)) { table2.sample[,toConvert[i]] <-as.numeric(as.character(table2.sample[,toConvert[i]])) } # blank correction d15N blankCorrected.d15N <- sapply(1:nrow(table2.sample), function(x) { blank.correction(blankValue.N[1], blankValue.N[2], table2.sample$Area.N[x],table2.sample$d14N.d15N.ratio[x]) }) table2.sample$d14N.d15N.BlankCorrected <- blankCorrected.d15N ## Area Correction d13C Area.Corrected.d13C <- sapply(1:nrow(table2.sample), function(x) { Area.correction(table2.sample$Area.C[x], table2.sample$equipement.dilution[x]) }) table2.sample$Area.C.Corrected <- Area.Corrected.d13C ## blank correction d13C blankCorrected.d13C <- sapply(1:nrow(table2.sample), function(x) { blank.correction(blankValue.C[1], blankValue.C[2], table2.sample$Area.C.Corrected[x],table2.sample$d12C.d13C.ratio[x]) }) table2.sample$d12C.d13C.BlankCorrected <- blankCorrected.d13C Rank.Analysis <- seq(1,nrow(table2.sample)) table2.sample <- cbind(Rank.Analysis, table2.sample) return(list(table2.standard, table2.sample)) } else {NULL} }) output$toCheck <- renderTable({ table2()[[1]] }) table2.standard <- reactive({ table2()[[1]] }) table2.sample <- reactive({ table2()[[2]] }) dilution <- reactive ({ gelA.lines <- NULL for(i in 1:length(input$gelA)) { gelA.lines <- c(gelA.lines, which(table2.sample()$sample.name == input$gelA[i])) } gelA.table <- table2.sample()[gelA.lines,] table.WithoutGelA <- table2.sample()[complementVector(1:nrow(table2.sample()), gelA.lines),] ## table of the dilution dilution.Sample <- vector() dilution.factor <- length(levels(as.factor(table.WithoutGelA$equipement.dilution))) for(i in i:dilution.factor) { dilution.Sample[i] <- length(which(table.WithoutGelA$equipement.dilution == as.numeric(as.character(levels(as.factor(table.WithoutGelA$equipement.dilution))[i])))) } names(dilution.Sample) <- levels(as.factor(table.WithoutGelA$equipement.dilution)) dilution.Sample <- t(as.matrix(dilution.Sample)) rownames(dilution.Sample) <- "Number of sample analyzed with this dilution" return(list(dilution.Sample, gelA.table, table.WithoutGelA)) }) gelA.table <- reactive({ dilution()[[2]] }) table.WithoutGelA <- reactive({ dilution()[[3]] }) output$dilutionTable <- renderTable({ if(!is.null(resultMatrix())) { dilution()[[1]] } }, include.rownames=TRUE)
Karina's procedure of Normalization
Normalized.signature = (Stand.1_TRUE - Stand.2_TRUE)/(Stand.1_OBS - Stand.2_OBS) * (signature - Stand.1_OBS) + Stand.1_TRUE
At (d15N) = 100/(271.872114/(1+(Normalized.signature/1000))+1)
At (d13N) = 100/(89.443838/(1+(Normalized.signature/1000))+1)
table2.sample.Karina <- reactive({ table2.sample.Karina <- table2.sample() norm.Karina.d15N <- sapply(1:nrow(table2.sample.Karina), function(x) { Karina.Normalisation(signature = table2.sample.Karina$d14N.d15N.BlankCorrected[x], true.Values = as.numeric(as.character(table1()[nrow(table1()),2:3])), real.Values = as.numeric(as.character(table1()[(nrow(table1())-2),2:(length(input$N.define) +1)]))) }) table2.sample.Karina$Normalized.d14N.d15N <- norm.Karina.d15N At.d15N <- 100/(271.872114/(1+(table2.sample.Karina$Normalized.d14N.d15N/1000))+1) table2.sample.Karina$At.N <- At.d15N norm.Karina.d13C <- sapply(1:nrow(table2.sample.Karina), function(x) { Karina.Normalisation(signature = table2.sample.Karina$d12C.d13C.BlankCorrected[x], true.Values = as.numeric(as.character(table1()[nrow(table1()),4:5])), real.Values = as.numeric(as.character(table1()[(nrow(table1())-2),(length(input$N.define) +2):(length(input$N.define) +3)]))) }) table2.sample.Karina$Normalized.d12C.d13C <- norm.Karina.d13C At.d13C <- 100/(89.443838/(1+(table2.sample.Karina$Normalized.d12C.d13C/1000))+1) table2.sample.Karina$At.C <- At.d13C return(table2.sample.Karina) }) output$dataSampleKarina <- renderDT({ if(length(input$C.define) > 1 & length(input$N.define) > 1 ) { table2.sample.Karina() } else {} }) output$SaveButton <- renderUI({ actionButton("save", "Save the data") }) output$Save <- renderUI({ if(!is.null(input$save)) { if(input$save > 0){ isolate({ if(length(input$C.define) > 1 & length(input$N.define) > 1 ) { if(input$nameSession == "Name of the session") { toAdd <- "" } else { toAdd <- paste0("_", input$nameSession) } table0 <- matrix("", 20, 2) table0[,1] <- c("Total C and D Isotope Analysis", "", "1. Session settings", "Date", "Samples", "Responsible", "Lab. Temp", "System", "Column", "Temp, Owen", "Carrier gas", "Carrier flow", "Reference gas1", "Reference flow", "Reference gas2", "Reference flow", "Method", "", "", "2. Blank corrected delta values for isotope standards" ) table0[,2] <- c("", "", "", input$dateProcessig, input$SampleName, input$Responsible, input$Temperature, input$system, input$Column, input$temp.Owen, input$carrier.Gas, input$carrier.flow, input$Reference.gas1, input$Reference.flow1, input$Reference.gas2, input$Reference.flow2, input$Method, "", "", "" ) table1_new <- table1() lapply(2:ncol(table1_new), function(x) { table1_new[3:nrow(table1_new),x] <- as.numeric(as.character(table1_new[3:nrow(table1_new), x])) }) table1_new[1:2,1] <- c("Isotope", "Standard") table2.standard_new <- table2.standard() lapply(5:ncol(table2.standard_new), function(x) { table2.standard_new[1:nrow(table2.standard_new), x] <- as.numeric(as.character(table2.standard_new[1:nrow(table2.standard_new), x])) }) table2.sample.Karina_new <- table2.sample.Karina() lapply(5:ncol(table2.sample.Karina_new), function(x) { table2.sample.Karina_new[1:nrow(table2.sample.Karina_new), x] <- as.numeric(as.character(table2.sample.Karina_new[1:nrow(table2.sample.Karina_new), x])) }) table.Interm1 <- matrix("3. Blank correction of delta value in standards", ncol = 1, nrow = 1) table.Interm2 <- matrix("4. Results from samples", ncol = 1, nrow = 1) normStyle <- createStyle(valign = "center", halign = "center", numFmt = "0.00") GeneraltitleStyle <- createStyle(valign = "center", halign = "center", fontSize = 14, textDecoration = "bold") titleStyle <- createStyle(valign = "center", halign = "left", fontSize = 14, textDecoration = "bold") tableStyle <- createStyle(borderStyle = "thin", border = "TopBottomLeftRight") colorBlue <- createStyle(fgFill = "#99ccff") colorGreen <- createStyle(fgFill = "#00ff00") wb <- createWorkbook("Example.xlsx") addWorksheet(wb, "CNEA_data") writeData(wb, sheet = 1, CNEA(), colNames = T) addWorksheet(wb, "isotope_data") writeData(wb, sheet = 2, table0, colNames = FALSE) writeData(wb, sheet = 2, table1_new, startRow = nrow(table0) + 1, colNames = F) writeData(wb, sheet = 2, table.Interm1, startRow = nrow(table0) + nrow(table1_new) + 3, colNames = F) writeData(wb, sheet = 2, table2.standard_new, startRow = nrow(table0) + nrow(table1_new) + 4, colNames = T) writeData(wb, sheet = 2, table.Interm2, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, colNames = F) writeData(wb, sheet = 2, table2.sample.Karina_new, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8, colNames = T) nbRow_FinalTable <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + nrow(table2.sample.Karina_new) + 8 lapply(1:17, function(x) { addStyle(wb, sheet = 2, normStyle, cols = x, rows = 1:nbRow_FinalTable) }) addStyle(wb, sheet = 2, GeneraltitleStyle, rows = 1, cols = 1, stack = T) addStyle(wb, sheet = 2, titleStyle, rows = 20, cols = 1, stack = T) addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + 3, cols = 1, stack = T) addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, cols = 1, stack = T) table1_end <- nrow(table0) + nrow(table1_new) lapply(1:5, function(x) { addStyle(wb, sheet = 2, tableStyle, cols = x, rows = 21:table1_end, stack = T) }) table2_stand_begin <- nrow(table0) + nrow(table1_new) + 4 table2_stand_end <- nrow(table0) + nrow(table1_new) + 4 + nrow(table2.standard_new) lapply(1:16, function(x) { addStyle(wb, sheet = 2, tableStyle, rows = table2_stand_begin:table2_stand_end, cols = x, stack = T) }) addStyle(wb, sheet = 2, colorBlue, cols = 8, rows = table2_stand_begin:table2_stand_end, stack = T) addStyle(wb, sheet = 2, colorBlue, cols = 15, rows = table2_stand_begin:table2_stand_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 9, rows = table2_stand_begin:table2_stand_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 16, rows = table2_stand_begin:table2_stand_end, stack = T) table2_sample_begin <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8 table2_sample_end <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8 + nrow(table2.sample.Karina_new) lapply(1:17, function(x) { addStyle(wb, sheet = 2, tableStyle, rows = table2_sample_begin:table2_sample_end, cols = x, stack = T) }) addStyle(wb, sheet = 2, colorBlue, cols = 9, rows = table2_sample_begin:table2_sample_end, stack = T) addStyle(wb, sheet = 2, colorBlue, cols = 16, rows = table2_sample_begin:table2_sample_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 10, rows = table2_sample_begin:table2_sample_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 17, rows = table2_sample_begin:table2_sample_end, stack = T) mergeCells(wb, sheet = 2, cols = 1:18, rows = 1) mergeCells(wb, sheet = 2, cols = 1:8, rows = 20) mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + 3) mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7) mergeCells(wb, sheet = 2, cols = 2:3, rows = 21) mergeCells(wb, sheet = 2, cols = 4:5, rows = 21) if(Sys.info()[1] == "Windows"){ path <- choose.dir() } else { path <- jchoose.dir() } pathExport <- paste0(path, "/finalTable.Sample.Karina",toAdd, ".xlsx") saveWorkbook(wb, file = pathExport, overwrite = TRUE) } }) return("Karina's results have been saved :)") } } })
Final Table
r DTOutput("dataSampleKarina")
r uiOutput("SaveButton")
r uiOutput("Save")
Peter's procedure of Normalization
Here, the user has to select the relevant dilution to keep in the linear regression
r tableOutput('dilutionTable')
Define the dilution factor to consider for the normalization:
r uiOutput('choiceDilution')
output$choiceDilution <- renderUI({ if(!is.null(resultMatrix())) { dilution.suggested <- levels(as.factor(gelA.table()$equipement.dilution)) toPick.dilution <- dilution.suggested[which(dilution.suggested != "0" & dilution.suggested != " " & dilution.suggested != "" & !is.na(dilution.suggested))] checkboxGroupInput("dilutionPicked", label = "", choices = toPick.dilution, selected = toPick.dilution[1], inline = TRUE) } }) gelA.table.dilution <- reactive({ if(!is.null(resultMatrix())) { toConsider <-lapply(1:length(input$dilutionPicked), function(x) { which(gelA.table()$equipement.dilution == input$dilutionPicked[x]) }) toConsider <- unlist(toConsider) gelA.table.dilution <- gelA.table()[toConsider, ] gelA.table.dilution <- gelA.table.dilution[order(gelA.table.dilution$Rank.Analysis),] return(gelA.table.dilution) } }) output$GelA.tokeep.N <- renderUI({ if(!is.null(gelA.table.dilution())) { checkboxGroupInput("GelA.tokeep.N", label = p("Select the gelA to keep for the linear regression"), choices = gelA.table.dilution()$Box.position, selected = gelA.table.dilution()$Box.position, inline = T ) } else {} }) gelA.dilution_toKeep.N <- reactive({ if(!is.null(resultMatrix()) & !is.null(input$GelA.tokeep.N)) { toConsider <-lapply(1:length(input$GelA.tokeep.N), function(x) { which(gelA.table.dilution()$Box.position == input$GelA.tokeep.N[x]) }) toConsider <- unlist(toConsider) gelA.dilution_toKeep <- gelA.table.dilution()[toConsider, ] gelA.dilution_toKeep <- gelA.dilution_toKeep[order(gelA.dilution_toKeep$Rank.Analysis),] return(gelA.dilution_toKeep) } }) gelA.dilution_toKeep.C <- reactive({ if(!is.null(resultMatrix()) & !is.null(input$GelA.tokeep.C)) { toConsider <-lapply(1:length(input$GelA.tokeep.C), function(x) { which(gelA.table.dilution()$Box.position == input$GelA.tokeep.C[x]) }) toConsider <- unlist(toConsider) gelA.dilution_toKeep <- gelA.table.dilution()[toConsider, ] gelA.dilution_toKeep <- gelA.dilution_toKeep[order(gelA.dilution_toKeep$Rank.Analysis),] return(gelA.dilution_toKeep) } }) output$GelA.tokeep.C <- renderUI({ if(!is.null(gelA.table.dilution())) { checkboxGroupInput("GelA.tokeep.C", label = p("Select the gelA to keep for the linear regression"), choices = gelA.table.dilution()$Box.position, selected = gelA.table.dilution()$Box.position, inline = T ) } else {} }) model.15N <- reactive({ if(!is.null(gelA.dilution_toKeep.N())) { model.d15N <- lm(gelA.dilution_toKeep.N()$d14N.d15N.BlankCorrected ~ gelA.dilution_toKeep.N()$Rank.Analysis) Intercept.N <- summary(model.d15N)$coefficients[1] Slope.N <- summary(model.d15N)$coefficients[2] return(c(Intercept.N, Slope.N)) } }) model.13C <- reactive({ if(!is.null(gelA.dilution_toKeep.C())) { model.d13C <- lm(gelA.dilution_toKeep.C()$d12C.d13C.BlankCorrected ~ gelA.dilution_toKeep.C()$Rank.Analysis) Intercept.C <- summary(model.d13C)$coefficients[1] Slope.C <- summary(model.d13C)$coefficients[2] return(c(Intercept.C, Slope.C)) } }) output$linearRegression.N <- renderPlot({ if(!is.null(gelA.dilution_toKeep.N())) { plot(gelA.dilution_toKeep.N()$d14N.d15N.BlankCorrected ~ gelA.dilution_toKeep.N()$Rank.Analysis, ylab = "d14N.d15N.BlankCorrected", xlab = "Rank.Analysis") text(gelA.dilution_toKeep.N()$Rank.Analysis, gelA.dilution_toKeep.N()$d14N.d15N.BlankCorrected, labels=gelA.dilution_toKeep.N()$Box.position, cex= 0.7, pos=4) abline(model.15N()[1], model.15N()[2], col = 'red') } }) output$linearRegression.C <- renderPlot({ if(!is.null(gelA.dilution_toKeep.C())) { plot(gelA.dilution_toKeep.C()$d12C.d13C.BlankCorrected ~ gelA.dilution_toKeep.C()$Rank.Analysis, ylab = "d12C.d13C.BlankCorrected", xlab = "Rank.Analysis") text(gelA.dilution_toKeep.C()$Rank.Analysis, gelA.dilution_toKeep.C()$d12C.d13C.BlankCorrected, labels=gelA.dilution_toKeep.C()$Box.position, cex= 0.7, pos=4) abline(model.13C()[1], model.13C()[2], col = 'red') } }) table2.sample.Peter <- reactive({ if(!is.null(model.15N()) & !is.null(model.13C())) { table2.sample.Peter <- table2.sample() Norm.d15N <- Peter.Correction.d15N(table2.sample.Peter$d14N.d15N.BlankCorrected, table2.sample.Peter$Rank.Analysis, model.15N()[2], model.15N()[1]) table2.sample.Peter$Normalized.d14N.d15N <- Norm.d15N Norm.d13C <- Peter.Correction.d13C(table2.sample.Peter$d12C.d13C.BlankCorrected, table2.sample.Peter$Rank.Analysis, model.13C()[2], model.13C()[1]) table2.sample.Peter$Normalized.d12C.d13C <- Norm.d13C return(table2.sample.Peter) } }) output$modelN <- renderText({ if(!is.null(model.15N()) & !is.null(model.13C())) { paste("For N, the parameters of the model: intercept = ", round(model.15N()[1],10), " and slope = ", round(model.15N()[2], 10)) } }) output$modelC <- renderText({ if(!is.null(model.15N()) & !is.null(model.13C())) { paste("For C, the parameters of the model: intercept = ", round(model.13C()[1],10), " and slope = ", round(model.13C()[2], 10)) } }) output$FinalTable <- renderDT({ table2.sample.Peter() }) output$SaveButton2 <- renderUI({ actionButton("save2", "Save the data") }) output$Save2 <- renderUI({ if(!is.null(input$save2)) { if(input$save2 > 0){ isolate({ if(!is.null(table2.sample.Peter())) { if(input$nameSession == "Name of the session") { toAdd <- "" } else { toAdd <- paste0("_", input$nameSession) } table0 <- matrix("", 20, 2) table0[,1] <- c("Total C and D Isotope Analysis", "", "1. Session settings", "Date", "Samples", "Responsible", "Lab. Temp", "System", "Column", "Temp, Owen", "Carrier gas", "Carrier flow", "Reference gas1", "Reference flow", "Reference gas2", "Reference flow", "Method", "", "", "2. Blank corrected delta values for isotope standards" ) table0[,2] <- c("", "", "", input$dateProcessig, input$SampleName, input$Responsible, input$Temperature, input$system, input$Column, input$temp.Owen, input$carrier.Gas, input$carrier.flow, input$Reference.gas1, input$Reference.flow1, input$Reference.gas2, input$Reference.flow2, input$Method, "", "", "" ) table1_new <- table1() lapply(2:ncol(table1_new), function(x) { table1_new[3:nrow(table1_new),x] <- as.numeric(as.character(table1_new[3:nrow(table1_new), x])) }) table1_new[1:2,1] <- c("Isotope", "Standard") table2.standard_new <- table2.standard() lapply(5:ncol(table2.standard_new), function(x) { table2.standard_new[1:nrow(table2.standard_new), x] <- as.numeric(as.character(table2.standard_new[1:nrow(table2.standard_new), x])) }) table2.sample.Peter_new <- table2.sample.Peter() lapply(5:ncol(table2.sample.Peter_new), function(x) { table2.sample.Peter_new[1:nrow(table2.sample.Peter_new), x] <- as.numeric(as.character(table2.sample.Peter_new[1:nrow(table2.sample.Peter_new), x])) }) table.Interm1 <- matrix("3. Blank correction of delta value in standards", ncol = 1, nrow = 1) table.Interm2 <- matrix("4. Results from samples", ncol = 1, nrow = 1) normStyle <- createStyle(valign = "center", halign = "center", numFmt = "0.00") GeneraltitleStyle <- createStyle(valign = "center", halign = "center", fontSize = 14, textDecoration = "bold") titleStyle <- createStyle(valign = "center", halign = "left", fontSize = 14, textDecoration = "bold") tableStyle <- createStyle(borderStyle = "thin", border = "TopBottomLeftRight") colorBlue <- createStyle(fgFill = "#99ccff") colorGreen <- createStyle(fgFill = "#00ff00") wb <- createWorkbook("Example.xlsx") addWorksheet(wb, "CNEA_data") writeData(wb, sheet = 1, CNEA(), colNames = T) addWorksheet(wb, "isotope_data") writeData(wb, sheet = 2, table0, colNames = FALSE) writeData(wb, sheet = 2, table1_new, startRow = nrow(table0) + 1, colNames = F) writeData(wb, sheet = 2, table.Interm1, startRow = nrow(table0) + nrow(table1_new) + 3, colNames = F) writeData(wb, sheet = 2, table2.standard_new, startRow = nrow(table0) + nrow(table1_new) + 4, colNames = T) writeData(wb, sheet = 2, table.Interm2, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, colNames = F) writeData(wb, sheet = 2, table2.sample.Peter_new, startRow = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8, colNames = T) nbRow_FinalTable <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + nrow(table2.sample.Peter_new) + 8 lapply(1:17, function(x) { addStyle(wb, sheet = 2, normStyle, cols = x, rows = 1:nbRow_FinalTable) }) addStyle(wb, sheet = 2, GeneraltitleStyle, rows = 1, cols = 1, stack = T) addStyle(wb, sheet = 2, titleStyle, rows = 20, cols = 1, stack = T) addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + 3, cols = 1, stack = T) addStyle(wb, sheet = 2, titleStyle, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7, cols = 1, stack = T) table1_end <- nrow(table0) + nrow(table1_new) lapply(1:5, function(x) { addStyle(wb, sheet = 2, tableStyle, cols = x, rows = 21:table1_end, stack = T) }) table2_stand_begin <- nrow(table0) + nrow(table1_new) + 4 table2_stand_end <- nrow(table0) + nrow(table1_new) + 4 + nrow(table2.standard_new) lapply(1:16, function(x) { addStyle(wb, sheet = 2, tableStyle, rows = table2_stand_begin:table2_stand_end, cols = x, stack = T) }) addStyle(wb, sheet = 2, colorBlue, cols = 8, rows = table2_stand_begin:table2_stand_end, stack = T) addStyle(wb, sheet = 2, colorBlue, cols = 15, rows = table2_stand_begin:table2_stand_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 9, rows = table2_stand_begin:table2_stand_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 16, rows = table2_stand_begin:table2_stand_end, stack = T) table2_sample_begin <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8 table2_sample_end <- nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 8 + nrow(table2.sample.Peter_new) lapply(1:17, function(x) { addStyle(wb, sheet = 2, tableStyle, rows = table2_sample_begin:table2_sample_end, cols = x, stack = T) }) addStyle(wb, sheet = 2, colorBlue, cols = 9, rows = table2_sample_begin:table2_sample_end, stack = T) addStyle(wb, sheet = 2, colorBlue, cols = 16, rows = table2_sample_begin:table2_sample_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 10, rows = table2_sample_begin:table2_sample_end, stack = T) addStyle(wb, sheet = 2, colorGreen, cols = 17, rows = table2_sample_begin:table2_sample_end, stack = T) mergeCells(wb, sheet = 2, cols = 1:18, rows = 1) mergeCells(wb, sheet = 2, cols = 1:8, rows = 20) mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + 3) mergeCells(wb, sheet = 2, cols = 1:8, rows = nrow(table0) + nrow(table1_new) + nrow(table2.standard_new) + 7) mergeCells(wb, sheet = 2, cols = 2:3, rows = 21) mergeCells(wb, sheet = 2, cols = 4:5, rows = 21) if(Sys.info()[1] == "Windows"){ path <- choose.dir() } else { path <- jchoose.dir() } pathExport <- paste0(path, "/finalTable.Sample.Peter",toAdd, ".xlsx") saveWorkbook(wb, file = pathExport, overwrite = TRUE) } }) return("Peter's results have been saved :)") } } })
1. Linear regression d15N
r uiOutput('GelA.tokeep.N')
r textOutput('modelN')
r plotOutput('linearRegression.N')
2. Linear regression d13C
r uiOutput('GelA.tokeep.C')
r textOutput('modelC')
r plotOutput('linearRegression.C')
3. Final Table
r DTOutput("FinalTable")
r uiOutput("SaveButton2")
r uiOutput("Save2")
Data exploration
radioButtons("tableChosen", label = "Choose the table that you want to explore", choices = c("Karina's procedure Table", "Peter's procedure Table"), selected = "Peter's procedure Table", inline = T ) dataToExplore <- reactive({ if(input$tableChosen == "Karina's procedure Table") { if(!is.null(table2.sample.Karina())) { output <- table2.sample.Karina() } else {NULL} } else { if(!is.null(table2.sample.Peter())) { output <- table2.sample.Peter() } else {} } }) output$pivot <- renderRpivotTable({ if(!is.null(dataToExplore())) { rpivotTable(dataToExplore(),width="100%", height="400px") } else {} })
r rpivotTableOutput('pivot')
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.