Nothing
R/app_server.R
In SEAHORS: Spatial Exploration of ArcHaeological Objects in R Shiny
Defines functions
app_server
app_server <- function(input, output, session) {
digitnumber<-reactiveVal(11)
base::options(digits=11) ##add 1.8.x
observeEvent(input$digit.number, {
digitnumber(input$digit.number)
base::options(digits=digitnumber())
})
##### set variable to avoid notes in R package----
.stretch <- NULL
layer2 <- NULL
level <- NULL
null.2 <- NULL
point.size <- NULL
point.size2 <- NULL
shapeX.2 <- NULL
text.2 <- NULL
##### necessary settings----
options(shiny.maxRequestSize=150*1024^2) ## limits 150 MO to import
font.size <- "8pt"
vv<-reactiveVal(NULL) ## for plotly_selected
minsize<-reactiveVal(0.25) ##for min point
size.scale<-reactiveVal(3) ##for point
stepX<-reactiveVal(0.1) ## step size sliders
stepY<-reactiveVal(0.1) ## step size sliders
stepZ<-reactiveVal(0.1) ## step size sliders
transpar<-reactiveVal(1) ## alpha for density plot
data.fit<-reactiveVal() ##for import fit data
data.fit2<-reactiveVal() ##for import fit data
data.fit3<-reactiveVal() ##for import fit data
rotated.new.dataxy<-reactiveVal() ## to include new xyzdata from rotation
shape_all<-reactiveVal("circle") ##for import fit data
session_store <- reactiveValues() ## for save plot
setXX<-reactiveVal(NULL) ##input$setx
setYY<-reactiveVal(NULL) ##input$sety
setZZ<-reactiveVal(NULL) ##input$setz
height.size<-reactiveVal(800) ## default size of figure
width.size<-reactiveVal(1000) ## default size of figure
data.fit.3D<-reactiveVal() ## for refit data for 3D plot
listinfosmarqueur<-reactiveVal(NULL) ## for listinfos to be null at the beginning.
colorofrefit<-reactiveVal("red")## color base for refit
legendplotlyfig<-reactiveVal(TRUE) ##for legends.
inputcolor<-reactiveVal("null")
fileisupload<-reactiveVal(NULL)
save.col.react.fit<-reactiveVal()
mypaletteofcolors.fit<-reactiveVal()
nnrow.df.df<-reactiveVal(0) ##nrow df$df
ratiox<-reactiveVal(1) ## aspectratio X
ratioy<-reactiveVal(1) ## aspectratio y
ratioz<-reactiveVal(1) ## aspectratio z
ratio.simple<-reactiveVal(1)
font_size<-reactiveVal(12)
font_tick<-reactiveVal(12)
nameX<-reactiveVal("X")
nameY<-reactiveVal("Y")
nameZ<-reactiveVal("Z")
Xtickmarks.size<-reactiveVal()
Ytickmarks.size<-reactiveVal()
Ztickmarks.size<-reactiveVal()
Xminorbreaks<-reactiveVal(1)
Yminorbreaks<-reactiveVal(1)
Zminorbreaks<-reactiveVal(1)
ID.no.suppl.data.txt<-reactiveVal("no data")
notunique.txt<-reactiveVal("no data")
notunique2.txt<-reactiveVal("no data")
suppl.no.include.txt<-reactiveVal("no data")
## update 1.4 - to import
input_file1.name<-reactiveVal()
input_file1.datapath<-reactiveVal()
getdata.launch<-reactiveVal()
e<-reactiveVal(NULL) ## create an environment to save the 2D.slice pdf
ratio.slice<-reactiveVal(1)
nb.slice<-reactiveVal(1) ##nb of slice for saving it
fileisupload.avoidload<-reactiveVal() ## add for 1.9
##### import data----
df<-reactiveValues( #creation df
df=NULL) # end reactivevalues
observeEvent(input$file1, {
input_file1.name(input$file1$name)
input_file1.datapath(input$file1$datapath)
})
observeEvent(input$getData, {
getdata.launch(input$getData)
})
observe({
req(!is.null(input_file1.datapath()))
extension <- tools::file_ext(input_file1.name())
switch(extension,
csv = {updateSelectInput(session, "worksheet", choices = input_file1.name())},
xls = { selectionWorksheet <-excel_sheets(path = input_file1.datapath())
updateSelectInput(session, "worksheet", choices = selectionWorksheet)},
xlsx = { selectionWorksheet <-excel_sheets(path = input_file1.datapath())
updateSelectInput(session, "worksheet", choices = selectionWorksheet)})
})
observeEvent(getdata.launch(), {
req(!is.null(input_file1.datapath()))
extension <- tools::file_ext(input_file1.name())
df$df2 <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input_file1.datapath(), n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input_file1.datapath(), n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input_file1.datapath(), n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input_file1.datapath(),
header = input$header,
sep = sep2, stringsAsFactors = F, fileEncoding="latin1",
dec=".")},
xls = readxl::read_xls(input_file1.datapath(), sheet=input$worksheet),
xlsx = readxl::read_xlsx(input_file1.datapath(), sheet=input$worksheet))
fileisupload(1)
fileisupload.avoidload(1) #add for 1.9
})# end observe of df$df2
observeEvent(!is.null(fileisupload()), { ## add two necessary columns for the rest of manipulations, correct issues with comma and majuscule
req(!is.null(fileisupload()))
req(!is.null(fileisupload.avoidload())) #add for 1.9
null<-"0"
shapeX<-shape_all()
df$df<-df$df2[,!sapply(df$df2, function(x) is.logical(x))] ##remove column without data
if (input$set.dec == TRUE){
df$df[] <- apply(df$df,2,function (x) stringr::str_replace_all(x,",","."))
} else{}
if(!is.null(df$df[sapply(df$df, function(x) !is.numeric(x))])) {
df$df[sapply(df$df, function(x) !is.numeric(x))] <- mutate_all(df$df[sapply(df$df, function(x) !is.numeric(x))], .funs=stringr::str_to_lower)}
text<-""
df$df<-cbind(shapeX,text,null,df$df)
df$df[is.na(df$df)] <- "" ### add to 1.8.x
nnrow.df.df(nrow(df$df))
listinfosmarqueur(1)
}) #end observe
##### reset data ----
observeEvent(input$reset.BDD, {
fileisupload(NULL)
shinyjs::refresh()
shinyjs::reset('file1')
df$df <- NULL
df$df2 <- NULL
# input_file1(NULL)
input_file1.name(NULL)
input_file1.datapath(NULL)
}, priority = 1000)
#### others options ----
observeEvent(input$Colors,{
inputcolor(input$Colors)
})
observeEvent(input$minsize, {
minsize(input$minsize)
})
observeEvent(input$alpha.density, {
transpar(input$alpha.density)
})
observeEvent(input$point.size,{
size.scale(input$point.size)
})
output$X.limx2=renderUI({
req(input$checkbox.auto.limits==FALSE)
req(!is.null(fileisupload()))
req(input$xslider)
z2min=df$df[,input$setx] %>% floor() %>% min(na.rm = TRUE)
z2max=df$df[,input$setx] %>% ceiling() %>% max(na.rm = TRUE)
z2diff=z2max-z2min
zmin=z2min-z2diff*25/100
zmax=z2max+z2diff*25/100
sliderInput('X.limx','X lim',min=zmin,max=zmax,value=c(zmin,zmax),step=0.5)
})
output$Y.limx2=renderUI({
req(input$checkbox.auto.limits==FALSE)
req(!is.null(fileisupload()))
req(input$yslider)
z2min=df$df[,input$sety] %>% floor() %>% min(na.rm = TRUE)
z2max=df$df[,input$sety] %>% ceiling() %>% max(na.rm = TRUE)
z2diff=z2max-z2min
zmin=z2min-z2diff*25/100
zmax=z2max+z2diff*25/100
sliderInput('Y.limx','Y lim',min=zmin,max=zmax,value=c(zmin,zmax),step=0.5)
})
icon_svg_path = "M10,6.536c-2.263,0-4.099,1.836-4.099,4.098S7.737,14.732,10,14.732s4.099-1.836,4.099-4.098S12.263,6.536,10,6.536M10,13.871c-1.784,0-3.235-1.453-3.235-3.237S8.216,7.399,10,7.399c1.784,0,3.235,1.452,3.235,3.235S11.784,13.871,10,13.871M17.118,5.672l-3.237,0.014L12.52,3.697c-0.082-0.105-0.209-0.168-0.343-0.168H7.824c-0.134,0-0.261,0.062-0.343,0.168L6.12,5.686H2.882c-0.951,0-1.726,0.748-1.726,1.699v7.362c0,0.951,0.774,1.725,1.726,1.725h14.236c0.951,0,1.726-0.773,1.726-1.725V7.195C18.844,6.244,18.069,5.672,17.118,5.672 M17.98,14.746c0,0.477-0.386,0.861-0.862,0.861H2.882c-0.477,0-0.863-0.385-0.863-0.861V7.384c0-0.477,0.386-0.85,0.863-0.85l3.451,0.014c0.134,0,0.261-0.062,0.343-0.168l1.361-1.989h3.926l1.361,1.989c0.082,0.105,0.209,0.168,0.343,0.168l3.451-0.014c0.477,0,0.862,0.184,0.862,0.661V14.746z"
### button for png dl
dl_button <- list(
name = "Download as .png",
icon = list(
path = icon_svg_path,
transform = "scale(0.84) translate(-1, 0)"
),
click = htmlwidgets::JS('function(gd) {Plotly.downloadImage(gd, {format: "png"}
) }') )
##### option figures ----
observeEvent(input$fontsizeaxis, {
font_size(input$fontsizeaxis)
})
observeEvent(input$fontsizetick, {
font_tick(input$fontsizetick)
})
observeEvent(input$Xtickmarks, {
Xtickmarks.size(input$Xtickmarks)
})
observeEvent(input$Ytickmarks, {
Ytickmarks.size(input$Ytickmarks)
})
observeEvent(input$Ztickmarks, {
Ztickmarks.size(input$Ztickmarks)
})
observeEvent(input$Xminor.breaks, {
Xminorbreaks(input$Xminor.breaks)
})
observeEvent(input$Yminor.breaks, {
Yminorbreaks(input$Yminor.breaks)
})
observeEvent(input$Zminor.breaks, {
Zminorbreaks(input$Zminor.breaks)
})
output$themeforfigure=renderUI({
req(!is.null(fileisupload()))
themes <- c("theme_bw", "theme_classic", "theme_dark", "theme_grey", "theme_light", "theme_linedraw", "theme_minimal")
selectInput("themeforfigure.list", h4("Theme for 'Simple 2Dplot'"),
choices = themes,
selected = "theme_minimal")
})
themeforfigure.choice<-reactiveVal(c("theme_minimal"))
observeEvent(input$themeforfigure.list,{
themeforfigure.choice(c(input$themeforfigure.list))
})
##### option size of figure ----
observeEvent(input$height.size.a, {
height.size(input$height.size.a)
})
#
observeEvent(input$height.size.b, {
height.size(input$height.size.b)
})
observeEvent(input$width.size.b, {
width.size(input$width.size.b)
})
#
observeEvent(input$height.size.b.simple, {
height.size(input$height.size.b.simple)
})
observeEvent(input$width.size.b.simple, {
width.size(input$width.size.b.simple)
})
#
observeEvent(input$height.size.c, {
height.size(input$height.size.c)
})
observeEvent(input$width.size.c, {
width.size(input$width.size.c)
})
#
observeEvent(input$height.size.d, {
height.size(input$height.size.d)
})
observeEvent(input$width.size.d, {
width.size(input$width.size.d)
})
#
observeEvent(input$height.size.e, {
height.size(input$height.size.e)
})
observeEvent(input$width.size.e, {
width.size(input$width.size.e)
})
observeEvent(input$ratiox, {
ratiox(input$ratiox)
})
observeEvent(input$ratioy, {
ratioy(input$ratioy)
})
observeEvent(input$ratioz, {
ratioz(input$ratioz)
})
observeEvent(input$ratio.to.coord.simple, {
ratio.simple(input$ratio.to.coord.simple)
})
observeEvent(input$ratio.to.coord.simple.2, {
ratio.simple(input$ratio.to.coord.simple.2)
})
observeEvent(input$ratio.to.coord, {
ratio.simple(input$ratio.to.coord)
})
##### function used in the script ----
#function for density
get_density <- function(x, y, ...) {
dens <- MASS::kde2d(x, y, ...)
ix <- findInterval(x, dens$x)
iy <- findInterval(y, dens$y)
ii <- cbind(ix, iy)
return(dens$z[ii])
}
#function for newgroup
dataModal <- function() {
if (!is.null(vv) && !is.null(values$newgroup)) {
modalDialog(
selectInput("select.new.group", label = h3("Select the new group"),
choices = values$newgroup,
selected = values$newgroup[1]),
textInput("NewGroup", "Choose the name of assignement",value = "new.variable"),
footer = tagList(
modalButton("Cancel"),
actionButton("Change", "OK")
)
)
}
}
#function for refit
seq2 <- function(from, to, by=1){
if (to>=from){
return(seq(from, to, by))
}else{
return(NULL)
}
}
#function for orthopho import from Rstoolbox
.toRaster <- function(x) {
if (inherits(x, "SpatRaster")) {
return(stack(x))
} else {
return(x)
}
}
.numBand <- function(raster, ...){
bands <- list(...)
lapply(bands, function(band) if(is.character(band)) which(names(raster) == band) else band )
}
ggRGB<-function(img, r = 3, g = 2, b = 1, scale, maxpixels = 5e+05,
stretch = "none", ext = NULL, limits = NULL, clipValues = "limits",
quantiles = c(0.02, 0.98), ggObj = TRUE, ggLayer = FALSE,
alpha = 1, coord_equal = TRUE, geom_raster = FALSE, nullValue = 0)
{
img <- .toRaster(img)
verbose <- getOption("RStoolbox.verbose")
annotation <- !geom_raster
rgb <- unlist(.numBand(raster = img, r, g, b))
nComps <- length(rgb)
if (inherits(img, "RasterLayer"))
img <- brick(img)
rr <- sampleRegular(img[[rgb]], maxpixels, ext = ext, asRaster = TRUE)
RGB <- getValues(rr)
if (!is.matrix(RGB))
RGB <- as.matrix(RGB)
if (!is.null(limits)) {
if (!is.matrix(limits)) {
limits <- matrix(limits, ncol = 2, nrow = nComps,
byrow = TRUE)
}
if (!is.matrix(clipValues)) {
if (!anyNA(clipValues) && clipValues[1] == "limits") {
clipValues <- limits
}
else {
clipValues <- matrix(clipValues, ncol = 2, nrow = nComps,
byrow = TRUE)
}
}
for (i in 1:nComps) {
if (verbose) {
message("Number of pixels clipped in ",
c("red", "green", "blue")[i],
" band:\n", "below limit: ", sum(RGB[,
i] < limits[i, 1], na.rm = TRUE), " | above limit: ",
sum(RGB[, i] > limits[i, 2], na.rm = TRUE))
}
RGB[RGB[, i] < limits[i, 1], i] <- clipValues[i,
1]
RGB[RGB[, i] > limits[i, 2], i] <- clipValues[i,
2]
}
}
rangeRGB <- range(RGB, na.rm = TRUE)
if (missing("scale")) {
scale <- rangeRGB[2]
}
if (rangeRGB[1] < 0) {
RGB <- RGB - rangeRGB[1]
scale <- scale - rangeRGB[1]
rangeRGB <- rangeRGB - rangeRGB[1]
}
if (scale < rangeRGB[2]) {
warning("Scale < max value. Resetting scale to max.",
call. = FALSE)
scale <- rangeRGB[2]
}
RGB <- na.omit(RGB)
if (stretch != "none") {
stretch <- tolower(stretch)
for (i in seq_along(rgb)) {
RGB[, i] <- .stretch(RGB[, i], method = stretch,
quantiles = quantiles, band = i)
}
scale <- 1
}
naind <- as.vector(attr(RGB, "na.action"))
nullbands <- sapply(list(r, g, b), is.null)
if (any(nullbands)) {
RGBm <- matrix(nullValue, ncol = 3, nrow = NROW(RGB))
RGBm[, !nullbands] <- RGB
RGB <- RGBm
}
if (!is.null(naind)) {
z <- rep(NA, times = ncell(rr))
z[-naind] <- rgb(RGB[, 1], RGB[, 2], RGB[, 3], max = scale,
alpha = alpha * scale)
}
else {
z <- rgb(RGB[, 1], RGB[, 2], RGB[, 3], max = scale, alpha = alpha *
scale)
}
df_raster <- data.frame(coordinates(rr), fill = z, stringsAsFactors = FALSE)
x <- y <- fill <- NULL
if (ggObj) {
exe <- as.vector(extent(rr))
df <- data.frame(x = exe[1:2], y = exe[3:4])
if (annotation) {
dz <- matrix(z, nrow = nrow(rr), ncol = ncol(rr),
byrow = TRUE)
p <- ggplot2::annotation_raster(raster = dz, xmin = exe[1],
xmax = exe[2], ymin = exe[3], ymax = exe[4],
interpolate = FALSE)
if (!ggLayer) {
p <- ggplot2::ggplot() + p + ggplot2::geom_blank(data = df, aes(x = x,
y = y))
}
}
else {
p <- ggplot2::geom_raster(data = df_raster, aes(x = x, y = y,
fill = fill), alpha = alpha)
if (!ggLayer) {
p <- ggplot2::ggplot() + p + ggplot2::scale_fill_identity()
}
}
if (coord_equal & !ggLayer)
p <- p + ggplot2::coord_equal()
return(p)
}
else {
return(df_raster)
}
}
# functions for 2D slice
plotUI <- function(id) {
ns <- NS(id)
if (input$advanced.slice==TRUE){
plotlyOutput(ns("plot"), height = height.size()) } else {
plotOutput(ns("plot.2"), height = height.size())
}
}
plotServer <- function(id,df.sub.a, Xvar, Yvar,liste.valeur.slice) {
moduleServer(
id,
function(input, output, session) {
t2 <- list(
family = "Arial",
size = 14,
color = "red")
output$plot <- renderPlotly({
df.sub2<-df.sub()
set.antivar.2d.slice<-c(setXX(),setYY())[c(setXX(),setYY())!=set.var.2d.slice()]
set.antivar.2d.name<-c(nameX(),nameY())[c(setXX(),setYY())!=set.var.2d.slice()]
Xtickmarks.size<-c(Xtickmarks.size(),Ytickmarks.size())[c(setXX(),setYY())!=set.var.2d.slice()]
yymax = df.sub2[,setZZ()] %>% ceiling() %>% max(na.rm = TRUE)
yymin=df.sub2[,setZZ()] %>% floor() %>% min(na.rm = TRUE)
xymax = df.sub2[,set.antivar.2d.slice] %>% ceiling() %>% max(na.rm = TRUE)
xymin=df.sub2[,set.antivar.2d.slice] %>% floor() %>% min(na.rm = TRUE)
df.sub.a<-as.data.frame(df.sub.a)
min.size2<-minsize()
size.scale <- size.scale()
myvaluesx<-unlist(myvaluesx())
shapeX<-df.sub.a$shapeX
shape.level<-levels(as.factor(shapeX))
p<- plot_ly(x=~df.sub.a[,Xvar], y = ~df.sub.a[,Yvar],
type="scatter",
color = ~df.sub.a$layer2,
colors = myvaluesx,
size = ~df.sub.a$point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~df.sub.a$shapeX,
symbols = shape.level,
text=df.sub.a$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'),
height = height.size(),
width = width.size())
Xtval<-seq(floor(min(df.sub.a[[Xvar]])),max(df.sub.a[[Xvar]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub.a[[Yvar]])),max(df.sub.a[[Yvar]]), Zminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ztickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ztickmarks.size())]
p<-p %>% layout(showlegend = legendplotlyfig(),
title = list(text=liste.valeur.slice,font=t2,x =0.1),
scene = list(aspectratio=list(x=1,y=1,z=1)),
xaxis = list(title=paste(set.antivar.2d.name), range=c(xymin,xymax),
dtick = Xtickmarks.size,
tick0 = floor(min(df.sub.a[,Xvar])),
tickvals=Xtval,
ticktext=Xttxt,
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis=list(title=paste(nameZ()), range=c(yymin,yymax),
dtick = Ztickmarks.size(),
tick0 = floor(min(df.sub.a[,Yvar])),
tickvals=Ytval,
ticktext=Yttxt,
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
}) # end of renderPlotly
}
)
}
plotServer.simple <- function(id,df.sub.a, Xvar, Yvar,liste.valeur.slice,i) {
moduleServer(
id,
function(input, output, session) {
t2 <- list(
family = "Arial",
size = 14,
color = "red")
output$plot.2 <- renderPlot({
df.sub2<-df.sub()
set.antivar.2d.slice<-c(setXX(),setYY())[c(setXX(),setYY())!=set.var.2d.slice()]
set.antivar.2d.name<-c(nameX(),nameY())[c(setXX(),setYY())!=set.var.2d.slice()]
Xtickmarks.size<-c(Xtickmarks.size(),Ytickmarks.size())[c(setXX(),setYY())!=set.var.2d.slice()]
yymax = df.sub2[,setZZ()] %>% ceiling() %>% max(na.rm = TRUE)
yymin=df.sub2[,setZZ()] %>% floor() %>% min(na.rm = TRUE)
xymax = df.sub2[,set.antivar.2d.slice] %>% ceiling() %>% max(na.rm = TRUE)
xymin=df.sub2[,set.antivar.2d.slice] %>% floor() %>% min(na.rm = TRUE)
df.sub.a<-as.data.frame(df.sub.a)
min.size2<-minsize()
size.scale <- size.scale()
myvaluesx<-unlist(myvaluesx())
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df.sub()$layer2)) %in% levels(as.factor(droplevels(df.sub.a$layer2)))]
shapeX<-df.sub.a$shapeX
shape.level<-levels(as.factor(shapeX))
ppsz<-df.sub.a$point.size2
p <- ggplot2::ggplot()
p<- p + ggplot2::geom_point(data = df.sub.a,
aes(x = .data[[set.antivar.2d.slice]],
y = .data[[setZZ()]],
col=factor(layer2)),
size=ppsz,
shape=shapeX
)+
ggplot2::coord_fixed(ratio.simple())
p<- p + ggplot2::scale_color_manual(values=myvaluesx2)+
ggplot2::scale_shape_manual(values=shape.level)+
ggplot2::scale_size_manual(values=c(min.size2,size.scale))+
xlab(paste(set.antivar.2d.name))+ylab(nameZ())+
do.call(themeforfigure.choice(), list()) +
theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),
legend.title = element_blank())+
theme(legend.position='none')
p<-p+ggplot2::scale_x_continuous(limits= c(xymin,xymax), breaks=seq(floor(min(xymin)),max(xymax),Xtickmarks.size), minor_breaks =seq(floor(min(xymin)),max(xymax),Xminorbreaks()))+
ggplot2::scale_y_continuous(limits= c(yymin,yymax),breaks=seq(floor(min(yymin)),max(yymax),Ztickmarks.size()), minor_breaks = seq(floor(min(yymin)),max(yymax),Zminorbreaks()))
nb.slice(i)
assign(paste0("session_store$test$",i),p, envir=e())
p
}) # end of renderPlotly
}
)
}
#function for color
color.function<-function (levelofcolor,name,selected_rainbow,loadingfile){
uvalues <-levels(as.factor(levelofcolor))
n <- length(uvalues)
choices <- as.list(uvalues)
#myorder <- as.list(1:n)
if (!is.null (loadingfile)) {
mycolors <-unlist(loadingfile)
selected_rainbow<-1
} else {
mycolors <- list("darkgreen", "blue","purple", "green","pink","orange","grey","aquamarine","chartreuse",
"mintcream","salmon","brown","lightblue","lightslateblue","gold")}
colors <- paste0("background:",mycolors,";")
colors <- paste0(colors,"color:black;")
colors <- paste0(colors,"font-family: Arial;")
colors <- paste0(colors,"font-weight: bold;")
selected2 <-mycolors
nk <- length(mycolors) ## to repeat colors when there are more bars than the number of colors
tagList(
div(br()),
div(
lapply(1:n, function(i){
k <- i %% nk
if (k==0) k=nk
if (selected_rainbow == "1") {
selected2 <-mycolors[i] }
shinyWidgets::spectrumInput(
inputId = paste0(name,i),
label = paste0(uvalues[i], ": " ),
choices = list(mycolors,
as.list(rainbow(10)),
as.list(heat.colors(10)),
as.list(terrain.colors(10)),
as.list(cm.colors(10)),
as.list(topo.colors(10)
)
),
selected = selected2,
options = list(`toggle-palette-more-text` = "Show more")
)
}),
)
)
} # end of color.function
# function for switching axis
var.function<-function(var.xyz){
var<-setXX()
var2<-setYY()
axis.var.name<-nameX()
axis.var2.name<-nameY()
Xtickmarks.size<-Xtickmarks.size()
Ytickmarks.size<-Ytickmarks.size()
Xminorbreaks<-Xminorbreaks()
Yminorbreaks<-Yminorbreaks()
if (var.xyz != "xy"){
switch(var.xyz,
# xy={
# var<-setXX()
# var2<-setYY()
# axis.var.name<-nameX()
# axis.var2.name<-nameY()
# Xtickmarks.size<-Xtickmarks.size()
# Ytickmarks.size<-Ytickmarks.size()
# Xminorbreaks<-Xminorbreaks()
# Yminorbreaks<-Yminorbreaks()
# },
yz={ var<-setYY()
var2<-setZZ()
axis.var.name<-nameY()
axis.var2.name<-nameZ()
Xtickmarks.size<-Ytickmarks.size()
Ytickmarks.size<-Ztickmarks.size()
Xminorbreaks<-Yminorbreaks()
Yminorbreaks<-Zminorbreaks()
},
xz={ var<-setXX()
var2<-setZZ()
axis.var.name<-nameX()
axis.var2.name<-nameZ()
Xtickmarks.size<-Xtickmarks.size()
Ytickmarks.size<-Ztickmarks.size()
Xminorbreaks<-Xminorbreaks()
Yminorbreaks<-Zminorbreaks()
},
yx={ var<-setYY()
var2<-setXX()
axis.var.name<-nameY()
axis.var2.name<-nameX()
Xtickmarks.size<-Ytickmarks.size()
Ytickmarks.size<-Xtickmarks.size()
Xminorbreaks<-Yminorbreaks()
Yminorbreaks<-Xminorbreaks()
}
) } else {} # enf of if
new.list.parameter<-list(var,var2,axis.var.name,axis.var2.name,Xtickmarks.size,Ytickmarks.size,Xminorbreaks,Yminorbreaks)
return(new.list.parameter)
}
# # function for minor grid
# minor.grid.info.function<-function(var.xyz,var,var2,Xminorbreaks,Xtickmarks.size,Yminorbreaks,Ytickmarks.size){
# Xtval<-seq(floor(min(var.xyz[[var]])),max(var.xyz[[var]]), Xminorbreaks)
# Xttxt <- rep("",length(Xtval))
# Xttxt[seq(1,length(Xtval),Xtickmarks.size)]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size)]
#
# Ytval<-seq(floor(min(var.xyz[[var2]])),max(var.xyz[[var2]]), Yminorbreaks)
# Yttxt <- rep("",length(Ytval))
# Yttxt[seq(1,length(Ytval),Ytickmarks.size)]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size)]
#
# Ztval<-seq(floor(min(var.xyz[[setZZ()]])),max(var.xyz[[setZZ()]]), Zminorbreaks())
# Zttxt <- rep("",length(Ztval))
# Zttxt[seq(1,length(Ztval),Ztickmarks.size())]<-as.character(Ztval)[seq(1,length(Ztval),Ztickmarks.size())]
#
# minor.grid.info<-list(Xtval,Xttxt,Ytval,Yttxt,Ztval,Zttxt)
# return(minor.grid.info)
# }
# function for rotated 2DPlot ----
rotated.table<-reactive({
isTruthy(df.sub())
points_start<-df.sub()
M <- cbind.data.frame(points_start[,input$setx],points_start[,input$sety])
alpha <- input$pi2 # in degree
M <- as.matrix(M)
# centrage
centroid <- colMeans(M)
Mc <- M - matrix(centroid, nrow=nrow(M), ncol=2, byrow = TRUE)
# matrix of rotation
alpha <- alpha/180*pi
R <- matrix(c(cos(alpha), sin(alpha), -sin(alpha), cos(alpha)), 2, 2)
# rotation
Mr <- Mc%*%R
# translation to come back at the center
Mr <- Mr + matrix(centroid, nrow=nrow(M), ncol=2, byrow = TRUE)
# normalisation of data
inidataxmax<- points_start[,input$setx]%>%as.numeric()%>%ceiling()%>% max()
inidataxmin<- points_start[,input$setx]%>%as.numeric()%>%floor()%>% min()
inidataymax<- points_start[,input$sety]%>%as.numeric()%>%ceiling()%>% max()
inidataymin<- points_start[,input$sety]%>%as.numeric()%>%floor()%>% min()
points_start$x2<-((Mr[,1]-min(Mr[,1]))/(max(Mr[,1])-min(Mr[,1])))*(abs(inidataxmax-inidataxmin))
points_start$y2<-((Mr[,2]-min(Mr[,2]))/(max(Mr[,2])-min(Mr[,2])))*(abs(inidataymax-inidataymin))
rotated.table<-points_start
})
##### output loading slide ----
liste.x<-reactiveVal(c("X.rotated","x","X","null","SPATIAL..X"))
observeEvent(input$setx,{
liste.x(c(input$setx))
})
liste.y<-reactiveVal(c("Y.rotated","y","Y","null","SPATIAL..Y"))
observeEvent(input$sety,{
liste.y(c(input$sety))
})
liste.z<-reactiveVal(c("z","Z","null","SPATIAL..Z"))
observeEvent(input$setz,{
liste.z(c(input$setz))
})
liste.date<-reactiveVal(c("Years","periods","SPATIAL..Year","Year"))
observeEvent(input$setdate,{
liste.date(c(input$setdate))
})
liste.nature2<-reactiveVal(c("Type","null","Nature","Code"))
observeEvent(input$setnature,{
liste.nature2(c(input$setnature))
})
liste.levels<-reactiveVal(c("UAS","Levels","null","SPATIAL..USfield","Assemblage"))
observeEvent(input$setlevels,{
liste.levels(c(input$setlevels))
})
liste.passe2<-reactiveVal(c("Passe","null"))
observeEvent(input$setpasse,{
liste.passe2(c(input$setpasse))
})
liste.ID<-reactiveVal(c("ID","Point","null","fieldID"))
observeEvent(input$setID,{
liste.ID(c(input$setID))
})
liste.sector2<-reactiveVal(c("null","context","localisation","square","Sector","SPATIAL..Square_field","Square"))
observeEvent(input$setsector,{
liste.sector2(c(input$setsector))
})
output$set.x=renderUI({
req(!is.null(fileisupload()))
selectInput("setx", h4("x (Default name: x)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.x())
})
output$set.y=renderUI({
req(!is.null(fileisupload()))
selectInput("sety", h4("y (Default name: y)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.y())
})
output$set.z=renderUI({
req(!is.null(fileisupload()))
selectInput("setz", h4("z (Default name: z)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.z())
})
observeEvent(input$setx,{
df$df[,input$setx]<-df$df[,input$setx]%>% as.numeric()
setXX(input$setx)
nameX(input$setx)
})
observeEvent(input$sety,{
df$df[,input$sety]<-df$df[,input$sety]%>% as.numeric()
setYY(input$sety)
nameY(input$sety)
})
observeEvent(input$setz,{
df$df[,input$setz]<-df$df[,input$setz]%>% as.numeric()
setZZ(input$setz)
nameZ(input$setz)
})
output$set.nature=renderUI({
req(!is.null(fileisupload()))
selectInput("setnature", h4("Type (Default name: Type)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.nature2())
})
output$set.levels=renderUI({
req(!is.null(fileisupload()))
selectInput("setlevels", h4("Levels (Default name: Levels)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.levels())
})
output$set.date=renderUI({
req(!is.null(fileisupload()))
selectInput("setdate", h4("years : format years (Default name: Years)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.date())
})
output$set.passe=renderUI({
req(!is.null(fileisupload()))
selectInput("setpasse", h4("others (No default name)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.passe2())
})
output$set.ID=renderUI({
req(!is.null(fileisupload()))
selectInput("setID", h4("Unique object ID (Default name: ID)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.ID())
})
output$set.sector=renderUI({
req(!is.null(fileisupload()))
selectInput("setsector", h4("Context/square/sector (Default name: Context, Square, Sector)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.sector2())
})
observeEvent(input$checkbox.invX, {
req(input$setx)
df$df[,setXX()]<-df$df[,setXX()]*-1
updateSelectInput(session,"setx",choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.x())
xmax = df$df[,setXX()] %>% ceiling() %>% max(na.rm = TRUE)
xmin=df$df[,setXX()] %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'xslider','x limits',min=xmin,max=xmax,value=c(xmin,xmax),step=stepX())
x2min=input$xslider[1]
x2max=input$xslider[2]
updateSliderInput(session,'ssectionXx2','x (point size): min/max',min=x2min,max=x2max,value=c(x2min,x2max),step=stepX())
})
observeEvent(input$checkbox.invY, {
req(input$sety)
df$df[,input$sety]<-df$df[,input$sety]*-1
updateSelectInput(session,"sety",choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.y())
ymax = df$df[,setYY()] %>% ceiling() %>% max(na.rm = TRUE)
ymin=df$df[,setYY()] %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'yslider','y limits',min=ymin,max=ymax,value=c(ymin,ymax),step=stepY())
y2min=input$yslider[1]
y2max=input$yslider[2]
updateSliderInput(session,'ssectionXy2','y (point size): min/max',min=y2min,max=y2max,value=c(y2min,y2max),step=stepY())
})
observeEvent(input$checkbox.invZ, {
req(input$setz)
df$df[,setZZ()]<-df$df[,setZZ()]*-1
updateSelectInput(session,"setz",choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.z())
zmax = df$df[,setZZ()] %>% ceiling() %>% max(na.rm = TRUE)
zmin=df$df[,setZZ()] %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'zslider','z limits',min=zmin,max=zmax,value=c(zmin,zmax),step=stepZ())
z2min=input$zslider[1]
z2max=input$zslider[2]
updateSliderInput(session,'ssectionXz2','z (point size): min/max',min=z2min,max=z2max,value=c(z2min,z2max),step=stepZ())
})
observeEvent(input$Name.X, {
req(input$setx)
nameX(input$Name.X)
})
observeEvent(input$Name.Y, {
req(input$sety)
nameY(input$Name.Y)
})
observeEvent(input$Name.Z, {
req(input$setz)
nameZ(input$Name.Z)
})
##### verification ----
observeEvent(ignoreInit = TRUE, c(setXX(),setYY(),setZZ(),input$setID), {
if( sum(is.na(as.numeric(df$df[,input$setx])))>0 || sum(is.na(as.numeric(df$df[,input$sety])))>0 || sum(is.na(as.numeric(df$df[,input$setz])))>0 || (dim(df$df[duplicated(df$df[,input$setID]),])[1]>0 & input$setID != "null")) {
showModal(modalDialog(
title = "Issues with loaded data",
if( sum(is.na(as.numeric(df$df[,input$setx])))>0) {
HTML(paste(sum(is.na(as.numeric(df$df[,input$setx]))), " X value(s) was/were not included as not numerical <br>"))},
if( sum(is.na(as.numeric(df$df[,input$sety])))>0) {
HTML(paste(sum(is.na(as.numeric(df$df[,input$sety]))), " Y value(s) was/were not included as not numerical<br>"))},
if( sum(is.na(as.numeric(df$df[,input$setz])))>0) {
HTML(paste(sum(is.na(as.numeric(df$df[,input$setz]))), " Z value(s) was/were not included as not numerical<br>"))},
if(input$setID != "null" & dim(df$df[duplicated(df$df[,input$setID]),])[1]>0) {
HTML(paste(dim(df$df[duplicated(df$df[,input$setID]),])[1], " object ID(s) is/are not unique !<br> "))
}
))
}
})
##verification to use distinct size options
observeEvent(ignoreInit = TRUE,
c(min.point.sliderx(),
min.point.slidery(),
min.point.sliderz(),
set.var.gris(),
minsize()),
{
req(!is.null(df.sub())) ##ajout 1.9
req(!is.null(df.sub.minpoint())) ##ajout 1.9
diff<-nrow(df.sub())-nrow(df.sub.minpoint())
if(diff>0 && input$setID == "null"){
showModal(modalDialog(
title = "No unique ID",
HTML("Size options are not available without unique ID")
))
}
})
##### import extradata ----
observe({
req(input$file.extradata)
extension <- tools::file_ext(input$file.extradata$name)
df$file.extradata <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.extradata$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.extradata$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.extradata$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.extradata$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,fileEncoding="latin1",
dec=".")},
xls = readxl::read_xls(input$file.extradata$datapath),
xlsx = readxl::read_xlsx(input$file.extradata$datapath))
}) #end observe
output$set.columnID=renderUI({
req(input$file.extradata)
req(input$setID)
selectInput("setcolumnID", h4("Select the unique objects ID)"),
choices = names(df$file.extradata),
selected = c(paste(input$setID)))
})
observeEvent(input$setcolumnID, { ## add two necessary columns for the rest of manipulations
df$file.extradata2<-df$file.extradata[,!sapply(df$file.extradata, function(x) is.logical(x))] ##remove column whitout data
df$file.extradata2[sapply(df$file.extradata2, function(x) !is.numeric(x))] <- mutate_all(df$file.extradata2[sapply(df$file.extradata2, function(x) !is.numeric(x))], .funs=str_to_lower)
temp.data<-df$df[duplicated(df$df[,input$setID]) | duplicated(df$df[,input$setID], fromLast = T),]
if (nrow(temp.data) >0 ) {notunique.txt(temp.data)
} else {notunique.txt("All IDs are unique")}
temp.data2<-df$file.extradata2[duplicated(df$file.extradata2[,input$setcolumnID]) | duplicated(df$file.extradata2[,input$setcolumnID], fromLast = T),]
if (nrow(temp.data2) >0 ) {notunique2.txt(temp.data2)
} else {notunique2.txt("All IDs are unique")}
}) #end observe
observeEvent(input$goButton.set.columnID, {
req(input$setcolumnID)
if(input$setID == "null"){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("No unique ID has been defined in the XYZ dataset"))
))
return()
}
if(dim(df$df[duplicated(df$df[,input$setID]),])[1]>0){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("Object IDs from the XYZ dataset are not unique. <br>
Import refit data required absolutely a unique ID per object"))
))
return()
}
names(df$file.extradata2)[match(paste(input$setcolumnID),names(df$file.extradata2))]<-paste(input$setID)
if(dim(df$file.extradata2[duplicated(df$file.extradata2[,input$setID]),])[1]>0){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("Object IDs from the imported dataset are not unique. <br>
Import refit data required absolutely a unique ID per object"))
))
return()
}
same.column.to.remove<-intersect(colnames(df$df),colnames(df$file.extradata2)) # remove column with same name
same.column.to.remove<-same.column.to.remove[same.column.to.remove!=input$setID]
df$file.extradata3<-df$file.extradata2[!names(df$file.extradata2)%in% c(same.column.to.remove)]
df$file.extradata3[,input$setID]<-as.character(df$file.extradata3[,input$setID]) ## same format to avoid pb
df$df[,input$setID]<-as.character(df$df[,input$setID]) ## same format to avoid pb
temp.data2<-setdiff(df$df[,input$setID],df$file.extradata3[,input$setID])
if(length(temp.data2)==0){
ID.no.suppl.data.txt("perfect")} else {suppl.no.include.txt(temp.data2)}
temp.data<-setdiff(df$file.extradata3[,input$setID],df$df[,input$setID])
if(length(temp.data)==0){
suppl.no.include.txt("perfect")} else {ID.no.suppl.data.txt(temp.data)}
df$df<-full_join(df$file.extradata3,df$df)%>%
relocate(c("shapeX","text","null"))
})
## table to show import extradata ----
output$notunique<- renderPrint({notunique.txt()})
output$notunique2<- renderPrint({notunique2.txt()})
output$suppl.no.include<- renderPrint({suppl.no.include.txt()})
output$ID.no.suppl.data<- renderPrint({ID.no.suppl.data.txt()})
##### import refit data ----
observe({
req(input$file.fit)
extension <- tools::file_ext(input$file.fit$name)
df$file.fit <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.fit$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.fit$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.fit$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.fit$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,
dec=".",fileEncoding="latin1")},
xls = readxl::read_xls(input$file.fit$datapath),
xlsx = readxl::read_xlsx(input$file.fit$datapath))
}) #end observe
output$set.columnID.for.fit=renderUI({
req(input$setID)
selectInput("setcolumnID.for.fit", h4("Select the column recording the unique object ID)"),
choices = names(df$file.fit),
selected = c(paste(input$setID)))
})
output$set.REM=renderUI({
selectInput("setREM", h4("Select the column recording the unique ID of refit groups"),
choices= names(df$file.fit),
selected = c("fit","refit","Rem","null"))
})
observeEvent(input$Refit.data.from.XYZ.file, {
updateSelectInput(session,"setcolumnID.for.fit",choices=if(input$Refit.data.from.XYZ.file == FALSE){names(df$file.fit)}else{names(df$df)[3:length(df$df)]},selected=input$setID )
updateSelectInput(session,"setREM",choices=if(input$Refit.data.from.XYZ.file == FALSE){names(df$file.fit)}else{names(df$df)[3:length(df$df)]},selected=c("fit","REM") )
})
observeEvent(input$goButton.set.columnID.for.fit, {
req(input$setcolumnID.for.fit)
req((input$setREM)!="")
if(input$setID == "null"){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("No unique ID has been defined in the XYZ dataset"))
))
return()
}
if(dim(df$df[duplicated(df$df[,input$setID]),])[1]>0){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("Object IDs from the XYZ dataset are not unique. <br>
Import refit data required absolutely a unique ID per object"))
))
return() }
if(input$Refit.data.from.XYZ.file == FALSE){
df$file.fit3<-df$file.fit
df$file.fit3<-df$file.fit3[,!sapply(df$file.fit3, function(x) is.logical(x))] ##remove column whitout data
df$file.fit3[sapply(df$file.fit3, function(x) !is.numeric(x))] <- mutate_all(df$file.fit3[sapply(df$file.fit3, function(x) !is.numeric(x))], .funs=str_to_lower)
df$file.fit3<-as.data.frame(df$file.fit3)
names(df$file.fit3)[match(paste(input$setcolumnID.for.fit),names(df$file.fit3))]<-paste(input$setID)
same.column.to.remove<-intersect(colnames(df$df),colnames(df$file.fit3))
same.column.to.remove<-same.column.to.remove[same.column.to.remove!=input$setID]
df$file.fit2<-df$file.fit3[!names(df$file.fit3)%in% c(same.column.to.remove)]
} else {
df$file.fit2<-df$df[!is.na(df$df[input$setREM]),]
df$file.fit2<-df$file.fit2[!df$file.fit2[input$setREM]=="" & !df$file.fit2[input$setREM]=="NA",]
}
df$file.fit2[,input$setID]<-as.character(df$file.fit2[,input$setID]) ## same format to avoid pb
df$df[,input$setID]<-as.character(df$df[,input$setID]) ## same format to avoid pb
data.fit(df$file.fit2)
})
observeEvent(data.fit(), {
req(input$setREM)
data.REM<-left_join(data.fit(),df$df)
if(all(is.na(data.REM$shapeX))==TRUE){ ##test to go next step
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("No refit data have been merged. <br> Unique IDs should not match together"))
))
return()
}
fac <- as.factor(data.REM[,input$setREM])
idx_lev <- which(nchar(levels(fac))>0)
eff <- table(fac)[idx_lev]
Lcombi <- lapply(lapply(eff, function(a){1:a} ), function(v){if (length(v)>1){combn(v, 2)}else{matrix(nrow=2, ncol=0)}})
Lidx <- lapply(names(eff), function(a,f){which(f==a)}, fac)
LcombiRow <- mapply( function(M, v){matrix(v[M], nrow(M), ncol(M))}, Lcombi, Lidx, SIMPLIFY = FALSE)
m1 <- data.REM[unlist(lapply(LcombiRow, function(M){M[1,]})),]
m2 <- data.REM[unlist(lapply(LcombiRow, function(M){M[2,]})),]
table.fit2 <- rbind(m1, m2)
colnames(m2)<-paste0(colnames(m2),".2")
colnames(m2)[which(names(m2) == paste0(input$setx,".2"))] <- "xend"
colnames(m2)[which(names(m2) == paste0(input$sety,".2"))] <- "yend"
colnames(m2)[which(names(m2) == paste0(input$setz,".2"))] <- "zend"
m2<-m2 %>% relocate(shapeX.2, text.2,null.2)
table.fit <- cbind(m1, m2[,4:ncol(m2)])
idx <- c(rbind(1:nrow(m1), 1:nrow(m2)+nrow(m1)))
table.fit2 <- table.fit2[idx,]
tt <- sapply(LcombiRow,ncol)*2
v1 <- rep(names(tt), tt)
v2 <- rep(unlist(lapply(sapply(LcombiRow,ncol), seq2, from=1)), each=2)
table.fit2 <- cbind(table.fit2, paste0(v1, ".", v2))
colnames(table.fit2)[which(names(table.fit2) == 'paste0(v1, ".", v2)')] <- "fit.2"
table.fit2<-table.fit2 %>% relocate(shapeX, text,null)
table.fit<-table.fit %>% relocate(shapeX, text,null)
data.fit2(table.fit)
data.fit.3D(table.fit2)
data.fit3(table.fit)
data.refit.choose(names(table.fit2)) ## for color of refit
showModal(modalDialog(
title = "Refit data",
HTML(paste("Refit data have been merged."))
))
})
## table to show refit ----
output$Fit.table.output<- renderPrint({
if (is.null(data.fit3())) { "no refit"} else {
data.fit3()[,4:ncol(data.fit3())]}
})
#### merge two columns ----
output$set.col1=renderUI({
req(!is.null(fileisupload()))
selectInput("setcol1", h4("Choose a first column"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = "")
})
output$set.col2=renderUI({
req(!is.null(fileisupload()))
selectInput("setcol2", h4("Choose a second column"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = "")
})
observeEvent(input$Merge2, {
new.group<-paste0(df$df[,input$setcol1],input$separatormerge,df$df[,input$setcol2])
df$df<-cbind(df$df,new.group)
colnames(df$df)[ncol(df$df)]<-c(input$Merge.groupe)
showModal(modalDialog(
HTML(paste("Data have been merged. <br>
The first value obtained is",df$df[,input$Merge.groupe][1] ))
))
})
##### ortho slide import ----
observe({ ### ortho xy
req(input$file2)
df$ortho.2<-stack(input$file2$datapath)
})
output$liste.ortho.file2=renderUI({
req(input$file2)
renderPlot({
s2<-stack(input$file2$datapath)
plotRGB(s2,maxpixels=50000)
})
})
output$liste.ortho.file3=renderUI({
req(input$file3)
renderPlot({
s3<-stack(input$file3$datapath)
plotRGB(s3,maxpixels=50000)
})
})
output$liste.ortho.file4=renderUI({
req(input$file4)
renderPlot({
s4<-stack(input$file4$datapath)
plotRGB(s4,maxpixels=50000)
})
})
output$liste.ortho.file5=renderUI({
req(input$file5)
renderPlot({
s5<-stack(input$file5$datapath)
plotRGB(s5,maxpixels=50000)
})
})
##### output sidebar ----
output$liste.Colors=renderUI({
req(!is.null(fileisupload()))
selectInput("Colors", h4("Variable to be colored"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = c("UAS","null",names(df$df)[1]))
})
output$liste.Nature=renderUI({
req(input$setnature)
checkboxGroupInput("Nature", h4("Type"),
choices = levels(as.factor(df$df[,input$setnature])),selected = factor(df$df[,input$setnature]))
})
output$liste.passe=renderUI({
req(input$setpasse)
checkboxGroupInput("Passe", h4(paste(input$setpasse)),
choices = levels(as.factor(df$df[,input$setpasse])),selected = levels(as.factor(df$df[,input$setpasse])))
})
output$liste.sector=renderUI({
req(input$setsector)
checkboxGroupInput("localisation", h4("Context"),
choices = levels(as.factor(df$df[,input$setsector])),selected = factor(df$df[,input$setsector]))
})
output$liste.UAS=renderUI({
req(input$setlevels)
checkboxGroupInput("UAS", h4("Levels"),
choices = levels(as.factor(df$df[,input$setlevels])),selected = factor(df$df[,input$setlevels]))
})
textnbobject<-reactiveVal(NULL)
observe({
if (!is.null(nrow(df$df))){
req(!is.null(df.sub()))
textnbobject(paste("Number of objects plotted:",nrow(df.sub()),"for a total of", nnrow.df.df(), "rows present in the dataset"))
}
})
output$nb=renderUI({
HTML(paste(textnbobject()))
})
output$nb2=renderUI({
HTML(paste(textnbobject()))
})
output$nb2.2=renderUI({
HTML(paste(textnbobject()))
})
output$nb3=renderUI({
HTML(paste(textnbobject()))
})
output$nb4=renderUI({
HTML(paste(textnbobject()))
})
output$nb5=renderUI({
HTML(paste(textnbobject()))
})
output$nb8=renderUI({
HTML(paste(textnbobject()))
})
output$nb6=renderUI({
req(!is.null(fileisupload()))
req(!is.null(df.sub()))
HTML(paste("Number of rows imported:",sum(nrow(df$df)-(max(sum(is.na(as.numeric(df$df[,input$setx]))),sum(is.na(as.numeric(df$df[,input$sety]))),sum(is.na(as.numeric(df$df[,input$setz])))))),"for a total of", nrow(df$df), "rows present in the dataset"))
})
output$ylimits=renderUI({
req(!is.null(fileisupload()))
req(input$sety)
ymax= df$df[,input$sety] %>% as.numeric() %>%ceiling() %>% max(na.rm = TRUE)
ymin=df$df[,input$sety] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
sliderInput('yslider','y limits',min=ymin,max=ymax,value=c(ymin,ymax),step=stepY())
})
output$xlimits=renderUI({
req(!is.null(fileisupload()))
req(input$setx)
xmax = df$df[,input$setx] %>% ceiling() %>% max(na.rm = TRUE)
xmin=df$df[,input$setx] %>% floor() %>% min(na.rm = TRUE)
sliderInput('xslider','x limits',min=xmin,max=xmax,value=c(xmin,xmax),step=stepX())
})
output$zlimits=renderUI({
req(!is.null(fileisupload()))
req(input$setz)
zmax = df$df[,input$setz] %>% ceiling() %>% max(na.rm = TRUE)
zmin=df$df[,input$setz] %>% floor() %>% min(na.rm = TRUE)
sliderInput('zslider','z limits',min=zmin,max=zmax,value=c(zmin,zmax),step=stepZ())
})
output$Date=renderUI({
req(!is.null(fileisupload()))
req(input$setdate)
dmin=min(as.numeric(df$df[,input$setdate]), na.rm=T)
dmax=max(as.numeric(df$df[,input$setdate]), na.rm=T)
if((dmax!="inf")==TRUE){
sliderInput('Date2','Year(s) :',min=dmin,max=dmax,value=c(dmin,dmax),step=1,sep='')
} else {}
})
##### output additional Setting slide ----
observeEvent(input$stepXsize, {
stepX(input$stepXsize)
})
observeEvent(input$stepYsize, {
stepY(input$stepYsize)
})
observeEvent(input$stepZsize, {
stepZ(input$stepZsize)
})
output$liste.infos=renderUI({
req(!is.null(fileisupload()))
checkboxGroupInput("listeinfos", h4("Choose the variable information to be shown while hovering points on plots"),
choices = names(df$df)[c(4:ncol(df$df))], selected = NULL)
})
output$shape2=renderUI({
req(!is.null(fileisupload()))
req(input$shape)
s2<-list("circle","square","triangle","diamond","star")
s2<-s2[s2!=input$shape]
selectInput("setshape2", h4("Secondary shape"),
choices = s2)
})
output$shape2.var1=renderUI({
req(!is.null(fileisupload()))
selectInput("setshape2.1", h5("Select variable for secondary shape"),
choices = names(df$df)[c(3:ncol(df$df))])
})
output$shape2.var2=renderUI({
req(!is.null(fileisupload()))
df$Sh2<-df$df
selectInput("setshape2.2", h5("Select variable modality for secondary shape"),
choices = levels(as.factor(df$Sh2[,input$setshape2.1])),selected = factor(df$Sh2[,input$shape2.var1]))
})
tt<-reactiveVal()
observeEvent(input$do.shape2, {
tt2<-paste(input$setshape2,input$setshape2.1," ", input$setshape2.2, " ")
tt3<-paste(tt2, tt(), sep="\n")
tt(tt3)
})
observeEvent(input$do.shape1, {
tt3<-NULL
tt(tt3)
})
output$text.shape <- renderText({
paste(tt())}
)
observeEvent(input$do.shape1, {
df$df$shapeX<-input$shape
})
observeEvent(input$do.shape2, {
df$df$shapeX[df$df[,input$setshape2.1] %in% input$setshape2.2]<-input$setshape2
})
observeEvent(input$optioninfosfigplotly, {
legendplotlyfig(input$optioninfosfigplotly)
})
output$ratiotocoorsimple2=renderUI({
req(input$advanced.slice==FALSE)
numericInput("ratio.to.coord.simple.2", label = h5("Ratio figure"), value = 1)
})
output$download.slice.output=renderUI({
req(input$advanced.slice==FALSE)
downloadButton("download.slice", "Download as .pdf")
})
#### liste infos ----
observeEvent(req(!is.null(listinfosmarqueur())),{
df$df$text<-""}
)
observeEvent(input$listeinfos.go, {
req(input$setz)
req(input$setID)
selected = c()
for (s in 1:length(input$listeinfos)) {
selected = c(selected, input$listeinfos[s])
}
if (is.null(selected)) {
selected = character(0)
}
df$df$text<-paste("<br><b>Z</b>:", df$df[,input$setz],"<br><b>ID</b>:", df$df[,input$setID])
if (length(input$listeinfos)>0){
for (ii in 1:length(input$listeinfos)){
text5<-paste("<br>",input$listeinfos[ii],": ",df$df[,input$listeinfos[ii]], sep="")
df$df$text<-paste(df$df$text,text5)
}
}
updateCheckboxGroupInput(session, "listeinfos", selected = selected)
listinfosmarqueur(NULL)
}) #end of observeevent
##### colors ----
save.col.react<-reactiveVal()
mypaletteofcolors<-reactiveVal()
observeEvent(df$file.color,{
mypaletteofcolors(df$file.color[2])
})
basiccolor= reactive({
req(!is.null(fileisupload()))
name<-"colorvar"
color.function(df$df[[inputcolor()]],name,1,mypaletteofcolors())
})
save.col2<-observeEvent(myvaluesx(),{
if (length(unlist(myvaluesx()))>1) {
color<-levels(as.factor(df$df[,inputcolor()]))
names_of_the_variable<-unlist(myvaluesx())
length(color)<-max(c(length(color),length(names_of_the_variable))) ## to avoid problem of different row
length(names_of_the_variable)<-max(c(length(color),length(names_of_the_variable)))
save.col.react(cbind.data.frame(color,names_of_the_variable))
}
})
observe({
req(input$file.color)
extension <- tools::file_ext(input$file.color$name)
df$file.color <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.color$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.color$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.color$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.color$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,
dec=".")},
xls = readxl::read_xls(input$file.color$datapath),
xlsx = readxl::read_xlsx(input$file.color$datapath))
})
myvaluesx<-reactive({
req(!is.null(fileisupload()))
myvaluesx <-NULL
n <- length(unique(df$df[,inputcolor()]))
val <- list()
if (!is.null(input[[paste0("colorvar",1)]])) {
myvaluesx <- lapply(1:n, function(i) {
if (i==1) val <- list(input[[paste0("colorvar",i)]])
else val <- list(val,input[[paste0("colorvar",i)]])
})}else{
myvaluesx <-list(c("blue"),c("red"),c("green"))
}
}) # end of myvaluexS
output$colors2 <- renderUI({
basiccolor()
})
##### color for refits ----
data.refit.choose<-reactiveVal(NULL)
inputcolor.refit<-reactiveVal("null")
output$liste.Colors.refit=renderUI({
req(!is.null(fileisupload()))
req(!is.null(data.refit.choose()))
selectInput("Colors.rerefit", h4("Refit variable to be colored"),
choices = data.refit.choose()[c(3:length(data.refit.choose()))],
selected = data.refit.choose()[1])
})
observeEvent(input$Colors.rerefit,{
inputcolor.refit(input$Colors.rerefit)
})
observeEvent(df$file.color.fit,{
mypaletteofcolors.fit(df$file.color.fit[2])
})
basiccolorforfit=reactive({
if (is.null(inputcolor.refit())) return(NULL)
data.fit.3D<-data.fit.3D()
name<-"colorvar.refit"
color.function(data.fit.3D[[inputcolor.refit()]],name,0,mypaletteofcolors.fit())
})
output$colorsrefits <- renderUI({
basiccolorforfit()
})
colorvalues<-reactive({
req(!is.null(data.fit()))
colorvalues<-NULL
n <- length(unique(data.fit.3D()[,input$setID]))
val <- list()
colorvalues<- lapply(1:n, function(i) {
if (i==1) val <- list(input[[paste0("colorvar.refit",i)]])
else val <- list(val,input[[paste0("colorvar.refit",i)]])
})
}) # end of Colorvalues
observeEvent(colorvalues(),{
if (length(unlist(colorvalues()))>1) {
color<-levels(as.factor(data.fit.3D()[[inputcolor.refit()]]))
names_of_the_variable<-unlist(colorvalues())
length(color)<-max(c(length(color),length(names_of_the_variable))) ## to avoid problem of different row
length(names_of_the_variable)<-max(c(length(color),length(names_of_the_variable)))
save.col.react.fit(cbind.data.frame(color,names_of_the_variable))
}
})
observe({
req(input$file.color.fit)
extension <- tools::file_ext(input$file.color.fit$name)
df$file.color.fit <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.color.fit$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.color.fit$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.color.fit$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.color.fit$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,
dec=".")},
xls = readxl::read_xls(input$file.color.fit$datapath),
xlsx = readxl::read_xlsx(input$file.color.fit$datapath))
})
##### variable subset refits ----
react.var.rerefit<-reactiveVal("null")
react.listevarrefit<-reactiveVal("0")
output$liste.var.refit=renderUI({
req(!is.null(fileisupload()))
req(!is.null(data.refit.choose()))
selectInput("var.rerefit", h4("Subsetting refit"),
choices = data.refit.choose()[c(3:length(data.refit.choose()))],
selected = data.refit.choose()[1])
})
output$liste.varrefit=renderUI({
req(!is.null(fileisupload()))
req(!is.null(data.refit.choose()))
checkboxGroupInput("listevarrefit", h4("Select the refit modalities to be shown"),
choices = levels(as.factor(data.fit.3D()[,input$var.rerefit])), selected = factor(data.fit.3D()[,input$var.rerefit]))
})
observeEvent(input$var.rerefit,{
react.var.rerefit(input$var.rerefit)
})
observeEvent(input$listevarrefit,{
react.listevarrefit(input$listevarrefit)
})
##### ouput 2D and 3D slide ----
output$sectionXy2=renderUI({
req(!is.null(fileisupload()))
req(input$yslider)
y2min=min(input$yslider)
y2max=max(input$yslider)
sliderInput('ssectionXy2','y (point size): min/max',min=y2min,max=y2max,value=c(y2min,y2max),step=stepY())
})
output$sectionXx2=renderUI({
req(!is.null(fileisupload()))
req(input$xslider)
x2min=input$xslider[1]
x2max=input$xslider[2]
sliderInput('ssectionXx2','x (point size): min/max',min=x2min,max=x2max,value=c(x2min,x2max),step=stepX())
})
output$sectionXz2=renderUI({
req(!is.null(fileisupload()))
req(input$zslider)
z2min=min(input$zslider)
z2max=max(input$zslider)
sliderInput('ssectionXz2','z (point size): min/max',min=z2min,max=z2max,value=c(z2min,z2max),step=stepZ())
})
output$var.gris.2D=renderUI({
req(!is.null(fileisupload()))
selectInput("set.var.gris.2D", h4("Select the variable for point that are going to be wide"),
choices = names(df$df)[c(3:ncol(df$df))])
})
output$var.gris.2D.1=renderUI({
req(!is.null(fileisupload()))
checkboxGroupInput("set.var.gris.2D.1", h4("Levels of variable"),
choices = levels(as.factor(df$df[,input$set.var.gris.2D])),selected = factor(df$df[,input$set.var.gris.2D]))
})
output$sectionXx3=renderUI({
req(!is.null(fileisupload()))
req(input$pi2)
xmin=0
xmax=input$xslider[2]-input$xslider[1]
sliderInput('ssectionXx3','x: min/max',min=xmin,max=xmax,value=c(xmin,xmax),step=0.05)
})
output$sectionXy3=renderUI({
req(!is.null(fileisupload()))
req(input$pi2)
ymin=0
ymax=input$yslider[2]-input$yslider[1]
sliderInput('ssectionXy3','y: min/max',min=ymin,max=ymax,value=c(ymin,ymax),step=0.05)
})
output$var.fit.3D=renderUI({
req(!is.null(data.fit.3D()))
radioButtons("var.fit.3D", "Include refits",
choices = c(no = "no",
yes = "yes"),
selected = "no", inline=TRUE)
})
var.sub2<-reactiveVal()
min.point.sliderx<-reactiveVal()
min.point.slidery<-reactiveVal()
min.point.sliderz<-reactiveVal()
set.var.gris<-reactiveVal()
observeEvent(input$set.var.gris.2D.1, {
var.sub2(input$set.var.gris.2D.1)
})
observeEvent(input$ssectionXx2,{
min.point.sliderx(input$ssectionXx2)
})
observeEvent(input$ssectionXy2,{
min.point.slidery(input$ssectionXy2)
})
observeEvent(input$ssectionXz2,{
min.point.sliderz(input$ssectionXz2)
})
observeEvent(input$set.var.gris.2D, {
set.var.gris(input$set.var.gris.2D)
})
##### new group slide ----
output$liste.newgroup=renderUI({
req(!is.null(fileisupload()))
selectInput("listenewgroup", h4("Copy data from another variable (select NULL for a default value of zero)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = c("null"))
})
values <- reactiveValues(newgroup = NULL)
create.newgroup <- observeEvent(input$go.ng, {
new.group<-df$df[,input$listenewgroup]
req(!isTruthy(input$text.new.group == values$newgroup)) ## block if two same names exist because problems later
values$newgroup <- c(values$newgroup, input$text.new.group)
df$df<-cbind(df$df,new.group)
colnames(df$df)[ncol(df$df)]<-c(input$text.new.group)
})
output$brushed<- renderPrint({
g1 <- df$df
d <- event_data('plotly_selected')
if (is.null(d)) return()
if (length(d)==0) {
vv(NULL)
return()
}
dd <- cbind(d[[3]],d[[4]])
list.parameter.info<-var.function(input$var1)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
WW<-which(g1[[var]] %in% dd[,1] & g1[[var2]] %in% dd[,2])
vv<-df$df[WW,4:ncol(df$df)]
vv(vv)
vv
})
observeEvent(input$Change2, {
showModal(dataModal())
})
observeEvent(input$Change, {
req(!is.null(input$Change))
df$df[which(row.names(df$df) %in% row.names(vv())),][input$text.new.group] <-
input$NewGroup
removeModal()
}) # end of Observe Event
#rename
output$liste.newgroup2=renderUI({
req(!is.null(fileisupload()))
selectInput("liste.newgroup.rename", label = h5("Select the new group"),
choices = values$newgroup,
selected = values$newgroup[1])
})
output$liste.newgroup4=renderUI({
req(!is.null(fileisupload()))
req(!is.null(values$newgroup))
req(input$liste.newgroup.rename != "")
selectInput("liste.newgroup3", label = h5("Select the variable"),
choices = factor(df$df[,input$liste.newgroup.rename]))
})
observeEvent(input$go.ng2, {
req(!is.null(input$liste.newgroup3))
df$df[,input$liste.newgroup.rename][df$df[,input$liste.newgroup.rename]==input$liste.newgroup3]<-input$text.new.group2
})
##### simplification to checkboxgroupinput ----
observeEvent(input$all_artifact_entry, {
req(input$setnature)
updateCheckboxGroupInput(session, "Nature",
selected = levels(as.factor(df$df[,input$setnature]))) })
observeEvent(input$reset_artifact_entry, {
updateCheckboxGroupInput(session, "Nature",
selected = FALSE)})
observeEvent(input$all_UAS_entry, {
req(input$setlevels)
updateCheckboxGroupInput(session, "UAS",
selected = levels(as.factor(df$df[,input$setlevels])))})
observeEvent(input$reset_UAS_entry, {
updateCheckboxGroupInput(session, "UAS",
selected = FALSE)})
##### creation df.sub that would be used to create plot ----
df.sub <- reactive({
req(!is.null(fileisupload()))
req(!is.null(input$xslider))
req(inputcolor())
df.sub<-df$df
plotcol<-df.sub[,inputcolor()]
df.sub$layer2 <- factor(plotcol)
df.sub$point.size <- size.scale()
df.sub$point.size2<-size.scale()
df.sub<-df.sub %>% relocate(layer2, point.size, point.size2)
if (input$setdate!="null"){
df.sub[,input$setdate] <-as.numeric(df.sub[,input$setdate])
df.sub[,input$setdate][is.na(df.sub[,input$setdate])]<-0
if (!is.null(input$Date2)) {
df.sub<-df.sub %>%
filter(df.sub[,input$setdate] >= input$Date2[1], df.sub[,input$setdate] <= input$Date2[2])}}
if (input$setsector!="null"){
df.sub <- df.sub[df.sub[,input$setsector] %in% input$localisation, ]}
if (input$setlevels!="null"){
df.sub <- df.sub[df.sub[,input$setlevels] %in% input$UAS, ]}
if (input$setnature!="null"){
df.sub <- df.sub[df.sub[,input$setnature] %in% input$Nature, ]}
if (input$setpasse!="null"){
df.sub <- df.sub[df.sub[,input$setpasse]%in% input$Passe, ]}
df.sub<-df.sub %>%
filter(.data[[input$setx]] >= input$xslider[1], .data[[input$setx]] <= input$xslider[2]) %>%
filter(.data[[input$sety]] >= input$yslider[1], .data[[input$sety]] <= input$yslider[2]) %>%
filter(.data[[input$setz]] >= input$zslider[1], .data[[input$setz]] <= input$zslider[2])
df.sub
}) # end of df.sub reactive
##### creation df.sub.minpoint ----
df.sub.minpoint <- reactive({
df.sub.minpoint<-df.sub()
if(!is.null(set.var.gris())) {
df.sub.minpoint<-df.sub.minpoint %>%
filter((.data[[set.var.gris()]] %in% var.sub2()))}
if(!is.null(min.point.sliderx())) {
df.sub.minpoint<-df.sub.minpoint %>%
filter(.data[[input$setx]] >= min(min.point.sliderx()), .data[[input$setx]] <= max(min.point.sliderx())) %>%
filter(.data[[input$sety]] >= min(min.point.slidery()), .data[[input$sety]] <= max(min.point.slidery())) %>%
filter(.data[[input$setz]] >= min(min.point.sliderz()), .data[[input$setz]] <= max(min.point.sliderz()))
}
if (nrow(df.sub.minpoint)>0){
df.sub.minpoint$point.size2<-size.scale()
}
df.sub.minpoint
}) # end of df.sub reactive
##### output.contents ----
output$contents <- renderTable({
req(!is.null(fileisupload()))
isTruthy(df.sub())
df.5<-df.sub()[1:10,]
df.6<-cbind.data.frame(df.5[,input$setx],df.5[,input$sety],df.5[,input$setz],df.5[,input$setID],
df.5[,input$setdate],df.5[,input$setsector],df.5[,input$setlevels],df.5[,input$setnature],
df.5[,input$setpasse])
colnames(df.6)<-c(input$setx,input$sety,input$setz,input$setID,
input$setdate,input$setsector,input$setlevels,
input$setnature,input$setpasse)
return(df.6[1:5,1:9])
})
# output to archeoViz format ----
output.archeoviz <- reactive({
req(!is.null(fileisupload()))
isTruthy(df.sub())
# subsetting:
df <- df.sub()
col.names <- c("id"=input$setID, "xmin"=input$setx, "ymin"=input$sety, "zmin"=input$setz, "layer"=input$setlevels, "object_type"=input$setnature, "object_other"=input$setpasse, "year"=input$setdate)
df <- df[, col.names]
colnames(df) <- names(col.names)
df$square_x <- ""
df$square_y <- ""
# guess if values are in meter, then convert to cm
test.x <- max(df$xmin, na.rm = T) - min(df$xmin, na.rm = T) < 100
test.y <- max(df$ymin, na.rm = T) - min(df$ymin, na.rm = T) < 100
if(test.x & test.y){
df[, c("xmin", "ymin", "zmin")] <- apply(
df[, c("xmin", "ymin", "zmin")], 2, function(x) x * 100)
}
# guess if altitude are used, then convert them into depth values
test.z <- table(df$zmin < 0)
test.z <- test.z[which(names(test.z) == "TRUE")] > test.z[which(names(test.z) == "FALSE")]
if(test.z){ df$zmin <- df$zmin * -1 }
# recoding, if needed:
if(length(unique(df$id)) != nrow(df)){
df$id_original <- df$id
df$id <- seq_len(nrow(df))
showNotification("ID are not unique and have been recoded",
type = "warning")
}
if( length(unique(df$object_other)) == 1 ){
if(unique(df$object_other) == "0"){df$object_other <- ""}
}
if( length(unique(df$year)) == 1) {
if(unique(df$year) == "0"){df$year <- ""}
}
# output:
df[c("id", "square_x", "square_y", "layer", "xmin", "ymin", "zmin", "object_type", "object_other", "year")]
})
output$download.archeoviz <- downloadHandler(
filename = function() {
paste(Sys.Date(),
sub("(.*)\\..*$", "\\1", input$worksheet),
"archeoviz.csv", sep="-")
},
content = function(file) {
write.table(output.archeoviz(), file, row.names = FALSE, sep=",")
}
)
archeoviz.url <- reactive({
req(output.archeoviz())
data.url <- session$registerDataObj(name = "table",
data = output.archeoviz(),
filterFunc = function(data, req) {
httpResponse(200, "text/csv",
write.csv2(data)
)
})
object.id <- gsub(".*w=(.*)&nonce.*", "\\1", data.url)
data.url <- paste0(session$clientData$url_protocol, "//",
session$clientData$url_hostname,
session$clientData$url_pathname,
"_w_", object.id,
"/session/", session$token, "/download/download.archeoviz")
paste0("https://analytics.huma-num.fr/archeoviz/en/?run.plots=TRUE&objects.df=", data.url)
})
output$run.archeoviz <- renderUI({
if(Sys.getenv('SHINY_PORT') != ""){ # only if remote use of the app
actionLink("run.archeoviz",
label = "* Directly send your SEAHORS data to archeoViz",
onclick = paste("window.open('",
archeoviz.url(), "', '_blank')"))
} else( return() )
})
##### 3D plot ----
output$plot3Dbox <- renderUI({
plotlyOutput("plot3d", height = height.size())
})
output$plot3d <- renderPlotly({
df.sub <- df.sub()
df.sub3 <-df.sub.minpoint()
min.size2<-minsize()
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
# if (nrow(df.sub3)>0){
# df.sub$point.size[!((df.sub[,input$setx] %in% df.sub3[,input$setx]) & (df.sub[,input$sety] %in% df.sub3[,input$sety]) & (df.sub[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
# }
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub$point.size[!((df.sub[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
shapeX<-df.sub$shapeX
shape.level<-levels(as.factor(shapeX))
text2<-df.sub$text
p <- plot_ly(df.sub,height = height.size(),width = height.size())
p <-add_trace(p, x = ~df.sub[,input$setx], y = ~df.sub[,input$sety], z = ~df.sub[,input$setz],
type="scatter3d",
color = ~layer2,
colors=myvaluesx,
size = ~point.size,
sizes = c(min.size2,size.scale),
mode = 'markers',
symbol = ~shapeX,
symbols =shape.level,
text = text2,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>')
) # end plotly
if (!is.null(data.fit.3D()) && input$var.fit.3D == "yes"){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit.3D()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub[,input$setID]))
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
p<-add_trace(p,x = ~data.fit.3D[,setXX()], y = ~data.fit.3D[,setYY()], z = ~data.fit.3D[,setZZ()], split = ~data.fit.3D[,input$setREM],
line = list(color=~data.fit.3D$color.fit),
type = "scatter3d", mode = "lines", showlegend = legendplotlyfig(), inherit = F)
}
Xtval<-seq(floor(min(df.sub[[setXX()]])),max(df.sub[[setXX()]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub[[setYY()]])),max(df.sub[[setYY()]]), Yminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ytickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size())]
Ztval<-seq(floor(min(df.sub[[setZZ()]])),max(df.sub[[setZZ()]]), Zminorbreaks())
Zttxt <- rep("",length(Ztval))
Zttxt[seq(1,length(Ztval),Ztickmarks.size())]<-as.character(Ztval)[seq(1,length(Ztval),Ztickmarks.size())]
p <- p %>% layout(
showlegend = legendplotlyfig(),
scene = list(
xaxis = list(title = nameX(),
dtick = Xtickmarks.size(),
#tick0 = floor(min(df.sub[,setXX()])),
#tickmode = "linear",
tickvals=Xtval,
ticktext=Xttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis = list(title = nameY(),
dtick = Ytickmarks.size(),
#tick0 = floor(min(df.sub[,setYY()])),
#tickmode = "linear",
tickvals=Ytval,
ticktext=Yttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
zaxis = list(title = nameZ(),
dtick = Ztickmarks.size(),
#tick0 = floor(min(df.sub[,setZZ()])),
#tickmode = "linear",
tickvals=Ztval,
ticktext=Zttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
camera = list(projection = list(type = 'orthographic')),
aspectmode = "manual",
aspectratio=list(x=ratiox(),y=ratioy(),z=ratioz())),
autosize=FALSE
)
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
session_store$plt <- p
p
})
##### 2D plot ----
##advanced plot ----
output$plot2Dbox <- renderUI({
plotlyOutput("sectionYplot", height = height.size())
})
output$sectionYplot <- renderPlotly({
plot2D.react()
session_store$plt2D<- plot2D.react()
})
plot2D.react<-reactive({
input$run_button
min.size2<-minsize()
orthofile<-NULL
if (input$var.ortho == "yes" ){
orthofile <- switch(input$var1,
xy = if(!is.null(input$file2)) {stack(input$file2$datapath)},
yx = if(!is.null(input$file5)) {stack(input$file5$datapath)},
xz = if(!is.null(input$file3)) {stack(input$file3$datapath)},
yz = if(!is.null(input$file4)) {stack(input$file4$datapath)})
}
height.size2<-height.size()
width.size2 <- width.size()
list.parameter.info<-var.function(input$var1)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
axis.var.name<-list.parameter.info[[3]]
axis.var2.name<-list.parameter.info[[4]]
Xtickmarks.size<-list.parameter.info[[5]]
Ytickmarks.size<-list.parameter.info[[6]]
Xminorbreaks<-list.parameter.info[[7]]
Yminorbreaks<-list.parameter.info[[8]]
isolate ({
df.sub2<-df.sub()
# minor.grid.info<-minor.grid.info.function(df.sub2,var,var2,Xminorbreaks,Xtickmarks.size,Yminorbreaks,Ytickmarks.size)
df.sub3<-df.sub.minpoint()
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
# if (nrow(df.sub3)>0){
# df.sub2$point.size2[!((df.sub2[,input$setx] %in% df.sub3[,input$setx]) & (df.sub2[,input$sety] %in% df.sub3[,input$sety]) & (df.sub2[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
#}
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub2$point.size2[!((df.sub2[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
shapeX<-df.sub2$shapeX
shape.level<-levels(as.factor(shapeX))
if (is.null(orthofile)){
p<- plot_ly(height = height.size(),
width = width.size())
p<- add_trace(p, x = ~df.sub2[[var]], y = ~df.sub2[[var2]],
type="scatter",
color = ~df.sub2$layer2,
colors = myvaluesx,
size = ~df.sub2$point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~df.sub2$shapeX,
symbols = shape.level,
text=df.sub2$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'))
if (input$var.fit.table == "yes" & !is.null(data.fit.3D())){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit.3D()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub2[,input$setID]))
if (length(levels(as.factor(data.fit.3D$color.fit)))>1){
for (i in 1:length (levels(as.factor(data.fit.3D[,input$setREM])))) {
data.fit.3D.2<-data.fit.3D[data.fit.3D[,input$setREM]==levels(as.factor(data.fit.3D[,input$setREM]))[i],]
if (length(levels(as.factor(data.fit.3D.2[["color.fit"]])))>1){
data.fit.3D$color.fit[((data.fit.3D[,input$setx] %in% data.fit.3D.2[,input$setx]) & (data.fit.3D[,input$sety] %in% data.fit.3D.2[,input$sety]) & (data.fit.3D[,input$setz] %in% data.fit.3D.2[,input$setz]))]<-c("#000000") # Black color for refit variable mixing
}}} #end of if
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
p<-add_trace(p,x = ~data.fit.3D[[var]], y = ~data.fit.3D[[var2]], split = ~data.fit.3D[,input$setREM],
line = list(color=~data.fit.3D$color.fit,width=input$w2),
type = "scatter", mode = "lines", showlegend = legendplotlyfig(), inherit = F)
} # end of refit
Xtval<-seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xminorbreaks)
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size)]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size)]
Ytval<-seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]), Yminorbreaks)
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ytickmarks.size)]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size)]
p <- p %>% layout(showlegend = legendplotlyfig(),
scene = list( aspectmode = "manual",
aspectratio=list(x=ratiox(),y=ratioy()),
autosize=FALSE),
xaxis = list(title = paste(axis.var.name),
dtick = Xtickmarks.size,
tick0 = floor(min(df.sub2[[var]])),
#tickmode = "linear",
tickvals=Xtval,
ticktext=Xttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis = list(title = paste(axis.var2.name),
dtick = Ytickmarks.size,
tick0 = floor(min(df.sub2[[var2]])),
#tickmode = "linear",
tickvals=Ytval,
ticktext=Yttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
} else {
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df.sub()$layer2)) %in% levels(as.factor(droplevels(df.sub2$layer2)))]
p <- ggplot2::ggplot()+
ggRGB(img = orthofile,
r = 1,
g = 2,
b = 3,
maxpixels =500000,
ggLayer = T)+
ggplot2::geom_point(data = df.sub2,
aes(x = .data[[var]],
y = .data[[var2]],
fill=layer2,
size=as.factor(point.size2),
shape=shapeX,
text= paste(paste(var,":"), .data[[var]], paste(var2,":"), .data[[var2]], paste(df.sub2$text))
))
if (input$var.fit.table == "yes" & !is.null(data.fit.3D())){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit3()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
if (is.null(colorvalues)) {
data.fit.3D$color.fit <-c("black")
}
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub2[,input$setID]))
# to have black color for refit several origins
if (length(levels(as.factor(data.fit.3D$color.fit)))>1){
for (i in 1:length(levels(as.factor(data.fit.3D[,input$setREM])))) {
data.fit.3D.2<-data.fit.3D[data.fit.3D[,input$setREM]==levels(as.factor(data.fit.3D[,input$setREM]))[i],]
if (is.na(data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]) || data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]){
data.fit.3D$color.fit[((data.fit.3D[,setXX()] %in% data.fit.3D.2[,setXX()]) & (data.fit.3D[,setYY()] %in% data.fit.3D.2[,setYY()]) & (data.fit.3D[,setZZ()] %in% data.fit.3D.2[,setZZ()]))]<-c("#000000") # Black color for refit variable mixing
}}} #end of if
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
varend<-stringr::str_to_lower(paste0(var,"end"))
var2end<-stringr::str_to_lower(paste0(var2,"end"))
p<-p+geom_segment(data=data.fit.3D, aes(x = .data[[var]], y = .data[[var2]], xend=.data[[varend]],
yend=.data[[var2end]]), color=data.fit.3D$color.fit, size=input$w2, inherit.aes = F)
}
p<-p+scale_fill_manual(values=myvaluesx2)+
scale_shape_manual(values=shape.level)+
scale_size_manual(values=c(size.scale,min.size2))+
xlab(paste(axis.var.name))+ylab(paste(axis.var2.name))+
do.call(themeforfigure.choice(), list()) +
theme(legend.position='none')+
theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),
legend.title = element_blank())+
theme(legend.position='none')
p<-p+scale_x_continuous(breaks=seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xtickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xminorbreaks))+
scale_y_continuous(breaks=seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Ytickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Yminorbreaks))
}
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
}) #end isolate
}) #plot2D.react
## interactive stack bar mode ----
df_2 <- reactiveVal(NULL)
observeEvent(input$chr_settingbp, {
req(!is.null(vv()))
req(input$setnature != "null")
req(input$setlevels != "null")
req(input$setlevels != input$setnature)
data.val <-vv()
df2<-data.val%>% group_by(.data[[input$setlevels]],.data[[input$setnature]])%>% summarise(value=n())
df_2(df2)
showModal(
modalDialog(
title = tags$h4(style = "color: red;","Bar plot of selected points per levels and nature"),
easyClose = T,
plotlyOutput("sectioninteractivebarplot")
))
})
output$sectioninteractivebarplot <- renderPlotly({
df2<-df_2()
fig<-plot_ly(df2, x = df2[[input$setlevels]],
y = df2$value,
type = 'bar',
name = df2[[input$setnature]],
text = df2$value
#color = df2[[input$setnature]],
#colors = brewer.pal(length(unique(df2[[input$setnature]])),
# "Paired")
)%>%
layout(barmode = 'stack',hoverlabel = list(bgcolor= 'white') ,bargap = 0.5) %>%
layout(xaxis = list(categoryorder = 'array',
categoryarray = df2[[input$setlevels]]), showlegend = T)
session_store$interactive.stack.bar<- fig
return(fig)
})
## simple 2D plot ----
output$plot2Dbox.simple <- renderUI({
plotOutput("sectionYplot.simple", height = height.size(), width = width.size())
})
output$sectionYplot.simple <- renderPlot({
plot(plot2D.simple.react())
session_store$plt2D.simple<- plot2D.simple.react()
})
plot2D.simple.react<-reactive({
min.size2<-minsize()
orthofile<-NULL
if (input$var.ortho.simple == "yes" ){
orthofile <- switch(input$var1.simple,
xy = if(!is.null(input$file2)) {stack(input$file2$datapath)},
yx = if(!is.null(input$file5)) {stack(input$file5$datapath)},
xz = if(!is.null(input$file3)) {stack(input$file3$datapath)},
yz = if(!is.null(input$file4)) {stack(input$file4$datapath)})
}
df.sub2<-df.sub()
df.sub3<-df.sub.minpoint()
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df.sub()$layer2)) %in% levels(as.factor(droplevels(df.sub2$layer2)))]
# if (nrow(df.sub3)>0){
# df.sub2$point.size2[!((df.sub2[,input$setx] %in% df.sub3[,input$setx]) & (df.sub2[,input$sety] %in% df.sub3[,input$sety]) & (df.sub2[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
# }
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub2$point.size2[!((df.sub2[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
list.parameter.info<-var.function(input$var1.simple)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
axis.var.name<-list.parameter.info[[3]]
axis.var2.name<-list.parameter.info[[4]]
Xtickmarks.size<-list.parameter.info[[5]]
Ytickmarks.size<-list.parameter.info[[6]]
Xminor.breaks<-list.parameter.info[[7]]
Yminor.breaks<-list.parameter.info[[8]]
shapeX<-df.sub2$shapeX
shape.level<-levels(as.factor(shapeX))
#point.size3<-as.factor(df.sub2$point.size2)
p <- ggplot2::ggplot()
if (!is.null(orthofile)){
p<-p + ggRGB(img = orthofile,
r = 1,
g = 2,
b = 3,
maxpixels =500000,
ggLayer = T)
}
p<- p + ggplot2::geom_point(data = df.sub2,
aes(x = .data[[var]],
y = .data[[var2]],
col=factor(layer2)),
size=df.sub2$point.size2,
shape=shapeX
) +
ggplot2::coord_fixed(ratio.simple())
if (input$var.fit.table.simple == "yes" & !is.null(data.fit.3D())){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit3()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
if (is.null(colorvalues)) {
data.fit.3D$color.fit <-c("black")
}
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub2[,input$setID]))
# to have black color for refit several origins
if (length(levels(as.factor(data.fit.3D$color.fit)))>1){
for (i in 1:length(levels(as.factor(data.fit.3D[,input$setREM])))) {
data.fit.3D.2<-data.fit.3D[data.fit.3D[,input$setREM]==levels(as.factor(data.fit.3D[,input$setREM]))[i],]
if (is.na(data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]) || data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]){
data.fit.3D$color.fit[((data.fit.3D[,setXX()] %in% data.fit.3D.2[,setXX()]) & (data.fit.3D[,setYY()] %in% data.fit.3D.2[,setYY()]) & (data.fit.3D[,setZZ()] %in% data.fit.3D.2[,setZZ()]))]<-c("#000000") # Black color for refit variable mixing
}}} #end of if
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
varend<-stringr::str_to_lower(paste0(var,"end"))
var2end<-stringr::str_to_lower(paste0(var2,"end"))
p<-p+geom_segment(data=data.fit.3D, aes(x = .data[[var]], y = .data[[var2]], xend=.data[[varend]],
yend=.data[[var2end]]), color=data.fit.3D$color.fit, size=input$w2, inherit.aes = F)
}
p<-p+ggplot2::scale_color_manual(values=myvaluesx2)+
ggplot2::scale_shape_manual(values=shape.level)+
ggplot2::scale_size_manual(values=c(min.size2,size.scale))+
xlab(paste(axis.var.name))+ylab(paste(axis.var2.name))+
do.call(themeforfigure.choice(), list()) +
theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),
legend.title = element_blank())+
theme(legend.position='none')
p<-p+scale_x_continuous(breaks=seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xtickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xminor.breaks))+
scale_y_continuous(breaks=seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Ytickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Yminor.breaks))
if (input$checkbox.auto.limits==FALSE) {
p<-p + ggplot2::expand_limits(x=c(input$X.limx[1],input$X.limx[2]), y=c(input$Y.limx[1], input$Y.limx[2]))
}
p
}) #end plot2D.react
##### 2D slice ----
set.var.2d.slice<-reactiveVal()
step.input.step2dslice<-reactiveVal(4)
observeEvent(input$step2dslice,{
if (is.numeric(input$step2dslice) && input$step2dslice !=0)
step.input.step2dslice(input$step2dslice)
})
output$range.2d.slice=renderUI({
req(!is.null(fileisupload()))
req(input$var.2d.slice)
set.var.2d.slice<- switch(input$var.2d.slice,
xz = setYY(),
yz = setXX())
set.var.2d.slice(set.var.2d.slice)
xymax = df$df[,set.var.2d.slice] %>% ceiling() %>% max(na.rm = TRUE)
xymin=df$df[,set.var.2d.slice] %>% floor() %>% min(na.rm = TRUE)
sliderInput('range2dslice','Range of slices',min=xymin,max=xymax,value=c(xymin,xymax),step=step.input.step2dslice())
})
observeEvent(c(input$range2dslice, step.input.step2dslice(),input$advanced.slice,input$xslider,input$yslider,input$zslider,myvaluesx(),
minsize(),
size.scale(),
shape_all()), {
req(!is.null(input$range2dslice))
ratio.slice<-(max(input$range2dslice)-min(input$range2dslice))/step.input.step2dslice()
ratio.slice<-ceiling(ratio.slice)
if (ratio.slice<1) {
ratio.slice<-1
}
ratio.slice(ratio.slice)
df.sub.list<-vector("list", ratio.slice)
min.size2<-minsize()
df.sub2<-df.sub()
set.var.2d.slice<-set.var.2d.slice()
set.antivar.2d.slice<-c(setXX(),setYY())[c(setXX(),setYY())!=set.var.2d.slice()]
df.sub3<-df.sub.minpoint()
# if (nrow(df.sub3)>0){
# df.sub2$point.size2[!((df.sub2[,input$setx] %in% df.sub3[,input$setx]) & (df.sub2[,input$sety] %in% df.sub3[,input$sety]) & (df.sub2[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
#}
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub2$point.size2[!((df.sub2[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
liste.valeur.slice<-vector(length=ratio.slice)
a <- new.env()
e(a)
for (j in 1:ratio.slice){
k<-j-1
val<-min(input$range2dslice)+k*step.input.step2dslice()
val2<-val+step.input.step2dslice()
if(val2>max(input$range2dslice)){
val2<-max(input$range2dslice)
}
liste.valeur.slice[j]<-paste("2D slice from ",val," to ",val2, " in ",set.var.2d.slice()," axis")
df.sub.list[[j]]<- filter (df.sub2, .data[[set.var.2d.slice]]>= val, .data[[set.var.2d.slice]]<=val2)
}
if (input$advanced.slice==TRUE){
plotServerList <- lapply(
1:ratio.slice,
function(i) {
plotServer(paste0("plot", i),df.sub.list[i],set.antivar.2d.slice,setZZ(),liste.valeur.slice[i])
} )
} else {
plotServerList <- lapply(
1:ratio.slice,
function(i) {
plotServer.simple(paste0("plot", i),df.sub.list[i],set.antivar.2d.slice,setZZ(),liste.valeur.slice[i],i)
})
}
})
output$plot.2dslide <- renderUI({
ns <- session$ns
tagList(
lapply(1:ratio.slice(),
function(i) {
plotUI(paste0("plot", i))
}
)
)
})
##### output sectiondensityplot slide ----
output$plotdens <- renderUI({
plotOutput("sectiondensityplot", height = height.size(), width = width.size())
})
output$sectiondensityplot <- renderPlot({
df.sub4<-df.sub()
min.size2<-minsize()
size.scale <- size.scale()
df.sub3<-df.sub.minpoint()
# if (nrow(df.sub3)>0){
# df.sub4$point.size2[!((df.sub4[,input$setx] %in% df.sub3[,input$setx]) & (df.sub4[,input$sety] %in% df.sub3[,input$sety]) & (df.sub4[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
# }
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub4$point.size2[!((df.sub4[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
myvaluesx<-unlist(myvaluesx())
orthofile<-NULL
if (input$var.ortho2 == "yes" ){
orthofile <- switch(input$var3,
xy = if(!is.null(input$file2)) {stack(input$file2$datapath)},
yx = if(!is.null(input$file5)) {stack(input$file5$datapath)},
xz = if(!is.null(input$file3)) {stack(input$file3$datapath)},
yz = if(!is.null(input$file4)) {stack(input$file4$datapath)}) }
list.parameter.info<-var.function(input$var3)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
nameaxis<-c(list.parameter.info[[3]],list.parameter.info[[4]])
Xtickmarks.size<-list.parameter.info[[5]]
Ytickmarks.size<-list.parameter.info[[6]]
Xminor.breaks<-list.parameter.info[[7]]
Yminor.breaks<-list.parameter.info[[8]]
df.sub4$density <- get_density(df.sub4[[var]], df.sub4[[var2]], n = 100)
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df$df[[inputcolor()]])) %in% levels(as.factor(df.sub4[[inputcolor()]]))]
# Density curve of x left panel
ydensity <- ggplot2::ggplot(df.sub4, aes(.data[[var]], fill=factor(.data[[inputcolor()]]))) +
ggplot2::geom_density(alpha=.5) +
ggplot2::scale_fill_manual( values = myvaluesx2)+
do.call(themeforfigure.choice(), list()) +
ggplot2::theme(legend.position = "none")
# Density curve of y right panel
zdensity <- ggplot2::ggplot(df.sub4, aes(.data[[var2]], fill=factor(.data[[inputcolor()]]))) +
ggplot2::geom_density(alpha=.5) +
scale_fill_manual( values = myvaluesx2) +
do.call(themeforfigure.choice(), list()) +
ggplot2::theme(legend.position = "none")+coord_flip()
blankPlot <- ggplot2::ggplot() +
ggplot2::geom_blank(aes(1,1))+
ggplot2::theme(plot.background = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank()
)
if (is.null(orthofile)){
p<-ggplot(df.sub4,aes(.data[[var]], .data[[var2]], color = density)) +
ggplot2::geom_point(aes(.data[[var]], .data[[var2]], color = density), alpha=transpar(), size=df.sub4$point.size2)+
ggplot2::scale_size_manual(values=c(size.scale,min.size2))+
ggplot2::labs(x = nameaxis[1],y = nameaxis[2])+
do.call(themeforfigure.choice(), list()) +
ggplot2::theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()))+
ggplot2::coord_fixed(ratio.simple())
# {if (input$ratio.to.coord)coord_fixed()}
} else { p <- ggplot2::ggplot()+ ggRGB(img = orthofile,
r = 1,
g = 2,
b = 3,
maxpixels =500000,
ggLayer = T) +
ggplot2::geom_point(df.sub4,mapping=aes(.data[[var]], .data[[var2]], color = density),alpha=transpar(), size=df.sub4$point.size2)+
ggplot2::labs(x = nameaxis[1],y = nameaxis[2])
}
if (input$var.plotlyg.lines== "yes") {
p<- p + ggplot2::geom_density_2d(mapping=aes(.data[[var]],.data[[var2]], color = after_stat(level)),data=df.sub4)}
p<- p + viridis::scale_color_viridis()+
ggplot2::guides(fill = guide_legend(title = "Level"))+
ggplot2::theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),)
p<- p + ggplot2::scale_x_continuous(breaks=seq(floor(min(df.sub4[[var]])),max(df.sub4[[var]]),Xtickmarks.size),minor_breaks = seq(floor(min(df.sub4[[var]])),max(df.sub4[[var]]),Xminor.breaks)) +
ggplot2::scale_y_continuous(breaks=seq(floor(min(df.sub4[[var2]])),max(df.sub4[[var2]]),Ytickmarks.size), minor_breaks = seq(floor(min(df.sub4[[var2]])),max(df.sub4[[var2]]),Yminor.breaks))
if (input$var.density.curves== "yes") {
p <- gridExtra::grid.arrange(ydensity, blankPlot, p, zdensity,
ncol=2, nrow=2, widths=c(4, 1.4), heights=c(1.4, 4))
} else {
p}
session_store$plotdensity <- p
p
}) #end output$sectiondensityplot
observeEvent(input$transferxyz,{
if (dim(df$df[duplicated(df$df[,input$setID]),])[1]>0) {
showModal(modalDialog(
title = "This option is not possible without an unique ID !",
HTML(paste(dim(df$df[duplicated(df$df[,input$setID]),])[1], " object ID(s) is/are not unique ... <br> "))
))
return()
}
rotated.new.dataxy<-rotated.new.dataxy()
names(rotated.new.dataxy)<-c(paste(input$setID),"X.rotated","Y.rotated")
if(isTRUE("X.rotated" %in% names(df$df))==TRUE) {
df$df<-df$df[,!colnames(df$df) %in% c("rotated")]
}
df$df<-full_join(df$df,rotated.new.dataxy)
updateSelectInput(session,"setx",
choices=names(df$df["X.rotated"]),
selected = names(df$df["X.rotated"]))
updateSelectInput(session,"sety",
choices=names(df$df["Y.rotated"]),
selected = names(df$df["Y.rotated"]))
})
###output rotated 2D plot ----
output$plot2Drota<- renderUI({
plotlyOutput("plot2d2", height = height.size())
})
output$plot2Drota2<- renderUI({
plotlyOutput("plot2d3", height = height.size())
})
output$plot2d2 <- renderPlotly({
req(input$pi2)
req(input$ssectionXy3)
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
min.size2<-minsize()
df.sub5<-rotated.table()
df.sub5<-as.data.frame(df.sub5)%>%
filter(.data[["x2"]]>= min(input$ssectionXx3), .data[["x2"]]<= max(input$ssectionXx3)) %>%
filter(.data[["y2"]]>= min(input$ssectionXy3), .data[["y2"]]<= max(input$ssectionXy3))
shapeX<-df.sub5$shapeX
shape.level<-levels(as.factor(shapeX))
df.sub5$point.size2<-size.scale()
temp.rot<-data.frame(df.sub5[,input$setID],df.sub5["x2"],df.sub5["y2"])
colnames(temp.rot)<-c("ID","X.rotated","Y.rotated")
rotated.new.dataxy(temp.rot)
p<- plot_ly(df.sub5, x = ~x2, y = ~y2,
type="scatter",
color = ~layer2,
colors = myvaluesx,
size = ~point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~shapeX,
symbols = shape.level,
text=df.sub5$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'),
height=height.size(),
width=width.size()
)
Xtval<-seq(floor(min(df.sub5[["x2"]])),max(df.sub5[["x2"]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub5[["y2"]])),max(df.sub5[["y2"]]), Yminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ytickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size())]
p <- p %>% layout(showlegend = legendplotlyfig(),
scene = list(aspectratio=list(x=ratiox(),y=ratioy(),z=ratioz())),
xaxis = list(title=paste0(nameX()," modified"),
dtick = Xtickmarks.size(),
tickvals=Xtval,
ticktext=Xttxt,
tick0 = floor(min(df.sub5[["x2"]])),
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis=list(title=paste(nameY()," modified"),
dtick = Ytickmarks.size(),
tickvals=Ytval,
ticktext=Yttxt,
tick0 = floor(min(df.sub5[["y2"]])),
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
session_store$plotrota <- p
p
})
output$plot2d3 <- renderPlotly({
req(input$pi2)
req(input$ssectionXy3)
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
min.size2<-minsize()
df.sub5<-rotated.table()
df.sub5<-df.sub5%>%
filter(.data[["x2"]]>= min(input$ssectionXx3), .data[["x2"]]<= max(input$ssectionXx3)) %>%
filter(.data[["y2"]]>= min(input$ssectionXy3), .data[["y2"]]<= max(input$ssectionXy3))
df.sub5<-as.data.frame(df.sub5)
df.sub5$var2<- df.sub5[,input$setz]
switch(input$var.section2D,
xz={var<-"x2"
var3<-paste0(nameX()," modified")},
yz={ var<-"y2"
var3<-paste0(nameY()," modified") })
shapeX<-df.sub5$shapeX
shape.level<-levels(as.factor(shapeX))
df.sub5$point.size2<-size.scale()
p<- plot_ly(df.sub5, x = ~df.sub5[[var]], y = ~df.sub5[[setZZ()]],
type="scatter",
color = ~layer2,
colors = myvaluesx,
size = ~point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~shapeX,
symbols = shape.level,
text=df.sub5$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'),
height=height.size(),
width=width.size()
)
Xtval<-seq(floor(min(df.sub5[[var]])),max(df.sub5[[var]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub5[[setZZ()]])),max(df.sub5[[setZZ()]]), Zminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ztickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ztickmarks.size())]
p <-p %>% layout(showlegend = legendplotlyfig(),
scene = list(aspectratio=list(x=ratiox(),y=ratioy(),z=ratioz())),
xaxis = list(title=paste0(var3),
dtick = Xtickmarks.size(),
tick0 = floor(min(df.sub5[[var]])),
tickvals=Xtval,
ticktext=Xttxt,
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis=list(title=paste(nameZ()),
dtick = Ytickmarks.size(),
tickvals=Ytval,
ticktext=Yttxt,
tick0 = floor(min(df.sub5[,input$setz])),
# tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg"))
})
##### download button ----
##3D plot
output$downloadData3D <- downloadHandler(
filename = function() {
paste("plot3D - ",paste(input$file1$name)," - ", Sys.Date(), ".html", sep="")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(session_store$plt), file, selfcontained = TRUE)
}
)
options(shiny.usecairo=T)
##2d plot
output$downloadData2D <- downloadHandler(
filename = function() {
paste("plot2D - ",paste(input$file1$name)," - ", Sys.Date(), ".html", sep="")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(session_store$plt2D), file, selfcontained = TRUE)
}
)
output$downloadData2D.simple <- downloadHandler(
filename = function(){paste("plot2D - ",paste(input$file1$name)," - ", Sys.Date(), '.pdf', sep = '')},
content = function(file){
ggsave(session_store$plt2D.simple,filename=file, device = "pdf")
},
)
##2D plot slice.simple mode
output$download.slice <- downloadHandler(
filename = function(){paste("plot2D - ",paste(input$file1$name)," - ", Sys.Date(), '.pdf', sep = '')},
content = function(file){
plot.lists<-list()
for (i in 1:nb.slice()) {
plot.lists[[i]]<-get(paste0("session_store$test$",i), envir=e())
}
ggsave(grid.arrange(grobs = plot.lists, ncol = 1),filename=file, device = "pdf",scale=nb.slice(),limitsize=FALSE)
},
)
##2d plot slice
output$downloadData2d.slice <- downloadHandler(
filename = function() {
paste("plot2D.slice - ",paste(input$file1$name)," - ", Sys.Date(), ".html", sep="")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(session_store$plotslice), file, selfcontained = TRUE)
}
)
##2d plot density
output$downloadDatadensity <- downloadHandler(
filename = function(){paste("plotDensity - ",paste(input$file1$name)," - ", Sys.Date(), '.pdf', sep = '')},
content = function(file){
ggsave(session_store$plotdensity,filename=file, device = "pdf")
},
)
# refit table
output$downloadData_redata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"_refit_table.csv",sep="")
},
content = function(file) {
write.table(data.fit3()[,4:ncol(data.fit3())], file, row.names = FALSE, sep=";",dec=".")
}
)
# raw table
output$downloadData_rawdata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),paste(input$file1$name),".csv",sep="")
},
content = function(file) {
write.table(df$df[,3:ncol(df$df)], file, row.names = FALSE, sep=";",dec=".")
}
)
# pivot table
output$downloadData_pivotdata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"pivot.table",".csv")
},
content = function(file) {
write.table(Pivotdatatable(), file, row.names = FALSE, sep=";",dec=".")
}
)
# save color
output$save.col<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"save.col",".csv")
},
content = function(file) {
write.table(save.col.react(), file, row.names = FALSE, sep=";",dec=".")
}
)
output$save.col.fit<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"save.col.refit",".csv")
},
content = function(file) {
write.table(save.col.react.fit(), file, row.names = FALSE, sep=";",dec=".")
}
)
#rotated table
output$downloadData_rotateddata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"rotated coordinates",".csv")
},
content = function(file) {
write.table(rotated.new.dataxy(), file, row.names = FALSE, sep=";",dec=".")
}
)
##### output summary slide ----
output$liste.summary=renderUI({
req(!is.null(fileisupload()))
checkboxGroupInput("listesum", h4("Variables for summary table"),
choices = names(df$df)[c(3:ncol(df$df))])
})
Pivotdatatable<-reactive({req(input$listesum)
df.sub<-df.sub()
liste.sum<-c(input$listesum) # creation d'une liste
table_matos<-df.sub %>% group_by(across(liste.sum)) %>% summarize(Freq=n())
colnames(table_matos)<-c(unlist(liste.sum),"n")
table_matos})
output$summary <- renderTable({
Pivotdatatable()
})
##### output Table ----
# output$table <- shiny::renderDataTable(
output$table <- DT::renderDataTable(
DT::datatable(
df.sub()[,-c(1:6)], extensions = 'Buttons', options = list(
lengthMenu = list(c(5, 15,50,100, -1), c('5', '15','50','100', 'All')),
pageLength = 15,
initComplete = htmlwidgets::JS(
"function(settings, json) {",
paste0("$(this.api().table().container()).css({'font-size': '", font.size, "'});"),
"}")
))
)#end renderDataTable
#### button example of Cassenade ----
observeEvent(input$button_example, {
updateTabsetPanel(session, "mainpanel",
selected = "Load data")
path <- paste0(tempdir(), "/cassenade.csv")
write.csv2(SEAHORS::cassenade, path)
input_file1.name("cassenade.csv")
input_file1.datapath(path)
df$file.fit <- SEAHORS::cassenade.refits
getdata.launch(1)
})
#### rmarkdown report template ----
w.report<-function(){
writeLines(con = "report.Rmd", text = "---
title: 'Welcome to *SEAHORS* report'
output: html_document
date : '`r format(Sys.time())`'
params:
data: NA
dataraw: NA
file: NA
path: NA
plot2: NA
plot2simple: NA
plot3: NA
plotrota: NA
plotdens: NA
nat: NA
pas: NA
loca: NA
UAS: NA
tobj: NA
xsli: NA
ysli: NA
zsli: NA
dat: NA
linfos: NA
col: NA
setx: NA
sety: NA
setz: NA
setid: NA
setsect: NA
setnat: NA
setlvl: NA
setdate: NA
setpasse: NA
fileextra: NA
filerem: NA
setrem: NA
tabrefit: NA
---
```{r setup, include= FALSE}
library(DT)
```
```{r, echo=FALSE}
if (file.exists(paste0(getwd(),'www/logo1.png'))){
htmltools::img(src = knitr::image_uri(file.path(getwd(), 'www/logo1.png')),
alt = 'logo',
style = 'position:absolute; top:0; right:0; padding:10px; height:150px ;')
}
```
```{r, echo=FALSE, include=FALSE}
file<-params$file
path<-params$path
data2<-params$data
nat<- params$nat
pas<-params$pas
loca <-params$loca
UAS <-params$UAS
tobj <-params$tobj
xsli<-params$xsli
ysli <-params$ysli
zsli<-params$zsli
dat <-params$dat
linfos<-params$linfos
col<-params$col
setx<-params$setx
sety<-params$sety
setz<-params$setz
setid<-params$setid
setsect<-params$setsect
setnat <-params$setnat
setlvl<-params$setlvl
setdate <-params$setdate
setpasse<-params$setpasse
fileextra<-params$fileextra
filerem <-params$filerem
setrem<-params$setrem
tabrefit <-params$tabrefit
data2raw<-params$dataraw
```
---
This report was produced using the file **`r file[1]`** <br>
### Setting informations
X axis: **`r setx`** <br>
- sliders Xlimits between **`r xsli[1]` ** and **`r xsli[2]` ** <br>
Y axis: **`r sety`** <br>
- sliders Ylimits between **`r ysli[1]` ** and **`r ysli[2]` ** <br>
Z axis: **`r setz`** <br>
-sliders Zlimits between **`r zsli[1]` ** and **`r zsli[2]` ** <br>
Year(s): **`r setdate `** <br>
- sliders between **`r dat[1] `** and **`r dat[2] `**<br>
Unique object IDs: **`r setid `**<br>
```{r , echo=FALSE, message=FALSE, out.width='50%'}
if (setid != 'null'){
if(dim(data2raw[duplicated(data2raw[,setid]),])[1]>0) {
paste('Object IDs were not unique') } else {
paste('All objects have unique IDs')
}}
```
Context: **`r setsect `** <br>
-with **`r loca`** parameters selected <br>
Levels: **`r setlvl `** <br>
-with **`r UAS `** parameters selected <br>
Type: **`r setnat `** <br>
-with **`r nat `** parameters selected <br>
Others: **`r setpasse `** <br>
-with **`r pas `** parameters selected<br>
**`r tobj `**
### Coloried variable :
```{r , echo=FALSE, message=FALSE, out.width='100%'}
col
```
### The data :
```{r , echo=FALSE, message=FALSE, out.width='100%'}
data2
```
### The refit data :
```{r , echo=FALSE, message=FALSE, out.width='100%'}
if (!is.null(tabrefit)) {
tabrefit} else {
paste('no refit table has been added')
}
```
### The plot(s) :
```{r plotlyout, echo=FALSE, message=FALSE, out.width='100%'}
if (!is.null(params$plot2)) {params$plot2}
if (!is.null(params$plot2simple)) {params$plot2simple}
if (!is.null(params$plot3)) {params$plot3}
if (!is.null(params$plotdens)) {params$plotdens}
if (!is.null(params$plotdens)) {params$plotrota}
```")
}
#### Rmarkdown report export ----
output$export.Rmarkdown<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"_report_Rmarkdown",".", input$docpdfhtml)
},
content = function(file) {
if (!is.null(data.fit3())){
data.fit4<-data.fit3()[,4:ncol(data.fit3())]
} else {
data.fit4<-NULL}
params2 <- list(data = df.sub()[,7:ncol(df.sub())],
dataraw = df$df[,4:ncol(df$df)],
file = input$file1$name,
path= input$file1$datapath,
plot3= session_store$plt,
plot2= session_store$plt2D,
plot2simple=session_store$plt2D.simple,
plotrota=session_store$plotrota,
plotdens=session_store$plotdensity,
nat=input$Nature,
pas=input$Passe,
loca=input$localisation,
UAS=input$UAS,
tobj=textnbobject(),
xsli=input$xslider,
ysli=input$yslider,
zsli=input$zslider,
dat=input$Date2,
linfos=listinfosmarqueur(),
col=save.col.react(),
setx=input$setx,
sety=input$sety,
setz=input$setz,
setid=input$setID,
setsect=input$setsector,
setnat=input$setnature,
setlvl=input$setlevels,
setdate=input$setdate,
setpasse= input$setpasse,
fileextra=input$file.extradata$name,
filerem=input$file.fit$name,
setrem=input$setREM,
tabrefit=data.fit4
)
w.report()
tmp_dir <- tempdir()
tmp_pic2 <- file.path(tmp_dir,"www/logo1.png")
file.copy("www/logo1.png", tmp_pic2, overwrite = TRUE)
tempReport <- tempfile(fileext = ".Rmd") # make sure to avoid conflicts with other shiny sessions if more params are used
file.copy("report.Rmd", tempReport, overwrite = TRUE)
rmarkdown::render(tempReport, output_format = paste0(input$docpdfhtml,"_document"), output_file = file, output_options = list(self_contained = TRUE),
params = params2
)
}
)
############################### ADD save & load for v1.9 ----
#button
observeEvent(input$save_load, {
req(!is.null(fileisupload()))
showModal(
modalDialog(
title = tags$h4(style = "color: red;","Save settings and data"),
easyClose = T,
fluidRow(
br(),
column(7, shinyWidgets::radioGroupButtons(
inputId = "Save_settings",
label = NULL,
choices = c("Save settings" = 1, "Save settings and data" = 2),
status = "danger"
),br(),
br(),),
br(),
br(),
#column(3, actionButton("go.gen.settings", "Generate"),),
column(7, downloadButton("export.settings", "Export settings as .rds document")),
br(),
hr(),
br(),),
)
)
})
observeEvent(input$save_load2, {
showModal(
modalDialog(
title = tags$h4(style = "color: red;","Load file"),
easyClose = T,
fluidRow(
column(7, fileInput("file.set", "Choose File to import settings (.rds)",
multiple = TRUE,
accept = c(
".rds")),
actionButton("go.load.settings", "load it")),
br(),
tags$h5(style = "color: blue;","This option is still in progress. Not all parameters could be loaded "),
tags$h5(style = "color: blue;"," And is still not totally perfectly scripted. You may need to load twice or third the datafile to recover all the parameters. ")
)
)
)
})
#save
global<-reactiveValues(digitnumber=NULL)
output$export.settings<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"save.settings",".rds")
},
content = function(file) {
req(!is.null(fileisupload))
global$data <-0
if (input$Save_settings ==2){
global$data <-"data_upload"
global$df<-df$df
}
global$digitnumber<-digitnumber()
global$setnature<-input$setnature
global$minsize<-minsize()
global$size.scale<-size.scale()
global$stepX<-stepX()
global$stepY<-stepY()
global$stepZ<-stepZ()
global$transpar<-transpar()
global$data.fit<-data.fit()
global$data.fit2<-data.fit2()
global$data.fit3<-data.fit3()
global$rotated.new.dataxy<-rotated.new.dataxy()
global$shape_all<-shape_all()
global$setXX<- setXX()
global$setYY<- setYY()
global$setZZ<- setZZ()
global$height.size<- height.size()
global$width.size<- width.size() #
global$data.fit.3D<- data.fit.3D() #
global$listinfosmarqueur<- listinfosmarqueur()
global$colorofrefit<- colorofrefit()#t
global$legendplotlyfig<- legendplotlyfig()
global$inputcolor<- inputcolor()
global$save.col.react.fit<- save.col.react.fit()
global$mypaletteofcolors.fit<- mypaletteofcolors.fit()
global$ratiox<- ratiox()
global$ratioy<- ratioy()
global$ratioz<- ratioz()
global$ratio.simple<- ratio.simple()
global$font_size<- font_size()
global$font_tick<- font_tick()
global$nameX<- input$Name.X
global$nameY<- input$Name.Y
global$nameZ<- input$Name.Z
global$Xtickmarks.size<- Xtickmarks.size()
global$Ytickmarks.size<- Ytickmarks.size()
global$Ztickmarks.size<- Ztickmarks.size()
global$Xminorbreaks<- Xminorbreaks()
global$Yminorbreaks<- Yminorbreaks()
global$Zminorbreaks<- Zminorbreaks()
global$ID.no.suppl.data.txt<- ID.no.suppl.data.txt()
global$notunique.txt<- notunique.txt()
global$notunique2.txt<- notunique2.txt()
global$suppl.no.include.txt<- suppl.no.include.txt()
global$input_file1.name<-input_file1.name()
global$input_file1.datapath<-input_file1.datapath()
global$getdata.launch<-getdata.launch()
global$ratio.slice<-ratio.slice()
global$nb.slice<-nb.slice()
global$themeforfigure.choice<-themeforfigure.choice()
global$textnbobject<-textnbobject()
global$var.sub2<-var.sub2()
global$min.point.sliderx<-min.point.sliderx()
global$min.point.slidery<-min.point.slidery()
global$min.point.sliderz<-min.point.sliderz()
global$set.var.gris<-set.var.gris()
global$set.var.2d.slice<-set.var.2d.slice()
global$step.input.step2dslice<-step.input.step2dslice()
#reactiveValues
global$values.newgroup<-values$newgroup
#input
global$setx<-input$setx
global$sety<-input$sety
global$setz<-input$setz
global$setnature<-input$setnature
global$setlevels<-input$setlevels
global$setdate<-input$setdate
global$setpasse<-input$setpasse
global$setID<-input$setID
global$setsector<-input$setsector
global$checkbox.invX<-input$checkbox.invX
global$input_xslider_1<-input$xslider[1]
global$input_xslider_2<-input$xslider[2]
global$checkbox.invY<-input$checkbox.invY
global$input_yslider_1<-input$yslider[1]
global$input_yslider_2<-input$yslider[2]
global$checkbox.invZ<-input$checkbox.invZ
global$input_zslider_1<-input$zslider[1]
global$input_zslider_2<-input$zslider[2]
global$pi2<-input$pi2
global$file2<-input$file2
global$file3<-input$file3
global$file4<-input$file4
global$file5<-input$file5
global$var.plotlyg.lines<-input$var.plotlyg.lines
global$var.density.curves<-input$var.density.curves
global$listeinfos.go<-input$listeinfos.go # to modify // mettre en reactival pour reaction auto
global$themeforfigure.list<-input$themeforfigure.list
#selectInput
global$Colors<-input$Colors
#checkboxGroupInput
global$Nature<-input$Nature
global$Passe<-input$Passe
global$localisation<-input$localisation
global$UAS<-input$UAS
global$listeinfos<-input$listeinfos
#sliderinput
global$yslider<- input$yslider
global$xslider<-input$xslider
print(input$xslider)
global$zslider<-input$zslider
print(input$zslider)
global$Date2<-input$Date2
global$ssectionXy2<-input$ssectionXy2
global$ssectionXx2<-input$ssectionXx2
global$ssectionXz2<-input$ssectionXz2
global$ssectionXx3<-input$ssectionXx3
global$ssectionXy3<-input$ssectionXy3
global$range2dslice<-input$range2dslice
#selectInput
global$setshape2<-input$setshape2
global$setshape2.1<-input$setshape2.1
global$setshape2.2<-input$setshape2.2
#numeric imput
global$ratio.to.coord.simple.2<-input$ratio.to.coord.simple.2
#pour les couleurs
global$save.col.react<-save.col.react()
global$save.col.react.fit<-save.col.react.fit()
#df$file.color<-save.col.react()
#df$file.color.fit<-save.col.react.fit()
#radiobutton
global$var1<-input$var1
global$var.ortho<-input$var.ortho
global$var.fit.table<-input$var.fit.table
global$var1.simple<-input$var1.simple
global$var.ortho.simple<-input$var.ortho.simple
global$var.fit.table.simple<-input$var.fit.table.simple
global$var.2d.slice<-input$var.2d.slice
global$var.section2D<-input$var.section2D
global$var3<-input$var3
global$var.ortho2<-input$var.ortho2
global$var.plotlyg.lines<-input$var.plotlyg.lines
global$var.density.curves<-input$var.density.curves
global$separatormerge<-input$separatormerge
global$var.fit.3D<-input$var.fit.3D
#checkboxinput
global$header<-input$header
global$set.dec<-input$set.dec
global$advanced.slice<-input$advanced.slice
to_save <- reactiveValuesToList(global)
saveRDS(to_save, file = file)
})
#load part
nexstep<-reactiveVal(0)
input_file.load<-reactiveVal(NULL)
input_file.load.datapath<-reactiveVal(NULL)
observe({
req(nexstep()==1)
global.load<-readRDS(input_file.load.datapath())
df$df$shapeX[df$df[,global.load$setshape2.1] %in% global.load$setshape2.2]<-global.load$setshape2
input_file1.name(global.load$input_file1.name)
updateNumericInput(session,"minsize", value=global.load$minsize)
updateNumericInput(session,"point.size", value=global.load$size.scale)
updateCheckboxInput(session,'advanced.slice',value = global.load$advanced.slice)
getdata.launch(global.load$getdata.launch)
rotated.new.dataxy(global.load$rotated.new.dataxy)
updateSliderInput(session,"alpha.density", value=global.load$transpar)
updateNumericInput(session,"height.size.b", value=global.load$height.size)
updateNumericInput(session,"width.size.b", value=global.load$width.size)
transpar(global.load$transpar)
height.size(global.load$height.size)
width.size(global.load$width.size)
shape_all(global.load$shape_all)
updateCheckboxInput(session, 'optioninfosfigplotly ', value = global.load$legendplotlyfig)
legendplotlyfig(global.load$legendplotlyfig)
listinfosmarqueur(global.load$listinfosmarqueur) ################################### celui la est a revoir
ID.no.suppl.data.txt(global.load$ID.no.suppl.data.txt)
notunique.txt(global.load$notunique.txt)
notunique2.txt(global.load$notunique2.txt)
updateSliderInput(session,"pi2",
value = global.load$pi2)
updateNumericInput(session,"ratiox", value=global.load$ratiox)
updateNumericInput(session,"ratioy", value=global.load$ratioy)
updateNumericInput(session,"ratioz", value=global.load$ratioz)
ratiox(global.load$ratiox)
ratioy(global.load$ratioy)
ratioz(global.load$ratioz)
updateNumericInput(session,"ratio.to.coord", value=global.load$ratio.simple)
updateNumericInput(session,"ratio.to.coord.simple", value=global.load$ratio.simple)
updateNumericInput(session,"ratio.to.coord.simple.2", value=global.load$ratio.to.coord.simple.2)
updateNumericInput(session,"stepXsize", value=global.load$stepX)
updateNumericInput(session,"stepYsize", value=global.load$stepY)
updateNumericInput(session,"stepZsize", value=global.load$stepZ)
stepX(global.load$stepX)
stepY(global.load$stepY)
stepZ(global.load$stepZ)
updateRadioButtons(session,"var1",selected = global.load$var1)
updateRadioButtons(session,"var.ortho",selected = global.load$var.ortho)
updateRadioButtons(session,"var.fit.table",selected = global.load$var.fit.table)
updateRadioButtons(session,"var1.simple",selected = global.load$var1.simple)
updateRadioButtons(session,"var.ortho.simple",selected = global.load$var.ortho.simple)
updateRadioButtons(session,"var.fit.table.simple",selected = global.load$var.fit.table.simple)
updateRadioButtons(session,"var.2d.slice",selected = global.load$var.2d.slice)
updateRadioButtons(session,"var.section2D",selected = global.load$var.section2D)
updateRadioButtons(session,"var3",selected = global.load$var3)
updateRadioButtons(session,"var.ortho2",selected = global.load$var.ortho2)
updateRadioButtons(session,"var.plotlyg.lines",selected = global.load$var.plotlyg.lines)
updateRadioButtons(session,"var.density.curves",selected = global.load$var.density.curves)
updateRadioButtons(session,"separatormerge",selected = global.load$separatormerge1)
updateRadioButtons(session,"var.fit.3D",selected = global.load$var.fit.3D)
set.var.2d.slice(global.load$set.var.2d.slice)
step.input.step2dslice(global.load$step.input.step2dslice)
ratio.slice(global.load$ratio.slice)
nb.slice(global.load$nb.slice)
#input_file1.datapath(global.load$input_file1.datapath)
updateSelectInput(session, 'themeforfigure.list', selected = global.load$themeforfigure.list)
themeforfigure.choice(global.load$themeforfigure.choice)
textnbobject(global.load$textnbobject) # no need ?
updateRadioButtons(session,"var.plotlyg.lines",selected = global.load$var.plotlyg.lines)
updateRadioButtons(session,"var.density.curves",selected = global.load$var.density.curves)
updateNumericInput(session,"fontsizeaxis",value=global.load$font_size)
updateNumericInput(session,"fontsizetick",value=global.load$font_tick)
updateTextInput(session, 'Name.X',value= global.load$nameX)
updateTextInput(session, 'Name.Y',value= global.load$nameY)
updateTextInput(session, 'Name.Z',value= global.load$nameZ)
updateNumericInput(session,"Xtickmarks",value=global.load$Xtickmarks.size)
updateNumericInput(session,"Ytickmarks",value=global.load$Ytickmarks.size)
updateNumericInput(session,"Ztickmarks",value=global.load$Ztickmarks.size)
updateNumericInput(session,"Xminor.breaks",value=global.load$Xminorbreaks)
updateNumericInput(session,"Yminor.breaks",value=global.load$Yminorbreaks)
updateNumericInput(session,"Zminor.breaks",value=global.load$Zminorbreaks)
set.var.gris(global.load$set.var.gris)
var.sub2(global.load$var.sub2)
updateSelectInput(session, 'set.var.gris.2D ', selected = global.load$set.var.gris)
updateCheckboxGroupInput(session, 'set.var.gris.2D ', selected = global.load$set.var.gris)
#values$newgroup<-global.load$values.newgroup
#refit to finish
data.fit(global.load$data.fit) ##for import fit data
data.fit2(global.load$data.fit2) ##for import fit data
data.fit3(global.load$data.fit3) ##for import fit data
data.fit.3D(global.load$data.fit.3D) ## for refit data for 3D plot
colorofrefit(global.load$colorofrefit)## color base for refit
#save.col.react.fit(global.load$save.col.react.fit)
mypaletteofcolors.fit(global.load$mypaletteofcolors.fit)
suppl.no.include.txt(global.load$suppl.no.include.txt)
save.col.react(global.load$save.col.react)
df$file.color<-save.col.react()
save.col.react.fit(global.load$save.col.react.fit)
df$file.color.fit<-save.col.react.fit()
updateSelectInput(session,"setx",
selected = global.load$setx)
updateSelectInput(session,"sety",
selected = global.load$sety)
updateSelectInput(session,"setz",
selected = global.load$setz)
updateCheckboxInput(session,"checkbox.invX",
value =global.load$checkbox.invX)
updateCheckboxInput(session,"checkbox.invY",
value =global.load$checkbox.invY)
updateCheckboxInput(session,"checkbox.invZ",
value =global.load$checkbox.invZ)
updateSelectInput(session,"setnature",
selected = global.load$setnature)
updateSelectInput(session,"setlevels",
selected = global.load$setlevels)
updateSelectInput(session,"setdate",
selected = global.load$setdate)
updateSelectInput(session,"setpasse",
selected = global.load$setpasse)
updateSelectInput(session,"setID",
selected = global.load$setID)
updateSelectInput(session,"setsector",
selected = global.load$setsector)
df.sub()
nexstep(2)
})
observe({
req(nexstep()==2)
global.load<-readRDS(input_file.load.datapath())
dmin=min(as.numeric(df$df[,global.load$setdate]), na.rm=T)
dmax=max(as.numeric(df$df[,global.load$setdate]), na.rm=T)
if (!is.infinite(dmin) && !is.infinite(dmax)) {
updateSliderInput(session,'Date2',min=dmin,max=dmax,value=c(global.load$Date2[1],global.load$Date2[2]))
}
xmax = df$df[,global.load$setXX] %>% as.numeric() %>% ceiling() %>% max(na.rm = TRUE)
xmin=df$df[,global.load$setXX] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'xslider',min=xmin,max=xmax,
value=c(global.load$xslider[1],global.load$xslider[2]),step=global.load$stepX)
ymax = df$df[,global.load$setYY] %>% as.numeric() %>% ceiling() %>% max(na.rm = TRUE)
ymin=df$df[,global.load$setYY] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
zmax = df$df[,global.load$setZZ] %>% as.numeric() %>% ceiling() %>% max(na.rm = TRUE)
zmin=df$df[,global.load$setZZ] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'yslider','y limits',min=ymin,max=ymax,
value=c(global.load$yslider[1],global.load$yslider[2]),step=global.load$stepY)
updateSliderInput(session,'zslider','z limits',min=zmin,max=zmax,
value=c(global.load$zslider[1],global.load$zslider[2]),step=global.load$stepZ)
updateCheckboxGroupInput(session,"UAS", selected=global.load$UAS)
updateCheckboxGroupInput(session,"Nature", selected=global.load$Nature)
updateCheckboxGroupInput(session,"Passe", selected=global.load$Passe)
updateCheckboxGroupInput(session,"localisation", selected=global.load$localisation)
updateCheckboxGroupInput(session,"listeinfos", selected=global.load$listeinfos)
# don't work strangely
updateSliderInput(session,'ssectionXy2',min=global.load$yslider[1],max=global.load$yslider[2],
value=c(global.load$ssectionXy2[1],global.load$ssectionXy2[2]),step=global.load$stepY)
updateSliderInput(session,'ssectionXx2',min=global.load$xslider[1],max=global.load$xslider[2],
value=c(global.load$ssectionXx2[1],global.load$ssectionXx2[2]),step=global.load$stepX)
updateSliderInput(session,'ssectionXz2',min=global.load$zslider[1],max=global.load$zslider[2],
value=c(global.load$ssectionXz2[1],global.load$ssectionXz2[2]),step=global.load$stepZ)
min.point.sliderx(global.load$min.point.sliderx)
min.point.slidery(global.load$min.point.slidery)
min.point.sliderz(global.load$min.point.sliderz)
updateSliderInput(session,'ssectionXy3',min=global.load$yslider[1],max=global.load$yslider[2],
value=c(global.load$ssectionXy3[1],global.load$ssectionXy3[2]),step=global.load$stepY)
updateSliderInput(session,'ssectionXx3',min=global.load$xslider[1],max=global.load$xslider[2],
value=c(global.load$ssectionXx3[1],global.load$ssectionXx3[2]),step=global.load$stepX)
updateSliderInput(session,'range2dslice',min=global.load$range2dslice[1],max=global.load$range2dslice[2],
value=c(global.load$range2dslice[1],global.load$range2dslice[2]))
df.sub.minpoint()
nexstep(4)
})
observeEvent(nexstep(),{
req(nexstep()==4)
req(!is.null(ttemp()))
global.load<-readRDS(input_file.load.datapath())
req(!is.null(df.sub.minpoint()))
nexstep(0)
input_file.load.datapath(NULL)
})
ttemp<-reactiveVal(NULL)
observeEvent(nexstep(),{
req(nexstep()==1)
updateRadioButtons(session,"bt2",selected=3)
ttemp(1)
})
observe({
req(!is.null(ttemp()))
req(!is.null(input_file.load.datapath()))
global.load<-readRDS(input_file.load.datapath())
req(!is.null(global.load$Colors))
updateSelectInput(session,"Colors",
selected = global.load$Colors)
inputcolor(global.load$Colors)
basiccolor()
})
observeEvent(input$file.set, {
nexstep(0)
input_file.load.datapath(NULL)
input_file.load(input$file.set$name)
input_file.load.datapath(input$file.set$datapath)
})
observe({
file = input$go.load.settings
ext = tools::file_ext(input_file.load.datapath())
req(file)
validate(need(ext == "rds", "Please upload a rds file"))
req(nexstep()==0)
global.load<-readRDS(input_file.load.datapath())
digitnumber(global.load$digitnumber)
updateCheckboxInput(session,'header',value = global.load$header)
updateCheckboxInput(session,'set.dec',value = global.load$set.dec)
if (global.load$data =="data_upload"){
df$df<-global.load$df
updateTabsetPanel(session, "mainpanel",
selected = "Load data")
inputcolor("null")
fileisupload(1)
} else {
if (is.null(df$df)) {
input_file.load(NULL)
input_file.load.datapath(NULL)
}
else {
updateTabsetPanel(session, "mainpanel",
selected = "Load data")
inputcolor(global.load$Colors)
fileisupload(1)
}
req(!is.null(df$df))
}
nexstep(1)
})
} # end server
Try the SEAHORS package in your browser
Any scripts or data that you put into this service are public.
SEAHORS documentation built on June 8, 2025, 11:36 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions app_server
app_server <- function(input, output, session) {
digitnumber<-reactiveVal(11)
base::options(digits=11) ##add 1.8.x
observeEvent(input$digit.number, {
digitnumber(input$digit.number)
base::options(digits=digitnumber())
})
##### set variable to avoid notes in R package----
.stretch <- NULL
layer2 <- NULL
level <- NULL
null.2 <- NULL
point.size <- NULL
point.size2 <- NULL
shapeX.2 <- NULL
text.2 <- NULL
##### necessary settings----
options(shiny.maxRequestSize=150*1024^2) ## limits 150 MO to import
font.size <- "8pt"
vv<-reactiveVal(NULL) ## for plotly_selected
minsize<-reactiveVal(0.25) ##for min point
size.scale<-reactiveVal(3) ##for point
stepX<-reactiveVal(0.1) ## step size sliders
stepY<-reactiveVal(0.1) ## step size sliders
stepZ<-reactiveVal(0.1) ## step size sliders
transpar<-reactiveVal(1) ## alpha for density plot
data.fit<-reactiveVal() ##for import fit data
data.fit2<-reactiveVal() ##for import fit data
data.fit3<-reactiveVal() ##for import fit data
rotated.new.dataxy<-reactiveVal() ## to include new xyzdata from rotation
shape_all<-reactiveVal("circle") ##for import fit data
session_store <- reactiveValues() ## for save plot
setXX<-reactiveVal(NULL) ##input$setx
setYY<-reactiveVal(NULL) ##input$sety
setZZ<-reactiveVal(NULL) ##input$setz
height.size<-reactiveVal(800) ## default size of figure
width.size<-reactiveVal(1000) ## default size of figure
data.fit.3D<-reactiveVal() ## for refit data for 3D plot
listinfosmarqueur<-reactiveVal(NULL) ## for listinfos to be null at the beginning.
colorofrefit<-reactiveVal("red")## color base for refit
legendplotlyfig<-reactiveVal(TRUE) ##for legends.
inputcolor<-reactiveVal("null")
fileisupload<-reactiveVal(NULL)
save.col.react.fit<-reactiveVal()
mypaletteofcolors.fit<-reactiveVal()
nnrow.df.df<-reactiveVal(0) ##nrow df$df
ratiox<-reactiveVal(1) ## aspectratio X
ratioy<-reactiveVal(1) ## aspectratio y
ratioz<-reactiveVal(1) ## aspectratio z
ratio.simple<-reactiveVal(1)
font_size<-reactiveVal(12)
font_tick<-reactiveVal(12)
nameX<-reactiveVal("X")
nameY<-reactiveVal("Y")
nameZ<-reactiveVal("Z")
Xtickmarks.size<-reactiveVal()
Ytickmarks.size<-reactiveVal()
Ztickmarks.size<-reactiveVal()
Xminorbreaks<-reactiveVal(1)
Yminorbreaks<-reactiveVal(1)
Zminorbreaks<-reactiveVal(1)
ID.no.suppl.data.txt<-reactiveVal("no data")
notunique.txt<-reactiveVal("no data")
notunique2.txt<-reactiveVal("no data")
suppl.no.include.txt<-reactiveVal("no data")
## update 1.4 - to import
input_file1.name<-reactiveVal()
input_file1.datapath<-reactiveVal()
getdata.launch<-reactiveVal()
e<-reactiveVal(NULL) ## create an environment to save the 2D.slice pdf
ratio.slice<-reactiveVal(1)
nb.slice<-reactiveVal(1) ##nb of slice for saving it
fileisupload.avoidload<-reactiveVal() ## add for 1.9
##### import data----
df<-reactiveValues( #creation df
df=NULL) # end reactivevalues
observeEvent(input$file1, {
input_file1.name(input$file1$name)
input_file1.datapath(input$file1$datapath)
})
observeEvent(input$getData, {
getdata.launch(input$getData)
})
observe({
req(!is.null(input_file1.datapath()))
extension <- tools::file_ext(input_file1.name())
switch(extension,
csv = {updateSelectInput(session, "worksheet", choices = input_file1.name())},
xls = { selectionWorksheet <-excel_sheets(path = input_file1.datapath())
updateSelectInput(session, "worksheet", choices = selectionWorksheet)},
xlsx = { selectionWorksheet <-excel_sheets(path = input_file1.datapath())
updateSelectInput(session, "worksheet", choices = selectionWorksheet)})
})
observeEvent(getdata.launch(), {
req(!is.null(input_file1.datapath()))
extension <- tools::file_ext(input_file1.name())
df$df2 <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input_file1.datapath(), n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input_file1.datapath(), n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input_file1.datapath(), n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input_file1.datapath(),
header = input$header,
sep = sep2, stringsAsFactors = F, fileEncoding="latin1",
dec=".")},
xls = readxl::read_xls(input_file1.datapath(), sheet=input$worksheet),
xlsx = readxl::read_xlsx(input_file1.datapath(), sheet=input$worksheet))
fileisupload(1)
fileisupload.avoidload(1) #add for 1.9
})# end observe of df$df2
observeEvent(!is.null(fileisupload()), { ## add two necessary columns for the rest of manipulations, correct issues with comma and majuscule
req(!is.null(fileisupload()))
req(!is.null(fileisupload.avoidload())) #add for 1.9
null<-"0"
shapeX<-shape_all()
df$df<-df$df2[,!sapply(df$df2, function(x) is.logical(x))] ##remove column without data
if (input$set.dec == TRUE){
df$df[] <- apply(df$df,2,function (x) stringr::str_replace_all(x,",","."))
} else{}
if(!is.null(df$df[sapply(df$df, function(x) !is.numeric(x))])) {
df$df[sapply(df$df, function(x) !is.numeric(x))] <- mutate_all(df$df[sapply(df$df, function(x) !is.numeric(x))], .funs=stringr::str_to_lower)}
text<-""
df$df<-cbind(shapeX,text,null,df$df)
df$df[is.na(df$df)] <- "" ### add to 1.8.x
nnrow.df.df(nrow(df$df))
listinfosmarqueur(1)
}) #end observe
##### reset data ----
observeEvent(input$reset.BDD, {
fileisupload(NULL)
shinyjs::refresh()
shinyjs::reset('file1')
df$df <- NULL
df$df2 <- NULL
# input_file1(NULL)
input_file1.name(NULL)
input_file1.datapath(NULL)
}, priority = 1000)
#### others options ----
observeEvent(input$Colors,{
inputcolor(input$Colors)
})
observeEvent(input$minsize, {
minsize(input$minsize)
})
observeEvent(input$alpha.density, {
transpar(input$alpha.density)
})
observeEvent(input$point.size,{
size.scale(input$point.size)
})
output$X.limx2=renderUI({
req(input$checkbox.auto.limits==FALSE)
req(!is.null(fileisupload()))
req(input$xslider)
z2min=df$df[,input$setx] %>% floor() %>% min(na.rm = TRUE)
z2max=df$df[,input$setx] %>% ceiling() %>% max(na.rm = TRUE)
z2diff=z2max-z2min
zmin=z2min-z2diff*25/100
zmax=z2max+z2diff*25/100
sliderInput('X.limx','X lim',min=zmin,max=zmax,value=c(zmin,zmax),step=0.5)
})
output$Y.limx2=renderUI({
req(input$checkbox.auto.limits==FALSE)
req(!is.null(fileisupload()))
req(input$yslider)
z2min=df$df[,input$sety] %>% floor() %>% min(na.rm = TRUE)
z2max=df$df[,input$sety] %>% ceiling() %>% max(na.rm = TRUE)
z2diff=z2max-z2min
zmin=z2min-z2diff*25/100
zmax=z2max+z2diff*25/100
sliderInput('Y.limx','Y lim',min=zmin,max=zmax,value=c(zmin,zmax),step=0.5)
})
icon_svg_path = "M10,6.536c-2.263,0-4.099,1.836-4.099,4.098S7.737,14.732,10,14.732s4.099-1.836,4.099-4.098S12.263,6.536,10,6.536M10,13.871c-1.784,0-3.235-1.453-3.235-3.237S8.216,7.399,10,7.399c1.784,0,3.235,1.452,3.235,3.235S11.784,13.871,10,13.871M17.118,5.672l-3.237,0.014L12.52,3.697c-0.082-0.105-0.209-0.168-0.343-0.168H7.824c-0.134,0-0.261,0.062-0.343,0.168L6.12,5.686H2.882c-0.951,0-1.726,0.748-1.726,1.699v7.362c0,0.951,0.774,1.725,1.726,1.725h14.236c0.951,0,1.726-0.773,1.726-1.725V7.195C18.844,6.244,18.069,5.672,17.118,5.672 M17.98,14.746c0,0.477-0.386,0.861-0.862,0.861H2.882c-0.477,0-0.863-0.385-0.863-0.861V7.384c0-0.477,0.386-0.85,0.863-0.85l3.451,0.014c0.134,0,0.261-0.062,0.343-0.168l1.361-1.989h3.926l1.361,1.989c0.082,0.105,0.209,0.168,0.343,0.168l3.451-0.014c0.477,0,0.862,0.184,0.862,0.661V14.746z"
### button for png dl
dl_button <- list(
name = "Download as .png",
icon = list(
path = icon_svg_path,
transform = "scale(0.84) translate(-1, 0)"
),
click = htmlwidgets::JS('function(gd) {Plotly.downloadImage(gd, {format: "png"}
) }') )
##### option figures ----
observeEvent(input$fontsizeaxis, {
font_size(input$fontsizeaxis)
})
observeEvent(input$fontsizetick, {
font_tick(input$fontsizetick)
})
observeEvent(input$Xtickmarks, {
Xtickmarks.size(input$Xtickmarks)
})
observeEvent(input$Ytickmarks, {
Ytickmarks.size(input$Ytickmarks)
})
observeEvent(input$Ztickmarks, {
Ztickmarks.size(input$Ztickmarks)
})
observeEvent(input$Xminor.breaks, {
Xminorbreaks(input$Xminor.breaks)
})
observeEvent(input$Yminor.breaks, {
Yminorbreaks(input$Yminor.breaks)
})
observeEvent(input$Zminor.breaks, {
Zminorbreaks(input$Zminor.breaks)
})
output$themeforfigure=renderUI({
req(!is.null(fileisupload()))
themes <- c("theme_bw", "theme_classic", "theme_dark", "theme_grey", "theme_light", "theme_linedraw", "theme_minimal")
selectInput("themeforfigure.list", h4("Theme for 'Simple 2Dplot'"),
choices = themes,
selected = "theme_minimal")
})
themeforfigure.choice<-reactiveVal(c("theme_minimal"))
observeEvent(input$themeforfigure.list,{
themeforfigure.choice(c(input$themeforfigure.list))
})
##### option size of figure ----
observeEvent(input$height.size.a, {
height.size(input$height.size.a)
})
#
observeEvent(input$height.size.b, {
height.size(input$height.size.b)
})
observeEvent(input$width.size.b, {
width.size(input$width.size.b)
})
#
observeEvent(input$height.size.b.simple, {
height.size(input$height.size.b.simple)
})
observeEvent(input$width.size.b.simple, {
width.size(input$width.size.b.simple)
})
#
observeEvent(input$height.size.c, {
height.size(input$height.size.c)
})
observeEvent(input$width.size.c, {
width.size(input$width.size.c)
})
#
observeEvent(input$height.size.d, {
height.size(input$height.size.d)
})
observeEvent(input$width.size.d, {
width.size(input$width.size.d)
})
#
observeEvent(input$height.size.e, {
height.size(input$height.size.e)
})
observeEvent(input$width.size.e, {
width.size(input$width.size.e)
})
observeEvent(input$ratiox, {
ratiox(input$ratiox)
})
observeEvent(input$ratioy, {
ratioy(input$ratioy)
})
observeEvent(input$ratioz, {
ratioz(input$ratioz)
})
observeEvent(input$ratio.to.coord.simple, {
ratio.simple(input$ratio.to.coord.simple)
})
observeEvent(input$ratio.to.coord.simple.2, {
ratio.simple(input$ratio.to.coord.simple.2)
})
observeEvent(input$ratio.to.coord, {
ratio.simple(input$ratio.to.coord)
})
##### function used in the script ----
#function for density
get_density <- function(x, y, ...) {
dens <- MASS::kde2d(x, y, ...)
ix <- findInterval(x, dens$x)
iy <- findInterval(y, dens$y)
ii <- cbind(ix, iy)
return(dens$z[ii])
}
#function for newgroup
dataModal <- function() {
if (!is.null(vv) && !is.null(values$newgroup)) {
modalDialog(
selectInput("select.new.group", label = h3("Select the new group"),
choices = values$newgroup,
selected = values$newgroup[1]),
textInput("NewGroup", "Choose the name of assignement",value = "new.variable"),
footer = tagList(
modalButton("Cancel"),
actionButton("Change", "OK")
)
)
}
}
#function for refit
seq2 <- function(from, to, by=1){
if (to>=from){
return(seq(from, to, by))
}else{
return(NULL)
}
}
#function for orthopho import from Rstoolbox
.toRaster <- function(x) {
if (inherits(x, "SpatRaster")) {
return(stack(x))
} else {
return(x)
}
}
.numBand <- function(raster, ...){
bands <- list(...)
lapply(bands, function(band) if(is.character(band)) which(names(raster) == band) else band )
}
ggRGB<-function(img, r = 3, g = 2, b = 1, scale, maxpixels = 5e+05,
stretch = "none", ext = NULL, limits = NULL, clipValues = "limits",
quantiles = c(0.02, 0.98), ggObj = TRUE, ggLayer = FALSE,
alpha = 1, coord_equal = TRUE, geom_raster = FALSE, nullValue = 0)
{
img <- .toRaster(img)
verbose <- getOption("RStoolbox.verbose")
annotation <- !geom_raster
rgb <- unlist(.numBand(raster = img, r, g, b))
nComps <- length(rgb)
if (inherits(img, "RasterLayer"))
img <- brick(img)
rr <- sampleRegular(img[[rgb]], maxpixels, ext = ext, asRaster = TRUE)
RGB <- getValues(rr)
if (!is.matrix(RGB))
RGB <- as.matrix(RGB)
if (!is.null(limits)) {
if (!is.matrix(limits)) {
limits <- matrix(limits, ncol = 2, nrow = nComps,
byrow = TRUE)
}
if (!is.matrix(clipValues)) {
if (!anyNA(clipValues) && clipValues[1] == "limits") {
clipValues <- limits
}
else {
clipValues <- matrix(clipValues, ncol = 2, nrow = nComps,
byrow = TRUE)
}
}
for (i in 1:nComps) {
if (verbose) {
message("Number of pixels clipped in ",
c("red", "green", "blue")[i],
" band:\n", "below limit: ", sum(RGB[,
i] < limits[i, 1], na.rm = TRUE), " | above limit: ",
sum(RGB[, i] > limits[i, 2], na.rm = TRUE))
}
RGB[RGB[, i] < limits[i, 1], i] <- clipValues[i,
1]
RGB[RGB[, i] > limits[i, 2], i] <- clipValues[i,
2]
}
}
rangeRGB <- range(RGB, na.rm = TRUE)
if (missing("scale")) {
scale <- rangeRGB[2]
}
if (rangeRGB[1] < 0) {
RGB <- RGB - rangeRGB[1]
scale <- scale - rangeRGB[1]
rangeRGB <- rangeRGB - rangeRGB[1]
}
if (scale < rangeRGB[2]) {
warning("Scale < max value. Resetting scale to max.",
call. = FALSE)
scale <- rangeRGB[2]
}
RGB <- na.omit(RGB)
if (stretch != "none") {
stretch <- tolower(stretch)
for (i in seq_along(rgb)) {
RGB[, i] <- .stretch(RGB[, i], method = stretch,
quantiles = quantiles, band = i)
}
scale <- 1
}
naind <- as.vector(attr(RGB, "na.action"))
nullbands <- sapply(list(r, g, b), is.null)
if (any(nullbands)) {
RGBm <- matrix(nullValue, ncol = 3, nrow = NROW(RGB))
RGBm[, !nullbands] <- RGB
RGB <- RGBm
}
if (!is.null(naind)) {
z <- rep(NA, times = ncell(rr))
z[-naind] <- rgb(RGB[, 1], RGB[, 2], RGB[, 3], max = scale,
alpha = alpha * scale)
}
else {
z <- rgb(RGB[, 1], RGB[, 2], RGB[, 3], max = scale, alpha = alpha *
scale)
}
df_raster <- data.frame(coordinates(rr), fill = z, stringsAsFactors = FALSE)
x <- y <- fill <- NULL
if (ggObj) {
exe <- as.vector(extent(rr))
df <- data.frame(x = exe[1:2], y = exe[3:4])
if (annotation) {
dz <- matrix(z, nrow = nrow(rr), ncol = ncol(rr),
byrow = TRUE)
p <- ggplot2::annotation_raster(raster = dz, xmin = exe[1],
xmax = exe[2], ymin = exe[3], ymax = exe[4],
interpolate = FALSE)
if (!ggLayer) {
p <- ggplot2::ggplot() + p + ggplot2::geom_blank(data = df, aes(x = x,
y = y))
}
}
else {
p <- ggplot2::geom_raster(data = df_raster, aes(x = x, y = y,
fill = fill), alpha = alpha)
if (!ggLayer) {
p <- ggplot2::ggplot() + p + ggplot2::scale_fill_identity()
}
}
if (coord_equal & !ggLayer)
p <- p + ggplot2::coord_equal()
return(p)
}
else {
return(df_raster)
}
}
# functions for 2D slice
plotUI <- function(id) {
ns <- NS(id)
if (input$advanced.slice==TRUE){
plotlyOutput(ns("plot"), height = height.size()) } else {
plotOutput(ns("plot.2"), height = height.size())
}
}
plotServer <- function(id,df.sub.a, Xvar, Yvar,liste.valeur.slice) {
moduleServer(
id,
function(input, output, session) {
t2 <- list(
family = "Arial",
size = 14,
color = "red")
output$plot <- renderPlotly({
df.sub2<-df.sub()
set.antivar.2d.slice<-c(setXX(),setYY())[c(setXX(),setYY())!=set.var.2d.slice()]
set.antivar.2d.name<-c(nameX(),nameY())[c(setXX(),setYY())!=set.var.2d.slice()]
Xtickmarks.size<-c(Xtickmarks.size(),Ytickmarks.size())[c(setXX(),setYY())!=set.var.2d.slice()]
yymax = df.sub2[,setZZ()] %>% ceiling() %>% max(na.rm = TRUE)
yymin=df.sub2[,setZZ()] %>% floor() %>% min(na.rm = TRUE)
xymax = df.sub2[,set.antivar.2d.slice] %>% ceiling() %>% max(na.rm = TRUE)
xymin=df.sub2[,set.antivar.2d.slice] %>% floor() %>% min(na.rm = TRUE)
df.sub.a<-as.data.frame(df.sub.a)
min.size2<-minsize()
size.scale <- size.scale()
myvaluesx<-unlist(myvaluesx())
shapeX<-df.sub.a$shapeX
shape.level<-levels(as.factor(shapeX))
p<- plot_ly(x=~df.sub.a[,Xvar], y = ~df.sub.a[,Yvar],
type="scatter",
color = ~df.sub.a$layer2,
colors = myvaluesx,
size = ~df.sub.a$point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~df.sub.a$shapeX,
symbols = shape.level,
text=df.sub.a$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'),
height = height.size(),
width = width.size())
Xtval<-seq(floor(min(df.sub.a[[Xvar]])),max(df.sub.a[[Xvar]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub.a[[Yvar]])),max(df.sub.a[[Yvar]]), Zminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ztickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ztickmarks.size())]
p<-p %>% layout(showlegend = legendplotlyfig(),
title = list(text=liste.valeur.slice,font=t2,x =0.1),
scene = list(aspectratio=list(x=1,y=1,z=1)),
xaxis = list(title=paste(set.antivar.2d.name), range=c(xymin,xymax),
dtick = Xtickmarks.size,
tick0 = floor(min(df.sub.a[,Xvar])),
tickvals=Xtval,
ticktext=Xttxt,
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis=list(title=paste(nameZ()), range=c(yymin,yymax),
dtick = Ztickmarks.size(),
tick0 = floor(min(df.sub.a[,Yvar])),
tickvals=Ytval,
ticktext=Yttxt,
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
}) # end of renderPlotly
}
)
}
plotServer.simple <- function(id,df.sub.a, Xvar, Yvar,liste.valeur.slice,i) {
moduleServer(
id,
function(input, output, session) {
t2 <- list(
family = "Arial",
size = 14,
color = "red")
output$plot.2 <- renderPlot({
df.sub2<-df.sub()
set.antivar.2d.slice<-c(setXX(),setYY())[c(setXX(),setYY())!=set.var.2d.slice()]
set.antivar.2d.name<-c(nameX(),nameY())[c(setXX(),setYY())!=set.var.2d.slice()]
Xtickmarks.size<-c(Xtickmarks.size(),Ytickmarks.size())[c(setXX(),setYY())!=set.var.2d.slice()]
yymax = df.sub2[,setZZ()] %>% ceiling() %>% max(na.rm = TRUE)
yymin=df.sub2[,setZZ()] %>% floor() %>% min(na.rm = TRUE)
xymax = df.sub2[,set.antivar.2d.slice] %>% ceiling() %>% max(na.rm = TRUE)
xymin=df.sub2[,set.antivar.2d.slice] %>% floor() %>% min(na.rm = TRUE)
df.sub.a<-as.data.frame(df.sub.a)
min.size2<-minsize()
size.scale <- size.scale()
myvaluesx<-unlist(myvaluesx())
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df.sub()$layer2)) %in% levels(as.factor(droplevels(df.sub.a$layer2)))]
shapeX<-df.sub.a$shapeX
shape.level<-levels(as.factor(shapeX))
ppsz<-df.sub.a$point.size2
p <- ggplot2::ggplot()
p<- p + ggplot2::geom_point(data = df.sub.a,
aes(x = .data[[set.antivar.2d.slice]],
y = .data[[setZZ()]],
col=factor(layer2)),
size=ppsz,
shape=shapeX
)+
ggplot2::coord_fixed(ratio.simple())
p<- p + ggplot2::scale_color_manual(values=myvaluesx2)+
ggplot2::scale_shape_manual(values=shape.level)+
ggplot2::scale_size_manual(values=c(min.size2,size.scale))+
xlab(paste(set.antivar.2d.name))+ylab(nameZ())+
do.call(themeforfigure.choice(), list()) +
theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),
legend.title = element_blank())+
theme(legend.position='none')
p<-p+ggplot2::scale_x_continuous(limits= c(xymin,xymax), breaks=seq(floor(min(xymin)),max(xymax),Xtickmarks.size), minor_breaks =seq(floor(min(xymin)),max(xymax),Xminorbreaks()))+
ggplot2::scale_y_continuous(limits= c(yymin,yymax),breaks=seq(floor(min(yymin)),max(yymax),Ztickmarks.size()), minor_breaks = seq(floor(min(yymin)),max(yymax),Zminorbreaks()))
nb.slice(i)
assign(paste0("session_store$test$",i),p, envir=e())
p
}) # end of renderPlotly
}
)
}
#function for color
color.function<-function (levelofcolor,name,selected_rainbow,loadingfile){
uvalues <-levels(as.factor(levelofcolor))
n <- length(uvalues)
choices <- as.list(uvalues)
#myorder <- as.list(1:n)
if (!is.null (loadingfile)) {
mycolors <-unlist(loadingfile)
selected_rainbow<-1
} else {
mycolors <- list("darkgreen", "blue","purple", "green","pink","orange","grey","aquamarine","chartreuse",
"mintcream","salmon","brown","lightblue","lightslateblue","gold")}
colors <- paste0("background:",mycolors,";")
colors <- paste0(colors,"color:black;")
colors <- paste0(colors,"font-family: Arial;")
colors <- paste0(colors,"font-weight: bold;")
selected2 <-mycolors
nk <- length(mycolors) ## to repeat colors when there are more bars than the number of colors
tagList(
div(br()),
div(
lapply(1:n, function(i){
k <- i %% nk
if (k==0) k=nk
if (selected_rainbow == "1") {
selected2 <-mycolors[i] }
shinyWidgets::spectrumInput(
inputId = paste0(name,i),
label = paste0(uvalues[i], ": " ),
choices = list(mycolors,
as.list(rainbow(10)),
as.list(heat.colors(10)),
as.list(terrain.colors(10)),
as.list(cm.colors(10)),
as.list(topo.colors(10)
)
),
selected = selected2,
options = list(`toggle-palette-more-text` = "Show more")
)
}),
)
)
} # end of color.function
# function for switching axis
var.function<-function(var.xyz){
var<-setXX()
var2<-setYY()
axis.var.name<-nameX()
axis.var2.name<-nameY()
Xtickmarks.size<-Xtickmarks.size()
Ytickmarks.size<-Ytickmarks.size()
Xminorbreaks<-Xminorbreaks()
Yminorbreaks<-Yminorbreaks()
if (var.xyz != "xy"){
switch(var.xyz,
# xy={
# var<-setXX()
# var2<-setYY()
# axis.var.name<-nameX()
# axis.var2.name<-nameY()
# Xtickmarks.size<-Xtickmarks.size()
# Ytickmarks.size<-Ytickmarks.size()
# Xminorbreaks<-Xminorbreaks()
# Yminorbreaks<-Yminorbreaks()
# },
yz={ var<-setYY()
var2<-setZZ()
axis.var.name<-nameY()
axis.var2.name<-nameZ()
Xtickmarks.size<-Ytickmarks.size()
Ytickmarks.size<-Ztickmarks.size()
Xminorbreaks<-Yminorbreaks()
Yminorbreaks<-Zminorbreaks()
},
xz={ var<-setXX()
var2<-setZZ()
axis.var.name<-nameX()
axis.var2.name<-nameZ()
Xtickmarks.size<-Xtickmarks.size()
Ytickmarks.size<-Ztickmarks.size()
Xminorbreaks<-Xminorbreaks()
Yminorbreaks<-Zminorbreaks()
},
yx={ var<-setYY()
var2<-setXX()
axis.var.name<-nameY()
axis.var2.name<-nameX()
Xtickmarks.size<-Ytickmarks.size()
Ytickmarks.size<-Xtickmarks.size()
Xminorbreaks<-Yminorbreaks()
Yminorbreaks<-Xminorbreaks()
}
) } else {} # enf of if
new.list.parameter<-list(var,var2,axis.var.name,axis.var2.name,Xtickmarks.size,Ytickmarks.size,Xminorbreaks,Yminorbreaks)
return(new.list.parameter)
}
# # function for minor grid
# minor.grid.info.function<-function(var.xyz,var,var2,Xminorbreaks,Xtickmarks.size,Yminorbreaks,Ytickmarks.size){
# Xtval<-seq(floor(min(var.xyz[[var]])),max(var.xyz[[var]]), Xminorbreaks)
# Xttxt <- rep("",length(Xtval))
# Xttxt[seq(1,length(Xtval),Xtickmarks.size)]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size)]
#
# Ytval<-seq(floor(min(var.xyz[[var2]])),max(var.xyz[[var2]]), Yminorbreaks)
# Yttxt <- rep("",length(Ytval))
# Yttxt[seq(1,length(Ytval),Ytickmarks.size)]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size)]
#
# Ztval<-seq(floor(min(var.xyz[[setZZ()]])),max(var.xyz[[setZZ()]]), Zminorbreaks())
# Zttxt <- rep("",length(Ztval))
# Zttxt[seq(1,length(Ztval),Ztickmarks.size())]<-as.character(Ztval)[seq(1,length(Ztval),Ztickmarks.size())]
#
# minor.grid.info<-list(Xtval,Xttxt,Ytval,Yttxt,Ztval,Zttxt)
# return(minor.grid.info)
# }
# function for rotated 2DPlot ----
rotated.table<-reactive({
isTruthy(df.sub())
points_start<-df.sub()
M <- cbind.data.frame(points_start[,input$setx],points_start[,input$sety])
alpha <- input$pi2 # in degree
M <- as.matrix(M)
# centrage
centroid <- colMeans(M)
Mc <- M - matrix(centroid, nrow=nrow(M), ncol=2, byrow = TRUE)
# matrix of rotation
alpha <- alpha/180*pi
R <- matrix(c(cos(alpha), sin(alpha), -sin(alpha), cos(alpha)), 2, 2)
# rotation
Mr <- Mc%*%R
# translation to come back at the center
Mr <- Mr + matrix(centroid, nrow=nrow(M), ncol=2, byrow = TRUE)
# normalisation of data
inidataxmax<- points_start[,input$setx]%>%as.numeric()%>%ceiling()%>% max()
inidataxmin<- points_start[,input$setx]%>%as.numeric()%>%floor()%>% min()
inidataymax<- points_start[,input$sety]%>%as.numeric()%>%ceiling()%>% max()
inidataymin<- points_start[,input$sety]%>%as.numeric()%>%floor()%>% min()
points_start$x2<-((Mr[,1]-min(Mr[,1]))/(max(Mr[,1])-min(Mr[,1])))*(abs(inidataxmax-inidataxmin))
points_start$y2<-((Mr[,2]-min(Mr[,2]))/(max(Mr[,2])-min(Mr[,2])))*(abs(inidataymax-inidataymin))
rotated.table<-points_start
})
##### output loading slide ----
liste.x<-reactiveVal(c("X.rotated","x","X","null","SPATIAL..X"))
observeEvent(input$setx,{
liste.x(c(input$setx))
})
liste.y<-reactiveVal(c("Y.rotated","y","Y","null","SPATIAL..Y"))
observeEvent(input$sety,{
liste.y(c(input$sety))
})
liste.z<-reactiveVal(c("z","Z","null","SPATIAL..Z"))
observeEvent(input$setz,{
liste.z(c(input$setz))
})
liste.date<-reactiveVal(c("Years","periods","SPATIAL..Year","Year"))
observeEvent(input$setdate,{
liste.date(c(input$setdate))
})
liste.nature2<-reactiveVal(c("Type","null","Nature","Code"))
observeEvent(input$setnature,{
liste.nature2(c(input$setnature))
})
liste.levels<-reactiveVal(c("UAS","Levels","null","SPATIAL..USfield","Assemblage"))
observeEvent(input$setlevels,{
liste.levels(c(input$setlevels))
})
liste.passe2<-reactiveVal(c("Passe","null"))
observeEvent(input$setpasse,{
liste.passe2(c(input$setpasse))
})
liste.ID<-reactiveVal(c("ID","Point","null","fieldID"))
observeEvent(input$setID,{
liste.ID(c(input$setID))
})
liste.sector2<-reactiveVal(c("null","context","localisation","square","Sector","SPATIAL..Square_field","Square"))
observeEvent(input$setsector,{
liste.sector2(c(input$setsector))
})
output$set.x=renderUI({
req(!is.null(fileisupload()))
selectInput("setx", h4("x (Default name: x)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.x())
})
output$set.y=renderUI({
req(!is.null(fileisupload()))
selectInput("sety", h4("y (Default name: y)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.y())
})
output$set.z=renderUI({
req(!is.null(fileisupload()))
selectInput("setz", h4("z (Default name: z)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.z())
})
observeEvent(input$setx,{
df$df[,input$setx]<-df$df[,input$setx]%>% as.numeric()
setXX(input$setx)
nameX(input$setx)
})
observeEvent(input$sety,{
df$df[,input$sety]<-df$df[,input$sety]%>% as.numeric()
setYY(input$sety)
nameY(input$sety)
})
observeEvent(input$setz,{
df$df[,input$setz]<-df$df[,input$setz]%>% as.numeric()
setZZ(input$setz)
nameZ(input$setz)
})
output$set.nature=renderUI({
req(!is.null(fileisupload()))
selectInput("setnature", h4("Type (Default name: Type)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.nature2())
})
output$set.levels=renderUI({
req(!is.null(fileisupload()))
selectInput("setlevels", h4("Levels (Default name: Levels)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.levels())
})
output$set.date=renderUI({
req(!is.null(fileisupload()))
selectInput("setdate", h4("years : format years (Default name: Years)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.date())
})
output$set.passe=renderUI({
req(!is.null(fileisupload()))
selectInput("setpasse", h4("others (No default name)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.passe2())
})
output$set.ID=renderUI({
req(!is.null(fileisupload()))
selectInput("setID", h4("Unique object ID (Default name: ID)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.ID())
})
output$set.sector=renderUI({
req(!is.null(fileisupload()))
selectInput("setsector", h4("Context/square/sector (Default name: Context, Square, Sector)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.sector2())
})
observeEvent(input$checkbox.invX, {
req(input$setx)
df$df[,setXX()]<-df$df[,setXX()]*-1
updateSelectInput(session,"setx",choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.x())
xmax = df$df[,setXX()] %>% ceiling() %>% max(na.rm = TRUE)
xmin=df$df[,setXX()] %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'xslider','x limits',min=xmin,max=xmax,value=c(xmin,xmax),step=stepX())
x2min=input$xslider[1]
x2max=input$xslider[2]
updateSliderInput(session,'ssectionXx2','x (point size): min/max',min=x2min,max=x2max,value=c(x2min,x2max),step=stepX())
})
observeEvent(input$checkbox.invY, {
req(input$sety)
df$df[,input$sety]<-df$df[,input$sety]*-1
updateSelectInput(session,"sety",choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.y())
ymax = df$df[,setYY()] %>% ceiling() %>% max(na.rm = TRUE)
ymin=df$df[,setYY()] %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'yslider','y limits',min=ymin,max=ymax,value=c(ymin,ymax),step=stepY())
y2min=input$yslider[1]
y2max=input$yslider[2]
updateSliderInput(session,'ssectionXy2','y (point size): min/max',min=y2min,max=y2max,value=c(y2min,y2max),step=stepY())
})
observeEvent(input$checkbox.invZ, {
req(input$setz)
df$df[,setZZ()]<-df$df[,setZZ()]*-1
updateSelectInput(session,"setz",choices = names(df$df)[c(3:ncol(df$df))],
selected = liste.z())
zmax = df$df[,setZZ()] %>% ceiling() %>% max(na.rm = TRUE)
zmin=df$df[,setZZ()] %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'zslider','z limits',min=zmin,max=zmax,value=c(zmin,zmax),step=stepZ())
z2min=input$zslider[1]
z2max=input$zslider[2]
updateSliderInput(session,'ssectionXz2','z (point size): min/max',min=z2min,max=z2max,value=c(z2min,z2max),step=stepZ())
})
observeEvent(input$Name.X, {
req(input$setx)
nameX(input$Name.X)
})
observeEvent(input$Name.Y, {
req(input$sety)
nameY(input$Name.Y)
})
observeEvent(input$Name.Z, {
req(input$setz)
nameZ(input$Name.Z)
})
##### verification ----
observeEvent(ignoreInit = TRUE, c(setXX(),setYY(),setZZ(),input$setID), {
if( sum(is.na(as.numeric(df$df[,input$setx])))>0 || sum(is.na(as.numeric(df$df[,input$sety])))>0 || sum(is.na(as.numeric(df$df[,input$setz])))>0 || (dim(df$df[duplicated(df$df[,input$setID]),])[1]>0 & input$setID != "null")) {
showModal(modalDialog(
title = "Issues with loaded data",
if( sum(is.na(as.numeric(df$df[,input$setx])))>0) {
HTML(paste(sum(is.na(as.numeric(df$df[,input$setx]))), " X value(s) was/were not included as not numerical <br>"))},
if( sum(is.na(as.numeric(df$df[,input$sety])))>0) {
HTML(paste(sum(is.na(as.numeric(df$df[,input$sety]))), " Y value(s) was/were not included as not numerical<br>"))},
if( sum(is.na(as.numeric(df$df[,input$setz])))>0) {
HTML(paste(sum(is.na(as.numeric(df$df[,input$setz]))), " Z value(s) was/were not included as not numerical<br>"))},
if(input$setID != "null" & dim(df$df[duplicated(df$df[,input$setID]),])[1]>0) {
HTML(paste(dim(df$df[duplicated(df$df[,input$setID]),])[1], " object ID(s) is/are not unique !<br> "))
}
))
}
})
##verification to use distinct size options
observeEvent(ignoreInit = TRUE,
c(min.point.sliderx(),
min.point.slidery(),
min.point.sliderz(),
set.var.gris(),
minsize()),
{
req(!is.null(df.sub())) ##ajout 1.9
req(!is.null(df.sub.minpoint())) ##ajout 1.9
diff<-nrow(df.sub())-nrow(df.sub.minpoint())
if(diff>0 && input$setID == "null"){
showModal(modalDialog(
title = "No unique ID",
HTML("Size options are not available without unique ID")
))
}
})
##### import extradata ----
observe({
req(input$file.extradata)
extension <- tools::file_ext(input$file.extradata$name)
df$file.extradata <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.extradata$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.extradata$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.extradata$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.extradata$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,fileEncoding="latin1",
dec=".")},
xls = readxl::read_xls(input$file.extradata$datapath),
xlsx = readxl::read_xlsx(input$file.extradata$datapath))
}) #end observe
output$set.columnID=renderUI({
req(input$file.extradata)
req(input$setID)
selectInput("setcolumnID", h4("Select the unique objects ID)"),
choices = names(df$file.extradata),
selected = c(paste(input$setID)))
})
observeEvent(input$setcolumnID, { ## add two necessary columns for the rest of manipulations
df$file.extradata2<-df$file.extradata[,!sapply(df$file.extradata, function(x) is.logical(x))] ##remove column whitout data
df$file.extradata2[sapply(df$file.extradata2, function(x) !is.numeric(x))] <- mutate_all(df$file.extradata2[sapply(df$file.extradata2, function(x) !is.numeric(x))], .funs=str_to_lower)
temp.data<-df$df[duplicated(df$df[,input$setID]) | duplicated(df$df[,input$setID], fromLast = T),]
if (nrow(temp.data) >0 ) {notunique.txt(temp.data)
} else {notunique.txt("All IDs are unique")}
temp.data2<-df$file.extradata2[duplicated(df$file.extradata2[,input$setcolumnID]) | duplicated(df$file.extradata2[,input$setcolumnID], fromLast = T),]
if (nrow(temp.data2) >0 ) {notunique2.txt(temp.data2)
} else {notunique2.txt("All IDs are unique")}
}) #end observe
observeEvent(input$goButton.set.columnID, {
req(input$setcolumnID)
if(input$setID == "null"){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("No unique ID has been defined in the XYZ dataset"))
))
return()
}
if(dim(df$df[duplicated(df$df[,input$setID]),])[1]>0){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("Object IDs from the XYZ dataset are not unique. <br>
Import refit data required absolutely a unique ID per object"))
))
return()
}
names(df$file.extradata2)[match(paste(input$setcolumnID),names(df$file.extradata2))]<-paste(input$setID)
if(dim(df$file.extradata2[duplicated(df$file.extradata2[,input$setID]),])[1]>0){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("Object IDs from the imported dataset are not unique. <br>
Import refit data required absolutely a unique ID per object"))
))
return()
}
same.column.to.remove<-intersect(colnames(df$df),colnames(df$file.extradata2)) # remove column with same name
same.column.to.remove<-same.column.to.remove[same.column.to.remove!=input$setID]
df$file.extradata3<-df$file.extradata2[!names(df$file.extradata2)%in% c(same.column.to.remove)]
df$file.extradata3[,input$setID]<-as.character(df$file.extradata3[,input$setID]) ## same format to avoid pb
df$df[,input$setID]<-as.character(df$df[,input$setID]) ## same format to avoid pb
temp.data2<-setdiff(df$df[,input$setID],df$file.extradata3[,input$setID])
if(length(temp.data2)==0){
ID.no.suppl.data.txt("perfect")} else {suppl.no.include.txt(temp.data2)}
temp.data<-setdiff(df$file.extradata3[,input$setID],df$df[,input$setID])
if(length(temp.data)==0){
suppl.no.include.txt("perfect")} else {ID.no.suppl.data.txt(temp.data)}
df$df<-full_join(df$file.extradata3,df$df)%>%
relocate(c("shapeX","text","null"))
})
## table to show import extradata ----
output$notunique<- renderPrint({notunique.txt()})
output$notunique2<- renderPrint({notunique2.txt()})
output$suppl.no.include<- renderPrint({suppl.no.include.txt()})
output$ID.no.suppl.data<- renderPrint({ID.no.suppl.data.txt()})
##### import refit data ----
observe({
req(input$file.fit)
extension <- tools::file_ext(input$file.fit$name)
df$file.fit <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.fit$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.fit$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.fit$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.fit$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,
dec=".",fileEncoding="latin1")},
xls = readxl::read_xls(input$file.fit$datapath),
xlsx = readxl::read_xlsx(input$file.fit$datapath))
}) #end observe
output$set.columnID.for.fit=renderUI({
req(input$setID)
selectInput("setcolumnID.for.fit", h4("Select the column recording the unique object ID)"),
choices = names(df$file.fit),
selected = c(paste(input$setID)))
})
output$set.REM=renderUI({
selectInput("setREM", h4("Select the column recording the unique ID of refit groups"),
choices= names(df$file.fit),
selected = c("fit","refit","Rem","null"))
})
observeEvent(input$Refit.data.from.XYZ.file, {
updateSelectInput(session,"setcolumnID.for.fit",choices=if(input$Refit.data.from.XYZ.file == FALSE){names(df$file.fit)}else{names(df$df)[3:length(df$df)]},selected=input$setID )
updateSelectInput(session,"setREM",choices=if(input$Refit.data.from.XYZ.file == FALSE){names(df$file.fit)}else{names(df$df)[3:length(df$df)]},selected=c("fit","REM") )
})
observeEvent(input$goButton.set.columnID.for.fit, {
req(input$setcolumnID.for.fit)
req((input$setREM)!="")
if(input$setID == "null"){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("No unique ID has been defined in the XYZ dataset"))
))
return()
}
if(dim(df$df[duplicated(df$df[,input$setID]),])[1]>0){
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("Object IDs from the XYZ dataset are not unique. <br>
Import refit data required absolutely a unique ID per object"))
))
return() }
if(input$Refit.data.from.XYZ.file == FALSE){
df$file.fit3<-df$file.fit
df$file.fit3<-df$file.fit3[,!sapply(df$file.fit3, function(x) is.logical(x))] ##remove column whitout data
df$file.fit3[sapply(df$file.fit3, function(x) !is.numeric(x))] <- mutate_all(df$file.fit3[sapply(df$file.fit3, function(x) !is.numeric(x))], .funs=str_to_lower)
df$file.fit3<-as.data.frame(df$file.fit3)
names(df$file.fit3)[match(paste(input$setcolumnID.for.fit),names(df$file.fit3))]<-paste(input$setID)
same.column.to.remove<-intersect(colnames(df$df),colnames(df$file.fit3))
same.column.to.remove<-same.column.to.remove[same.column.to.remove!=input$setID]
df$file.fit2<-df$file.fit3[!names(df$file.fit3)%in% c(same.column.to.remove)]
} else {
df$file.fit2<-df$df[!is.na(df$df[input$setREM]),]
df$file.fit2<-df$file.fit2[!df$file.fit2[input$setREM]=="" & !df$file.fit2[input$setREM]=="NA",]
}
df$file.fit2[,input$setID]<-as.character(df$file.fit2[,input$setID]) ## same format to avoid pb
df$df[,input$setID]<-as.character(df$df[,input$setID]) ## same format to avoid pb
data.fit(df$file.fit2)
})
observeEvent(data.fit(), {
req(input$setREM)
data.REM<-left_join(data.fit(),df$df)
if(all(is.na(data.REM$shapeX))==TRUE){ ##test to go next step
showModal(modalDialog(
title = "Issues with merging data",
HTML(paste("No refit data have been merged. <br> Unique IDs should not match together"))
))
return()
}
fac <- as.factor(data.REM[,input$setREM])
idx_lev <- which(nchar(levels(fac))>0)
eff <- table(fac)[idx_lev]
Lcombi <- lapply(lapply(eff, function(a){1:a} ), function(v){if (length(v)>1){combn(v, 2)}else{matrix(nrow=2, ncol=0)}})
Lidx <- lapply(names(eff), function(a,f){which(f==a)}, fac)
LcombiRow <- mapply( function(M, v){matrix(v[M], nrow(M), ncol(M))}, Lcombi, Lidx, SIMPLIFY = FALSE)
m1 <- data.REM[unlist(lapply(LcombiRow, function(M){M[1,]})),]
m2 <- data.REM[unlist(lapply(LcombiRow, function(M){M[2,]})),]
table.fit2 <- rbind(m1, m2)
colnames(m2)<-paste0(colnames(m2),".2")
colnames(m2)[which(names(m2) == paste0(input$setx,".2"))] <- "xend"
colnames(m2)[which(names(m2) == paste0(input$sety,".2"))] <- "yend"
colnames(m2)[which(names(m2) == paste0(input$setz,".2"))] <- "zend"
m2<-m2 %>% relocate(shapeX.2, text.2,null.2)
table.fit <- cbind(m1, m2[,4:ncol(m2)])
idx <- c(rbind(1:nrow(m1), 1:nrow(m2)+nrow(m1)))
table.fit2 <- table.fit2[idx,]
tt <- sapply(LcombiRow,ncol)*2
v1 <- rep(names(tt), tt)
v2 <- rep(unlist(lapply(sapply(LcombiRow,ncol), seq2, from=1)), each=2)
table.fit2 <- cbind(table.fit2, paste0(v1, ".", v2))
colnames(table.fit2)[which(names(table.fit2) == 'paste0(v1, ".", v2)')] <- "fit.2"
table.fit2<-table.fit2 %>% relocate(shapeX, text,null)
table.fit<-table.fit %>% relocate(shapeX, text,null)
data.fit2(table.fit)
data.fit.3D(table.fit2)
data.fit3(table.fit)
data.refit.choose(names(table.fit2)) ## for color of refit
showModal(modalDialog(
title = "Refit data",
HTML(paste("Refit data have been merged."))
))
})
## table to show refit ----
output$Fit.table.output<- renderPrint({
if (is.null(data.fit3())) { "no refit"} else {
data.fit3()[,4:ncol(data.fit3())]}
})
#### merge two columns ----
output$set.col1=renderUI({
req(!is.null(fileisupload()))
selectInput("setcol1", h4("Choose a first column"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = "")
})
output$set.col2=renderUI({
req(!is.null(fileisupload()))
selectInput("setcol2", h4("Choose a second column"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = "")
})
observeEvent(input$Merge2, {
new.group<-paste0(df$df[,input$setcol1],input$separatormerge,df$df[,input$setcol2])
df$df<-cbind(df$df,new.group)
colnames(df$df)[ncol(df$df)]<-c(input$Merge.groupe)
showModal(modalDialog(
HTML(paste("Data have been merged. <br>
The first value obtained is",df$df[,input$Merge.groupe][1] ))
))
})
##### ortho slide import ----
observe({ ### ortho xy
req(input$file2)
df$ortho.2<-stack(input$file2$datapath)
})
output$liste.ortho.file2=renderUI({
req(input$file2)
renderPlot({
s2<-stack(input$file2$datapath)
plotRGB(s2,maxpixels=50000)
})
})
output$liste.ortho.file3=renderUI({
req(input$file3)
renderPlot({
s3<-stack(input$file3$datapath)
plotRGB(s3,maxpixels=50000)
})
})
output$liste.ortho.file4=renderUI({
req(input$file4)
renderPlot({
s4<-stack(input$file4$datapath)
plotRGB(s4,maxpixels=50000)
})
})
output$liste.ortho.file5=renderUI({
req(input$file5)
renderPlot({
s5<-stack(input$file5$datapath)
plotRGB(s5,maxpixels=50000)
})
})
##### output sidebar ----
output$liste.Colors=renderUI({
req(!is.null(fileisupload()))
selectInput("Colors", h4("Variable to be colored"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = c("UAS","null",names(df$df)[1]))
})
output$liste.Nature=renderUI({
req(input$setnature)
checkboxGroupInput("Nature", h4("Type"),
choices = levels(as.factor(df$df[,input$setnature])),selected = factor(df$df[,input$setnature]))
})
output$liste.passe=renderUI({
req(input$setpasse)
checkboxGroupInput("Passe", h4(paste(input$setpasse)),
choices = levels(as.factor(df$df[,input$setpasse])),selected = levels(as.factor(df$df[,input$setpasse])))
})
output$liste.sector=renderUI({
req(input$setsector)
checkboxGroupInput("localisation", h4("Context"),
choices = levels(as.factor(df$df[,input$setsector])),selected = factor(df$df[,input$setsector]))
})
output$liste.UAS=renderUI({
req(input$setlevels)
checkboxGroupInput("UAS", h4("Levels"),
choices = levels(as.factor(df$df[,input$setlevels])),selected = factor(df$df[,input$setlevels]))
})
textnbobject<-reactiveVal(NULL)
observe({
if (!is.null(nrow(df$df))){
req(!is.null(df.sub()))
textnbobject(paste("Number of objects plotted:",nrow(df.sub()),"for a total of", nnrow.df.df(), "rows present in the dataset"))
}
})
output$nb=renderUI({
HTML(paste(textnbobject()))
})
output$nb2=renderUI({
HTML(paste(textnbobject()))
})
output$nb2.2=renderUI({
HTML(paste(textnbobject()))
})
output$nb3=renderUI({
HTML(paste(textnbobject()))
})
output$nb4=renderUI({
HTML(paste(textnbobject()))
})
output$nb5=renderUI({
HTML(paste(textnbobject()))
})
output$nb8=renderUI({
HTML(paste(textnbobject()))
})
output$nb6=renderUI({
req(!is.null(fileisupload()))
req(!is.null(df.sub()))
HTML(paste("Number of rows imported:",sum(nrow(df$df)-(max(sum(is.na(as.numeric(df$df[,input$setx]))),sum(is.na(as.numeric(df$df[,input$sety]))),sum(is.na(as.numeric(df$df[,input$setz])))))),"for a total of", nrow(df$df), "rows present in the dataset"))
})
output$ylimits=renderUI({
req(!is.null(fileisupload()))
req(input$sety)
ymax= df$df[,input$sety] %>% as.numeric() %>%ceiling() %>% max(na.rm = TRUE)
ymin=df$df[,input$sety] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
sliderInput('yslider','y limits',min=ymin,max=ymax,value=c(ymin,ymax),step=stepY())
})
output$xlimits=renderUI({
req(!is.null(fileisupload()))
req(input$setx)
xmax = df$df[,input$setx] %>% ceiling() %>% max(na.rm = TRUE)
xmin=df$df[,input$setx] %>% floor() %>% min(na.rm = TRUE)
sliderInput('xslider','x limits',min=xmin,max=xmax,value=c(xmin,xmax),step=stepX())
})
output$zlimits=renderUI({
req(!is.null(fileisupload()))
req(input$setz)
zmax = df$df[,input$setz] %>% ceiling() %>% max(na.rm = TRUE)
zmin=df$df[,input$setz] %>% floor() %>% min(na.rm = TRUE)
sliderInput('zslider','z limits',min=zmin,max=zmax,value=c(zmin,zmax),step=stepZ())
})
output$Date=renderUI({
req(!is.null(fileisupload()))
req(input$setdate)
dmin=min(as.numeric(df$df[,input$setdate]), na.rm=T)
dmax=max(as.numeric(df$df[,input$setdate]), na.rm=T)
if((dmax!="inf")==TRUE){
sliderInput('Date2','Year(s) :',min=dmin,max=dmax,value=c(dmin,dmax),step=1,sep='')
} else {}
})
##### output additional Setting slide ----
observeEvent(input$stepXsize, {
stepX(input$stepXsize)
})
observeEvent(input$stepYsize, {
stepY(input$stepYsize)
})
observeEvent(input$stepZsize, {
stepZ(input$stepZsize)
})
output$liste.infos=renderUI({
req(!is.null(fileisupload()))
checkboxGroupInput("listeinfos", h4("Choose the variable information to be shown while hovering points on plots"),
choices = names(df$df)[c(4:ncol(df$df))], selected = NULL)
})
output$shape2=renderUI({
req(!is.null(fileisupload()))
req(input$shape)
s2<-list("circle","square","triangle","diamond","star")
s2<-s2[s2!=input$shape]
selectInput("setshape2", h4("Secondary shape"),
choices = s2)
})
output$shape2.var1=renderUI({
req(!is.null(fileisupload()))
selectInput("setshape2.1", h5("Select variable for secondary shape"),
choices = names(df$df)[c(3:ncol(df$df))])
})
output$shape2.var2=renderUI({
req(!is.null(fileisupload()))
df$Sh2<-df$df
selectInput("setshape2.2", h5("Select variable modality for secondary shape"),
choices = levels(as.factor(df$Sh2[,input$setshape2.1])),selected = factor(df$Sh2[,input$shape2.var1]))
})
tt<-reactiveVal()
observeEvent(input$do.shape2, {
tt2<-paste(input$setshape2,input$setshape2.1," ", input$setshape2.2, " ")
tt3<-paste(tt2, tt(), sep="\n")
tt(tt3)
})
observeEvent(input$do.shape1, {
tt3<-NULL
tt(tt3)
})
output$text.shape <- renderText({
paste(tt())}
)
observeEvent(input$do.shape1, {
df$df$shapeX<-input$shape
})
observeEvent(input$do.shape2, {
df$df$shapeX[df$df[,input$setshape2.1] %in% input$setshape2.2]<-input$setshape2
})
observeEvent(input$optioninfosfigplotly, {
legendplotlyfig(input$optioninfosfigplotly)
})
output$ratiotocoorsimple2=renderUI({
req(input$advanced.slice==FALSE)
numericInput("ratio.to.coord.simple.2", label = h5("Ratio figure"), value = 1)
})
output$download.slice.output=renderUI({
req(input$advanced.slice==FALSE)
downloadButton("download.slice", "Download as .pdf")
})
#### liste infos ----
observeEvent(req(!is.null(listinfosmarqueur())),{
df$df$text<-""}
)
observeEvent(input$listeinfos.go, {
req(input$setz)
req(input$setID)
selected = c()
for (s in 1:length(input$listeinfos)) {
selected = c(selected, input$listeinfos[s])
}
if (is.null(selected)) {
selected = character(0)
}
df$df$text<-paste("<br><b>Z</b>:", df$df[,input$setz],"<br><b>ID</b>:", df$df[,input$setID])
if (length(input$listeinfos)>0){
for (ii in 1:length(input$listeinfos)){
text5<-paste("<br>",input$listeinfos[ii],": ",df$df[,input$listeinfos[ii]], sep="")
df$df$text<-paste(df$df$text,text5)
}
}
updateCheckboxGroupInput(session, "listeinfos", selected = selected)
listinfosmarqueur(NULL)
}) #end of observeevent
##### colors ----
save.col.react<-reactiveVal()
mypaletteofcolors<-reactiveVal()
observeEvent(df$file.color,{
mypaletteofcolors(df$file.color[2])
})
basiccolor= reactive({
req(!is.null(fileisupload()))
name<-"colorvar"
color.function(df$df[[inputcolor()]],name,1,mypaletteofcolors())
})
save.col2<-observeEvent(myvaluesx(),{
if (length(unlist(myvaluesx()))>1) {
color<-levels(as.factor(df$df[,inputcolor()]))
names_of_the_variable<-unlist(myvaluesx())
length(color)<-max(c(length(color),length(names_of_the_variable))) ## to avoid problem of different row
length(names_of_the_variable)<-max(c(length(color),length(names_of_the_variable)))
save.col.react(cbind.data.frame(color,names_of_the_variable))
}
})
observe({
req(input$file.color)
extension <- tools::file_ext(input$file.color$name)
df$file.color <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.color$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.color$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.color$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.color$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,
dec=".")},
xls = readxl::read_xls(input$file.color$datapath),
xlsx = readxl::read_xlsx(input$file.color$datapath))
})
myvaluesx<-reactive({
req(!is.null(fileisupload()))
myvaluesx <-NULL
n <- length(unique(df$df[,inputcolor()]))
val <- list()
if (!is.null(input[[paste0("colorvar",1)]])) {
myvaluesx <- lapply(1:n, function(i) {
if (i==1) val <- list(input[[paste0("colorvar",i)]])
else val <- list(val,input[[paste0("colorvar",i)]])
})}else{
myvaluesx <-list(c("blue"),c("red"),c("green"))
}
}) # end of myvaluexS
output$colors2 <- renderUI({
basiccolor()
})
##### color for refits ----
data.refit.choose<-reactiveVal(NULL)
inputcolor.refit<-reactiveVal("null")
output$liste.Colors.refit=renderUI({
req(!is.null(fileisupload()))
req(!is.null(data.refit.choose()))
selectInput("Colors.rerefit", h4("Refit variable to be colored"),
choices = data.refit.choose()[c(3:length(data.refit.choose()))],
selected = data.refit.choose()[1])
})
observeEvent(input$Colors.rerefit,{
inputcolor.refit(input$Colors.rerefit)
})
observeEvent(df$file.color.fit,{
mypaletteofcolors.fit(df$file.color.fit[2])
})
basiccolorforfit=reactive({
if (is.null(inputcolor.refit())) return(NULL)
data.fit.3D<-data.fit.3D()
name<-"colorvar.refit"
color.function(data.fit.3D[[inputcolor.refit()]],name,0,mypaletteofcolors.fit())
})
output$colorsrefits <- renderUI({
basiccolorforfit()
})
colorvalues<-reactive({
req(!is.null(data.fit()))
colorvalues<-NULL
n <- length(unique(data.fit.3D()[,input$setID]))
val <- list()
colorvalues<- lapply(1:n, function(i) {
if (i==1) val <- list(input[[paste0("colorvar.refit",i)]])
else val <- list(val,input[[paste0("colorvar.refit",i)]])
})
}) # end of Colorvalues
observeEvent(colorvalues(),{
if (length(unlist(colorvalues()))>1) {
color<-levels(as.factor(data.fit.3D()[[inputcolor.refit()]]))
names_of_the_variable<-unlist(colorvalues())
length(color)<-max(c(length(color),length(names_of_the_variable))) ## to avoid problem of different row
length(names_of_the_variable)<-max(c(length(color),length(names_of_the_variable)))
save.col.react.fit(cbind.data.frame(color,names_of_the_variable))
}
})
observe({
req(input$file.color.fit)
extension <- tools::file_ext(input$file.color.fit$name)
df$file.color.fit <- switch(extension,
csv = {
sep2 <- if( ";" %in% strsplit(readLines(input$file.color.fit$datapath, n=1)[1], split="")[[1]] ){";"
} else if( "," %in% strsplit(readLines(input$file.color.fit$datapath, n=1)[1], split="")[[1]] ){","
} else if ( "\t" %in% strsplit(readLines(input$file.color.fit$datapath, n=1)[1], split="")[[1]] ){"\t"
} else {";"}
utils::read.csv(input$file.color.fit$datapath,
header = input$header,
sep = sep2, stringsAsFactors = F,
dec=".")},
xls = readxl::read_xls(input$file.color.fit$datapath),
xlsx = readxl::read_xlsx(input$file.color.fit$datapath))
})
##### variable subset refits ----
react.var.rerefit<-reactiveVal("null")
react.listevarrefit<-reactiveVal("0")
output$liste.var.refit=renderUI({
req(!is.null(fileisupload()))
req(!is.null(data.refit.choose()))
selectInput("var.rerefit", h4("Subsetting refit"),
choices = data.refit.choose()[c(3:length(data.refit.choose()))],
selected = data.refit.choose()[1])
})
output$liste.varrefit=renderUI({
req(!is.null(fileisupload()))
req(!is.null(data.refit.choose()))
checkboxGroupInput("listevarrefit", h4("Select the refit modalities to be shown"),
choices = levels(as.factor(data.fit.3D()[,input$var.rerefit])), selected = factor(data.fit.3D()[,input$var.rerefit]))
})
observeEvent(input$var.rerefit,{
react.var.rerefit(input$var.rerefit)
})
observeEvent(input$listevarrefit,{
react.listevarrefit(input$listevarrefit)
})
##### ouput 2D and 3D slide ----
output$sectionXy2=renderUI({
req(!is.null(fileisupload()))
req(input$yslider)
y2min=min(input$yslider)
y2max=max(input$yslider)
sliderInput('ssectionXy2','y (point size): min/max',min=y2min,max=y2max,value=c(y2min,y2max),step=stepY())
})
output$sectionXx2=renderUI({
req(!is.null(fileisupload()))
req(input$xslider)
x2min=input$xslider[1]
x2max=input$xslider[2]
sliderInput('ssectionXx2','x (point size): min/max',min=x2min,max=x2max,value=c(x2min,x2max),step=stepX())
})
output$sectionXz2=renderUI({
req(!is.null(fileisupload()))
req(input$zslider)
z2min=min(input$zslider)
z2max=max(input$zslider)
sliderInput('ssectionXz2','z (point size): min/max',min=z2min,max=z2max,value=c(z2min,z2max),step=stepZ())
})
output$var.gris.2D=renderUI({
req(!is.null(fileisupload()))
selectInput("set.var.gris.2D", h4("Select the variable for point that are going to be wide"),
choices = names(df$df)[c(3:ncol(df$df))])
})
output$var.gris.2D.1=renderUI({
req(!is.null(fileisupload()))
checkboxGroupInput("set.var.gris.2D.1", h4("Levels of variable"),
choices = levels(as.factor(df$df[,input$set.var.gris.2D])),selected = factor(df$df[,input$set.var.gris.2D]))
})
output$sectionXx3=renderUI({
req(!is.null(fileisupload()))
req(input$pi2)
xmin=0
xmax=input$xslider[2]-input$xslider[1]
sliderInput('ssectionXx3','x: min/max',min=xmin,max=xmax,value=c(xmin,xmax),step=0.05)
})
output$sectionXy3=renderUI({
req(!is.null(fileisupload()))
req(input$pi2)
ymin=0
ymax=input$yslider[2]-input$yslider[1]
sliderInput('ssectionXy3','y: min/max',min=ymin,max=ymax,value=c(ymin,ymax),step=0.05)
})
output$var.fit.3D=renderUI({
req(!is.null(data.fit.3D()))
radioButtons("var.fit.3D", "Include refits",
choices = c(no = "no",
yes = "yes"),
selected = "no", inline=TRUE)
})
var.sub2<-reactiveVal()
min.point.sliderx<-reactiveVal()
min.point.slidery<-reactiveVal()
min.point.sliderz<-reactiveVal()
set.var.gris<-reactiveVal()
observeEvent(input$set.var.gris.2D.1, {
var.sub2(input$set.var.gris.2D.1)
})
observeEvent(input$ssectionXx2,{
min.point.sliderx(input$ssectionXx2)
})
observeEvent(input$ssectionXy2,{
min.point.slidery(input$ssectionXy2)
})
observeEvent(input$ssectionXz2,{
min.point.sliderz(input$ssectionXz2)
})
observeEvent(input$set.var.gris.2D, {
set.var.gris(input$set.var.gris.2D)
})
##### new group slide ----
output$liste.newgroup=renderUI({
req(!is.null(fileisupload()))
selectInput("listenewgroup", h4("Copy data from another variable (select NULL for a default value of zero)"),
choices = names(df$df)[c(3:ncol(df$df))],
selected = c("null"))
})
values <- reactiveValues(newgroup = NULL)
create.newgroup <- observeEvent(input$go.ng, {
new.group<-df$df[,input$listenewgroup]
req(!isTruthy(input$text.new.group == values$newgroup)) ## block if two same names exist because problems later
values$newgroup <- c(values$newgroup, input$text.new.group)
df$df<-cbind(df$df,new.group)
colnames(df$df)[ncol(df$df)]<-c(input$text.new.group)
})
output$brushed<- renderPrint({
g1 <- df$df
d <- event_data('plotly_selected')
if (is.null(d)) return()
if (length(d)==0) {
vv(NULL)
return()
}
dd <- cbind(d[[3]],d[[4]])
list.parameter.info<-var.function(input$var1)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
WW<-which(g1[[var]] %in% dd[,1] & g1[[var2]] %in% dd[,2])
vv<-df$df[WW,4:ncol(df$df)]
vv(vv)
vv
})
observeEvent(input$Change2, {
showModal(dataModal())
})
observeEvent(input$Change, {
req(!is.null(input$Change))
df$df[which(row.names(df$df) %in% row.names(vv())),][input$text.new.group] <-
input$NewGroup
removeModal()
}) # end of Observe Event
#rename
output$liste.newgroup2=renderUI({
req(!is.null(fileisupload()))
selectInput("liste.newgroup.rename", label = h5("Select the new group"),
choices = values$newgroup,
selected = values$newgroup[1])
})
output$liste.newgroup4=renderUI({
req(!is.null(fileisupload()))
req(!is.null(values$newgroup))
req(input$liste.newgroup.rename != "")
selectInput("liste.newgroup3", label = h5("Select the variable"),
choices = factor(df$df[,input$liste.newgroup.rename]))
})
observeEvent(input$go.ng2, {
req(!is.null(input$liste.newgroup3))
df$df[,input$liste.newgroup.rename][df$df[,input$liste.newgroup.rename]==input$liste.newgroup3]<-input$text.new.group2
})
##### simplification to checkboxgroupinput ----
observeEvent(input$all_artifact_entry, {
req(input$setnature)
updateCheckboxGroupInput(session, "Nature",
selected = levels(as.factor(df$df[,input$setnature]))) })
observeEvent(input$reset_artifact_entry, {
updateCheckboxGroupInput(session, "Nature",
selected = FALSE)})
observeEvent(input$all_UAS_entry, {
req(input$setlevels)
updateCheckboxGroupInput(session, "UAS",
selected = levels(as.factor(df$df[,input$setlevels])))})
observeEvent(input$reset_UAS_entry, {
updateCheckboxGroupInput(session, "UAS",
selected = FALSE)})
##### creation df.sub that would be used to create plot ----
df.sub <- reactive({
req(!is.null(fileisupload()))
req(!is.null(input$xslider))
req(inputcolor())
df.sub<-df$df
plotcol<-df.sub[,inputcolor()]
df.sub$layer2 <- factor(plotcol)
df.sub$point.size <- size.scale()
df.sub$point.size2<-size.scale()
df.sub<-df.sub %>% relocate(layer2, point.size, point.size2)
if (input$setdate!="null"){
df.sub[,input$setdate] <-as.numeric(df.sub[,input$setdate])
df.sub[,input$setdate][is.na(df.sub[,input$setdate])]<-0
if (!is.null(input$Date2)) {
df.sub<-df.sub %>%
filter(df.sub[,input$setdate] >= input$Date2[1], df.sub[,input$setdate] <= input$Date2[2])}}
if (input$setsector!="null"){
df.sub <- df.sub[df.sub[,input$setsector] %in% input$localisation, ]}
if (input$setlevels!="null"){
df.sub <- df.sub[df.sub[,input$setlevels] %in% input$UAS, ]}
if (input$setnature!="null"){
df.sub <- df.sub[df.sub[,input$setnature] %in% input$Nature, ]}
if (input$setpasse!="null"){
df.sub <- df.sub[df.sub[,input$setpasse]%in% input$Passe, ]}
df.sub<-df.sub %>%
filter(.data[[input$setx]] >= input$xslider[1], .data[[input$setx]] <= input$xslider[2]) %>%
filter(.data[[input$sety]] >= input$yslider[1], .data[[input$sety]] <= input$yslider[2]) %>%
filter(.data[[input$setz]] >= input$zslider[1], .data[[input$setz]] <= input$zslider[2])
df.sub
}) # end of df.sub reactive
##### creation df.sub.minpoint ----
df.sub.minpoint <- reactive({
df.sub.minpoint<-df.sub()
if(!is.null(set.var.gris())) {
df.sub.minpoint<-df.sub.minpoint %>%
filter((.data[[set.var.gris()]] %in% var.sub2()))}
if(!is.null(min.point.sliderx())) {
df.sub.minpoint<-df.sub.minpoint %>%
filter(.data[[input$setx]] >= min(min.point.sliderx()), .data[[input$setx]] <= max(min.point.sliderx())) %>%
filter(.data[[input$sety]] >= min(min.point.slidery()), .data[[input$sety]] <= max(min.point.slidery())) %>%
filter(.data[[input$setz]] >= min(min.point.sliderz()), .data[[input$setz]] <= max(min.point.sliderz()))
}
if (nrow(df.sub.minpoint)>0){
df.sub.minpoint$point.size2<-size.scale()
}
df.sub.minpoint
}) # end of df.sub reactive
##### output.contents ----
output$contents <- renderTable({
req(!is.null(fileisupload()))
isTruthy(df.sub())
df.5<-df.sub()[1:10,]
df.6<-cbind.data.frame(df.5[,input$setx],df.5[,input$sety],df.5[,input$setz],df.5[,input$setID],
df.5[,input$setdate],df.5[,input$setsector],df.5[,input$setlevels],df.5[,input$setnature],
df.5[,input$setpasse])
colnames(df.6)<-c(input$setx,input$sety,input$setz,input$setID,
input$setdate,input$setsector,input$setlevels,
input$setnature,input$setpasse)
return(df.6[1:5,1:9])
})
# output to archeoViz format ----
output.archeoviz <- reactive({
req(!is.null(fileisupload()))
isTruthy(df.sub())
# subsetting:
df <- df.sub()
col.names <- c("id"=input$setID, "xmin"=input$setx, "ymin"=input$sety, "zmin"=input$setz, "layer"=input$setlevels, "object_type"=input$setnature, "object_other"=input$setpasse, "year"=input$setdate)
df <- df[, col.names]
colnames(df) <- names(col.names)
df$square_x <- ""
df$square_y <- ""
# guess if values are in meter, then convert to cm
test.x <- max(df$xmin, na.rm = T) - min(df$xmin, na.rm = T) < 100
test.y <- max(df$ymin, na.rm = T) - min(df$ymin, na.rm = T) < 100
if(test.x & test.y){
df[, c("xmin", "ymin", "zmin")] <- apply(
df[, c("xmin", "ymin", "zmin")], 2, function(x) x * 100)
}
# guess if altitude are used, then convert them into depth values
test.z <- table(df$zmin < 0)
test.z <- test.z[which(names(test.z) == "TRUE")] > test.z[which(names(test.z) == "FALSE")]
if(test.z){ df$zmin <- df$zmin * -1 }
# recoding, if needed:
if(length(unique(df$id)) != nrow(df)){
df$id_original <- df$id
df$id <- seq_len(nrow(df))
showNotification("ID are not unique and have been recoded",
type = "warning")
}
if( length(unique(df$object_other)) == 1 ){
if(unique(df$object_other) == "0"){df$object_other <- ""}
}
if( length(unique(df$year)) == 1) {
if(unique(df$year) == "0"){df$year <- ""}
}
# output:
df[c("id", "square_x", "square_y", "layer", "xmin", "ymin", "zmin", "object_type", "object_other", "year")]
})
output$download.archeoviz <- downloadHandler(
filename = function() {
paste(Sys.Date(),
sub("(.*)\\..*$", "\\1", input$worksheet),
"archeoviz.csv", sep="-")
},
content = function(file) {
write.table(output.archeoviz(), file, row.names = FALSE, sep=",")
}
)
archeoviz.url <- reactive({
req(output.archeoviz())
data.url <- session$registerDataObj(name = "table",
data = output.archeoviz(),
filterFunc = function(data, req) {
httpResponse(200, "text/csv",
write.csv2(data)
)
})
object.id <- gsub(".*w=(.*)&nonce.*", "\\1", data.url)
data.url <- paste0(session$clientData$url_protocol, "//",
session$clientData$url_hostname,
session$clientData$url_pathname,
"_w_", object.id,
"/session/", session$token, "/download/download.archeoviz")
paste0("https://analytics.huma-num.fr/archeoviz/en/?run.plots=TRUE&objects.df=", data.url)
})
output$run.archeoviz <- renderUI({
if(Sys.getenv('SHINY_PORT') != ""){ # only if remote use of the app
actionLink("run.archeoviz",
label = "* Directly send your SEAHORS data to archeoViz",
onclick = paste("window.open('",
archeoviz.url(), "', '_blank')"))
} else( return() )
})
##### 3D plot ----
output$plot3Dbox <- renderUI({
plotlyOutput("plot3d", height = height.size())
})
output$plot3d <- renderPlotly({
df.sub <- df.sub()
df.sub3 <-df.sub.minpoint()
min.size2<-minsize()
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
# if (nrow(df.sub3)>0){
# df.sub$point.size[!((df.sub[,input$setx] %in% df.sub3[,input$setx]) & (df.sub[,input$sety] %in% df.sub3[,input$sety]) & (df.sub[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
# }
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub$point.size[!((df.sub[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
shapeX<-df.sub$shapeX
shape.level<-levels(as.factor(shapeX))
text2<-df.sub$text
p <- plot_ly(df.sub,height = height.size(),width = height.size())
p <-add_trace(p, x = ~df.sub[,input$setx], y = ~df.sub[,input$sety], z = ~df.sub[,input$setz],
type="scatter3d",
color = ~layer2,
colors=myvaluesx,
size = ~point.size,
sizes = c(min.size2,size.scale),
mode = 'markers',
symbol = ~shapeX,
symbols =shape.level,
text = text2,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>')
) # end plotly
if (!is.null(data.fit.3D()) && input$var.fit.3D == "yes"){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit.3D()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub[,input$setID]))
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
p<-add_trace(p,x = ~data.fit.3D[,setXX()], y = ~data.fit.3D[,setYY()], z = ~data.fit.3D[,setZZ()], split = ~data.fit.3D[,input$setREM],
line = list(color=~data.fit.3D$color.fit),
type = "scatter3d", mode = "lines", showlegend = legendplotlyfig(), inherit = F)
}
Xtval<-seq(floor(min(df.sub[[setXX()]])),max(df.sub[[setXX()]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub[[setYY()]])),max(df.sub[[setYY()]]), Yminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ytickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size())]
Ztval<-seq(floor(min(df.sub[[setZZ()]])),max(df.sub[[setZZ()]]), Zminorbreaks())
Zttxt <- rep("",length(Ztval))
Zttxt[seq(1,length(Ztval),Ztickmarks.size())]<-as.character(Ztval)[seq(1,length(Ztval),Ztickmarks.size())]
p <- p %>% layout(
showlegend = legendplotlyfig(),
scene = list(
xaxis = list(title = nameX(),
dtick = Xtickmarks.size(),
#tick0 = floor(min(df.sub[,setXX()])),
#tickmode = "linear",
tickvals=Xtval,
ticktext=Xttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis = list(title = nameY(),
dtick = Ytickmarks.size(),
#tick0 = floor(min(df.sub[,setYY()])),
#tickmode = "linear",
tickvals=Ytval,
ticktext=Yttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
zaxis = list(title = nameZ(),
dtick = Ztickmarks.size(),
#tick0 = floor(min(df.sub[,setZZ()])),
#tickmode = "linear",
tickvals=Ztval,
ticktext=Zttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
camera = list(projection = list(type = 'orthographic')),
aspectmode = "manual",
aspectratio=list(x=ratiox(),y=ratioy(),z=ratioz())),
autosize=FALSE
)
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
session_store$plt <- p
p
})
##### 2D plot ----
##advanced plot ----
output$plot2Dbox <- renderUI({
plotlyOutput("sectionYplot", height = height.size())
})
output$sectionYplot <- renderPlotly({
plot2D.react()
session_store$plt2D<- plot2D.react()
})
plot2D.react<-reactive({
input$run_button
min.size2<-minsize()
orthofile<-NULL
if (input$var.ortho == "yes" ){
orthofile <- switch(input$var1,
xy = if(!is.null(input$file2)) {stack(input$file2$datapath)},
yx = if(!is.null(input$file5)) {stack(input$file5$datapath)},
xz = if(!is.null(input$file3)) {stack(input$file3$datapath)},
yz = if(!is.null(input$file4)) {stack(input$file4$datapath)})
}
height.size2<-height.size()
width.size2 <- width.size()
list.parameter.info<-var.function(input$var1)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
axis.var.name<-list.parameter.info[[3]]
axis.var2.name<-list.parameter.info[[4]]
Xtickmarks.size<-list.parameter.info[[5]]
Ytickmarks.size<-list.parameter.info[[6]]
Xminorbreaks<-list.parameter.info[[7]]
Yminorbreaks<-list.parameter.info[[8]]
isolate ({
df.sub2<-df.sub()
# minor.grid.info<-minor.grid.info.function(df.sub2,var,var2,Xminorbreaks,Xtickmarks.size,Yminorbreaks,Ytickmarks.size)
df.sub3<-df.sub.minpoint()
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
# if (nrow(df.sub3)>0){
# df.sub2$point.size2[!((df.sub2[,input$setx] %in% df.sub3[,input$setx]) & (df.sub2[,input$sety] %in% df.sub3[,input$sety]) & (df.sub2[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
#}
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub2$point.size2[!((df.sub2[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
shapeX<-df.sub2$shapeX
shape.level<-levels(as.factor(shapeX))
if (is.null(orthofile)){
p<- plot_ly(height = height.size(),
width = width.size())
p<- add_trace(p, x = ~df.sub2[[var]], y = ~df.sub2[[var2]],
type="scatter",
color = ~df.sub2$layer2,
colors = myvaluesx,
size = ~df.sub2$point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~df.sub2$shapeX,
symbols = shape.level,
text=df.sub2$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'))
if (input$var.fit.table == "yes" & !is.null(data.fit.3D())){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit.3D()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub2[,input$setID]))
if (length(levels(as.factor(data.fit.3D$color.fit)))>1){
for (i in 1:length (levels(as.factor(data.fit.3D[,input$setREM])))) {
data.fit.3D.2<-data.fit.3D[data.fit.3D[,input$setREM]==levels(as.factor(data.fit.3D[,input$setREM]))[i],]
if (length(levels(as.factor(data.fit.3D.2[["color.fit"]])))>1){
data.fit.3D$color.fit[((data.fit.3D[,input$setx] %in% data.fit.3D.2[,input$setx]) & (data.fit.3D[,input$sety] %in% data.fit.3D.2[,input$sety]) & (data.fit.3D[,input$setz] %in% data.fit.3D.2[,input$setz]))]<-c("#000000") # Black color for refit variable mixing
}}} #end of if
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
p<-add_trace(p,x = ~data.fit.3D[[var]], y = ~data.fit.3D[[var2]], split = ~data.fit.3D[,input$setREM],
line = list(color=~data.fit.3D$color.fit,width=input$w2),
type = "scatter", mode = "lines", showlegend = legendplotlyfig(), inherit = F)
} # end of refit
Xtval<-seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xminorbreaks)
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size)]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size)]
Ytval<-seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]), Yminorbreaks)
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ytickmarks.size)]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size)]
p <- p %>% layout(showlegend = legendplotlyfig(),
scene = list( aspectmode = "manual",
aspectratio=list(x=ratiox(),y=ratioy()),
autosize=FALSE),
xaxis = list(title = paste(axis.var.name),
dtick = Xtickmarks.size,
tick0 = floor(min(df.sub2[[var]])),
#tickmode = "linear",
tickvals=Xtval,
ticktext=Xttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis = list(title = paste(axis.var2.name),
dtick = Ytickmarks.size,
tick0 = floor(min(df.sub2[[var2]])),
#tickmode = "linear",
tickvals=Ytval,
ticktext=Yttxt,
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
} else {
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df.sub()$layer2)) %in% levels(as.factor(droplevels(df.sub2$layer2)))]
p <- ggplot2::ggplot()+
ggRGB(img = orthofile,
r = 1,
g = 2,
b = 3,
maxpixels =500000,
ggLayer = T)+
ggplot2::geom_point(data = df.sub2,
aes(x = .data[[var]],
y = .data[[var2]],
fill=layer2,
size=as.factor(point.size2),
shape=shapeX,
text= paste(paste(var,":"), .data[[var]], paste(var2,":"), .data[[var2]], paste(df.sub2$text))
))
if (input$var.fit.table == "yes" & !is.null(data.fit.3D())){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit3()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
if (is.null(colorvalues)) {
data.fit.3D$color.fit <-c("black")
}
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub2[,input$setID]))
# to have black color for refit several origins
if (length(levels(as.factor(data.fit.3D$color.fit)))>1){
for (i in 1:length(levels(as.factor(data.fit.3D[,input$setREM])))) {
data.fit.3D.2<-data.fit.3D[data.fit.3D[,input$setREM]==levels(as.factor(data.fit.3D[,input$setREM]))[i],]
if (is.na(data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]) || data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]){
data.fit.3D$color.fit[((data.fit.3D[,setXX()] %in% data.fit.3D.2[,setXX()]) & (data.fit.3D[,setYY()] %in% data.fit.3D.2[,setYY()]) & (data.fit.3D[,setZZ()] %in% data.fit.3D.2[,setZZ()]))]<-c("#000000") # Black color for refit variable mixing
}}} #end of if
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
varend<-stringr::str_to_lower(paste0(var,"end"))
var2end<-stringr::str_to_lower(paste0(var2,"end"))
p<-p+geom_segment(data=data.fit.3D, aes(x = .data[[var]], y = .data[[var2]], xend=.data[[varend]],
yend=.data[[var2end]]), color=data.fit.3D$color.fit, size=input$w2, inherit.aes = F)
}
p<-p+scale_fill_manual(values=myvaluesx2)+
scale_shape_manual(values=shape.level)+
scale_size_manual(values=c(size.scale,min.size2))+
xlab(paste(axis.var.name))+ylab(paste(axis.var2.name))+
do.call(themeforfigure.choice(), list()) +
theme(legend.position='none')+
theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),
legend.title = element_blank())+
theme(legend.position='none')
p<-p+scale_x_continuous(breaks=seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xtickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xminorbreaks))+
scale_y_continuous(breaks=seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Ytickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Yminorbreaks))
}
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
}) #end isolate
}) #plot2D.react
## interactive stack bar mode ----
df_2 <- reactiveVal(NULL)
observeEvent(input$chr_settingbp, {
req(!is.null(vv()))
req(input$setnature != "null")
req(input$setlevels != "null")
req(input$setlevels != input$setnature)
data.val <-vv()
df2<-data.val%>% group_by(.data[[input$setlevels]],.data[[input$setnature]])%>% summarise(value=n())
df_2(df2)
showModal(
modalDialog(
title = tags$h4(style = "color: red;","Bar plot of selected points per levels and nature"),
easyClose = T,
plotlyOutput("sectioninteractivebarplot")
))
})
output$sectioninteractivebarplot <- renderPlotly({
df2<-df_2()
fig<-plot_ly(df2, x = df2[[input$setlevels]],
y = df2$value,
type = 'bar',
name = df2[[input$setnature]],
text = df2$value
#color = df2[[input$setnature]],
#colors = brewer.pal(length(unique(df2[[input$setnature]])),
# "Paired")
)%>%
layout(barmode = 'stack',hoverlabel = list(bgcolor= 'white') ,bargap = 0.5) %>%
layout(xaxis = list(categoryorder = 'array',
categoryarray = df2[[input$setlevels]]), showlegend = T)
session_store$interactive.stack.bar<- fig
return(fig)
})
## simple 2D plot ----
output$plot2Dbox.simple <- renderUI({
plotOutput("sectionYplot.simple", height = height.size(), width = width.size())
})
output$sectionYplot.simple <- renderPlot({
plot(plot2D.simple.react())
session_store$plt2D.simple<- plot2D.simple.react()
})
plot2D.simple.react<-reactive({
min.size2<-minsize()
orthofile<-NULL
if (input$var.ortho.simple == "yes" ){
orthofile <- switch(input$var1.simple,
xy = if(!is.null(input$file2)) {stack(input$file2$datapath)},
yx = if(!is.null(input$file5)) {stack(input$file5$datapath)},
xz = if(!is.null(input$file3)) {stack(input$file3$datapath)},
yz = if(!is.null(input$file4)) {stack(input$file4$datapath)})
}
df.sub2<-df.sub()
df.sub3<-df.sub.minpoint()
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df.sub()$layer2)) %in% levels(as.factor(droplevels(df.sub2$layer2)))]
# if (nrow(df.sub3)>0){
# df.sub2$point.size2[!((df.sub2[,input$setx] %in% df.sub3[,input$setx]) & (df.sub2[,input$sety] %in% df.sub3[,input$sety]) & (df.sub2[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
# }
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub2$point.size2[!((df.sub2[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
list.parameter.info<-var.function(input$var1.simple)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
axis.var.name<-list.parameter.info[[3]]
axis.var2.name<-list.parameter.info[[4]]
Xtickmarks.size<-list.parameter.info[[5]]
Ytickmarks.size<-list.parameter.info[[6]]
Xminor.breaks<-list.parameter.info[[7]]
Yminor.breaks<-list.parameter.info[[8]]
shapeX<-df.sub2$shapeX
shape.level<-levels(as.factor(shapeX))
#point.size3<-as.factor(df.sub2$point.size2)
p <- ggplot2::ggplot()
if (!is.null(orthofile)){
p<-p + ggRGB(img = orthofile,
r = 1,
g = 2,
b = 3,
maxpixels =500000,
ggLayer = T)
}
p<- p + ggplot2::geom_point(data = df.sub2,
aes(x = .data[[var]],
y = .data[[var2]],
col=factor(layer2)),
size=df.sub2$point.size2,
shape=shapeX
) +
ggplot2::coord_fixed(ratio.simple())
if (input$var.fit.table.simple == "yes" & !is.null(data.fit.3D())){
colorvalues<-unlist(colorvalues())
data.fit.3D<-data.fit3()
data.fit.3D$color.fit<-colorvalues[match(data.fit.3D[[inputcolor.refit()]],levels(as.factor(data.fit.3D[[inputcolor.refit()]])))] # set up the list of color
if (is.null(colorvalues)) {
data.fit.3D$color.fit <-c("black")
}
data.fit.3D<-data.fit.3D %>% filter((.data[[input$setID]] %in% df.sub2[,input$setID]))
# to have black color for refit several origins
if (length(levels(as.factor(data.fit.3D$color.fit)))>1){
for (i in 1:length(levels(as.factor(data.fit.3D[,input$setREM])))) {
data.fit.3D.2<-data.fit.3D[data.fit.3D[,input$setREM]==levels(as.factor(data.fit.3D[,input$setREM]))[i],]
if (is.na(data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]) || data.fit.3D.2[[inputcolor.refit()]] != data.fit.3D.2[[paste0(inputcolor.refit(),".2")]]){
data.fit.3D$color.fit[((data.fit.3D[,setXX()] %in% data.fit.3D.2[,setXX()]) & (data.fit.3D[,setYY()] %in% data.fit.3D.2[,setYY()]) & (data.fit.3D[,setZZ()] %in% data.fit.3D.2[,setZZ()]))]<-c("#000000") # Black color for refit variable mixing
}}} #end of if
data.fit.3D<-data.fit.3D[data.fit.3D[,react.var.rerefit()] %in% react.listevarrefit(),]
varend<-stringr::str_to_lower(paste0(var,"end"))
var2end<-stringr::str_to_lower(paste0(var2,"end"))
p<-p+geom_segment(data=data.fit.3D, aes(x = .data[[var]], y = .data[[var2]], xend=.data[[varend]],
yend=.data[[var2end]]), color=data.fit.3D$color.fit, size=input$w2, inherit.aes = F)
}
p<-p+ggplot2::scale_color_manual(values=myvaluesx2)+
ggplot2::scale_shape_manual(values=shape.level)+
ggplot2::scale_size_manual(values=c(min.size2,size.scale))+
xlab(paste(axis.var.name))+ylab(paste(axis.var2.name))+
do.call(themeforfigure.choice(), list()) +
theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),
legend.title = element_blank())+
theme(legend.position='none')
p<-p+scale_x_continuous(breaks=seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xtickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var]])),max(df.sub2[[var]]),Xminor.breaks))+
scale_y_continuous(breaks=seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Ytickmarks.size), minor_breaks = seq(floor(min(df.sub2[[var2]])),max(df.sub2[[var2]]),Yminor.breaks))
if (input$checkbox.auto.limits==FALSE) {
p<-p + ggplot2::expand_limits(x=c(input$X.limx[1],input$X.limx[2]), y=c(input$Y.limx[1], input$Y.limx[2]))
}
p
}) #end plot2D.react
##### 2D slice ----
set.var.2d.slice<-reactiveVal()
step.input.step2dslice<-reactiveVal(4)
observeEvent(input$step2dslice,{
if (is.numeric(input$step2dslice) && input$step2dslice !=0)
step.input.step2dslice(input$step2dslice)
})
output$range.2d.slice=renderUI({
req(!is.null(fileisupload()))
req(input$var.2d.slice)
set.var.2d.slice<- switch(input$var.2d.slice,
xz = setYY(),
yz = setXX())
set.var.2d.slice(set.var.2d.slice)
xymax = df$df[,set.var.2d.slice] %>% ceiling() %>% max(na.rm = TRUE)
xymin=df$df[,set.var.2d.slice] %>% floor() %>% min(na.rm = TRUE)
sliderInput('range2dslice','Range of slices',min=xymin,max=xymax,value=c(xymin,xymax),step=step.input.step2dslice())
})
observeEvent(c(input$range2dslice, step.input.step2dslice(),input$advanced.slice,input$xslider,input$yslider,input$zslider,myvaluesx(),
minsize(),
size.scale(),
shape_all()), {
req(!is.null(input$range2dslice))
ratio.slice<-(max(input$range2dslice)-min(input$range2dslice))/step.input.step2dslice()
ratio.slice<-ceiling(ratio.slice)
if (ratio.slice<1) {
ratio.slice<-1
}
ratio.slice(ratio.slice)
df.sub.list<-vector("list", ratio.slice)
min.size2<-minsize()
df.sub2<-df.sub()
set.var.2d.slice<-set.var.2d.slice()
set.antivar.2d.slice<-c(setXX(),setYY())[c(setXX(),setYY())!=set.var.2d.slice()]
df.sub3<-df.sub.minpoint()
# if (nrow(df.sub3)>0){
# df.sub2$point.size2[!((df.sub2[,input$setx] %in% df.sub3[,input$setx]) & (df.sub2[,input$sety] %in% df.sub3[,input$sety]) & (df.sub2[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
#}
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub2$point.size2[!((df.sub2[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
liste.valeur.slice<-vector(length=ratio.slice)
a <- new.env()
e(a)
for (j in 1:ratio.slice){
k<-j-1
val<-min(input$range2dslice)+k*step.input.step2dslice()
val2<-val+step.input.step2dslice()
if(val2>max(input$range2dslice)){
val2<-max(input$range2dslice)
}
liste.valeur.slice[j]<-paste("2D slice from ",val," to ",val2, " in ",set.var.2d.slice()," axis")
df.sub.list[[j]]<- filter (df.sub2, .data[[set.var.2d.slice]]>= val, .data[[set.var.2d.slice]]<=val2)
}
if (input$advanced.slice==TRUE){
plotServerList <- lapply(
1:ratio.slice,
function(i) {
plotServer(paste0("plot", i),df.sub.list[i],set.antivar.2d.slice,setZZ(),liste.valeur.slice[i])
} )
} else {
plotServerList <- lapply(
1:ratio.slice,
function(i) {
plotServer.simple(paste0("plot", i),df.sub.list[i],set.antivar.2d.slice,setZZ(),liste.valeur.slice[i],i)
})
}
})
output$plot.2dslide <- renderUI({
ns <- session$ns
tagList(
lapply(1:ratio.slice(),
function(i) {
plotUI(paste0("plot", i))
}
)
)
})
##### output sectiondensityplot slide ----
output$plotdens <- renderUI({
plotOutput("sectiondensityplot", height = height.size(), width = width.size())
})
output$sectiondensityplot <- renderPlot({
df.sub4<-df.sub()
min.size2<-minsize()
size.scale <- size.scale()
df.sub3<-df.sub.minpoint()
# if (nrow(df.sub3)>0){
# df.sub4$point.size2[!((df.sub4[,input$setx] %in% df.sub3[,input$setx]) & (df.sub4[,input$sety] %in% df.sub3[,input$sety]) & (df.sub4[,input$setz] %in% df.sub3[,input$setz]))]<-min.size2
# }
if (nrow(df.sub3)>0 && input$setID != "null"){
df.sub4$point.size2[!((df.sub4[,input$setID] %in% df.sub3[,input$setID]))]<-min.size2
}
myvaluesx<-unlist(myvaluesx())
orthofile<-NULL
if (input$var.ortho2 == "yes" ){
orthofile <- switch(input$var3,
xy = if(!is.null(input$file2)) {stack(input$file2$datapath)},
yx = if(!is.null(input$file5)) {stack(input$file5$datapath)},
xz = if(!is.null(input$file3)) {stack(input$file3$datapath)},
yz = if(!is.null(input$file4)) {stack(input$file4$datapath)}) }
list.parameter.info<-var.function(input$var3)
var<-list.parameter.info[[1]]
var2<-list.parameter.info[[2]]
nameaxis<-c(list.parameter.info[[3]],list.parameter.info[[4]])
Xtickmarks.size<-list.parameter.info[[5]]
Ytickmarks.size<-list.parameter.info[[6]]
Xminor.breaks<-list.parameter.info[[7]]
Yminor.breaks<-list.parameter.info[[8]]
df.sub4$density <- get_density(df.sub4[[var]], df.sub4[[var2]], n = 100)
# to correct the color for ggplot2
myvaluesx2<-myvaluesx[levels(as.factor(df$df[[inputcolor()]])) %in% levels(as.factor(df.sub4[[inputcolor()]]))]
# Density curve of x left panel
ydensity <- ggplot2::ggplot(df.sub4, aes(.data[[var]], fill=factor(.data[[inputcolor()]]))) +
ggplot2::geom_density(alpha=.5) +
ggplot2::scale_fill_manual( values = myvaluesx2)+
do.call(themeforfigure.choice(), list()) +
ggplot2::theme(legend.position = "none")
# Density curve of y right panel
zdensity <- ggplot2::ggplot(df.sub4, aes(.data[[var2]], fill=factor(.data[[inputcolor()]]))) +
ggplot2::geom_density(alpha=.5) +
scale_fill_manual( values = myvaluesx2) +
do.call(themeforfigure.choice(), list()) +
ggplot2::theme(legend.position = "none")+coord_flip()
blankPlot <- ggplot2::ggplot() +
ggplot2::geom_blank(aes(1,1))+
ggplot2::theme(plot.background = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank()
)
if (is.null(orthofile)){
p<-ggplot(df.sub4,aes(.data[[var]], .data[[var2]], color = density)) +
ggplot2::geom_point(aes(.data[[var]], .data[[var2]], color = density), alpha=transpar(), size=df.sub4$point.size2)+
ggplot2::scale_size_manual(values=c(size.scale,min.size2))+
ggplot2::labs(x = nameaxis[1],y = nameaxis[2])+
do.call(themeforfigure.choice(), list()) +
ggplot2::theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()))+
ggplot2::coord_fixed(ratio.simple())
# {if (input$ratio.to.coord)coord_fixed()}
} else { p <- ggplot2::ggplot()+ ggRGB(img = orthofile,
r = 1,
g = 2,
b = 3,
maxpixels =500000,
ggLayer = T) +
ggplot2::geom_point(df.sub4,mapping=aes(.data[[var]], .data[[var2]], color = density),alpha=transpar(), size=df.sub4$point.size2)+
ggplot2::labs(x = nameaxis[1],y = nameaxis[2])
}
if (input$var.plotlyg.lines== "yes") {
p<- p + ggplot2::geom_density_2d(mapping=aes(.data[[var]],.data[[var2]], color = after_stat(level)),data=df.sub4)}
p<- p + viridis::scale_color_viridis()+
ggplot2::guides(fill = guide_legend(title = "Level"))+
ggplot2::theme(axis.title.x = element_text(size=font_size()),
axis.title.y = element_text(size=font_size()),
axis.text.x = element_text(size=font_tick()),
axis.text.y = element_text(size=font_tick()),)
p<- p + ggplot2::scale_x_continuous(breaks=seq(floor(min(df.sub4[[var]])),max(df.sub4[[var]]),Xtickmarks.size),minor_breaks = seq(floor(min(df.sub4[[var]])),max(df.sub4[[var]]),Xminor.breaks)) +
ggplot2::scale_y_continuous(breaks=seq(floor(min(df.sub4[[var2]])),max(df.sub4[[var2]]),Ytickmarks.size), minor_breaks = seq(floor(min(df.sub4[[var2]])),max(df.sub4[[var2]]),Yminor.breaks))
if (input$var.density.curves== "yes") {
p <- gridExtra::grid.arrange(ydensity, blankPlot, p, zdensity,
ncol=2, nrow=2, widths=c(4, 1.4), heights=c(1.4, 4))
} else {
p}
session_store$plotdensity <- p
p
}) #end output$sectiondensityplot
observeEvent(input$transferxyz,{
if (dim(df$df[duplicated(df$df[,input$setID]),])[1]>0) {
showModal(modalDialog(
title = "This option is not possible without an unique ID !",
HTML(paste(dim(df$df[duplicated(df$df[,input$setID]),])[1], " object ID(s) is/are not unique ... <br> "))
))
return()
}
rotated.new.dataxy<-rotated.new.dataxy()
names(rotated.new.dataxy)<-c(paste(input$setID),"X.rotated","Y.rotated")
if(isTRUE("X.rotated" %in% names(df$df))==TRUE) {
df$df<-df$df[,!colnames(df$df) %in% c("rotated")]
}
df$df<-full_join(df$df,rotated.new.dataxy)
updateSelectInput(session,"setx",
choices=names(df$df["X.rotated"]),
selected = names(df$df["X.rotated"]))
updateSelectInput(session,"sety",
choices=names(df$df["Y.rotated"]),
selected = names(df$df["Y.rotated"]))
})
###output rotated 2D plot ----
output$plot2Drota<- renderUI({
plotlyOutput("plot2d2", height = height.size())
})
output$plot2Drota2<- renderUI({
plotlyOutput("plot2d3", height = height.size())
})
output$plot2d2 <- renderPlotly({
req(input$pi2)
req(input$ssectionXy3)
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
min.size2<-minsize()
df.sub5<-rotated.table()
df.sub5<-as.data.frame(df.sub5)%>%
filter(.data[["x2"]]>= min(input$ssectionXx3), .data[["x2"]]<= max(input$ssectionXx3)) %>%
filter(.data[["y2"]]>= min(input$ssectionXy3), .data[["y2"]]<= max(input$ssectionXy3))
shapeX<-df.sub5$shapeX
shape.level<-levels(as.factor(shapeX))
df.sub5$point.size2<-size.scale()
temp.rot<-data.frame(df.sub5[,input$setID],df.sub5["x2"],df.sub5["y2"])
colnames(temp.rot)<-c("ID","X.rotated","Y.rotated")
rotated.new.dataxy(temp.rot)
p<- plot_ly(df.sub5, x = ~x2, y = ~y2,
type="scatter",
color = ~layer2,
colors = myvaluesx,
size = ~point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~shapeX,
symbols = shape.level,
text=df.sub5$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'),
height=height.size(),
width=width.size()
)
Xtval<-seq(floor(min(df.sub5[["x2"]])),max(df.sub5[["x2"]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub5[["y2"]])),max(df.sub5[["y2"]]), Yminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ytickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ytickmarks.size())]
p <- p %>% layout(showlegend = legendplotlyfig(),
scene = list(aspectratio=list(x=ratiox(),y=ratioy(),z=ratioz())),
xaxis = list(title=paste0(nameX()," modified"),
dtick = Xtickmarks.size(),
tickvals=Xtval,
ticktext=Xttxt,
tick0 = floor(min(df.sub5[["x2"]])),
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis=list(title=paste(nameY()," modified"),
dtick = Ytickmarks.size(),
tickvals=Ytval,
ticktext=Yttxt,
tick0 = floor(min(df.sub5[["y2"]])),
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg")
)
session_store$plotrota <- p
p
})
output$plot2d3 <- renderPlotly({
req(input$pi2)
req(input$ssectionXy3)
myvaluesx<-unlist(myvaluesx())
size.scale <- size.scale()
min.size2<-minsize()
df.sub5<-rotated.table()
df.sub5<-df.sub5%>%
filter(.data[["x2"]]>= min(input$ssectionXx3), .data[["x2"]]<= max(input$ssectionXx3)) %>%
filter(.data[["y2"]]>= min(input$ssectionXy3), .data[["y2"]]<= max(input$ssectionXy3))
df.sub5<-as.data.frame(df.sub5)
df.sub5$var2<- df.sub5[,input$setz]
switch(input$var.section2D,
xz={var<-"x2"
var3<-paste0(nameX()," modified")},
yz={ var<-"y2"
var3<-paste0(nameY()," modified") })
shapeX<-df.sub5$shapeX
shape.level<-levels(as.factor(shapeX))
df.sub5$point.size2<-size.scale()
p<- plot_ly(df.sub5, x = ~df.sub5[[var]], y = ~df.sub5[[setZZ()]],
type="scatter",
color = ~layer2,
colors = myvaluesx,
size = ~point.size2,
sizes = c(min.size2,size.scale),
mode = 'markers',
fill = ~'',
symbol = ~shapeX,
symbols = shape.level,
text=df.sub5$text,
hovertemplate = paste('<b>X</b>: %{x:.4}',
'<br><b>Y</b>: %{y}',
'<b>%{text}</b>'),
height=height.size(),
width=width.size()
)
Xtval<-seq(floor(min(df.sub5[[var]])),max(df.sub5[[var]]),Xminorbreaks())
Xttxt <- rep("",length(Xtval))
Xttxt[seq(1,length(Xtval),Xtickmarks.size())]<-as.character(Xtval)[seq(1,length(Xtval),Xtickmarks.size())]
Ytval<-seq(floor(min(df.sub5[[setZZ()]])),max(df.sub5[[setZZ()]]), Zminorbreaks())
Yttxt <- rep("",length(Ytval))
Yttxt[seq(1,length(Ytval),Ztickmarks.size())]<-as.character(Ytval)[seq(1,length(Ytval),Ztickmarks.size())]
p <-p %>% layout(showlegend = legendplotlyfig(),
scene = list(aspectratio=list(x=ratiox(),y=ratioy(),z=ratioz())),
xaxis = list(title=paste0(var3),
dtick = Xtickmarks.size(),
tick0 = floor(min(df.sub5[[var]])),
tickvals=Xtval,
ticktext=Xttxt,
#tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
yaxis=list(title=paste(nameZ()),
dtick = Ytickmarks.size(),
tickvals=Ytval,
ticktext=Yttxt,
tick0 = floor(min(df.sub5[,input$setz])),
# tickmode = "linear",
titlefont = list(size = font_size()), tickfont = list(size = font_tick())),
dragmode = "select")%>%
event_register("plotly_selecting")
p <-p %>%
config(displaylogo = FALSE,
modeBarButtonsToAdd = list(dl_button),
toImageButtonOptions = list(
format = "svg"))
})
##### download button ----
##3D plot
output$downloadData3D <- downloadHandler(
filename = function() {
paste("plot3D - ",paste(input$file1$name)," - ", Sys.Date(), ".html", sep="")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(session_store$plt), file, selfcontained = TRUE)
}
)
options(shiny.usecairo=T)
##2d plot
output$downloadData2D <- downloadHandler(
filename = function() {
paste("plot2D - ",paste(input$file1$name)," - ", Sys.Date(), ".html", sep="")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(session_store$plt2D), file, selfcontained = TRUE)
}
)
output$downloadData2D.simple <- downloadHandler(
filename = function(){paste("plot2D - ",paste(input$file1$name)," - ", Sys.Date(), '.pdf', sep = '')},
content = function(file){
ggsave(session_store$plt2D.simple,filename=file, device = "pdf")
},
)
##2D plot slice.simple mode
output$download.slice <- downloadHandler(
filename = function(){paste("plot2D - ",paste(input$file1$name)," - ", Sys.Date(), '.pdf', sep = '')},
content = function(file){
plot.lists<-list()
for (i in 1:nb.slice()) {
plot.lists[[i]]<-get(paste0("session_store$test$",i), envir=e())
}
ggsave(grid.arrange(grobs = plot.lists, ncol = 1),filename=file, device = "pdf",scale=nb.slice(),limitsize=FALSE)
},
)
##2d plot slice
output$downloadData2d.slice <- downloadHandler(
filename = function() {
paste("plot2D.slice - ",paste(input$file1$name)," - ", Sys.Date(), ".html", sep="")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(session_store$plotslice), file, selfcontained = TRUE)
}
)
##2d plot density
output$downloadDatadensity <- downloadHandler(
filename = function(){paste("plotDensity - ",paste(input$file1$name)," - ", Sys.Date(), '.pdf', sep = '')},
content = function(file){
ggsave(session_store$plotdensity,filename=file, device = "pdf")
},
)
# refit table
output$downloadData_redata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"_refit_table.csv",sep="")
},
content = function(file) {
write.table(data.fit3()[,4:ncol(data.fit3())], file, row.names = FALSE, sep=";",dec=".")
}
)
# raw table
output$downloadData_rawdata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),paste(input$file1$name),".csv",sep="")
},
content = function(file) {
write.table(df$df[,3:ncol(df$df)], file, row.names = FALSE, sep=";",dec=".")
}
)
# pivot table
output$downloadData_pivotdata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"pivot.table",".csv")
},
content = function(file) {
write.table(Pivotdatatable(), file, row.names = FALSE, sep=";",dec=".")
}
)
# save color
output$save.col<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"save.col",".csv")
},
content = function(file) {
write.table(save.col.react(), file, row.names = FALSE, sep=";",dec=".")
}
)
output$save.col.fit<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"save.col.refit",".csv")
},
content = function(file) {
write.table(save.col.react.fit(), file, row.names = FALSE, sep=";",dec=".")
}
)
#rotated table
output$downloadData_rotateddata<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"rotated coordinates",".csv")
},
content = function(file) {
write.table(rotated.new.dataxy(), file, row.names = FALSE, sep=";",dec=".")
}
)
##### output summary slide ----
output$liste.summary=renderUI({
req(!is.null(fileisupload()))
checkboxGroupInput("listesum", h4("Variables for summary table"),
choices = names(df$df)[c(3:ncol(df$df))])
})
Pivotdatatable<-reactive({req(input$listesum)
df.sub<-df.sub()
liste.sum<-c(input$listesum) # creation d'une liste
table_matos<-df.sub %>% group_by(across(liste.sum)) %>% summarize(Freq=n())
colnames(table_matos)<-c(unlist(liste.sum),"n")
table_matos})
output$summary <- renderTable({
Pivotdatatable()
})
##### output Table ----
# output$table <- shiny::renderDataTable(
output$table <- DT::renderDataTable(
DT::datatable(
df.sub()[,-c(1:6)], extensions = 'Buttons', options = list(
lengthMenu = list(c(5, 15,50,100, -1), c('5', '15','50','100', 'All')),
pageLength = 15,
initComplete = htmlwidgets::JS(
"function(settings, json) {",
paste0("$(this.api().table().container()).css({'font-size': '", font.size, "'});"),
"}")
))
)#end renderDataTable
#### button example of Cassenade ----
observeEvent(input$button_example, {
updateTabsetPanel(session, "mainpanel",
selected = "Load data")
path <- paste0(tempdir(), "/cassenade.csv")
write.csv2(SEAHORS::cassenade, path)
input_file1.name("cassenade.csv")
input_file1.datapath(path)
df$file.fit <- SEAHORS::cassenade.refits
getdata.launch(1)
})
#### rmarkdown report template ----
w.report<-function(){
writeLines(con = "report.Rmd", text = "---
title: 'Welcome to *SEAHORS* report'
output: html_document
date : '`r format(Sys.time())`'
params:
data: NA
dataraw: NA
file: NA
path: NA
plot2: NA
plot2simple: NA
plot3: NA
plotrota: NA
plotdens: NA
nat: NA
pas: NA
loca: NA
UAS: NA
tobj: NA
xsli: NA
ysli: NA
zsli: NA
dat: NA
linfos: NA
col: NA
setx: NA
sety: NA
setz: NA
setid: NA
setsect: NA
setnat: NA
setlvl: NA
setdate: NA
setpasse: NA
fileextra: NA
filerem: NA
setrem: NA
tabrefit: NA
---
```{r setup, include= FALSE}
library(DT)
```
```{r, echo=FALSE}
if (file.exists(paste0(getwd(),'www/logo1.png'))){
htmltools::img(src = knitr::image_uri(file.path(getwd(), 'www/logo1.png')),
alt = 'logo',
style = 'position:absolute; top:0; right:0; padding:10px; height:150px ;')
}
```
```{r, echo=FALSE, include=FALSE}
file<-params$file
path<-params$path
data2<-params$data
nat<- params$nat
pas<-params$pas
loca <-params$loca
UAS <-params$UAS
tobj <-params$tobj
xsli<-params$xsli
ysli <-params$ysli
zsli<-params$zsli
dat <-params$dat
linfos<-params$linfos
col<-params$col
setx<-params$setx
sety<-params$sety
setz<-params$setz
setid<-params$setid
setsect<-params$setsect
setnat <-params$setnat
setlvl<-params$setlvl
setdate <-params$setdate
setpasse<-params$setpasse
fileextra<-params$fileextra
filerem <-params$filerem
setrem<-params$setrem
tabrefit <-params$tabrefit
data2raw<-params$dataraw
```
---
This report was produced using the file **`r file[1]`** <br>
### Setting informations
X axis: **`r setx`** <br>
- sliders Xlimits between **`r xsli[1]` ** and **`r xsli[2]` ** <br>
Y axis: **`r sety`** <br>
- sliders Ylimits between **`r ysli[1]` ** and **`r ysli[2]` ** <br>
Z axis: **`r setz`** <br>
-sliders Zlimits between **`r zsli[1]` ** and **`r zsli[2]` ** <br>
Year(s): **`r setdate `** <br>
- sliders between **`r dat[1] `** and **`r dat[2] `**<br>
Unique object IDs: **`r setid `**<br>
```{r , echo=FALSE, message=FALSE, out.width='50%'}
if (setid != 'null'){
if(dim(data2raw[duplicated(data2raw[,setid]),])[1]>0) {
paste('Object IDs were not unique') } else {
paste('All objects have unique IDs')
}}
```
Context: **`r setsect `** <br>
-with **`r loca`** parameters selected <br>
Levels: **`r setlvl `** <br>
-with **`r UAS `** parameters selected <br>
Type: **`r setnat `** <br>
-with **`r nat `** parameters selected <br>
Others: **`r setpasse `** <br>
-with **`r pas `** parameters selected<br>
**`r tobj `**
### Coloried variable :
```{r , echo=FALSE, message=FALSE, out.width='100%'}
col
```
### The data :
```{r , echo=FALSE, message=FALSE, out.width='100%'}
data2
```
### The refit data :
```{r , echo=FALSE, message=FALSE, out.width='100%'}
if (!is.null(tabrefit)) {
tabrefit} else {
paste('no refit table has been added')
}
```
### The plot(s) :
```{r plotlyout, echo=FALSE, message=FALSE, out.width='100%'}
if (!is.null(params$plot2)) {params$plot2}
if (!is.null(params$plot2simple)) {params$plot2simple}
if (!is.null(params$plot3)) {params$plot3}
if (!is.null(params$plotdens)) {params$plotdens}
if (!is.null(params$plotdens)) {params$plotrota}
```")
}
#### Rmarkdown report export ----
output$export.Rmarkdown<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"_report_Rmarkdown",".", input$docpdfhtml)
},
content = function(file) {
if (!is.null(data.fit3())){
data.fit4<-data.fit3()[,4:ncol(data.fit3())]
} else {
data.fit4<-NULL}
params2 <- list(data = df.sub()[,7:ncol(df.sub())],
dataraw = df$df[,4:ncol(df$df)],
file = input$file1$name,
path= input$file1$datapath,
plot3= session_store$plt,
plot2= session_store$plt2D,
plot2simple=session_store$plt2D.simple,
plotrota=session_store$plotrota,
plotdens=session_store$plotdensity,
nat=input$Nature,
pas=input$Passe,
loca=input$localisation,
UAS=input$UAS,
tobj=textnbobject(),
xsli=input$xslider,
ysli=input$yslider,
zsli=input$zslider,
dat=input$Date2,
linfos=listinfosmarqueur(),
col=save.col.react(),
setx=input$setx,
sety=input$sety,
setz=input$setz,
setid=input$setID,
setsect=input$setsector,
setnat=input$setnature,
setlvl=input$setlevels,
setdate=input$setdate,
setpasse= input$setpasse,
fileextra=input$file.extradata$name,
filerem=input$file.fit$name,
setrem=input$setREM,
tabrefit=data.fit4
)
w.report()
tmp_dir <- tempdir()
tmp_pic2 <- file.path(tmp_dir,"www/logo1.png")
file.copy("www/logo1.png", tmp_pic2, overwrite = TRUE)
tempReport <- tempfile(fileext = ".Rmd") # make sure to avoid conflicts with other shiny sessions if more params are used
file.copy("report.Rmd", tempReport, overwrite = TRUE)
rmarkdown::render(tempReport, output_format = paste0(input$docpdfhtml,"_document"), output_file = file, output_options = list(self_contained = TRUE),
params = params2
)
}
)
############################### ADD save & load for v1.9 ----
#button
observeEvent(input$save_load, {
req(!is.null(fileisupload()))
showModal(
modalDialog(
title = tags$h4(style = "color: red;","Save settings and data"),
easyClose = T,
fluidRow(
br(),
column(7, shinyWidgets::radioGroupButtons(
inputId = "Save_settings",
label = NULL,
choices = c("Save settings" = 1, "Save settings and data" = 2),
status = "danger"
),br(),
br(),),
br(),
br(),
#column(3, actionButton("go.gen.settings", "Generate"),),
column(7, downloadButton("export.settings", "Export settings as .rds document")),
br(),
hr(),
br(),),
)
)
})
observeEvent(input$save_load2, {
showModal(
modalDialog(
title = tags$h4(style = "color: red;","Load file"),
easyClose = T,
fluidRow(
column(7, fileInput("file.set", "Choose File to import settings (.rds)",
multiple = TRUE,
accept = c(
".rds")),
actionButton("go.load.settings", "load it")),
br(),
tags$h5(style = "color: blue;","This option is still in progress. Not all parameters could be loaded "),
tags$h5(style = "color: blue;"," And is still not totally perfectly scripted. You may need to load twice or third the datafile to recover all the parameters. ")
)
)
)
})
#save
global<-reactiveValues(digitnumber=NULL)
output$export.settings<- downloadHandler(
filename = function() {
paste0(Sys.Date(),"save.settings",".rds")
},
content = function(file) {
req(!is.null(fileisupload))
global$data <-0
if (input$Save_settings ==2){
global$data <-"data_upload"
global$df<-df$df
}
global$digitnumber<-digitnumber()
global$setnature<-input$setnature
global$minsize<-minsize()
global$size.scale<-size.scale()
global$stepX<-stepX()
global$stepY<-stepY()
global$stepZ<-stepZ()
global$transpar<-transpar()
global$data.fit<-data.fit()
global$data.fit2<-data.fit2()
global$data.fit3<-data.fit3()
global$rotated.new.dataxy<-rotated.new.dataxy()
global$shape_all<-shape_all()
global$setXX<- setXX()
global$setYY<- setYY()
global$setZZ<- setZZ()
global$height.size<- height.size()
global$width.size<- width.size() #
global$data.fit.3D<- data.fit.3D() #
global$listinfosmarqueur<- listinfosmarqueur()
global$colorofrefit<- colorofrefit()#t
global$legendplotlyfig<- legendplotlyfig()
global$inputcolor<- inputcolor()
global$save.col.react.fit<- save.col.react.fit()
global$mypaletteofcolors.fit<- mypaletteofcolors.fit()
global$ratiox<- ratiox()
global$ratioy<- ratioy()
global$ratioz<- ratioz()
global$ratio.simple<- ratio.simple()
global$font_size<- font_size()
global$font_tick<- font_tick()
global$nameX<- input$Name.X
global$nameY<- input$Name.Y
global$nameZ<- input$Name.Z
global$Xtickmarks.size<- Xtickmarks.size()
global$Ytickmarks.size<- Ytickmarks.size()
global$Ztickmarks.size<- Ztickmarks.size()
global$Xminorbreaks<- Xminorbreaks()
global$Yminorbreaks<- Yminorbreaks()
global$Zminorbreaks<- Zminorbreaks()
global$ID.no.suppl.data.txt<- ID.no.suppl.data.txt()
global$notunique.txt<- notunique.txt()
global$notunique2.txt<- notunique2.txt()
global$suppl.no.include.txt<- suppl.no.include.txt()
global$input_file1.name<-input_file1.name()
global$input_file1.datapath<-input_file1.datapath()
global$getdata.launch<-getdata.launch()
global$ratio.slice<-ratio.slice()
global$nb.slice<-nb.slice()
global$themeforfigure.choice<-themeforfigure.choice()
global$textnbobject<-textnbobject()
global$var.sub2<-var.sub2()
global$min.point.sliderx<-min.point.sliderx()
global$min.point.slidery<-min.point.slidery()
global$min.point.sliderz<-min.point.sliderz()
global$set.var.gris<-set.var.gris()
global$set.var.2d.slice<-set.var.2d.slice()
global$step.input.step2dslice<-step.input.step2dslice()
#reactiveValues
global$values.newgroup<-values$newgroup
#input
global$setx<-input$setx
global$sety<-input$sety
global$setz<-input$setz
global$setnature<-input$setnature
global$setlevels<-input$setlevels
global$setdate<-input$setdate
global$setpasse<-input$setpasse
global$setID<-input$setID
global$setsector<-input$setsector
global$checkbox.invX<-input$checkbox.invX
global$input_xslider_1<-input$xslider[1]
global$input_xslider_2<-input$xslider[2]
global$checkbox.invY<-input$checkbox.invY
global$input_yslider_1<-input$yslider[1]
global$input_yslider_2<-input$yslider[2]
global$checkbox.invZ<-input$checkbox.invZ
global$input_zslider_1<-input$zslider[1]
global$input_zslider_2<-input$zslider[2]
global$pi2<-input$pi2
global$file2<-input$file2
global$file3<-input$file3
global$file4<-input$file4
global$file5<-input$file5
global$var.plotlyg.lines<-input$var.plotlyg.lines
global$var.density.curves<-input$var.density.curves
global$listeinfos.go<-input$listeinfos.go # to modify // mettre en reactival pour reaction auto
global$themeforfigure.list<-input$themeforfigure.list
#selectInput
global$Colors<-input$Colors
#checkboxGroupInput
global$Nature<-input$Nature
global$Passe<-input$Passe
global$localisation<-input$localisation
global$UAS<-input$UAS
global$listeinfos<-input$listeinfos
#sliderinput
global$yslider<- input$yslider
global$xslider<-input$xslider
print(input$xslider)
global$zslider<-input$zslider
print(input$zslider)
global$Date2<-input$Date2
global$ssectionXy2<-input$ssectionXy2
global$ssectionXx2<-input$ssectionXx2
global$ssectionXz2<-input$ssectionXz2
global$ssectionXx3<-input$ssectionXx3
global$ssectionXy3<-input$ssectionXy3
global$range2dslice<-input$range2dslice
#selectInput
global$setshape2<-input$setshape2
global$setshape2.1<-input$setshape2.1
global$setshape2.2<-input$setshape2.2
#numeric imput
global$ratio.to.coord.simple.2<-input$ratio.to.coord.simple.2
#pour les couleurs
global$save.col.react<-save.col.react()
global$save.col.react.fit<-save.col.react.fit()
#df$file.color<-save.col.react()
#df$file.color.fit<-save.col.react.fit()
#radiobutton
global$var1<-input$var1
global$var.ortho<-input$var.ortho
global$var.fit.table<-input$var.fit.table
global$var1.simple<-input$var1.simple
global$var.ortho.simple<-input$var.ortho.simple
global$var.fit.table.simple<-input$var.fit.table.simple
global$var.2d.slice<-input$var.2d.slice
global$var.section2D<-input$var.section2D
global$var3<-input$var3
global$var.ortho2<-input$var.ortho2
global$var.plotlyg.lines<-input$var.plotlyg.lines
global$var.density.curves<-input$var.density.curves
global$separatormerge<-input$separatormerge
global$var.fit.3D<-input$var.fit.3D
#checkboxinput
global$header<-input$header
global$set.dec<-input$set.dec
global$advanced.slice<-input$advanced.slice
to_save <- reactiveValuesToList(global)
saveRDS(to_save, file = file)
})
#load part
nexstep<-reactiveVal(0)
input_file.load<-reactiveVal(NULL)
input_file.load.datapath<-reactiveVal(NULL)
observe({
req(nexstep()==1)
global.load<-readRDS(input_file.load.datapath())
df$df$shapeX[df$df[,global.load$setshape2.1] %in% global.load$setshape2.2]<-global.load$setshape2
input_file1.name(global.load$input_file1.name)
updateNumericInput(session,"minsize", value=global.load$minsize)
updateNumericInput(session,"point.size", value=global.load$size.scale)
updateCheckboxInput(session,'advanced.slice',value = global.load$advanced.slice)
getdata.launch(global.load$getdata.launch)
rotated.new.dataxy(global.load$rotated.new.dataxy)
updateSliderInput(session,"alpha.density", value=global.load$transpar)
updateNumericInput(session,"height.size.b", value=global.load$height.size)
updateNumericInput(session,"width.size.b", value=global.load$width.size)
transpar(global.load$transpar)
height.size(global.load$height.size)
width.size(global.load$width.size)
shape_all(global.load$shape_all)
updateCheckboxInput(session, 'optioninfosfigplotly ', value = global.load$legendplotlyfig)
legendplotlyfig(global.load$legendplotlyfig)
listinfosmarqueur(global.load$listinfosmarqueur) ################################### celui la est a revoir
ID.no.suppl.data.txt(global.load$ID.no.suppl.data.txt)
notunique.txt(global.load$notunique.txt)
notunique2.txt(global.load$notunique2.txt)
updateSliderInput(session,"pi2",
value = global.load$pi2)
updateNumericInput(session,"ratiox", value=global.load$ratiox)
updateNumericInput(session,"ratioy", value=global.load$ratioy)
updateNumericInput(session,"ratioz", value=global.load$ratioz)
ratiox(global.load$ratiox)
ratioy(global.load$ratioy)
ratioz(global.load$ratioz)
updateNumericInput(session,"ratio.to.coord", value=global.load$ratio.simple)
updateNumericInput(session,"ratio.to.coord.simple", value=global.load$ratio.simple)
updateNumericInput(session,"ratio.to.coord.simple.2", value=global.load$ratio.to.coord.simple.2)
updateNumericInput(session,"stepXsize", value=global.load$stepX)
updateNumericInput(session,"stepYsize", value=global.load$stepY)
updateNumericInput(session,"stepZsize", value=global.load$stepZ)
stepX(global.load$stepX)
stepY(global.load$stepY)
stepZ(global.load$stepZ)
updateRadioButtons(session,"var1",selected = global.load$var1)
updateRadioButtons(session,"var.ortho",selected = global.load$var.ortho)
updateRadioButtons(session,"var.fit.table",selected = global.load$var.fit.table)
updateRadioButtons(session,"var1.simple",selected = global.load$var1.simple)
updateRadioButtons(session,"var.ortho.simple",selected = global.load$var.ortho.simple)
updateRadioButtons(session,"var.fit.table.simple",selected = global.load$var.fit.table.simple)
updateRadioButtons(session,"var.2d.slice",selected = global.load$var.2d.slice)
updateRadioButtons(session,"var.section2D",selected = global.load$var.section2D)
updateRadioButtons(session,"var3",selected = global.load$var3)
updateRadioButtons(session,"var.ortho2",selected = global.load$var.ortho2)
updateRadioButtons(session,"var.plotlyg.lines",selected = global.load$var.plotlyg.lines)
updateRadioButtons(session,"var.density.curves",selected = global.load$var.density.curves)
updateRadioButtons(session,"separatormerge",selected = global.load$separatormerge1)
updateRadioButtons(session,"var.fit.3D",selected = global.load$var.fit.3D)
set.var.2d.slice(global.load$set.var.2d.slice)
step.input.step2dslice(global.load$step.input.step2dslice)
ratio.slice(global.load$ratio.slice)
nb.slice(global.load$nb.slice)
#input_file1.datapath(global.load$input_file1.datapath)
updateSelectInput(session, 'themeforfigure.list', selected = global.load$themeforfigure.list)
themeforfigure.choice(global.load$themeforfigure.choice)
textnbobject(global.load$textnbobject) # no need ?
updateRadioButtons(session,"var.plotlyg.lines",selected = global.load$var.plotlyg.lines)
updateRadioButtons(session,"var.density.curves",selected = global.load$var.density.curves)
updateNumericInput(session,"fontsizeaxis",value=global.load$font_size)
updateNumericInput(session,"fontsizetick",value=global.load$font_tick)
updateTextInput(session, 'Name.X',value= global.load$nameX)
updateTextInput(session, 'Name.Y',value= global.load$nameY)
updateTextInput(session, 'Name.Z',value= global.load$nameZ)
updateNumericInput(session,"Xtickmarks",value=global.load$Xtickmarks.size)
updateNumericInput(session,"Ytickmarks",value=global.load$Ytickmarks.size)
updateNumericInput(session,"Ztickmarks",value=global.load$Ztickmarks.size)
updateNumericInput(session,"Xminor.breaks",value=global.load$Xminorbreaks)
updateNumericInput(session,"Yminor.breaks",value=global.load$Yminorbreaks)
updateNumericInput(session,"Zminor.breaks",value=global.load$Zminorbreaks)
set.var.gris(global.load$set.var.gris)
var.sub2(global.load$var.sub2)
updateSelectInput(session, 'set.var.gris.2D ', selected = global.load$set.var.gris)
updateCheckboxGroupInput(session, 'set.var.gris.2D ', selected = global.load$set.var.gris)
#values$newgroup<-global.load$values.newgroup
#refit to finish
data.fit(global.load$data.fit) ##for import fit data
data.fit2(global.load$data.fit2) ##for import fit data
data.fit3(global.load$data.fit3) ##for import fit data
data.fit.3D(global.load$data.fit.3D) ## for refit data for 3D plot
colorofrefit(global.load$colorofrefit)## color base for refit
#save.col.react.fit(global.load$save.col.react.fit)
mypaletteofcolors.fit(global.load$mypaletteofcolors.fit)
suppl.no.include.txt(global.load$suppl.no.include.txt)
save.col.react(global.load$save.col.react)
df$file.color<-save.col.react()
save.col.react.fit(global.load$save.col.react.fit)
df$file.color.fit<-save.col.react.fit()
updateSelectInput(session,"setx",
selected = global.load$setx)
updateSelectInput(session,"sety",
selected = global.load$sety)
updateSelectInput(session,"setz",
selected = global.load$setz)
updateCheckboxInput(session,"checkbox.invX",
value =global.load$checkbox.invX)
updateCheckboxInput(session,"checkbox.invY",
value =global.load$checkbox.invY)
updateCheckboxInput(session,"checkbox.invZ",
value =global.load$checkbox.invZ)
updateSelectInput(session,"setnature",
selected = global.load$setnature)
updateSelectInput(session,"setlevels",
selected = global.load$setlevels)
updateSelectInput(session,"setdate",
selected = global.load$setdate)
updateSelectInput(session,"setpasse",
selected = global.load$setpasse)
updateSelectInput(session,"setID",
selected = global.load$setID)
updateSelectInput(session,"setsector",
selected = global.load$setsector)
df.sub()
nexstep(2)
})
observe({
req(nexstep()==2)
global.load<-readRDS(input_file.load.datapath())
dmin=min(as.numeric(df$df[,global.load$setdate]), na.rm=T)
dmax=max(as.numeric(df$df[,global.load$setdate]), na.rm=T)
if (!is.infinite(dmin) && !is.infinite(dmax)) {
updateSliderInput(session,'Date2',min=dmin,max=dmax,value=c(global.load$Date2[1],global.load$Date2[2]))
}
xmax = df$df[,global.load$setXX] %>% as.numeric() %>% ceiling() %>% max(na.rm = TRUE)
xmin=df$df[,global.load$setXX] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'xslider',min=xmin,max=xmax,
value=c(global.load$xslider[1],global.load$xslider[2]),step=global.load$stepX)
ymax = df$df[,global.load$setYY] %>% as.numeric() %>% ceiling() %>% max(na.rm = TRUE)
ymin=df$df[,global.load$setYY] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
zmax = df$df[,global.load$setZZ] %>% as.numeric() %>% ceiling() %>% max(na.rm = TRUE)
zmin=df$df[,global.load$setZZ] %>% as.numeric() %>% floor() %>% min(na.rm = TRUE)
updateSliderInput(session,'yslider','y limits',min=ymin,max=ymax,
value=c(global.load$yslider[1],global.load$yslider[2]),step=global.load$stepY)
updateSliderInput(session,'zslider','z limits',min=zmin,max=zmax,
value=c(global.load$zslider[1],global.load$zslider[2]),step=global.load$stepZ)
updateCheckboxGroupInput(session,"UAS", selected=global.load$UAS)
updateCheckboxGroupInput(session,"Nature", selected=global.load$Nature)
updateCheckboxGroupInput(session,"Passe", selected=global.load$Passe)
updateCheckboxGroupInput(session,"localisation", selected=global.load$localisation)
updateCheckboxGroupInput(session,"listeinfos", selected=global.load$listeinfos)
# don't work strangely
updateSliderInput(session,'ssectionXy2',min=global.load$yslider[1],max=global.load$yslider[2],
value=c(global.load$ssectionXy2[1],global.load$ssectionXy2[2]),step=global.load$stepY)
updateSliderInput(session,'ssectionXx2',min=global.load$xslider[1],max=global.load$xslider[2],
value=c(global.load$ssectionXx2[1],global.load$ssectionXx2[2]),step=global.load$stepX)
updateSliderInput(session,'ssectionXz2',min=global.load$zslider[1],max=global.load$zslider[2],
value=c(global.load$ssectionXz2[1],global.load$ssectionXz2[2]),step=global.load$stepZ)
min.point.sliderx(global.load$min.point.sliderx)
min.point.slidery(global.load$min.point.slidery)
min.point.sliderz(global.load$min.point.sliderz)
updateSliderInput(session,'ssectionXy3',min=global.load$yslider[1],max=global.load$yslider[2],
value=c(global.load$ssectionXy3[1],global.load$ssectionXy3[2]),step=global.load$stepY)
updateSliderInput(session,'ssectionXx3',min=global.load$xslider[1],max=global.load$xslider[2],
value=c(global.load$ssectionXx3[1],global.load$ssectionXx3[2]),step=global.load$stepX)
updateSliderInput(session,'range2dslice',min=global.load$range2dslice[1],max=global.load$range2dslice[2],
value=c(global.load$range2dslice[1],global.load$range2dslice[2]))
df.sub.minpoint()
nexstep(4)
})
observeEvent(nexstep(),{
req(nexstep()==4)
req(!is.null(ttemp()))
global.load<-readRDS(input_file.load.datapath())
req(!is.null(df.sub.minpoint()))
nexstep(0)
input_file.load.datapath(NULL)
})
ttemp<-reactiveVal(NULL)
observeEvent(nexstep(),{
req(nexstep()==1)
updateRadioButtons(session,"bt2",selected=3)
ttemp(1)
})
observe({
req(!is.null(ttemp()))
req(!is.null(input_file.load.datapath()))
global.load<-readRDS(input_file.load.datapath())
req(!is.null(global.load$Colors))
updateSelectInput(session,"Colors",
selected = global.load$Colors)
inputcolor(global.load$Colors)
basiccolor()
})
observeEvent(input$file.set, {
nexstep(0)
input_file.load.datapath(NULL)
input_file.load(input$file.set$name)
input_file.load.datapath(input$file.set$datapath)
})
observe({
file = input$go.load.settings
ext = tools::file_ext(input_file.load.datapath())
req(file)
validate(need(ext == "rds", "Please upload a rds file"))
req(nexstep()==0)
global.load<-readRDS(input_file.load.datapath())
digitnumber(global.load$digitnumber)
updateCheckboxInput(session,'header',value = global.load$header)
updateCheckboxInput(session,'set.dec',value = global.load$set.dec)
if (global.load$data =="data_upload"){
df$df<-global.load$df
updateTabsetPanel(session, "mainpanel",
selected = "Load data")
inputcolor("null")
fileisupload(1)
} else {
if (is.null(df$df)) {
input_file.load(NULL)
input_file.load.datapath(NULL)
}
else {
updateTabsetPanel(session, "mainpanel",
selected = "Load data")
inputcolor(global.load$Colors)
fileisupload(1)
}
req(!is.null(df$df))
}
nexstep(1)
})
} # end server
Try the SEAHORS package in your browser
Any scripts or data that you put into this service are public.
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.