Nothing
movepars <-
function(nareas=4,accuage=40,getpars=T,getrates=T)
{
################################################################################
#
# movement June 23, 2009.
# This function comes with no warranty or guarantee of accuracy
#
# Purpose: Provide GUI for exploring movement rate parameters in Stock Synthesis
# Written: Ian Taylor, NMFS NWFSC/UW
# based on selectivity GUI by Tommy Garrison, UW
# Returns: plot of double normal or double logistic selectivity
# General: parameterization matched Stock Synthesis v3.03
# Notes: For more information go to: http://code.google.com/p/r4ss/
# Required packages: tcltk
#
################################################################################
# run this next line if package not installed
# install.packages("tcltk")
require(tcltk) || stop("package tcltk is required")
if(!nareas %in% 2:4) stop("'nareas' input must be 2, 3, or 4")
geterrmessage()
movecalc <- function(firstage, accuage, minage, maxage, valueA, valueB) {
# subfunction to calculate movement rates
# can be used as a stand-alone function
# by uncommenting the plot command near the bottom
veclengths <- unique(c(length(minage),length(maxage),length(valueA),length(valueB)))
if(length(veclengths)!=1){
print("Error! input vectors minage, maxage, valueA, valueB need to all have the same length",quote=F)
}else{
npars <- veclengths
}
agevec <- 0:accuage
nages <- length(agevec)
movemat1 <- matrix(NA,npars,nages) # raw values
movemat2 <- matrix(NA,npars,nages) # normalized to sum to 1
temp <- 1/(maxage-minage)
temp1 <- temp*(valueB-valueA)
for(iage in 1:nages){
for(ipar in 1:npars){
if(agevec[iage] <= minage[ipar]) movemat1[ipar,iage] <- valueA[ipar]
if(agevec[iage] >= maxage[ipar]) movemat1[ipar,iage] <- valueB[ipar]
if(agevec[iage] > minage[ipar] & agevec[iage] < maxage[ipar]) movemat1[ipar,iage] <- valueA[ipar] + (agevec[iage]-minage[ipar])*temp1[ipar]
}
}
# exponentiate
movemat1 <- exp(movemat1)
# rescale
movemat2 <- movemat1/matrix(apply(movemat1,2,sum),npars,nages,byrow=T)
lty <- c('91','42','22','4222')
lwd <- rep(3,npars)
col <- c('blue','red','green3','purple')
namevec <- paste("area 1 to area",1:npars)
# plot(0,type='n',xlim=range(agevec),ylim=c(0,1),xaxs='i',yaxs='i',
# xlab='Age',ylab='Movement rate')
matplot(x=agevec,y=t(movemat2),type='l',lty=lty,lwd=lwd,col=col,add=T)
legend('topright',legend=namevec,lty=lty,lwd=lwd,col=col,bty='n')
return(movemat2)
} # end movecalc subfunction
## don't know how to print to command line while GUI is open
# print(paste("running movement parameter GUI for Stock Synthesis with nareas=",nareas," and accumulator age=",accuage,sep=""),quote=F)
done <- tclVar(0)
movepars <- new.env()
# initial values
minage1 <- tclVar(0)
maxage1 <- tclVar(0)
valueA1 <- tclVar(0)
valueB1 <- tclVar(0)
minage2 <- tclVar( 3)
maxage2 <- tclVar(15)
valueA2 <- tclVar(-2)
valueB2 <- tclVar(-1)
if(nareas>=3){
minage3 <- tclVar( 3)
maxage3 <- tclVar(15)
valueA3 <- tclVar(-3)
valueB3 <- tclVar(-2)
}
if(nareas==4){
minage4 <- tclVar( 3)
maxage4 <- tclVar(15)
valueA4 <- tclVar(-4)
valueB4 <- tclVar(-3)
}
replot <- function(...) {
# subfunction to remake the plot
minage1 <- as.numeric(tclObj(minage1))
maxage1 <- as.numeric(tclObj(maxage1))
valueA1 <- as.numeric(tclObj(valueA1))
valueB1 <- as.numeric(tclObj(valueB1))
minage2 <- as.numeric(tclObj(minage2))
maxage2 <- as.numeric(tclObj(maxage2))
valueA2 <- as.numeric(tclObj(valueA2))
valueB2 <- as.numeric(tclObj(valueB2))
if(nareas>=3){
minage3 <- as.numeric(tclObj(minage3))
maxage3 <- as.numeric(tclObj(maxage3))
valueA3 <- as.numeric(tclObj(valueA3))
valueB3 <- as.numeric(tclObj(valueB3))
}else{ # dummies needed for later
minage3 <- NA
maxage3 <- NA
valueA3 <- NA
valueB3 <- NA
}
if(nareas==4){
minage4 <- as.numeric(tclObj(minage4))
maxage4 <- as.numeric(tclObj(maxage4))
valueA4 <- as.numeric(tclObj(valueA4))
valueB4 <- as.numeric(tclObj(valueB4))
}else{ # dummies needed for later
minage4 <- NA
maxage4 <- NA
valueA4 <- NA
valueB4 <- NA
}
plot(0,type='n',xlim=c(0,accuage),ylim=c(0,1),xaxs='i',yaxs='i',
xlab='Age',ylab='Movement rate')
rates <- movecalc(firstage=0, accuage=accuage,
minage=c(minage1,minage2,minage3,minage4)[1:nareas],
maxage=c(maxage1,maxage2,maxage3,maxage4)[1:nareas],
valueA=c(valueA1,valueA2,valueA3,valueA4)[1:nareas],
valueB=c(valueB1,valueB2,valueB3,valueB4)[1:nareas])
dat <- list(pars = data.frame(
minage=c(minage1,minage2,minage3,minage4)[1:nareas],
maxage=c(maxage1,maxage2,maxage3,maxage4)[1:nareas],
valueA=c(valueA1,valueA2,valueA3,valueA4)[1:nareas],
valueB=c(valueB1,valueB2,valueB3,valueB4)[1:nareas],
label=paste("area_1_to_area_",1:nareas,sep="")),
rates = rates)
assign('dat',dat,envir=movepars)
} # end replot
base <- tktoplevel()
tkwm.title(base, "Examine Movement Patterns")
spec.frm <- tkframe(base, borderwidth = 2)
left.frm <- tkframe(spec.frm)
right.frm <- tkframe(spec.frm)
# frame 1:
frame1 <- tkframe(left.frm, relief = "groove", borderwidth = 2)
tkpack(tklabel(frame1, text = "Parameters for movement from area 1 to area 1 (usually not estimated)",font="variable 12 bold"), fill = "both", side = "top")
#minage
entry.minage1 <- tkentry(frame1, textvariable = minage1, width="8")
tkpack(ts1 <- tkscale(frame1, label = "beginning of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = minage1,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#maxage
entry.maxage1 <- tkentry(frame1, textvariable = maxage1, width="8")
tkpack(ts1 <- tkscale(frame1, label = "end of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = maxage1,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueA
entry.valueA1 <- tkentry(frame1, textvariable = valueA1, width="8")
tkpack(ts1 <- tkscale(frame1, label = "value A :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueA1,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueB
entry.valueB1 <- tkentry(frame1, textvariable = valueB1, width="8")
tkpack(ts1 <- tkscale(frame1, label = "value B :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueB1,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
# entry boxes
tkpack(entry.valueB1, side = "right")
tkpack(entry.valueA1, side = "right")
tkpack(entry.maxage1, side = "right")
tkpack(entry.minage1, side = "right")
# frame2:
frame2 <- tkframe(left.frm, relief = "groove", borderwidth = 2)
tkpack(tklabel(frame2, text = "Parameters for movement from area 1 to area 2",font="variable 12 bold"), fill = "both", side = "top")
#minage
entry.minage2 <- tkentry(frame2, textvariable = minage2, width="8")
tkpack(ts1 <- tkscale(frame2, label = "beginning of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = minage2,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#maxage
entry.maxage2 <- tkentry(frame2, textvariable = maxage2, width="8")
tkpack(ts1 <- tkscale(frame2, label = "end of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = maxage2,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueA
entry.valueA2 <- tkentry(frame2, textvariable = valueA2, width="8")
tkpack(ts1 <- tkscale(frame2, label = "value A :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueA2,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueB
entry.valueB2 <- tkentry(frame2, textvariable = valueB2, width="8")
tkpack(ts1 <- tkscale(frame2, label = "value B :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueB2,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
# entry boxes
tkpack(entry.valueB2, side = "right")
tkpack(entry.valueA2, side = "right")
tkpack(entry.maxage2, side = "right")
tkpack(entry.minage2, side = "right")
### frame3:
if(nareas >= 3){
frame3 <- tkframe(left.frm, relief = "groove", borderwidth = 2)
tkpack(tklabel(frame3, text = "Parameters for movement from area 1 to area 3",font="variable 12 bold"), fill = "both", side = "top")
#minage
entry.minage3 <- tkentry(frame3, textvariable = minage3, width="8")
tkpack(ts1 <- tkscale(frame3, label = "beginning of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = minage3,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#maxage
entry.maxage3 <- tkentry(frame3, textvariable = maxage3, width="8")
tkpack(ts1 <- tkscale(frame3, label = "end of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = maxage3,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueA
entry.valueA3 <- tkentry(frame3, textvariable = valueA3, width="8")
tkpack(ts1 <- tkscale(frame3, label = "value A :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueA3,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueB
entry.valueB3 <- tkentry(frame3, textvariable = valueB3, width="8")
tkpack(ts1 <- tkscale(frame3, label = "value B :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueB3,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
# entry boxes
tkpack(entry.valueB3, side = "right")
tkpack(entry.valueA3, side = "right")
tkpack(entry.maxage3, side = "right")
tkpack(entry.minage3, side = "right")
}
### frame4:
if(nareas == 4){
frame4 <- tkframe(left.frm, relief = "groove", borderwidth = 4)
tkpack(tklabel(frame4, text = "Parameters for movement from area 1 to area 4",font="variable 12 bold"), fill = "both", side = "top")
#minage
entry.minage4 <- tkentry(frame4, textvariable = minage4, width="8")
tkpack(ts1 <- tkscale(frame4, label = "beginning of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = minage4,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#maxage
entry.maxage4 <- tkentry(frame4, textvariable = maxage4, width="8")
tkpack(ts1 <- tkscale(frame4, label = "end of ramp", command = replot,
from = 0, to = accuage, showvalue = 1, variable = maxage4,
resolution = 1, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueA
entry.valueA4 <- tkentry(frame4, textvariable = valueA4, width="8")
tkpack(ts1 <- tkscale(frame4, label = "value A :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueA4,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
#valueB
entry.valueB4 <- tkentry(frame4, textvariable = valueB4, width="8")
tkpack(ts1 <- tkscale(frame4, label = "value B :", command = replot,
from = -5, to = 5, showvalue = 1, variable = valueB4,
resolution = 0.01, orient = "horiz", relief = "groove"),
fill = "x", expand = 1, padx = 3, ipadx = 30, pady = 2, ipady = 2, side = "left")
# entry boxes
tkpack(entry.valueB4, side = "right")
tkpack(entry.valueA4, side = "right")
tkpack(entry.maxage4, side = "right")
tkpack(entry.minage4, side = "right")
}
OnOK <- function() {
replot()
}
OnQuit <- function() {
tclvalue(done) <- 2
}
OnUpdate <- function() {
replot()
}
if(nareas==2) tkpack(frame1, frame2, fill = "x")
if(nareas==3) tkpack(frame1, frame2, frame3, fill = "x")
if(nareas==4) tkpack(frame1, frame2, frame3, frame4, fill = "x")
tkpack(left.frm, right.frm, side = "left", anchor = "n")
q.but <- tkbutton(base, text = "Quit", command = OnQuit)
update.but <- tkbutton(base, text = "Update", command = OnUpdate)
tkpack(spec.frm)
tkpack(q.but, side = "right")
tkpack(update.but, side = "right")
replot()
tkbind(base, "<Destroy>", function() tclvalue(done) <- 2)
tkwait.variable(done)
tkdestroy(base)
dat <- get('dat',envir=movepars)
if(getpars | getrates){
if (getpars & !getrates) dat <- dat$pars
if (!getpars & getrates) dat <- dat$rates
return(dat)
}
else return(invisible())
} # end selfit function
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.