library(shiny, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(shinyWidgets, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(shinydashboard, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(MtreeRing, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(testthat, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(magrittr, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(png, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(jpeg, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(tiff, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(bmp, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(magick, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(imager, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(dplR, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(spatstat, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(measuRing, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
library(dplyr, lib.loc = "/home/ubuntu/R/x86_64-pc-linux-gnu-library/3.5")
# Run the application
createUI <- function()
{
shiny.title <- dashboardHeader(title = 'MtreeRing')
shiny.sider <- dashboardSidebar(
sidebarMenu(
menuItem('Image Loading',tabName = 'input_pre',
icon = icon('folder-open', lib = 'font-awesome')),
menuItem('Measurement',tabName = 'mea_arg',
icon = icon('gear', lib = 'font-awesome'), selected = TRUE)
)
)
page1 <- fluidRow(
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Image Preview'),
width = 12, status = 'primary', solidHeader = T, collapsible = T,
plotOutput('pre.img',
brush = brushOpts(
id = "plot1_brush",
opacity = 0.25,
resetOnNew = TRUE)
)
),
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Image Upload'),
width = 4, status = 'primary', solidHeader = T, collapsible = T,
conditionalPanel(
condition = '!input.inmethod',
fileInput('selectfile', 'Choose an image file',
buttonLabel = 'Browse...', width = '80%')
),
prettySwitch(inputId = "magick.switch", label = "Magick ON",
value = TRUE, fill = TRUE, status = "success"),
helpText('Image upload is limited to 150 MB per file. Supported',
' formats include png, jpg, tif and bmp.',
style = 'color:#000000;font-size:90%'),
prettyCheckbox(
inputId = "inmethod",
label = div(style = 'color:#000000;font-weight: bolder;','Image Path'),
shape = "curve", value = F, status = "success"),
conditionalPanel(
condition = 'input.inmethod',
textInput('enter.path', 'Enter file path', ''),
helpText('For example: C:/Users/shiny/img01.png',
style = 'color:#000000;font-size:90%'),
hr()
),
actionButton(
'buttoninputimage', 'Load ',
class = "btn btn-primary btn-md",
icon = icon('upload', "fa-1x"),
style = 'color:#FFFFFF;text-align:center;
font-weight: bolder;font-size:110%;'),
useSweetAlert()
),
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Image Rotation'),
width = 3, status = 'primary', solidHeader = T, collapsible = T,
prettyRadioButtons(inputId = "rotatede", label = "",
choices = c("0 degrees" = "rotate0",
"90 degrees" = "rotate90",
"180 degrees" = "rotate180",
"270 degrees" = "rotate270"),
shape = "curve", status = "success",
fill = TRUE, inline = TRUE),
helpText("Rotation angle in degrees. Note that the bark ",
"side should be placed at the left side of the ",
"graphical window and the pith side at the right.",
style = 'color:#000000;font-size:90%;text-align:justify;'),
actionButton(
'buttonrotate', 'Rotate',
class = "btn btn-primary btn-md",
icon = icon('repeat',"fa-1x"),
style = 'color:#FFFFFF;text-align:center;
font-weight: bolder;font-size:110%;')
),
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Image Cropping'),
width = 3, status = 'primary', solidHeader = T, collapsible = T,
helpText("To remove unwanted cores and irrelevant objects, ",
"move the mouse to the core you wish to measure and",
"create a rectangle by brushing, see details below.",
style = 'color:#000000;font-size:90%;text-align:justify;'),
prettyRadioButtons(inputId = "cropcondition", label = "",
choiceNames = 'UNCROPPED', choiceValues = list('a'),
status = "danger", shape = "square",
fill = FALSE, inline = FALSE),
prettyCheckbox(
inputId = "showcropp",
label = div(style = 'color:#000000;font-weight: bolder;', 'Show Help'),
shape = "curve", value = F, status = "success"
),
conditionalPanel(
condition = 'input.showcropp',
helpText(
"The operation \"brush\" allows users to create a transparent ",
"rectangle on the image and drag it around. For cores scanned ",
"side by side, the user can choose a core of interest by brushing.",
style = 'color:#000000;text-align:justify;'),
helpText(
"After brushing, click on the button \"Crop\" to create a",
" cropped area. The measurement will be performed within",
" this area, rather than the whole (uncropped) image.",
style = 'color:#000000;text-align:justify;'),
helpText(
"To cancel this operation, click on the button \"Cancel\".",
" If the transparent rectangle exists, the user should first ",
"click on the outer region of the rectangle (this will make the",
" rectangle disappear) and then click on the button \"Cancel\".",
style = 'color:#FF0000;text-align:justify;')
),
hr(),
actionButton(
'buttoncrop', 'Crop',
class = "btn btn-primary btn-md",
icon = icon('crop',"fa-1x"),
style = 'color:#FFFFFF;text-align:center;
font-weight: bolder;font-size:110%;')
)
)
page2.1 <- fluidRow(
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Options'),
width = 4, status = 'primary', solidHeader = T, collapsible = T,
textInput('tuid', 'Series ID', '', width = '75%'),
textInput('dpi', 'DPI', '', '75%'),
textInput('sample_yr', 'Sampling year', '', '75%'),
textInput('m_line', 'Y-coordinate of path', '', '75%'),
prettyCheckbox(
inputId = "incline",
label = div(
style = 'color:#000000;font-weight: bolder;', 'Inclined tree rings'),
shape = "curve", value = F, status = "success"
),
conditionalPanel(
condition = 'input.incline',
numericInput('h.dis', 'Distance between paths (mm)',
1, 0.1, 30, 0.1, width = '75%')
),
br(),
radioGroupButtons(
inputId = "measuremethod",
label = 'Measurement mode',
status = "btn btn-primary btn-md",
#individual = T,
size = 'normal',
selected = 'auto',
choiceNames = list(
div(style = 'color:#FFFFFF;font-weight: bolder;', 'Manual'),
div(style = 'color:#FFFFFF;font-weight: bolder;', 'Automation')),
choiceValues = list('manual', 'auto'),
width = '100%')
),
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Options'),
width = 4, status = 'primary', solidHeader = T, collapsible = T,
sliderInput('linelwd', 'Path width',
0.2, 3, 1, 0.1, width = '80%'),
sliderInput('label.cex', 'Magnification for labels',
0.2, 3, 1, 0.1, width = '80%'),
radioGroupButtons(
inputId = "pch",
label = 'Symbol for borders', status = "btn btn-primary btn-md",
size = 'sm',
choiceNames = list(
div(style = 'color:#FFFFFF;font-weight: bolder;',
icon('circle', 'fa-lg')),
div(style = 'color:#FFFFFF;font-weight: bolder;',
icon('circle', 'fa-1x')),
div(style = 'color:#FFFFFF;font-weight: bolder;',
icon('circle-o', 'fa-1x')),
div(style = 'color:#FFFFFF;font-weight: bolder;',
icon('times', 'fa-1x')),
div(style = 'color:#FFFFFF;font-weight: bolder;',
icon('plus', 'fa-1x'))
),
selected = '20',
choiceValues = list('19', '20', '1', '4', '3'),
width = '100%'
),
colorSelectorInput(
inputId = "border.color", label = "Color for borders",
choices = c("black", "gray", "white", "red", "#FF6000",
"#FFBF00", "#DFFF00", "#80FF00", "#20FF00",
"#00FF40", "#00FF9F", "cyan", "#009FFF", "#0040FF",
"#2000FF", "#8000FF", "#DF00FF", "#FF00BF"),
selected = '#20FF00', mode = "radio", display_label = FALSE, ncol = 9
),
colorSelectorInput(
inputId = "label.color", label = "Color for labels",
choices = c("black", "gray", "white", "red", "#FF6000",
"#FFBF00", "#DFFF00", "#80FF00", "#20FF00",
"#00FF40", "#00FF9F", "cyan", "#009FFF", "#0040FF",
"#2000FF", "#8000FF", "#DF00FF", "#FF00BF"),
selected = 'black', mode = "radio", display_label = FALSE, ncol = 9
)
),
conditionalPanel(
condition = 'input.measuremethod=="auto"',
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Options'),
width = 4, status = 'primary', solidHeader = T, collapsible = T,
prettyCheckbox(
inputId = "isrgb",
label = div(
style = 'color:#000000;font-weight:bolder;', "Default RGB"),
shape = "curve", value = T, status = "success"
),
conditionalPanel(
condition = '!input.isrgb',
textInput('customRGB', 'Custom RGB', '0.299,0.587,0.114'),
helpText('Note:The three numbers correspond to',
'R, G and B components,respectively.',
style = 'color:#000000;font-weight: bolder'),
hr()
),
radioGroupButtons(
inputId = "method",
label = 'Ring detection method',
status = "btn btn-primary btn-md",
#individual = T,
selected = 'canny',
size = 'normal',
choiceNames = list(
div(style = 'color:#FFFFFF;font-weight: bolder;font-size:80%',
'Watershed'),
div(style = 'color:#FFFFFF;font-weight: bolder;font-size:80%',
'Canny'),
div(style = 'color:#FFFFFF;font-weight: bolder;font-size:80%',
'measuRing')
),
choiceValues = list('watershed', 'canny', 'lineardetect'),
width = '100%'
),
conditionalPanel(
condition = 'input.method=="watershed"',
selectInput('watershed.threshold',
'Otsu threshold',
c('Auto (Recommended)' = 'auto',
'Custom' = 'custom.waterthr'),
width = '75%'
),
conditionalPanel(
condition = 'input["watershed.threshold"]=="auto"',
sliderInput('watershed.adjust',
'Threshold adjusment factor',
0.5, 1.5, 0.8, 0.05, width = '85%')
),
conditionalPanel(
condition = 'input["watershed.threshold"]=="custom.waterthr"',
textInput('watershed.threshold2', 'Threshold value', ''),
'A value of the form XX% (e.g. 98%)'
)
),
conditionalPanel(
condition = 'input.method=="canny"',
prettyCheckbox(
inputId = "defaultcanny",
label = div(
style = 'color:#000000;font-weight: bolder;',
"Auto threshold (Recommanded)"),
shape = "curve", value = T, status = "success"),
conditionalPanel(
condition = 'input.defaultcanny',
sliderInput('canny.adjust',
'Threshold adjusment factor',
0.8, 1.8, 1.4, 0.05, width = '75%')
),
conditionalPanel(
condition = '!input.defaultcanny',
textInput('canny.t2', 'Threshold for strong edges', '', '75%'),
textInput('canny.t1', 'Threshold for weak edges', '', '75%')
),
numericInput('canny.smoothing',
'Degree of smoothing',
1, 0, 4, 1, width = '75%')
),
conditionalPanel(
condition = 'input.method!="lineardetect"',
prettyCheckbox(inputId = "defaultse",
label = div(
style = 'color:#000000;font-weight: bolder;',
"Default structuring elements"),
shape = "curve", value = T, status = "success"),
conditionalPanel(
condition = '!input.defaultse',
textInput('struc.ele1', 'First structuring element', '', '75%'),
textInput('struc.ele2', 'Second structuring element', '', '75%')
),
hr()
),
conditionalPanel(
condition = 'input.method=="lineardetect"',
textInput('origin', ' Origin in smoothed gray', '0', '75%'),
'If you use the linear detection, don\'t ',
'tick the checkbox "Inclined tree rings".',
hr()
),
helpText('Automatic detection may take a few seconds (depending',
' on the image size and complexity of the sample).',
#style = 'color:#000000;font-size:95%;text-align:justify;')
style = 'color:#000000;font-size:90%;')
)
),
box(
title = div(style = 'color:#FFFFFF;font-size:100%;
font-weight: bolder', 'Tree Ring Detection'),
width = 12, status = 'primary', solidHeader = T, collapsible = T,
conditionalPanel(
condition = 'input.measuremethod!="auto"',
actionButton(
'buttoncreatpath', 'Create Path',
class = "btn btn-primary btn-md", icon = icon('plus'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
),
useSweetAlert(),
actionButton(
'buttonrcm', 'Remove All',
class = "btn btn-danger btn-md", icon = icon('trash'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
),
useSweetAlert()
),
conditionalPanel(
condition = 'input.measuremethod=="auto"',
actionButton(
'buttoncreatpath2', 'Create Path',
class = "btn btn-primary btn-md", icon = icon('plus'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
),
useSweetAlert(),
actionButton(
'buttonrcm2', 'Remove All',
class = "btn btn-danger btn-md", icon = icon('trash'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
),
useSweetAlert(),
actionButton(
'button_run_auto', 'Run Detection',
class = "btn btn-success btn-md", icon = icon('play'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
),
useSweetAlert()
),
hr(),
plotOutput('pre.img2',
dblclick = "plot2_dblclick",
brush = brushOpts(
id = "plot2_brush",
resetOnNew = TRUE
)
),
hr(),
actionButton(
'buttonsubimg', 'Create Sub-image',
class = "btn btn-primary btn-md", icon = icon('search-plus'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
)
),
box(
title = div(style = 'color:#FFFFFF;font-size:100%;
font-weight: bolder', 'Tree Ring Editing'),
width = 12, status = 'primary', solidHeader = T, collapsible = T,
actionButton(
'buttonzoomdel', 'Delete Border',
class = "btn btn-danger btn-md",
icon = icon('eraser'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
),
useSweetAlert(),
hr(),
plotOutput('zoom.img',
dblclick = dblclickOpts(id = "zoom_dblclick"),
brush = brushOpts(
id = "zoom_brush",
resetOnNew = TRUE
)
)
)
)
page2.2 <- fluidRow(
column(width = 12,
conditionalPanel(
condition = '!input.tuheader',
box(
title = div(style = 'color:#FFFFFF;font-size:80%;
font-weight: bolder', 'Delete Borders'),
width = 3, status = 'primary', solidHeader = T, collapsible = T,
conditionalPanel(
condition = 'input.incline',
textInput('del.u', 'Border number in the upper portion', '', '75%'),
textInput('del.l', 'Border number in the lower portion', '', '75%')
),
conditionalPanel(
condition = '!input.incline',
textInput('del', 'Border number', '', '75%')
),
helpText(
"To perform a mass deletion of ring borders, use commas ",
"to separate border numbers, e.g. 1, 2, 3, 4",
style = 'color:#000000;text-align:justify;'
),
br(),
br(),
actionButton(
'button_del', 'Delete Border',
class = "btn btn-danger btn-md", icon = icon('eraser'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
)
)
),
tabBox(
#title = tagList(shiny::icon("gear"), 'Output'),
title = div(
style = 'color:#000000;font-weight: bolder;',
icon('cog', class = 'fa-spin', lib = 'font-awesome'), 'Output'),
width = 6,
tabPanel(
div(style = 'color:#000000;font-weight: bolder;',
icon('list-ol', 'fa-1x'), ' Results'),
#HTML("<p style = 'color:#000000;'><b>Results</b></p>"),
actionButton(
'button_results', 'Generate Series',
class = "btn btn-primary btn-md",
style = 'color:#FFFFFF;text-align:center;font-weight:bolder;'
),
useSweetAlert(),
actionButton(
'button_hide', 'Hide Series',
class = "btn btn-primary btn-md",
style = 'color:#FFFFFF;text-align:center;font-weight:bolder;'
),
useSweetAlert(),
br(),
tableOutput('results')
),
tabPanel(
div(style = 'color:#000000;font-weight: bolder;',
icon('arrow-down', 'fa-1x'), ' CSV'
),
textInput('csv.name', 'Name of the csv file', '', width = '50%'),
helpText(
style = 'color:#000000;font-weight: normal;',
'The filename extension is not required. ',
'Leave blank to use the current series ID.'
),
helpText(
style = 'color:#FF0000;font-weight: normal;',
'Attention: if running the app within an RStudio window',
', the rename operation doesn\'t work. Please run the app',
' within a browser.'
),
hr(),
#HTML("<p style = 'color:#000000;'><b>CSV</b></p>"),
downloadButton(
'RingWidth.csv', 'Download CSV',
class = "btn btn-primary btn-md",
style = 'color:#FFFFFF;text-align:center;font-weight:bolder;'
)
),
tabPanel(
div(style = 'color:#000000;font-weight: bolder;',
icon('arrow-down', 'fa-1x'), ' RWL'),
textInput('rwl.name', 'Name of the rwl file', '', width = '50%'),
helpText(style = 'color:#000000;font-weight: normal;',
'The filename extension is not required. ',
' Leave blank to use the current series ID.'),
helpText(style = 'color:#FF0000;font-weight: normal;',
'Attention: if running the app within an RStudio window',
', the rename operation doesn\'t work. Please run the app',
' within a browser.'),
hr(),
selectInput('tuprec', 'Precision of the rwl file',
c('0.01' = '0.01', '0.001' = '0.001'),
selected = '0.01', width = '50%'),
helpText(style = 'color:#000000;font-weight: normal;',
'Units are in mm.'),
hr(),
checkboxInput('tuheader', 'Header of the File', F),
conditionalPanel(
condition = 'input.tuheader',
actionButton(
'reset.hdr', 'Reset Header',
class = "btn btn-danger btn-md",
icon = icon('trash'),
style = 'color:#FFFFFF;text-align:center;font-weight: bolder'
)
),
helpText(style = 'color:#000000;font-weight: normal;',
'For more details about the header, please',
'read reference manual of the R package dplR.',
'The output file is Tucson format.'),
hr(),
#HTML("<p style = 'color:#000000;'><b>RWL</b></p>"),
downloadButton(
'RingWidth.rwl', 'Download RWL',
class = "btn btn-primary btn-md",
style = 'color:#FFFFFF;text-align:center;font-weight:bolder;'
)
)
),
conditionalPanel(
condition = 'input.tuheader',
box(
title = 'Header',width = 3,
status = 'primary', solidHeader = T, collapsible = T,
textInput('tuhdr1', 'Site ID', ''),
textInput('tuhdr2', 'Site Name', ''),
textInput('tuhdr3', 'Species Code', ''),
textInput('tuhdr4', 'State or Country', ''),
textInput('tuhdr5', 'Species', ''),
textInput('tuhdr6', 'Elevation', '')
)
),
conditionalPanel(
condition = 'input.tuheader',
box(
title = 'Header',width = 3,
status = 'primary', solidHeader = T, collapsible = T,
textInput('tuhdr7', 'Latitude', ''),
textInput('tuhdr8', 'Longitude', ''),
textInput('tuhdr9', 'First Year', ''),
textInput('tuhdr10', 'Last Year', ''),
textInput('tuhdr11', 'Lead Investigator', ''),
textInput('tuhdr12', 'Completion Date', '')
)
)
)
)
shiny.body <- dashboardBody(
tabItems(
tabItem(tabName = 'input_pre', page1),
tabItem(tabName = 'mea_arg', page2.1, page2.2)
)
)
ui <- dashboardPage(
shiny.title,
shiny.sider,
shiny.body
)
return(ui)
}
createServer <- function(input, output, session)
{
f.morphological <- function(seg.data, struc.ele1, struc.ele2, x.dpi) {
if (is.null(struc.ele1)) {
stru.1 <- x.dpi/400
struc.ele1 <- c(stru.1, stru.1) %>% round
}
if (is.null(struc.ele2)) {
stru.2 <- x.dpi/80
struc.ele2 <- c(stru.2, stru.2) %>% round
}
cim <- as.cimg(seg.data)
cim2 <- erode_rect(cim, sx = struc.ele1[1], sy = struc.ele1[2], sz = 1L)
cim2 <- dilate_rect(cim2, sx = struc.ele1[1], sy = struc.ele1[2], sz = 1L)
cim2 <- dilate_rect(cim2, sx = struc.ele1[1], sy = struc.ele1[2], sz = 1L)
cim2 <- erode_rect(cim2, sx = struc.ele1[1], sy = struc.ele1[2], sz = 1L)
cim2 <- erode_rect(cim2, sx = struc.ele2[1], sy = struc.ele2[2], sz = 1L)
cim2 <- dilate_rect(cim2, sx = struc.ele2[1], sy = struc.ele2[2], sz = 1L)
return(cim2)
}
hat <- function(seg.mor, x.dpi, watershed.threshold, watershed.adjust) {
black.hat <- mclosing_square(seg.mor, size = round(x.dpi / 10))
black.hat <- black.hat - seg.mor
black.hat <- threshold(black.hat, thr = watershed.threshold,
approx = FALSE, adjust = watershed.adjust)
black.hat <- 1 - black.hat
black.hat.mat <- black.hat[, , 1, 1]
return(black.hat.mat)
}
normalize <- function(x) {
return((x - min(x))/(max(x) - min(x)))
}
correct.color <- function(water.c2) {
color.adj <- function(i, water.c2, diff.m) {
color.position <- which(water.c2 == i, arr.ind = T)
row.range <- range(color.position[, 1])
row.range <- row.range[1]:row.range[2]
color.adjacent <- integer()
for (j in row.range) {
row.p <- which(color.position[, 1] == j)
min.column <- color.position[row.p, 2] %>% min
color.diff <- which(diff.m[, j] != 0)
color.pre.p <- color.diff[which(color.diff == min.column) - 1] - 1
color.pre <- water.c2[j, color.pre.p]
color.adjacent <- c(color.adjacent, color.pre)
}
max(color.adjacent)
}
water.c3 <- cbind(matrix(-1, nrow(water.c2), 1),
matrix(0, nrow(water.c2), 1),
water.c2)
diff.m <- apply(water.c3, 1, function(x) c(0, diff(x)))
color.max <- max(water.c2)
df.color <- data.frame(color = c(1:color.max),
adj = rep(NA, times = color.max))
for (i in 1:color.max) {
test.c <- color.adj(i, water.c3, diff.m)
df.color[i, 2] <- test.c
}
for (i in -1:color.max) {
adj.c <- which(df.color[, 2] == i)
if (length(adj.c) >= 2) {
max.c <- max(df.color[adj.c, 1])
covered.c <- sort(df.color[adj.c, 1])
covered.c <- covered.c[-length(covered.c)]
for (j in covered.c) {
cl <- which(water.c3 == j, arr.ind = T)
water.c3[cl] <- max.c
df.color[which(df.color == j, arr.ind = T)] <- max.c
}
}
}
return(water.c3[, -c(1, 2)])
}
water.im <- function(black.hat, correct) {
water.c <- connected(im(black.hat), background = 0, method = "C")
water.c2 <- apply(water.c$v, 2, function(x){
x[is.na(x)]<- 0
return(x)
})
if (correct)
water.c2 <- correct.color(water.c2)
return(water.c2)
}
watershed.im <- function(water.seg, seg.data) {
normalize <- function(x) return((x - min(x))/(max(x) - min(x)))
imgra <- imgradient(as.cimg(seg.data), axes = "y", scheme = 2)
watershed.seg <- watershed(as.cimg(water.seg), imgra, fill_lines = T)
watershed.seg <- normalize(watershed.seg[, , 1, 1])
return(watershed.seg)
}
r.det <- function(seg.data, py) {
gray.values <- seg.data[py, ]
diff.gray <- c(0, diff(gray.values, lag = 1))
col.num <- which(diff.gray != 0)
if (length(col.num) == 0)
stop("Ring border was not detected")
return(col.num)
}
f.sort <- function(border.col, dp) {
filter.col <- diff(border.col) >= dp/10
selected.border <- c(border.col[1], border.col[-1][filter.col])
return(selected.border)
}
f.border <- function(seg.data, py, dp) {
border.col <- r.det(seg.data, py)
border.col <- f.sort(border.col, dp)
return(border.col)
}
plot.marker <- function(py, incline, dp, sample_yr, h.dis, l.w,
bor.color, lab.color, pch, label.cex,
df.loc, plot.year, img.name)
{
title(main = img.name)
if (!is.null(py)) {
abline(h = py, lty = 2, lwd = l.w, col = lab.color)
if (incline) {
abline(h = py, lty = 1, lwd = l.w, col = lab.color)
number.of.pixels <- round((h.dis / 2) * dp)
py.upper <- py + number.of.pixels
abline(h = py.upper, lty = 2, lwd = l.w, col = lab.color)
py.lower <- py - number.of.pixels
abline(h = py.lower, lty = 2, lwd = l.w, col = lab.color)
}
} else {
return()
}
if (nrow(df.loc ) >= 3) {
bx <- df.loc$x[-c(1,2)]
where.bx <- df.loc$z[-c(1,2)]
where.bx <- where.bx[order(bx)]
bx <- sort(bx)
if (incline) {
up <- which(where.bx > 0)
lenup <- length(up)
if (lenup >= 1) {
by.up <- rep(py.upper, time = lenup)
points(bx[up], by.up, col = bor.color, type = "p",
pch = pch, cex = label.cex * 0.75)
if (plot.year) {
year.u <- c(sample_yr:(sample_yr - lenup + 1))
text(bx[up], by.up, year.u, adj = c(1.5, 0.5),
srt = 90, col = lab.color, cex = label.cex)
border.num <- 1:lenup
text(bx[up], by.up, border.num, adj = c(0.5, -1.25),
col = lab.color, cex = label.cex)
}
}
lower <- which(where.bx < 0)
lenlo <- length(lower)
if (lenlo >= 1) {
by.lower <- rep(py.lower, time = lenlo)
points(bx[lower], by.lower, col = bor.color, type = "p",
pch = pch, cex = label.cex * 0.75)
if (plot.year) {
year.l <- c(sample_yr:(sample_yr - lenlo + 1))
text(bx[lower], by.lower, year.l, adj = c(1.5, 0.5),
srt = 90, col = lab.color, cex = label.cex)
border.num <- 1:lenlo
text(bx[lower], by.lower, border.num, adj = c(0.5, -1.25),
col = lab.color, cex = label.cex)
}
}
} else {
if (length(bx) >= 1) {
lenbx <- length(bx)
by <- rep(py, time = lenbx)
points(bx, by, col = bor.color, type = "p",
pch = pch, cex = label.cex * 0.75)
if (plot.year) {
year.u <- c(sample_yr:(sample_yr - length(by) + 1))
text(bx, by, year.u, adj = c(1.5, 0.5),
srt = 90, col = lab.color, cex = label.cex)
border.num <- 1:lenbx
text(bx, by, border.num, adj = c(0.5, -1.25),
col = lab.color, cex = label.cex)
}
}
}
}
}
f.rw <- function(outfile, sample_yr, incline, py, dpi, h.dis) {
df.loc <- outfile
bx <- df.loc$x[-c(1:2)]
where.bx <- df.loc$z[-c(1:2)]
where.bx <- where.bx[order(bx)]
bx <- sort(bx)
dp <- dpi/25.4
if (!incline) {
lenbx <- length(bx)
diff.col.num <- c(NA, diff(bx))
rw <- round(diff.col.num/dp, 2)
years <- c(sample_yr:(sample_yr - lenbx + 1))
df.rw <- data.frame(year = years, column.numbers = bx, ring.width = rw)
} else {
up <- which(where.bx > 0)
lenup <- length(up)
if (lenup >= 1) {
bx.up <- bx[up]
diff.col.num.up <- c(NA, diff(bx.up))
rw.up <- round(diff.col.num.up/dp, 2)
}
lower <- which(where.bx < 0)
lenlo <- length(lower)
if (lenlo >= 1) {
bx.lower <- bx[lower]
diff.col.num.lower <- c(NA, diff(bx.lower))
rw.lower <- round(diff.col.num.lower/dp, 2)
}
years <- c(sample_yr:(sample_yr - lenup + 1))
mean.bor <- (diff.col.num.lower[-1] + diff.col.num.up[-1])/2
x.cor <- abs(bx.lower - bx.up)
x.cor <- x.cor[-length(x.cor)]
correct.rw <- mean.bor * cos(atan(x.cor/(dp * h.dis)))
correct.rw <- c(NA, correct.rw)
correct.rw <- round(correct.rw/dp, 2)
df.rw <- data.frame(year = years, upper.cn = bx.up, upper.rw = rw.up,
lower.cn = bx.lower, lower.rw = rw.lower,
ring.width = correct.rw)
}
return(df.rw)
}
automatic.det <- function(img, incline, method, h.dis, dpi, m_line, RGB,
x1, x2, y1, y2, arghed, watershed.threshold,
watershed.adjust, struc.ele1, struc.ele2,
default.canny, canny.t1, canny.t2, canny.adjust,
canny.smoothing, origin)
{
dp <- dpi/25.4
py <- round(m_line)
if (incline) {
number.of.pixels <- round((h.dis/2) * dp)
py.upper <- py + number.of.pixels
py.lower <- py - number.of.pixels
}
dim.img <- image_info(img) %>% '['(1,2:3) %>% as.numeric
dimcol <- dim.img[1]
dimrow <- dim.img[2]
if (x1 <= 0) x1 <- 1
if (y1 <= 0) y1 <- 0
if (x2 >= dimcol) x2 <- dimcol
if (y2 >= dimrow) y2 <- dimrow - 1
img.range <- paste0(as.character(x2 - x1 + 1), 'x',
as.character(y2 - y1 + 1), '+',
as.character(x1 - 1), '+',
as.character(dimrow - y2 - 1))
img.crop <- image_crop(img, img.range)
rd.martix <- img.crop[[1]]
hex2dec <- function(rd.martix) apply(rd.martix, 1, as.numeric)
rd.channel <- dim(rd.martix)[1]
if (rd.channel == 1) {
rd.m.array <- hex2dec(rd.martix[1, , ])
} else {
rd.m.array <- array(0, dim = rev(dim(rd.martix)))
for (i in 1:rd.channel) {
rd.m.array[, , i] <- hex2dec(rd.martix[i, , ])
}
}
rd.m.array <- rd.m.array/255
if (rd.channel == 1)
seg.data <- rd.m.array[, ]
if (rd.channel == 2)
seg.data <- rd.m.array[, , 1]
if (rd.channel >= 3)
seg.data <- apply(rd.m.array[, , 1:3], 1, function(x) x %*% RGB) %>% t
if (method == 'watershed') {
seg.mor <- f.morphological(seg.data, struc.ele1, struc.ele2, dpi)
black.hat <- hat(seg.mor, dpi, watershed.threshold, watershed.adjust)
marker.img <- water.im(black.hat, T)
seg.data <- watershed.im(marker.img, seg.mor)
}
if (method == 'canny') {
seg.mor <- f.morphological(seg.data, struc.ele1, struc.ele2, dpi)
if (default.canny) {
canny.seg <- cannyEdges(as.cimg(seg.mor), alpha = canny.adjust,
sigma = canny.smoothing)
} else {
canny.seg <- cannyEdges(as.cimg(seg.mor), t1=canny.t1, t2=canny.t2,
alpha = canny.adjust, sigma = canny.smoothing)
}
seg.data <- canny.seg[, , 1, 1]
}
if (method == 'lineardetect') {
attributes(seg.data)['image'] <- 'img'
smoothed <- graySmoothed(seg.data, ppi = dpi, rgb = RGB)
borders <- linearDetect(smoothed, origin = origin)
borders <- borders + x1 - 1
py.ld <- round((y1 + y2)/2)
df <- data.frame(x = borders,
y = rep(py.ld, time = length(borders)),
z = rep(0, time = length(borders)))
df.loc <- rbind(arghed, df)
return(df.loc)
}
if (incline) {
bor.u <- f.border(seg.data, y2 - py.upper, dp) + x1 - 1
bor.l <- f.border(seg.data, y2 - py.lower, dp) + x1 - 1
if (method == 'watershed') {
bor.u <- bor.u - 1
bor.l <- bor.l - 1
}
df.u <- data.frame(x = bor.u, y = py.upper, z = 1)
df.l <- data.frame(x = bor.l, y = py.lower, z = -1)
df.loc <- rbind(arghed, df.u, df.l)
} else {
bor.col <- f.border(seg.data, y2 - py, dp) + x1 - 1
if (method == 'watershed')
bor.col <- bor.col - 1
df <- data.frame(x = bor.col, y = py, z = 0)
df.loc <- rbind(arghed, df)
}
return(df.loc)
}
readImg <- function(img, img.name, magick.switch = TRUE) {
img.size <- file.size(img)/1024^2
options(warn = -1)
if(img.size <= 10 | !magick.switch){
if (grepl("\\.tif", img))
tree.data <- readTIFF(img, native = FALSE, info = TRUE)
if (grepl("\\.png", img))
tree.data <- readPNG(img, native = FALSE, info = TRUE)
if (grepl("\\.jpg", img) | grepl("\\.jpeg", img))
tree.data <- readJPEG(img, native = FALSE)
if (grepl("\\.bmp", img)) {
tree.data <- read.bmp(img)
tree.data <- tree.data/255
}
td.dim <- dim(tree.data)
if (!is.matrix(tree.data)) {
if(any(td.dim[3]== c(2,4)))
tree.data <- tree.data[, , -td.dim[3]]
}
if(is.matrix(tree.data)){
tdata <- as.raster(tree.data) %>%
image_read %>%
image_convert(colorspace = 'gray')
} else {
tdata <- image_read(tree.data)
}
rm(tree.data)
gc()
} else {
tdata <- image_read(img)
}
options(warn = 0)
dim.tdata <- image_info(tdata) %>% '['(1, 2:3) %>% as.numeric
attributes(tdata) <- c(attributes(tdata),
list(img.name = img.name, dimt = dim.tdata))
return(tdata)
}
imgInput <- function(tdata, tdata.copy, plot1_rangesx, plot1_rangesy) {
dimt <- attributes(tdata)$dimt
img.name <- attributes(tdata)$img.name
dimcol <- dimt[1]
dimrow <- dimt[2]
xleft <- 0
ybottom <- 0
xright <- dimcol
ytop <- dimrow
par(mar = c(2.5, 2, 2, 0))
plot(x = c(xleft, xright), y = c(ybottom, ytop),
xlim = c(xleft, xright), ylim = c(ybottom, ytop),
main = img.name, xlab = "", ylab = "",
type = "n", axes = F, cex.main = 1.2)
axis(1, col = "grey", cex.axis = 1)
axis(2, col = "grey", cex.axis = 1)
rasterImage(as.raster(tdata.copy), xleft, ybottom,
xright, ytop, interpolate = FALSE)
if (!is.null(plot1_rangesx)) {
xmin <- plot1_rangesx[1]
xmax <- plot1_rangesx[2]
ymin <- plot1_rangesy[1]
ymax <- plot1_rangesy[2]
x <- c(xmin, xmax, xmax, xmin, xmin)
y <- c(ymin, ymin, ymax, ymax, ymin)
points(x, y, type = 'l', lty = 2, lwd = 1.5)
}
}
imgInput_crop <- function(tdata) {
img.name <- attributes(tdata)$img.name
dim.tdata <- dim(tdata)
dimcol <- dim.tdata[2]
dimrow <- dim.tdata[1]
xleft <- 0
ybottom <- 0
xright <- dimcol
ytop <- dimrow
par(mar = c(2.5, 2, 2, 0))
plot(x = c(xleft, xright), y = c(ybottom, ytop),
xlim = c(xleft, xright), ylim = c(ybottom, ytop),
main = img.name, xlab = "", ylab = "",
type = "n", axes = F, cex.main = 1.2)
axis(1, col = "grey", cex.axis = 1)
axis(2, col = "grey", cex.axis = 1)
rasterImage(tdata, xleft, ybottom,
xright, ytop, interpolate = FALSE)
return(tdata)
}
rotateImg <- function(tdata, degree) {
tdata <- image_rotate(tdata, degree)
dim.tdata <- image_info(tdata) %>% '['(1,2:3) %>% as.numeric
attributes(tdata) <- c(attributes(tdata), list(dimt = dim.tdata))
return(tdata)
}
options(shiny.maxRequestSize = 150*(1024^2))
img.file <- reactiveValues(data = NULL)
img.file.crop <- reactiveValues(data = NULL)
img.file.copy <- reactiveValues(data = NULL)
observeEvent(input$inmethod, {
img.file$data <- NULL
img.file.copy$data <- NULL
img.file.crop$data <- NULL
img.file.zoom$data <- NULL
df.loc$data <- NULL
df.loc$ID <- NULL
plot1_ranges$x <- NULL
plot1_ranges$y <- NULL
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
rw.dataframe$data <- NULL
updatePrettyRadioButtons(
session = session, inputId = "cropcondition",
choiceNames = 'UNCROPPED', choiceValues = list('a'),
prettyOptions = list(shape = "curve", status = "danger",
fill = F, inline = F)
)
updateActionButton(session, "buttoncrop", label = "Crop")
updatePrettyRadioButtons(
session = session, inputId = "rotatede",
label = "Clockwise Rotation",
choices = c("0 degrees" = "rotate0",
"90 degrees" = "rotate90",
"180 degrees" = "rotate180",
"270 degrees" = "rotate270"),
prettyOptions = list(shape = "curve", status = "success",
fill = F, inline = F)
)
})
observeEvent(input$buttonrotate, {
if (!input$inmethod)
img <- input$selectfile["datapath"] %>% as.character
if (input$inmethod)
img <- input$enter.path
img.check1 <- ifelse(length(img) >= 1, TRUE, FALSE)
img.check2 <- FALSE
if (img.check1)
img.check2 <- ifelse(nchar(img) > 1, TRUE, FALSE)
if (any(!img.check1, !img.check2, is.null(img.file$data))) {
err.text <- paste('The preview image has not been generated')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
degree <- input$rotatede %>% substring(7) %>% as.numeric
img.file$data <- rotateImg(img.file$data, degree)
img.file.crop$data <- img.file$data
img.file.copy$data <- rotateImg(img.file.copy$data, degree)
img.file.zoom$data <- NULL
new.dimt <- attributes(img.file$data)[["dimt"]]
attributes(img.file.copy$data)[["dimt"]] <- new.dimt
plot1_ranges$x <- NULL
plot1_ranges$y <- NULL
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
df.loc$data <- NULL
df.loc$ID <- NULL
rw.dataframe$data <- NULL
updateTextInput(session, "m_line", value = '',
label = 'Y-coordinate of the path')
updatePrettyRadioButtons(
session = session, inputId = "cropcondition",
choiceNames = 'UNCROPPED', choiceValues = list('a'),
prettyOptions = list(shape = "curve", status = "danger",
fill = F, inline = F)
)
updateActionButton(session, "buttoncrop", label = "Crop")
})
observeEvent(input$magick.switch, {
if(input$magick.switch){
updatePrettySwitch(session, inputId = 'magick.switch',
label = 'Magick ON', value = TRUE)
} else {
updatePrettySwitch(session, inputId = 'magick.switch',
label = 'Magick OFF', value = FALSE)
}
})
observeEvent(input$buttoninputimage, {
magick.switch <- input$magick.switch
if (!input$inmethod) {
imgf <- input$selectfile
if (is.null(imgf)) {
err.text <- paste('The image file has not been uploaded')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
img <- as.character(imgf["datapath"])
img.name <- as.character(imgf["name"])
}
if (input$inmethod) {
img <- input$enter.path
if (img == '') {
err.text <- paste('The file path has not been entered')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
img.name <- basename(img)
}
updatePrettyRadioButtons(
session = session, inputId = "rotatede",
label = "Clockwise Rotation",
choices = c("0 degrees" = "rotate0",
"90 degrees" = "rotate90",
"180 degrees" = "rotate180",
"270 degrees" = "rotate270"),
prettyOptions = list(shape = "curve", status = "success",
fill = F, inline = F)
)
plot1_ranges$x <- NULL
plot1_ranges$y <- NULL
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
df.loc$data <- NULL
df.loc$ID <- NULL
rw.dataframe$data <- NULL
#cur.time <- as.character(Sys.time())
updateTextInput(session, "m_line", value = '',
label = 'Y-coordinate of the path')
updateTextInput(session, "tuid", value = '',
label = 'Series ID')
updateTextInput(session, "sample_yr", value = '',
label = 'Sampling year')
updateTextInput(session, "dpi", value = '',
label = 'DPI of the image')
updatePrettyRadioButtons(
session = session, inputId = "cropcondition",
choiceNames = 'UNCROPPED', choiceValues = list('a'),
prettyOptions = list(shape = "curve", status = "danger",
fill = F, inline = F)
)
updateActionButton(session, "buttoncrop", label = "Crop")
img.file$data <- readImg(img, img.name, magick.switch)
img.file.crop$data <- img.file$data
#img.file.crop.copy$data <- as.raster(img.file$data)
img.file.zoom$data <- NULL
dim.tdata <- attributes(img.file$data)[["dimt"]]
dimcol <- dim.tdata[1]
dimrow <- dim.tdata[2]
if ((dimcol*dimrow) >= 1.2e+07) {
resize.ratio <- 0.25
resize.str <- paste0(round(dimcol*resize.ratio), 'x',
round(dimrow*resize.ratio))
img.file.copy$data <- image_resize(img.file$data, resize.str)
} else {
img.file.copy$data <- img.file$data
}
})
plot1_ranges <- reactiveValues(x = NULL, y = NULL)
observeEvent(input$buttoncrop, {
if(is.null(img.file$data)){
err.text <- paste('The preview image have not been generated')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
plot1_brush <- input$plot1_brush
plot1_ranges$x <- NULL
plot1_ranges$y <- NULL
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
df.loc$data <- NULL
df.loc$ID <- NULL
rw.dataframe$data <- NULL
img.file.zoom$data <- NULL
updateTextInput(session, "m_line", value = '',
label = 'Y-coordinate of the path')
updateTextInput(session, "tuid", value = '', label = 'Series ID')
if (!is.null(plot1_brush)) {
plot1_ranges$x <- c(round(plot1_brush$xmin), round(plot1_brush$xmax))
plot1_ranges$y <- c(round(plot1_brush$ymin), round(plot1_brush$ymax))
dimcol <- attributes(img.file$data)[["dimt"]][1]
dimrow <- attributes(img.file$data)[["dimt"]][2]
if (plot1_ranges$x[1] <= 0) plot1_ranges$x[1] <- 0
if (plot1_ranges$y[1] <= 0) plot1_ranges$y[1] <- 0
if (plot1_ranges$x[2] >= dimcol) plot1_ranges$x[2] <- dimcol
if (plot1_ranges$y[2] >= dimrow) plot1_ranges$y[2] <- dimrow
xmin <- plot1_ranges$x[1]
ymin <- plot1_ranges$y[1]
xmax <- plot1_ranges$x[2]
ymax <- plot1_ranges$y[2]
img.range <- paste0(as.character(xmax-xmin), 'x',
as.character(ymax-ymin), '+',
as.character(xmin), '+',
as.character(dimrow-ymax))
img.file.crop$data <- image_crop(img.file$data, img.range)
updateActionButton(session, "buttoncrop", label = "Cancel")
updatePrettyRadioButtons(
session = session, inputId = "cropcondition",
choiceNames = 'CROPPED', choiceValues = list('a'),
prettyOptions = list(shape = "curve", status = "success",
fill = F, inline = F)
)
} else {
img.file.crop$data <- img.file$data
updateActionButton(session, "buttoncrop", label = "Crop")
updatePrettyRadioButtons(
session = session, inputId = "cropcondition",
choiceNames = 'UNCROPPED', choiceValues = list('a'),
prettyOptions = list(shape = "curve", status = "danger",
fill = F, inline = F)
)
}
})
output$pre.img <- renderPlot({
if (is.null(img.file$data)) return()
imgInput(img.file$data, img.file.copy$data, plot1_ranges$x, plot1_ranges$y)
})
plot2_ranges <- reactiveValues(x = NULL, y = NULL)
img.file.zoom <- reactiveValues(data = NULL)
zoom.add <- reactiveValues(data = NULL)
df.loc <- reactiveValues(data = NULL, ID = NULL)
observeEvent(input$buttoncreatpath, {
if (is.null(img.file.crop$data)) {
err.text <- 'Path creation fails because the image has not been plotted'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
py <- as.numeric(input$m_line)
if (is.na(py)) {
err.text <- 'Please enter a valid y-coordinate of the path'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
dpi <- as.numeric(input$dpi)
if (is.na(dpi)) {
err.text <- 'Please enter the DPI of the image'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
seriesID <- input$tuid
if (seriesID == '') {
err.text <- 'Please enter the series ID'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
incline <- input$incline
if(incline){
h.dis <- as.numeric(input$h.dis)
incline.cond <- 1
} else {
h.dis <- 0
incline.cond <- 0
}
dim.tdata <- image_info(img.file.crop$data) %>% '['(1, 2:3) %>% as.numeric
dimrow <- dim.tdata[2]
if (py >= dimrow) {
err.text <- paste('The Y-coordinate of the path is out of range.',
'Please type a valid Y-coordinate')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
f.df.loc <- c(dpi, incline.cond, 0, py, h.dis, 0) %>%
matrix(byrow = T, nrow = 2) %>%
as.data.frame(stringsAsFactors = F)
colnames(f.df.loc) <- c('x', 'y', 'z')
df.loc$data <- f.df.loc
df.loc$ID <- seriesID
})
observeEvent(input$buttoncreatpath2, {
if (is.null(img.file.crop$data)) {
err.text <- 'Path creation fails because the image has not been plotted'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
py <- as.numeric(input$m_line)
if (is.na(py)) {
err.text <- 'Please enter a valid y-coordinate of the path'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
dpi <- as.numeric(input$dpi)
if (is.na(dpi)) {
err.text <- 'Please enter the DPI of the image'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
seriesID <- input$tuid
if (seriesID == '') {
err.text <- 'Please enter the series ID'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
incline <- input$incline
if(incline){
h.dis <- as.numeric(input$h.dis)
incline.cond <- 1
} else {
h.dis <- 0
incline.cond <- 0
}
dim.tdata <- image_info(img.file.crop$data) %>% '['(1, 2:3) %>% as.numeric
dimrow <- dim.tdata[2]
if (py >= dimrow) {
err.text <- paste('The Y-coordinate of the path is out of range.',
'Please type a valid Y-coordinate')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
f.df.loc <- c(dpi, incline.cond, 0, py, h.dis, 0) %>%
matrix(byrow = T, nrow = 2) %>%
as.data.frame(stringsAsFactors = F)
colnames(f.df.loc) <- c('x', 'y', 'z')
df.loc$data <- f.df.loc
df.loc$ID <- seriesID
})
observeEvent(input$buttonsubimg, {
plot2_brush <- input$plot2_brush
if (is.null(img.file.crop$data)) {
err.text <- 'The tree ring image has not been plotted'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (!is.null(plot2_brush$xmin)) {
plot2_ranges$x <- c(round(plot2_brush$xmin), round(plot2_brush$xmax))
plot2_ranges$y <- c(round(plot2_brush$ymin), round(plot2_brush$ymax))
dim.tdata <- image_info(img.file.crop$data) %>% '['(1,2:3) %>% as.numeric
dimcol <- dim.tdata[1]
dimrow <- dim.tdata[2]
if (plot2_ranges$x[1] <= 0) plot2_ranges$x[1] <- 0
if (plot2_ranges$y[1] <= 0) plot2_ranges$y[1] <- 0
if (plot2_ranges$x[2] >= dimcol) plot2_ranges$x[2] <- dimcol
if (plot2_ranges$y[2] >= dimrow) plot2_ranges$y[2] <- dimrow
xmin <- plot2_ranges$x[1]
ymin <- plot2_ranges$y[1]
xmax <- plot2_ranges$x[2]
ymax <- plot2_ranges$y[2]
img.range <- paste0(as.character(xmax - xmin), 'x',
as.character(ymax - ymin), '+',
as.character(xmin), '+',
as.character(dimrow - ymax))
img.file.zoom$data <- image_crop(img.file.crop$data, img.range)
} else {
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
img.file.zoom$data <- NULL
err.text <- 'You have not selected a part of the image by brushing'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
})
observeEvent(input$plot2_dblclick, {
plot2_brush <- input$plot2_brush
if (is.null(img.file.crop$data)) {
err.text <- 'The tree ring image has not been plotted'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (!is.null(plot2_brush$xmin)) {
plot2_ranges$x <- c(round(plot2_brush$xmin), round(plot2_brush$xmax))
plot2_ranges$y <- c(round(plot2_brush$ymin), round(plot2_brush$ymax))
dim.tdata <- image_info(img.file.crop$data) %>% '['(1,2:3) %>% as.numeric
dimcol <- dim.tdata[1]
dimrow <- dim.tdata[2]
if (plot2_ranges$x[1] <= 0) plot2_ranges$x[1] <- 0
if (plot2_ranges$y[1] <= 0) plot2_ranges$y[1] <- 0
if (plot2_ranges$x[2] >= dimcol) plot2_ranges$x[2] <- dimcol
if (plot2_ranges$y[2] >= dimrow) plot2_ranges$y[2] <- dimrow
xmin <- plot2_ranges$x[1]
ymin <- plot2_ranges$y[1]
xmax <- plot2_ranges$x[2]
ymax <- plot2_ranges$y[2]
img.range <- paste0(as.character(xmax - xmin), 'x',
as.character(ymax - ymin), '+',
as.character(xmin), '+',
as.character(dimrow - ymax))
img.file.zoom$data <- image_crop(img.file.crop$data, img.range)
} else {
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
img.file.zoom$data <- NULL
err.text <- 'You have not selected a part of the image by brushing'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
})
observeEvent(input$zoom_dblclick, {
if (is.null(img.file.zoom$data)) {
err.text <- 'A zoomed-in image has not been created'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (is.null(df.loc$data)) {
err.text <- paste('You can not add new ring borders',
'because a path has not been created')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
f.df.loc <- df.loc$data
plot.arg <- f.df.loc[1:2,]
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1] - plot2_ranges$y[1]
bor <- input$zoom_dblclick
bor.x <- bor$x + plot2_ranges$x[1]
bor.y <- bor$y
if (!incline)
f.df.loc <- rbind(f.df.loc, list(bor.x, bor.y, 0))
if (incline) {
if (bor.y == py) {
err.text <- 'Please click on the upper path or the lower path'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (bor.y > py)
f.df.loc <- rbind(f.df.loc, list(bor.x, bor.y, 1))
if (bor.y < py)
f.df.loc <- rbind(f.df.loc, list(bor.x, bor.y, -1))
}
df.loc$data <- f.df.loc
})
# plot3_ranges <- reactiveValues(data = NULL)
observeEvent(input$buttonzoomdel, {
if (is.null(input$zoom_brush$xmin)) {
err.text <- 'You have not selected a part of the image by brushing'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (is.null(df.loc$data)) {
err.text <- 'A path has not been created'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (nrow(df.loc$data) <= 2) {
remove.text <- 'Ring border was NOT found along the path'
sendSweetAlert(
session = session, title = "Error", text = remove.text, type = "error"
)
return()
}
xmin <- input$zoom_brush$xmin
xmax <- input$zoom_brush$xmax
ymin <- input$zoom_brush$ymin
ymax <- input$zoom_brush$ymax
plot.arg <- df.loc$data[1:2,]
dpi <- plot.arg[1, 1]
dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
x.ranges <- df.loc$data$x[-c(1:2)] - plot2_ranges$x[1]
delete.bor <- which(x.ranges >= xmin & x.ranges <= xmax)
if (length(delete.bor) == 0) {
err.text <- 'Ring border was NOT found in the area you selected'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (incline) {
number.of.pixels <- round((h.dis/2) * dp)
py.upper <- py + number.of.pixels
py.lower <- py - number.of.pixels
which.line <- df.loc$data$z[-c(1:2)][delete.bor]
y.value <- ifelse(which.line > 0,
py.upper - plot2_ranges$y[1],
py.lower - plot2_ranges$y[1])
is.contain <- ymin <= y.value & ymax >= y.value
if (any(is.contain)) {
delete.bor <- delete.bor[is.contain] + 2
df.loc$data <- df.loc$data[-delete.bor,]
} else {
err.text <- 'Ring border was NOT found in the area you selected'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
}
} else {
y.value <- py - plot2_ranges$y[1]
is.contain <- ymin <= y.value & ymax >= y.value
if (any(is.contain)) {
delete.bor <- delete.bor[is.contain] + 2
df.loc$data <- df.loc$data[-delete.bor,]
} else {
err.text <- 'Ring border was NOT found in the area you selected'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
}
}
})
output$pre.img2 <- renderPlot({
if (is.null(img.file$data)) return()
imgInput_crop(as.raster(img.file.crop$data))
sample_yr <- as.numeric(input$sample_yr)
if (is.na(sample_yr)) return()
pch <- as.numeric(input$pch)
bor.color <- input$border.color
lab.color <- input$label.color
l.w <- as.numeric(input$linelwd)
label.cex <- as.numeric(input$label.cex)*0.7
if (is.null(df.loc$data)) return()
if (is.null(df.loc$ID)) return()
f.df.loc <- df.loc$data
plot.arg <- f.df.loc[1:2,]
dpi <- plot.arg[1, 1]
dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
img.name <- paste('Series ID:', df.loc$ID)
plot.marker(py, incline, dp, sample_yr, h.dis, l.w, bor.color,
lab.color, pch, label.cex, f.df.loc, T, img.name)
})
output$zoom.img <- renderPlot({
if (is.null(plot2_ranges$x)) return()
if (is.null(img.file.zoom$data)) return()
# if (is.null(img.file.zoom.copy$data)) return()
imgInput_crop(as.raster(img.file.zoom$data))
sample_yr <- as.numeric(input$sample_yr)
if(is.na(sample_yr)) return()
pch <- as.numeric(input$pch)
bor.color <- input$border.color
lab.color <- input$label.color
l.w <- as.numeric(input$linelwd)
label.cex <- as.numeric(input$label.cex)
if(is.null(df.loc$data)) return()
if(is.null(df.loc$ID)) return()
f.df.loc <- df.loc$data
f.df.loc$x[-c(1, 2)] <- f.df.loc$x[-c(1, 2)] - plot2_ranges$x[1]
plot.arg <- f.df.loc[1:2, ]
dpi <- plot.arg[1, 1]
dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1] - plot2_ranges$y[1]
h.dis <- plot.arg[2, 2]
img.name <- paste('Series ID:', df.loc$ID)
plot.marker(py, incline, dp, sample_yr, h.dis, l.w, bor.color,
lab.color, pch, label.cex, f.df.loc, T, img.name)
})
#autoresult <- reactiveValues(data = NULL, text = NULL)
#icon.value <- reactiveValues(data = 0)
observeEvent(input$button_run_auto, {
if (is.null(input$plot2_brush)) {
brush.text <- paste('Please select a part of the image by brushing',
'before running the automatic measurement')
sendSweetAlert(
session = session, title = "Error", text = brush.text, type = "error"
)
return()
}
if (is.null(df.loc$data)) {
err.text <- 'A path has not been created'
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
f.df.loc <- df.loc$data
brush <- input$plot2_brush
x1 <- brush$xmin
x2 <- brush$xmax
y1 <- brush$ymin
y2 <- brush$ymax
isrgb <- input$isrgb
if (isrgb) {
RGB <- c(0.299, 0.587, 0.114)
} else {
RGB <- strsplit(input$customRGB, ',')[[1]] %>% as.numeric
}
plot.arg <- f.df.loc[1:2,]
dpi <- plot.arg[1, 1]
dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
m_line <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
m_line.upper <- m_line
m_line.lower <- m_line
if (incline) {
number.of.pixels <- round((h.dis/2) * dp)
m_line.lower <- m_line + number.of.pixels
m_line.upper <- m_line - number.of.pixels
}
img <- img.file.crop$data
method <- input$method
linear.warning <- FALSE
if (m_line.upper <= y1 | m_line.lower >= y2) {
result.text <- paste('The brushed area does not contain the',
'path. Please re-brush on the image')
sendSweetAlert(
session = session, title = "Error", text = result.text, type = "error"
)
return()
}
defaultse <- input$defaultse
if (defaultse) {
struc.ele1 <- NULL
struc.ele2 <- NULL
} else {
struc.ele1 <- input$struc.ele1
struc.ele1 <- strsplit(struc.ele1, ',')[[1]] %>% as.numeric
if (length(struc.ele1) >= 3) {
err.t <- paste('The rectangular structuring element allows no more',
'than two non-negative integers. If entering two',
'integers, the first integer is the width of the',
'structuring element and the second is height. Use',
'a comma to separate integers. For example: 15,10')
sendSweetAlert(
session = session, title = "Error", text = err.t, type = "error"
)
return()
}
if (length(struc.ele1) == 0) {
err.text <- paste('The size of the first structuring',
'element has not been entered')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (as.numeric(struc.ele1) %>% is.na %>% any) {
err.text <- paste('The size of the structuring element',
'should be non-negative integers')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (length(struc.ele1) == 1)
struc.ele1 <- c(struc.ele1, struc.ele1)
struc.ele2 <- input$struc.ele2
struc.ele2 <- strsplit(struc.ele2, ',')[[1]] %>% as.numeric
if (length(struc.ele2) >= 3) {
err.t <- paste('The rectangular structuring element allows no more',
'than two non-negative integers. If entering two',
'integers, the first integer is the width of the',
'structuring element and the second is height. Use',
'a comma to separate integers. For example: 15,10')
sendSweetAlert(
session = session, title = "Error", text = err.t, type = "error"
)
return()
}
if (length(struc.ele2) == 0) {
err.text <- paste('The size of the second structuring',
'element has not been entered')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if (as.numeric(struc.ele2) %>% is.na %>% any) {
err.text <- paste('The size of the structuring element',
'should be non-negative integers')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
return()
}
if(length(struc.ele2) == 1)
struc.ele2 <- c(struc.ele2, struc.ele2)
}
if (method == 'watershed') {
if(input$watershed.threshold == 'custom.waterthr'){
watershed.threshold <- input$watershed.threshold2
} else {
watershed.threshold <- input$watershed.threshold
}
watershed.adjust <- input$watershed.adjust
df.loc$data <- automatic.det(img, incline, method, h.dis, dpi, m_line,
RGB, x1, x2, y1, y2, plot.arg,
watershed.threshold, watershed.adjust,
struc.ele1, struc.ele2)
}
if (method == "canny") {
default.canny <- input$defaultcanny
canny.t1 <- as.numeric(input$canny.t1)
canny.t2 <- as.numeric(input$canny.t2)
canny.adjust <- input$canny.adjust
canny.smoothing <- input$canny.smoothing
df.loc$data <- automatic.det(
img, incline, method, h.dis, dpi, m_line, RGB,
x1, x2, y1, y2, plot.arg, watershed.threshold,
watershed.adjust, struc.ele1, struc.ele2, default.canny,
canny.t1, canny.t2, canny.adjust, canny.smoothing)
}
if (method == "lineardetect") {
origin <- as.numeric(input$origin)
py.ld <- round((y1 + y2)/2)
updateTextInput(session, "m_line", value = as.character(round(py.ld)))
f.df.loc <- automatic.det(img, incline, method, h.dis, dpi, m_line,
RGB, x1, x2, y1, y2, plot.arg, origin = origin)
if(incline){
updateCheckboxInput(session, 'incline', 'Inclined tree rings', F)
f.df.loc[1, 2] <- FALSE
linear.warning <- TRUE
}
f.df.loc[2, 1] <- py.ld
df.loc$data <- f.df.loc
}
number.border <- nrow(df.loc$data) - 2
if (number.border == 0) {
rt <- 'Ring border was NOT detected'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
} else {
rt <- paste(number.border, 'boreders were detected')
sendSweetAlert(
session = session, title = "Finished", text = rt, type = "success"
)
}
if (linear.warning) {
rt <- paste('If you use the linear detection, don\'t',
'tick the checkbox "Inclined tree rings".',
'This checkbox has been automatically corrected.')
sendSweetAlert(
session = session, title = "TIPS", text = rt, type = "warning"
)
}
})
observeEvent(input$buttonrcm, {
# plot1_ranges$x <- NULL
# plot1_ranges$y <- NULL
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
df.loc$data <- NULL
df.loc$ID <- NULL
updateTextInput(session, "m_line", value = '',
label = 'Y-coordinate of the path')
rt <- paste('The existing path and borders have been',
'removed. You need to re-create a path')
sendSweetAlert(
session = session, title = "Success", text = rt, type = "success"
)
})
observeEvent(input$buttonrcm2, {
plot2_ranges$x <- NULL
plot2_ranges$y <- NULL
df.loc$data <- NULL
df.loc$ID <- NULL
updateTextInput(session, "m_line", value = '',
label = 'Y-coordinate of the path')
rt <- paste('The existing path and borders have been',
'removed. You need to re-create a path')
sendSweetAlert(
session = session, title = "Success", text = rt, type = "success"
)
})
observeEvent(input$button_del, {
if (is.null(df.loc$data)) {
rt <- paste('You can not remove ring borders because',
'the path has not been created.')
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
f.df.loc <- df.loc$data
plot.arg <- f.df.loc[1:2, ]
dpi <- plot.arg[1, 1]
dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
m_line <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
if (nrow(f.df.loc) < 3) {
rt <- 'Ring border was not found along the path'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
bx <- f.df.loc$x[-c(1, 2)]
where.bx <- f.df.loc$z[-c(1, 2)]
where.bx <- where.bx[order(bx)]
bx <- sort(bx)
if (incline) {
if (input$del.u == '' & input$del.l == '') {
rt <- 'Please enter at least one border number'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
del.u <- input$del.u
del.l <- input$del.l
if (del.u != '')
del.u <- strsplit(del.u, ",")[[1]] %>% as.numeric
if(del.l != '')
del.l <- strsplit(del.l, ",")[[1]] %>% as.numeric
# ndf <- length(del.u) + length(del.l)
up <- which(where.bx > 0)
lenup <- length(up)
bx.u <- bx[up]
if (lenup >= 1 & input$del.u != '') {
if (max(del.u) <= lenup) {
bx.u <- bx.u[-del.u]
} else {
rt <- 'The border number you entered did not exist'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
}
lower <- which(where.bx < 0)
lenlo <- length(lower)
bx.l <- bx[lower]
if (lenlo >= 1 & input$del.l != '') {
if (max(del.l) <= lenlo) {
bx.l <- bx.l[-del.l]
} else {
rt <- 'The border number you entered did not exist'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
}
df.u <- data.frame(x = bx.u, y = m_line, z = 1)
df.l <- data.frame(x = bx.l, y = m_line, z = -1)
df.loc$data <- rbind(plot.arg, df.u, df.l)
updateTextInput(session, "del.u",
label = 'Border number in the upper portion',
value = '')
updateTextInput(session, "del.l",
label = 'Border number in the lower portion',
value = '')
} else {
if (input$del == '') {
rt <- 'Please enter at least one border number'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
del <- strsplit(input$del, ",")[[1]] %>% as.numeric
if (max(del) <= length(bx)) {
bx <- bx[-del]
df <- data.frame(x = bx, y = m_line, z = 0)
df.loc$data <- rbind(plot.arg, df)
updateTextInput(session, "del", label = 'Border number', value = '')
} else {
rt <- 'The border number you entered did not exist'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
}
})
rw.dataframe <- reactiveValues(data = NULL)
observeEvent(input$button_results, {
if (is.null(df.loc$data)) {
error.text <- 'Ring border was not found along the path'
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
if (nrow(df.loc$data) <= 3) {
error.text <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
sample_yr <- as.numeric(input$sample_yr)
if (is.na(sample_yr)) {
error.text <- paste('Please check the argument \'Sampling year\' ')
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
plot.arg <- df.loc$data[1:2, ]
dpi <- plot.arg[1, 1]
dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
if (incline) {
incline.cond <- df.loc$data$z[-c(1:2)] %>% table %>% as.numeric
if (length(incline.cond) == 1) {
rt <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
if (all(incline.cond >= 2) & incline.cond[1] == incline.cond[2]) {
rw.dataframe$data <- f.rw(df.loc$data, sample_yr,
incline, py, dpi, h.dis)
} else {
if (any(incline.cond < 2)) {
err.text <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
} else {
err.text <- paste("If you tick the checkbox \"Inclined tree",
"rings\", the upper and lower paths should",
"have the same number of ring borders.")
sendSweetAlert(
session = session, title = "Error", text = err.text, type = "error"
)
}
}
} else {
rw.dataframe$data <- f.rw(df.loc$data, sample_yr,
incline, py, dpi, h.dis)
}
})
output$results <- renderTable({
if (is.null(rw.dataframe$data)) {
return()
} else {
return(rw.dataframe$data)
}
})
observeEvent(input$button_hide, {
if (is.null(rw.dataframe$data)) {
rt <- 'The data frame to be deleted does not exist'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
} else {
rw.dataframe$data <- NULL
}
})
output$RingWidth.csv <- downloadHandler(
filename = function() {
if (is.null(img.file$data)) {
img.name <- 'Download Unavailable'
return(paste0(img.name, '.csv'))
} else {
img.name <- input$tuid
}
if (input$csv.name != '')
img.name <- input$csv.name
return(paste0(img.name, '.csv'))
},
content = function(filename) {
if (is.null(df.loc$data)) {
rt <- 'Make sure you have added ring borders to the image'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
sample_yr <- as.numeric(input$sample_yr)
if (is.na(sample_yr)) {
error.text <- 'Please check the argument \'Sampling year\''
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
plot.arg <- df.loc$data[1:2, ]
dpi <- plot.arg[1, 1]
# dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
if (nrow(df.loc$data) <= 3) {
error.text <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
if (incline) {
incline.cond <- df.loc$data$z[-c(1:2)] %>% table %>% as.numeric
if (length(incline.cond) == 1) {
rt <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
if (all(incline.cond >= 2) & incline.cond[1] == incline.cond[2]) {
df.rw <- f.rw(df.loc$data, sample_yr, incline, py, dpi, h.dis)
write.csv(df.rw, filename, quote = FALSE, na = '--')
} else {
if (any(incline.cond < 2)) {
rt <- paste('A minimum of two ring borders on each path ',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
} else {
rt <- paste("If incline = TRUE, the upper and lower paths",
"should have the same number of ring borders")
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
}
} else {
df.rw <- f.rw(df.loc$data, sample_yr, incline, py, dpi, h.dis)
write.csv(df.rw, filename, quote = FALSE, na = '--')
}
},
contentType = 'csv'
)
observeEvent(input$reset.hdr,{
updateTextInput(session, "tuhdr1",label = 'Site ID',value = '')
updateTextInput(session, "tuhdr2",label = 'Site Name',value = '')
updateTextInput(session, "tuhdr3",label = 'Species Code',value = '')
updateTextInput(session, "tuhdr4",label = 'State or Country',value = '')
updateTextInput(session, "tuhdr5",label = 'Species',value = '')
updateTextInput(session, "tuhdr6",label = 'Elevation',value = '')
updateTextInput(session, "tuhdr7",label = 'Latitude',value = '')
updateTextInput(session, "tuhdr8",label = 'Longitude',value = '')
updateTextInput(session, "tuhdr9",label = 'First Year',value = '')
updateTextInput(session, "tuhdr10",label = 'Last Year',value = '')
updateTextInput(session, "tuhdr11",label = 'Lead Investigator',value = '')
updateTextInput(session, "tuhdr12",label = 'Completion Date',value = '')
})
output$RingWidth.rwl <- downloadHandler(
filename = function() {
if (is.null(img.file$data)) {
img.name <- 'Download Unavailable'
return(paste0(img.name, '.rwl'))
} else {
img.name <- input$tuid
}
if (input$rwl.name != '')
img.name <- input$rwl.name
return(paste0(img.name, '.rwl'))
},
content = function(filename) {
seriesID <- df.loc$ID
miss.id1 <- seriesID == ''
if (miss.id1) {
rt <- 'The series ID has not been entered'
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
if (is.null(df.loc$data)) {
error.text <- 'Make sure you have added ring borders to the image'
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
sample_yr <- as.numeric(input$sample_yr)
if (is.na(sample_yr)) {
error.text <- paste('Please check the argument \'Sampling year\'')
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
return()
}
if (nrow(df.loc$data) <= 3) {
error.text <- paste('A minimum of two ring borders on each path ',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = error.text, type = "error"
)
}
plot.arg <- df.loc$data[1:2, ]
dpi <- plot.arg[1, 1]
# dp <- dpi/25.4
incline <- ifelse(plot.arg[1, 2] == 0, FALSE, TRUE)
py <- plot.arg[2, 1]
h.dis <- plot.arg[2, 2]
df.rw <- NULL
if (incline) {
incline.cond <- df.loc$data$z[-c(1:2)] %>% table %>% as.numeric
if (length(incline.cond) == 1) {
rt <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
if (all(incline.cond >= 2) & incline.cond[1] == incline.cond[2]) {
df.rw <- f.rw(df.loc$data, sample_yr, incline, py, dpi, h.dis)
} else {
if (any(incline.cond < 2)) {
rt <- paste('A minimum of two ring borders on each path',
'was required to generate a ring-width series')
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
} else {
rt <- paste("If incline = TRUE, the upper and lower paths",
"should have the same number of ring borders")
sendSweetAlert(
session = session, title = "Error", text = rt, type = "error"
)
return()
}
}
} else {
df.rw <- f.rw(df.loc$data, sample_yr, incline, py, dpi, h.dis)
}
df.rwl <- data.frame(df.rw$ring.width, row.names = df.rw$year)
tuprec <- as.numeric(input$tuprec)
tuheader <- input$tuheader
tuhdr1 <- input$tuhdr1
tuhdr2<- input$tuhdr2
tuhdr3 <- input$tuhdr3
tuhdr4 <- input$tuhdr4
tuhdr5 <- input$tuhdr5
tuhdr6 <- input$tuhdr6
tuhdr7 <- input$tuhdr7
tuhdr8 <- input$tuhdr8
tuhdr9 <- input$tuhdr9
tuhdr10 <- input$tuhdr10
tuhdr11 <- input$tuhdr11
tuhdr12 <- input$tuhdr12
colnames(df.rwl) <- seriesID
hdr.list<- NULL
if (tuheader) {
hdr <- c(tuhdr1, tuhdr2, tuhdr3, tuhdr4, tuhdr5, tuhdr6,
tuhdr7, tuhdr8, tuhdr9, tuhdr10, tuhdr11, tuhdr12)
hdr.name <- c('site.id','site.name', 'spp.code', 'state.country',
'spp','elev', 'lat', 'long', 'first.yr', 'last.yr',
'lead.invs', 'comp.date')
which.not.empty <- hdr != ''
if (any(which.not.empty)) {
hdr.list <- lapply(hdr, function(x) x)
names(hdr.list) <- hdr.name
}
}
write.rwl(rwl.df = df.rwl, fname = filename,
format = "tucson", header = hdr.list,
append = FALSE, prec = tuprec)
}, contentType = "rwl"
)
}
options(shiny.testmode = TRUE)
shinyApp(ui = createUI(), server = createServer,
options = list(launch.browser = T))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.