I am trying to show navigation in R plot. The current status in time one or (t1) is set as val$currentstatus and next status in (t2) wants to be shown in the graph based on the action that the user choose from the checkbook. then I want to draw a line to show this path. The code that I wrote is as following
output$navigation<-renderPlot({
#initial state of X and Y
if(is.element("Within", vals$currentstatus))
x <- 1
y <- 2
if(is.element("Out", vals$currentstatus)) {
x <- 1
y <- 1
}
action<-c(input$action1,input$action2)
x<-1:4
y<-1:2
rewards<-matrix(rep(0,8),nrow=2)
rewards[1,4]<- -1
rewards[2,4]<- 1
values<-rewards#initial Values
states<-expand.grid(x=x,y=y)
#Transition probability
transition <- list( input$action1= c("within" = 0.8, "out" = .2),
input$action2= c("within" = 0.3, "out" = .7))
# The value of an action (e.g. move toward benchmark )
action.values <- list(input$action1 = c("x" = 1, "y" = 0),
input$action1 = c("x" = 1, "y" = 0))
# act() function serves to move the agent to go to new position
act <- function(action, state) {
action.value <- action.values[[action]]
new.state <- state
#
if(state["x"] == 4 && state["y"] == 1 || (state["x"] == 4 && state["y"] == 2))
return(state)
#
new.x = state["x"] + action.value["x"]
new.y=if(transition["within">"out"]){state["y"==2]}
if(transition["within"<"out"]){state["y"==1]}
}
plot(x, y, xaxt='n',yaxt='n',cex=10,pch=19,
col=ifelse(y==1,"red","green"),ylab="status",xlab="period",
xlim=c(0,4), ylim=c(0,3))
axis(1,at=1:4,labels=c("t1","t2","t3","t4"))
axis(2,at=1:2,labels=c("out bench","within bench"))
if next position is within bench it should be green and connect to the previous state and if it is out of bench should be red and connect to previous state. Also I want to see the name of chosen action on the connection line between two states.Moreover I want to know how can I update the new position and use it for calculating next state in next period (t3) and so force.Similar to the following graph:
Related
I have two input variables, and changing one will cause the change of the other one.
Further to that, if the value of input is outside limits it should default to min (if below) or max (if above) value.
All works fine as long as up and down arrows are being used.
The moment I am typing value 1 in Input1 it goes crazy.
Same if I am deleting Input2, even before I am typing anything...
I am aware that it must have something to do with reactive values, but can not fix it...
Any suggestion will be very much appreciated!
library(shiny)
ui <- fluidPage(
fluidRow(
uiOutput("Input1"),
numericInput("Input2", "Input 2",
min = 50, max = 150,
value = 100, step = 1)),
tableOutput("result")
)
#########################################################
server <- function(input, output, session) {
global <- reactiveValues(numVal = 10, numMin = 5, numMax = 15)
numVal <- reactive({
if(!is.null(input$Input1)){
if(input$Input1 < global$numMin) return(global$numMin)
if(input$Input1 > global$numMax) return(global$numMax)
return(input$Input1)
}else{
return(global$numVal)
}
})
output$Input1 <- renderUI(numericInput("Input1", "Input 1",
min = global$numMin, max = global$numMax,
value = numVal(), step = 0.1))
# when Input1 change, update Input2
observeEvent(input$Input1, {
updateNumericInput(session = session,
"Input2",
value = format(round(input$Input1*10, 0), nsmall = 0))
})
# when Input2 change, update Input1
observeEvent(input$Input2, {
updateNumericInput(session = session,
"Input1",
value = format(round(input$Input2*0.1, 1), nsmall = 1))
})
inputdata <- reactive({
data <- data.frame(Coef = as.numeric(input$Input1))
data
})
output$result <- renderTable({
data = inputdata()
resultTable = as.character(round((data$Coef + 10)*100, digits=2))
resultTable
})
}
#########################################################
shinyApp(ui, server)
You are on the brink of getting into a race condition:
Input 1 changes Input 2 changes Input 1 changes Input 2...
So foremost you should reconsider your design. You can use debounce / throttle to avoid some of the race consition by telling Shiny not too fire too quickly and as the updates are bijective you may achieve what you want, but I would really think about your design b/c these circle dependencies are almost never a good idea.
Having said that here is a solution which behaves better (N.B. I removed the dynamic rendering of the second input element as it has nothing to do wiht the problem at hand). It is not perfect, b/c you will eventually end up in a racing condition, but you can soften this situation by playing w/ the debouncing factors.
library(shiny)
ui <- fluidPage(
fluidRow(
numericInput("Input1", "Input 1",
min = 5, max = 15, value = 10, step = .1),
numericInput("Input2", "Input 2",
min = 50, max = 150,
value = 100, step = 1)),
tableOutput("result")
)
server <- function(input, output, session) {
## debounce both input, i.e. they are firing onyl if no change within 1sec happens
## c.f. ?debounce
getI1 <- reactive(input$Input1) %>%
debounce(1000)
getI2 <- reactive(input$Input2) %>%
debounce(1000)
observeEvent(input$Input1, {
updateNumericInput(session = session,
"Input2",
value = format(round(getI1() * 10, 0), nsmall = 0))
})
observeEvent(input$Input2, {
updateNumericInput(session = session,
"Input1",
value = format(round(getI2() * 0.1, 1), nsmall = 1))
})
inputdata <- reactive({
data <- data.frame(Coef = as.numeric(input$Input1))
data
})
output$result <- renderTable({
data = inputdata()
resultTable = as.character(round((data$Coef + 10)*100, digits=2))
resultTable
})
}
shinyApp(ui, server)
I am using a list of files, and I am trying to create a data frame that contains: for each sample, the percentage of two particular "GT" types by the levels of another factor variable called "chr" (with 1 to 24 levels).
It would have to look like this:
The problem I keep getting is that the vector never gets updated for the ith sample, it only keeps the first vector created. And then I am not sure how to save that updated vector on my data frame (df).
vector_chr <- vector();
for (i in seq_along(list_files)) {
GT <- list_files[[i]][,9]
chr <- list_files[[i]][,3]
GT$chr <- chr$chr # creating one df with both GT and chr
for (j in unique(GT$chr)){
dat_list = split(GT, GT$chr) # split data frames by chr (1 to 24)
table <- table(dat_list[[j]][,1]) # take GT and make a table
sum <- sum(table[3:4]) # sum GTs 3 and 4
perc <- sum/nrow(GT)
vector_chr <- c(vector_chr,perc) # assign the 24 percentages to a vector
}
df <- data.frame(matrix(ncol = 25, nrow = length(files)))
x <- c("Sample", "chr1", "chr2", "chr3",
"chr4", "chr5", "chr6", "chr7", "chr8", "chr9", "chr10",
"chr11", "chr12","chr13", "chr14", "chr15", "chr16",
"chr17", "chr18", "chr19", "chr20", "chr21", "chr22",
"chrX", "chrXY")
colnames(df) <- x
df$Sample <- names(list_files)
df[i,2:25] <- vector_chr # assign the 24 percentages for EACH sample
}
I am an environmental scientist trying to create a harvest simulation for oysters. I want the simulation to display two maps, one for showing the current oyster populations, and one for showing no-take zones (sanctuaries). Clicking on a plot on the map (each one has an invisible marker) should do something different depending on which map is showing. Clicking with the oyster population map should cause the population to update with oyster harvest occurring in the clicked plot. Clicking on the sanctuary map should cause the clicked plot to change is designation of open or closed.
The issue, as far as I can tell, is that all of these values reset every time an input is clicked. For example, it does not matter which map was showing previously, the "showSanctuary" variable, which is supposed to display F is the population map is up and T if the sanctuary map is up, is always set to False, its starting value, whenever a new input is clicked. The oyster population vector and sanctuary vector appear to do the same thing. How can I prevent these variables from resetting back to their starting values?
Also, I am very new to this forum, and I am not sure of the etiquette. I am going to post all of my code below absent the two scripts where I store my functions (I am certain they are not the issue), but it is a fairly lengthy program. This question relates to code between lines 70 and 152. I will post only those lines first, with the full script below it. Sorry again if that is not typical etiquette.
Lines where problem is occurring (this is inside the Server function):
#Make Reactive Values
offLim <- reactiveValues()
offLim = 0
showSanctuary <- reactiveValues()
showSanctuary = F
myOutputs <- reactiveValues()
myOutputs$outHarvTime = 0
myOutputs$outSacksTaken = 0
myOutputs$outAvgSize = 0
#React to click event
observeEvent(input$map_marker_click, {
click<-input$map_marker_click
if(is.null(click))
return()
xClk=trunc(click$lng*1000)/1000
yClk=trunc(click$lat*1000)/1000
xCor = which(coord$x == xClk)
yCor = which(coord$y == yClk)
myPlot = intersect(xCor, yCor)
if(showSanctuary == T){
if(offLim[myPlot]==1){
offLim[myPlot]=0
}else if(offLim[myPlot]==0){
offLim[myPlot]=1
}
myMap <- makeSanctuaryMap(offLim)
myOutputs$finalMap = myMap
}
else{
myHarvLim = input$amount
myMaxTime = input$effort
myMinSize = input$size
returnShells = input$shell
param = c(myHarvLim, myMaxTime, myMinSize, myPlot, returnShells)
newOysters = oysters
newDens = myDens
newShell = myShell
outVar<-localUpdate(param, newOysters, myMaxDens, newDens, newShell, nplts)
oysters = outVar$oysters
myDens = outVar$myDens
myShell = outVar$myShell
myOutputs$outAvgSize = outVar$avgSize
myOutputs$outHarvTime = outVar$harvTime
myOutputs$outSacksTaken = outVar$sacksTaken
myOutputs$finalMap = outVar$myMap
}
})
observeEvent(input$update,{
#Make sanctuary variables. Needs to be reactive to be global
showSanctuary = F #Whether the Map Currently Displays Sanctuary Areas
offLim = vector(length=nplts) #1 if plot is a Sanctuary or 0 if not
offLim[] = 0
offLim[!cond]<-NA
myOutputs$outAvgSize = NA
myOutputs$outHarvTime = NA
myOutputs$outSacksTaken = NA
myOutputs$finalMap = myMap
})
observeEvent(input$sanctuaryMap,{
print(showSanctuary)
showSanctuary = T
myMap <- makeSanctuaryMap(offLim)
myOutputs$finalMap = myMap
})
observeEvent(input$harvestMap,{
print(showSanctuary)
showSanctuary = F
myMap <- updateMap(heatVec)
myOutputs$finalMap = myMap
})
Full Script:
library(shiny)
library('leaflet')
library(raster)
library('sf')
library(rgdal)
source('updateFunctions.R')
effortLbl = "What is the maximum number of hours that you are willing to spend harvesting each day?"
amountLbl = "What is the maximum number of sacks of oysters you would harvest in one day?"
sizeLbl = "Select a minimum size for legal harvest (inches)"
shellLbl="Check to require culling on site"
ui<-fluidPage(
numericInput(inputId="effort", label=effortLbl, value=8, min=1, max=16, step=1),
numericInput(inputId="amount", label=amountLbl, value=4, min=1, max=40, step=1),
numericInput(inputId="size", label=sizeLbl, value=3, min=1, max=6, step=1),
checkboxInput(inputId="shell", label=shellLbl, value = FALSE),
actionButton(inputId="update", label="Begin"),
actionButton(inputId="sanctuaryMap", label="Set Sanctuaries"),
actionButton(inputId="harvestMap", label="Choose Harvest Area"),
leafletOutput("map"),
textOutput("time"),
textOutput("sacks"),
textOutput("size")
)
server<-function(input, output, session){
#Generate list of clickable coordinates
cedKey <- readOGR(dsn=path.expand("shapefile"), layer="LC_10_Area") #Imports Cedar Key shape file
ckCrd <- spTransform(cedKey, CRSobj = CRS("+init=epsg:4326")) #Converts shape file coordinate to longitude/latitude
matCrd=expand.grid(x=seq(from=-83.1164,to=-83.06251,length.out=moveRow), #Generates a series of coordinates within range
y=seq(from=29.2169,to=29.26528,length.out=moveRow))
df = data.frame(x = matCrd$x, y = matCrd$y)
s = SpatialPixelsDataFrame(df[,c('x', 'y')], data = df, proj4string = crs(ckCrd))
clp <- over(s[,c("x", "y")], ckCrd)
cond <- !is.na(clp$Id)
spNew<-s[cond,]
spDf = as.data.frame(spNew)
coord = data.frame(x=(trunc(df$x*1000)/1000), y=(trunc(df$y*1000)/1000))
#Initialize oyster population variables
nplts = 1600 #Total number of plots
nsize = 7 #Number of size classes (including larva)
oysters = matrix(0, nplts,nsize)
myDens = vector(length=nplts) #Total number of oysters weighted by size
myShell = vector(length=nplts) #The amount of dead shell (or other non-living hard substrate)
myMaxDens = 1000 #The maximum capacity of every plot
moveRow = sqrt(nplts) #The number of plots in a row
#Initialize oyster population with randomization
for(i in 1:nplts){
initMin = c(20,20,5,5,0,0) #Minimum number of oysters of each size at game start
initMax = c(60,40,30,20,10,5) #Maximum number of oysters of each size at game start
oysters[i,1:6]=runif(6, initMin, initMax)
oysters[i,7]=sum(oysters[i,1:6]*4)
}
oysters[!cond,]<-NA
for(i in 1:nplts){
myDens[i]=sum(oysters[i,1:6]*c(1:6))
myShell[i]=0.2*myDens[i]
}
#Set values of outputs before initial update
heatVec = vector(length=nplts)
for(i in 1:nplts){
heatVec[i] = (100*myDens[i])/myMaxDens
}
myMap = updateMap(heatVec)
#Make Reactive Values
offLim <- reactiveValues()
offLim = 0
showSanctuary <- reactiveValues()
showSanctuary = F
myOutputs <- reactiveValues()
myOutputs$outHarvTime = 0
myOutputs$outSacksTaken = 0
myOutputs$outAvgSize = 0
#React to click event
observeEvent(input$map_marker_click, {
click<-input$map_marker_click
if(is.null(click))
return()
xClk=trunc(click$lng*1000)/1000
yClk=trunc(click$lat*1000)/1000
xCor = which(coord$x == xClk)
yCor = which(coord$y == yClk)
myPlot = intersect(xCor, yCor)
if(showSanctuary == T){
if(offLim[myPlot]==1){
offLim[myPlot]=0
}else if(offLim[myPlot]==0){
offLim[myPlot]=1
}
myMap <- makeSanctuaryMap(offLim)
myOutputs$finalMap = myMap
}
else{
myHarvLim = input$amount
myMaxTime = input$effort
myMinSize = input$size
returnShells = input$shell
param = c(myHarvLim, myMaxTime, myMinSize, myPlot, returnShells)
newOysters = oysters
newDens = myDens
newShell = myShell
outVar<-localUpdate(param, newOysters, myMaxDens, newDens, newShell, nplts)
oysters = outVar$oysters
myDens = outVar$myDens
myShell = outVar$myShell
myOutputs$outAvgSize = outVar$avgSize
myOutputs$outHarvTime = outVar$harvTime
myOutputs$outSacksTaken = outVar$sacksTaken
myOutputs$finalMap = outVar$myMap
}
})
observeEvent(input$update,{
#Make sanctuary variables. Needs to be reactive to be global
showSanctuary = F #Whether the Map Currently Displays Sanctuary Areas
offLim = vector(length=nplts) #1 if plot is a Sanctuary or 0 if not
offLim[] = 0
offLim[!cond]<-NA
myOutputs$outAvgSize = NA
myOutputs$outHarvTime = NA
myOutputs$outSacksTaken = NA
myOutputs$finalMap = myMap
})
observeEvent(input$sanctuaryMap,{
print(showSanctuary)
showSanctuary = T
myMap <- makeSanctuaryMap(offLim)
myOutputs$finalMap = myMap
})
observeEvent(input$harvestMap,{
print(showSanctuary)
showSanctuary = F
myMap <- updateMap(heatVec)
myOutputs$finalMap = myMap
})
localUpdate <- function(param, locOyster, myMaxDens, locDens, locShell, nplts){
myUpdate<-updateFunction(locOyster, myMaxDens, locDens, locShell, param, nplts) #All updates done in separate script
#Set oyster pop, dens, and dead shell according to updates
oysters = myUpdate$oysters
for(i in 1:nplts){
myDens[i] = sum(oysters[i,1:6]*c(1:6))
}
myShell = myUpdate$shell
#Calculate heatmap values based on density (biomass)
for(i in 1:nplts){
heatVec[i] = (100*myDens[i])/myMaxDens
}
myMap <- updateMap(heatVec) #Create Map
return(list(avgSize = myUpdate$avgSize, harvTime = myUpdate$harvTime, sacksTaken = myUpdate$sacksTaken,
myMap = myMap, myShell = myShell, myDens = myDens, oysters = oysters))
}
#Assemble and Display Outputs
output$map <- renderLeaflet({
input$map_marker_click #Makes output dependent on map or button click (via isolate)
input$sanctuaryMap
input$harvestMap
input$update
isolate(myOutputs$finalMap)})
output$time <- renderText({
input$map_marker_click
input$update
timeString <- isolate(c("Time Spent Harvesting Each Day: ",
toString(trunc(myOutputs$outHarvTime*100)/100), " hours"))
timeString})
output$sacks <- renderText({
input$map_marker_click
input$update
sacksString<-isolate(c("Average Number of Sacks Harvested per Day: ",
toString(trunc(myOutputs$outSacksTaken*100)/100), " sacks"))
sacksString})
output$size <- renderText({
input$map_marker_click
input$update
sizeString<-isolate(c("Average Size of Harvested Oysters this Year: ",
toString(trunc(myOutputs$outAvgSize*100)/100), " inches"))
sizeString})
}
shinyApp(ui = ui, server = server)
For starters, you aren't using reactiveValues correctly. It would be something like this:
my_reactives <- reactiveValues()
my_reactives$offLim <- 0
my_reactives$showSanctuary <- F
I have a dataset in which I am graphing means from 4 treatments over time, along with their standard errors, at 2 sites. The standard error bars are not being assigned properly to their respective means --they are going to both panels - can you please advise? See example:
d <- data.frame(site=rep(1:2,each=12),time=rep(1:3,8),trt=rep(rep(1:4,each=3),2))
d$mn <- rnorm(24,4,1)
d$se <- rnorm(24,2,1)
d$ul <- d$mn+d$se # create y value for standard error upper limit
my.panel <- function(x,y, ...){
panel.xyplot(x, y, ...)
panel.arrows(x, y, x, d$ul, length = 0.1,
angle = 90)
}
xyplot(mn ~ time|site,data=d,
group = trt,
type=c('p','l'),
panel = my.panel
)
I have a list of items and for each item I am computing a value. Computing this value is a bit computationally intensive so I want to minimise it as much as possible.
The algorithm I need to implement is this:
I have a value X
For each item
a. compute the value for it, if it is < 0 ignore it completely
b. if (value > 0) && (value < X)
return pair (item, value)
Return all (item, value) pairs in a List (that have the value > 0), ideally sorted by value
To make it a bit clearer, step 3 only happens if none of the items have a value less than X. In step 2, when we encounter the first item that is less than X we should not compute the rest and just return that item (we can obviously return it in a Set() by itself to match the return type).
The code I have at the moment is as follows:
val itemValMap = items.foldLeft(Map[Item, Int)]()) {
(map : Map[Item, Int], key : Item) =>
val value = computeValue(item)
if ( value >= 0 ) //we filter out negative ones
map + (key -> value)
else
map
}
val bestItem = itemValMap.minBy(_._2)
if (bestItem._2 < bestX)
{
List(bestItem)
}
else
{
itemValMap.toList.sortBy(_._2)
}
However, what this code is doing is computing all the values in the list and choosing the best one, rather than stopping as a 'better' one is found. I suspect I have to use Streams in some way to achieve this?
OK, I'm not sure how your whole setup looks like, but I tried to prepare a minimal example that would mirror your situation.
Here it is then:
object StreamTest {
case class Item(value : Int)
def createItems() = List(Item(0),Item(3),Item(30),Item(8),Item(8),Item(4),Item(54),Item(-1),Item(23),Item(131))
def computeValue(i : Item) = { Thread.sleep(3000); i.value * 2 - 2 }
def process(minValue : Int)(items : Seq[Item]) = {
val stream = Stream(items: _*).map(item => item -> computeValue(item)).filter(tuple => tuple._2 >= 0)
stream.find(tuple => tuple._2 < minValue).map(List(_)).getOrElse(stream.sortBy(_._2).toList)
}
}
Each calculation takes 3 seconds. Now let's see how it works:
val items = StreamTest.createItems()
val result = StreamTest.process(2)(items)
result.foreach(r => println("Original: " + r._1 + " , calculated: " + r._2))
Gives:
[info] Running Main
Original: Item(3) , calculated: 4
Original: Item(4) , calculated: 6
Original: Item(8) , calculated: 14
Original: Item(8) , calculated: 14
Original: Item(23) , calculated: 44
Original: Item(30) , calculated: 58
Original: Item(54) , calculated: 106
Original: Item(131) , calculated: 260
[success] Total time: 31 s, completed 2013-11-21 15:57:54
Since there's no value smaller than 2, we got a list ordered by the calculated value. Notice that two pairs are missing, because calculated values are smaller than 0 and got filtered out.
OK, now let's try with a different minimum cut-off point:
val result = StreamTest.process(5)(items)
Which gives:
[info] Running Main
Original: Item(3) , calculated: 4
[success] Total time: 7 s, completed 2013-11-21 15:55:20
Good, it returned a list with only one item, the first value (second item in the original list) that was smaller than 'minimal' value and was not smaller than 0.
I hope that the example above is easily adaptable to your needs...
A simple way to avoid the computation of unneeded values is to make your collection lazy by using the view method:
val weigthedItems = items.view.map{ i => i -> computeValue(i) }.filter(_._2 >= 0 )
weigthedItems.find(_._2 < X).map(List(_)).getOrElse(weigthedItems.sortBy(_._2))
By example here is a test in the REPL:
scala> :paste
// Entering paste mode (ctrl-D to finish)
type Item = String
def computeValue( item: Item ): Int = {
println("Computing " + item)
item.toInt
}
val items = List[Item]("13", "1", "5", "-7", "12", "3", "-1", "15")
val X = 10
val weigthedItems = items.view.map{ i => i -> computeValue(i) }.filter(_._2 >= 0 )
weigthedItems.find(_._2 < X).map(List(_)).getOrElse(weigthedItems.sortBy(_._2))
// Exiting paste mode, now interpreting.
Computing 13
Computing 1
defined type alias Item
computeValue: (item: Item)Int
items: List[String] = List(13, 1, 5, -7, 12, 3, -1, 15)
X: Int = 10
weigthedItems: scala.collection.SeqView[(String, Int),Seq[_]] = SeqViewM(...)
res27: Seq[(String, Int)] = List((1,1))
As you can see computeValue was only called up to the first value < X (that is, up to 1)