Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
CSIRO-INRA
landsepi
Commits
ad7a3b1b
Commit
ad7a3b1b
authored
May 21, 2021
by
Jean-Francois Rey
☕
Browse files
update shiny apps
advanced mode keep memory of modification when switching
parent
00eb78c5
Changes
2
Hide whitespace changes
Inline
Side-by-side
inst/shiny-landsepi/global.R
View file @
ad7a3b1b
...
...
@@ -37,7 +37,7 @@ cleanDir(paste0(ROOT_PATH,"/www/tmp/"))
advanced_mode
<-
reactiveVal
(
FALSE
)
## Croptypes proportions in landscape
croptypes_proportions
<-
c
(
1
)
croptypes_proportions
<-
shiny
::
reactiveVal
(
c
(
1
)
)
## simul params reactive for view
## use to update view
...
...
@@ -96,7 +96,7 @@ checkCroptypesTable <- function(data) {
## no cultivars
if
(
ncol
(
data
)
<=
2
)
{
showErrorMessage
(
id
=
"croptypeError"
,
selectorafter
=
"#generateLandscape"
,
message
=
paste0
(
"There is no cultivars defined"
))
message
=
paste0
(
"There is no cultivars defined
in croptypes
"
))
isok
<-
FALSE
}
else
{
...
...
@@ -129,6 +129,7 @@ checkCroptypesTable <- function(data) {
checkCultivarsTable
<-
function
(
data
)
{
isok
<-
TRUE
shiny
::
removeUI
(
selector
=
"#cultivarsNameError"
)
if
(
sum
(
as.character
(
data
[,
1
])
==
""
)
!=
0
|
sum
(
grepl
(
"^\\s*$"
,
as.character
(
data
[,
1
])))
!=
0
)
{
showErrorMessage
(
id
=
"cultivarsNameError"
,
selectorafter
=
"#generateLandscape"
,
...
...
@@ -160,6 +161,8 @@ checkCultivarsGenesTable <- function(data){
checkGenesTable
<-
function
(
data
){
isok
<-
TRUE
shiny
::
removeUI
(
selector
=
"#GenesNameError"
)
if
(
sum
(
as.character
(
data
[,
1
])
==
""
)
!=
0
|
sum
(
grepl
(
"^\\s*$"
,
as.character
(
data
[,
1
])))
!=
0
)
{
showErrorMessage
(
id
=
"GenesNameError"
,
selectorafter
=
"#generateLandscape"
,
...
...
@@ -311,101 +314,3 @@ PercentageInput <- function(inputId, label, value) {
)
}
genCroptypesTable
<-
function
(
dt
,
proportions
,
mode
=
FALSE
)
{
#proportions <- rep(round(1/nrow(dt), 2),nrow(dt))
sum_prop
<-
sum
(
proportions
)
if
(
!
isTRUE
(
all.equal
(
sum_prop
,
1
))
||
is.na
(
sum_prop
))
{
proportions
[
1
]
<-
proportions
[
1
]
+
0.01
}
if
(
mode
==
0
)
{
disableCols
=
names
(
dt
)
}
else
disablesCols
=
c
()
croptypesTable
<-
editableDTServer
(
id
=
"croptypes"
,
DTdata
=
shiny
::
reactive
(
cbind
(
dt
,
data.frame
(
Proportions
=
proportions
))),
disableCol
=
disableCols
,
canRm
=
mode
)
shiny
::
observeEvent
(
croptypesTable
$
value
,
{
message
(
"Croptypes update"
)
if
(
sum
(
is.na
(
croptypesTable
$
value
)))
{
return
(
1
)
}
message
(
"i "
,
croptypesTable
$
data
)
message
(
"i "
,
croptypesTable
$
value
)
message
(
"i "
,
croptypesTable
$
row
)
message
(
"j"
,
croptypesTable
$
col
)
# Proportions col
if
(
croptypesTable
$
col
==
6
)
{
message
(
"prop inda "
,
croptypesTable
$
data
[,
"Proportions"
])
croptypes_proportions
<<-
croptypesTable
$
data
[,
"Proportions"
]
ProportionValidation
()
}
# shinyalert::shinyalert(
# title = "Erreur",
# text = error$message,
# closeOnEsc = TRUE)
},
ignoreNULL
=
TRUE
,
ignoreInit
=
TRUE
)
return
(
croptypesTable
)
}
# Take a table of 3 croptype with 3 cultivars and render it
RenderCroptypesold
<-
function
(
dt
)
{
DT
::
renderDT
(
dt
,
editable
=
list
(
target
=
"row"
,
disable
=
list
(
columns
=
c
(
0
,
10
))),
rownames
=
FALSE
,
options
=
list
(
paging
=
FALSE
,
searching
=
FALSE
,
bInfo
=
FALSE
,
ordering
=
FALSE
,
columnDefs
=
list
(
list
(
className
=
"dt-center"
,
targets
=
0
:
(
length
(
colnames
(
dt
))
-1
)
))
),
selection
=
"none"
,
colnames
=
c
(
colnames
(
dt
)),
class
=
"cell-border stripe"
)
}
# Take a table of 3 cultivars with 8 genes and render it
RenderCultivars
<-
function
(
dt
)
{
DT
::
renderDT
(
dt
,
options
=
list
(
paging
=
FALSE
,
searching
=
FALSE
,
bInfo
=
FALSE
,
ordering
=
FALSE
,
select
=
list
(
info
=
FALSE
),
columnDefs
=
list
(
list
(
className
=
"dt-center gene"
,
targets
=
0
:
length
(
colnames
(
dt
))
))
),
rownames
=
TRUE
,
selection
=
"none"
,
colnames
=
c
(
colnames
(
dt
)),
class
=
"cell-border stripe"
)
}
inst/shiny-landsepi/server.R
View file @
ad7a3b1b
...
...
@@ -106,12 +106,12 @@ server <- function(input, output, session) {
# Test if the croptypes proportion sum is 1
## TODO remove input$ and move to global.R
ProportionValidation
<-
function
()
{
if
(
input
$
demo
==
"RO"
)
{
if
(
input
$
demo
==
"RO"
||
(
advanced_mode
()
&&
!
is.na
(
input
$
rotationPeriod
)
&&
input
$
rotationPeriod
>
0
)
)
{
sum_prop
<-
((
croptypes_proportions
[
1
]
+
croptypes_proportions
[
2
])
+
(
croptypes_proportions
[
1
]
+
croptypes_proportions
[
3
]))
/
2
((
croptypes_proportions
()
[
1
]
+
croptypes_proportions
()
[
2
])
+
(
croptypes_proportions
()
[
1
]
+
croptypes_proportions
()
[
3
]))
/
2
}
else
{
sum_prop
<-
sum
(
as.numeric
(
croptypes_proportions
))
sum_prop
<-
sum
(
as.numeric
(
croptypes_proportions
()
))
}
shiny
::
removeUI
(
selector
=
"#propError"
)
...
...
@@ -220,7 +220,7 @@ server <- function(input, output, session) {
can_gen_landscape
$
rotation
<<-
TRUE
can_run_simul
$
landscape
<<-
FALSE
shiny
::
removeUI
(
selector
=
"#rotationPeriodError"
)
if
(
input
$
demo
==
"RO"
)
{
if
(
input
$
demo
==
"RO"
&&
advanced_mode
()
==
FALSE
)
{
if
(
input
$
rotationPeriod
<
1
||
input
$
rotationPeriod
>=
input
$
nYear
||
is.na
(
input
$
rotationPeriod
))
{
...
...
@@ -231,6 +231,8 @@ server <- function(input, output, session) {
can_gen_landscape
$
rotation
<<-
FALSE
}
}
can_gen_landscape
$
proportions
<<-
ProportionValidation
()
can_run_simul
$
landscape
<<-
FALSE
})
######################################################################################
# nYear validation
...
...
@@ -511,43 +513,35 @@ server <- function(input, output, session) {
# Remove old files
cleanDir
(
simul_params
@
OutputDir
)
print
(
simul_params
@
Croptypes
)
print
(
simul_params
@
Cultivars
)
print
(
simul_params
@
CultivarsGenes
)
print
(
simul_params
@
Genes
)
switch
(
input
$
demo
,
MO
=
{
rotation_period
<-
0
rotation_sequence
<-
list
(
c
(
simul_params
@
Croptypes
$
croptypeID
))
prop
<-
list
(
croptypes_proportions
)
# aggregLevel = strtoi(input$aggregLevel)
},
MI
=
{
rotation_period
<-
0
rotation_sequence
<-
simul_params
@
Croptypes
$
croptypeID
prop
<-
list
(
croptypes_proportions
)
# aggregLevel = strtoi(input$aggregLevel)
},
RO
=
{
rotation_period
<-
input
$
rotationPeriod
prop
<-
list
(
c
(
croptypes_proportions
[
1
],
croptypes_proportions
[
2
]),
c
(
croptypes_proportions
[
1
],
croptypes_proportions
[
3
])
)
# aggregLevel = strtoi(input$aggregLevel)
rotation_sequence
<-
list
(
c
(
simul_params
@
Croptypes
$
croptypeID
[
1
],
simul_params
@
Croptypes
$
croptypeID
[
2
]),
c
(
simul_params
@
Croptypes
$
croptypeID
[
1
],
simul_params
@
Croptypes
$
croptypeID
[
3
])
)
},
PY
=
{
rotation_sequence
<-
simul_params
@
Croptypes
$
croptypeID
rotation_period
<-
0
prop
<-
list
(
croptypes_proportions
[
1
:
2
])
# aggregLevel = strtoi(input$aggregLevel)
},
{
# Default case
print
(
"input$generateLandscape : Unknown input$demo"
)
}
)
# Croptypes Rotation
if
(
input
$
demo
==
"RO"
||
(
advanced_mode
()
&&
input
$
rotationPeriod
>
0
))
{
rotation_period
<-
input
$
rotationPeriod
prop
<-
list
(
c
(
croptypes_proportions
()[
1
],
croptypes_proportions
()[
2
]),
c
(
croptypes_proportions
()[
1
],
croptypes_proportions
()[
3
])
)
# aggregLevel = strtoi(input$aggregLevel)
rotation_sequence
<-
list
(
c
(
simul_params
@
Croptypes
$
croptypeID
[
1
],
simul_params
@
Croptypes
$
croptypeID
[
2
]),
c
(
simul_params
@
Croptypes
$
croptypeID
[
1
],
simul_params
@
Croptypes
$
croptypeID
[
3
])
)
}
else
{
rotation_period
<-
0
rotation_sequence
<-
list
(
c
(
simul_params
@
Croptypes
$
croptypeID
))
if
(
input
$
demo
==
"PY"
)
prop
<-
list
(
croptypes_proportions
()[
1
:
2
])
else
prop
<-
list
(
croptypes_proportions
())
}
simul_params
<<-
setSeed
(
simul_params
,
input
$
seed
)
incProgress
(
0.4
)
...
...
@@ -707,6 +701,7 @@ server <- function(input, output, session) {
######################################################################################
# Handle the demo list
shiny
::
observeEvent
(
input
$
demo
,
{
print
(
input
$
demo
)
# Cultivar tab
switch
(
input
$
demo
,
MO
=
{
...
...
@@ -731,6 +726,7 @@ server <- function(input, output, session) {
simul_params_cultivars
(
simul_params
@
Cultivars
)
simul_params_cultivarsgenes
(
simul_params
@
CultivarsGenes
)
simul_params_genes
(
simul_params
@
Genes
)
checkAllTables
()
can_gen_landscape
$
proportions
<<-
TRUE
can_gen_landscape
$
croptypeID
<<-
TRUE
...
...
@@ -755,15 +751,15 @@ server <- function(input, output, session) {
shiny
::
updateNumericInput
(
session
,
"rotationPeriod"
,
value
=
0
)
if
(
input
$
demo
==
"MO"
)
{
croptypes_proportions
<<-
c
(
0.33
,
0.33
,
0.34
)
croptypes_proportions
(
c
(
0.33
,
0.33
,
0.34
)
)
shiny
::
updateSelectInput
(
session
,
"aggregLevel"
,
selected
=
"high"
)
}
else
if
(
input
$
demo
==
"MI"
||
input
$
demo
==
"PY"
)
{
croptypes_proportions
<<-
c
(
0.5
,
0.5
)
croptypes_proportions
(
c
(
0.5
,
0.5
)
)
shiny
::
updateSelectInput
(
session
,
"aggregLevel"
,
selected
=
"high"
)
}
else
if
(
input
$
demo
==
"RO"
)
{
croptypes_proportions
<<-
c
(
0.5
,
0.5
,
0.5
)
croptypes_proportions
(
c
(
0.5
,
0.5
,
0.5
)
)
shinyjs
::
enable
(
id
=
"rotationPeriod"
)
shiny
::
updateNumericInput
(
session
,
"rotationPeriod"
,
value
=
2
)
shiny
::
updateSelectInput
(
session
,
"aggregLevel"
,
selected
=
"medium"
)
...
...
@@ -771,6 +767,7 @@ server <- function(input, output, session) {
else
if
(
input
$
demo
==
"PY"
)
{
shiny
::
updateSelectInput
(
session
,
"aggregLevel"
,
selected
=
"low"
)
}
})
###################
### TABS TABLES ###
...
...
@@ -780,7 +777,7 @@ server <- function(input, output, session) {
simul_params_croptypes
(
simul_params
@
Croptypes
)
croptypesTable
<-
editableDTServer
(
id
=
"croptypes"
,
DTdata
=
reactive
({
return
(
cbind
(
simul_params_croptypes
(),
data.frame
(
Proportions
=
croptypes_proportions
)))}),
DTdata
=
reactive
({
return
(
cbind
(
simul_params_croptypes
(),
data.frame
(
Proportions
=
croptypes_proportions
()
)))}),
disableCol
=
shiny
::
reactive
({
if
(
isTRUE
(
advanced_mode
()))
{
c
()
}
else
{
...
...
@@ -805,11 +802,12 @@ server <- function(input, output, session) {
#message("i ", croptypesTable$row)
#message("j ", croptypesTable$col)
croptypes_proportions
<<-
croptypesTable
$
data
[,
"Proportions"
]
croptypes_proportions
(
croptypesTable
$
data
[,
"Proportions"
]
)
can_gen_landscape
$
proportions
<<-
ProportionValidation
()
if
(
can_gen_landscape
$
proportions
==
FALSE
)
can_run_simul
$
landscape
<<-
FALSE
if
(
isTRUE
(
advanced_mode
()))
{
shiny
::
isolate
(
simul_params_croptypes
(
croptypesTable
$
data
[,
1
:
(
ncol
(
croptypesTable
$
data
)
-2
)]))
if
(
checkCroptypesTable
(
croptypesTable
$
data
[,
-
which
(
colnames
(
croptypesTable
$
data
)
%in%
c
(
"Proportions"
,
"delete"
))])
==
FALSE
)
{
can_run_simul
$
croptypes
<<-
FALSE
can_gen_landscape
$
croptypeID
<<-
FALSE
...
...
@@ -875,6 +873,7 @@ server <- function(input, output, session) {
# rename a cultivars in croptypes
crop
<-
simul_params_croptypes
()
colnames
(
crop
)
<-
c
(
colnames
(
simul_params_croptypes
())[
1
:
2
],
cultivarsTable
$
data
[,
1
])
colnames
(
simul_params
@
Croptypes
)
<<-
colnames
(
crop
)
simul_params_croptypes
(
crop
)
colnames
(
simul_params
@
CultivarsGenes
)
<<-
genesTable
$
data
[,
1
]
...
...
@@ -1062,5 +1061,5 @@ server <- function(input, output, session) {
shinyjs
::
hideElement
(
id
=
"outputside"
)
}
})
})
#
})
}
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment