fiveShowApp (Shinylive)
A serverless WebAssembly-powered target relative mean search explorer using five.show().
The live application below is running completely client-side in your browser using serverless Shinylive (WebAssembly). You can click directly on the baseline spline plot on the left to move individual nodes, and adjust the target relative mean slider on the right to trigger the binary search.
#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 650
#| components: [viewer]
library(shiny)
library(bslib)
library(splines)
library(stats)
library(graphics)
# --- Source: spline.R ---
## $Id: spline.R,v 1.0 2002/12/09 yandell@stat.wisc.edu Exp $
##
## Functions for Bland Ewing's modeling.
##
## Copyright (C) 2000,2001,2002 Brian S. Yandell.
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## These functions are distributed in the hope that they will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## The text of the GNU General Public License, version 2, is available
## as http://www.gnu.org/copyleft or by writing to the Free Software
## Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
##
###########################################################################################
## Support routines for future.meanvalue
###########################################################################################
spline.rate <- function( meanvalue, x )
{
coeff <- stats::coef( meanvalue )
for( i in 2:ncol( coeff ))
coeff[,i-1] <- i * coeff[,i]
coeff[,ncol( coeff ) ] <- 0
meanvalue$coefficients <- coeff
if( missing( x ))
stats::predict( meanvalue )
else
stats::predict( meanvalue, x )
}
###########################################################################################
spline.deriv <- function( s )
{
s$coefficients <- s$coefficients[,-1]
for( i in seq( 2, ncol( s$coefficients )))
s$coefficients[,i] <- s$coefficients[,i] * i
s
}
###########################################################################################
splinesum <- function( xy, fit = splines::interpSpline( xy$x, xy$y ),
log2 = log( 2 ), tol = 1e-5 )
{
n <- nrow( xy )
## mean time to future event (assume linear off end )
maxx <- xy[n,"x"]
mean.y <- maxx * mean( exp( - stats::predict( fit )$y )) + xy[1,"x"]
rate <- spline.rate( fit, maxx )$y
if( rate > tol )
mean.y <- mean.y + exp( - xy[n,"y"] ) / rate
## median time to future event
adiff <- diff( stats::coef( fit )[,1] )
## undefined if mean value function not monotone
if( !( all( adiff < 0) || all( adiff > 0 )))
median.y <- NA
else {
invmvalue <- splines::backSpline( fit )
median.y <- stats::predict( invmvalue, log2 )$y
if( is.na( median.y ))
median.y <- spline.extrapolate( fit, invmvalue, log2 )
}
c( mean = mean.y, median = median.y )
}
###########################################################################################
summaryshow <- function( xy, fit, col = "black", sums = splinesum( xy, fit ))
{
tmpar <- graphics::par( col = col )
graphics::mtext( paste( "mean =", round( sums[1], 2 )), 3, at = graphics::par("usr")[1], adj = 0 )
medianshow <- if( is.na( sums[2] ))
"curve not monotone"
else
paste( "median =", round( sums[2], 2 ))
graphics::mtext( medianshow, 3, at = graphics::par("usr")[2] / 1.25, adj = 1 )
graphics::par( tmpar )
invisible( sums )
}
###########################################################################################
curve.plot <- function( xy = seq(0,1,by=.25), y = c(0,.1,.5,.9,1),
z = graphics::locator(1,"n"), n=5, action="add",
fit = splines::interpSpline( xy$x, xy$y ),
backfit = TRUE, save.ends = 3, col = c("blue","red"), lwd = 4,
f = function( x ) x, finv = function( x ) x )
{
if( !is.list( xy )) {
xy <- data.frame( x = xy )
xy$y <- y
}
else
xy <- as.data.frame( xy )
if( !match( action, c("refresh","finish"), nomatch = 0 )) {
z <- as.data.frame(z)
tmp <- z$x > max( xy$x )
if( any( tmp )) {
if( all( tmp ))
return( xy )
z$x <- z$x[!tmp]
z$y <- z$y[!tmp]
}
}
remove.points <- function( xy, finv, save.ends = TRUE ) {
## find closest point after standardizing distances
usr <- graphics::par( "usr" )
tmp <- (( xy$x - z$x ) / diff( usr[1:2] )) ^ 2 +
(( xy$y - z$y ) / diff( usr[3:4] )) ^ 2
if( save.ends )
tmp <- tmp[ - c( 1, nrow( xy )) ]
tmp <- save.ends + min( seq( tmp )[ tmp == min( tmp ) ] )
tmpd <- xy[tmp,"y"]
tmpd <- finv( tmpd )
graphics::points( xy[tmp,"x"], tmpd, lwd = lwd, col = "white" )
tmp
}
for( i in 1:n) {
switch( action,
noaction =
return( xy )
,
add = {
graphics::points(z$x,z$y, lwd = lwd )
z$y <- f( z$y )
xy <- rbind(xy,z)
xy <- xy[order(xy$x),]
fit <- splines::interpSpline( xy$x, xy$y )
},
replace = {
graphics::points(z$x,z$y, lwd = lwd )
z$y <- f( z$y )
tmp <- remove.points( xy, finv, save.ends == 3 )
tmpp <- ( tmp > 1 & tmp < length( xy$x ))
if( save.ends != 2 | tmpp )
xy$x[tmp] <- z$x
if( save.ends != 1 | tmpp )
xy$y[tmp] <- z$y
fit <- splines::interpSpline( xy$x, xy$y )
},
delete = {
z$y <- f( z$y )
tmp <- remove.points( xy, finv, save.ends > 0 )
xy <- xy[-tmp,]
fit <- splines::interpSpline( xy$x, xy$y )
},
refresh =, finish = {
xy
}
)
tmpp <- stats::predict( fit )
graphics::lines( tmpp$x, finv( tmpp$y ), col = col[1], lwd = lwd )
adiff <- diff( stats::coef( fit )[,1] )
if( backfit & ( all( adiff < 0) || all( adiff > 0 ))) {
## backspline (not quite a spline) fit to inverse
tmpback <- stats::predict( splines::backSpline( fit ))
graphics::lines( tmpback$y, finv( tmpback$x ), col = col[2], lwd = lwd )
}
}
list( xy = xy[order(xy$x),], fit = fit )
}
###########################################################################################
cdf.lines <- function( data, fig = "mean value", nspline = 8,
conf = c(50,80,90,95), rescale = 1,
col = c("green","blue","red","orange") )
{
rate <- fig == "mean value"
n <- length( data )
data <- sort( data )
prob <- seq( n ) / ( n + 1 )
f <- - rescale * log( 1 - prob )
ylab <- "prob"
if( rate )
ylab <- "cum rate"
else
f <- 1 - exp( -f )
graphics::lines( data, f, lwd = 2 )
conf <- conf / 100
for( i in seq( length( conf ))) {
## lower confidence
tmp <- stats::qbinom( conf[i], n, prob, lower.tail = TRUE ) / ( n + 1 )
tmp <- 1 - exp( rescale * log( 1 - tmp ))
tmpna <- is.na( tmp )
if( any( tmpna ))
tmp[tmpna] <- f[1]
if( rate )
tmp <- - log( 1 - tmp )
graphics::lines( data, tmp, lty = 2, col = col[i] )
## upper confidence
tmp <- stats::qbinom( conf[i], n, prob, lower.tail = FALSE ) / ( n + 1 )
tmp <- 1 - exp( rescale * log( 1 - tmp ))
tmpna <- is.na( tmp )
if( any( tmpna ))
tmp[tmpna] <- f[n]
if( rate )
tmp <- - log( 1 - tmp )
graphics::lines( data, tmp, lty = 2, col = col[i] )
}
}
###########################################################################################
rspline <- function( meantime = 1,
fivepar = c(dispersion = 1, location = 0, intensity = 1, truncation = 0,
rejection = Inf ),
fit = NULL,
meanvalue = fit$meanvalue, invmvalue = fit$invmvalue,
span = Inf )
{
## dispersion = a, location = b, intensity = c
## truncation = -log(1-d), rejection = -log(1-e)
## y = a M^-1( G(d)+cV ) + b if 1 - exp( -cV ) < G(e)
## y = span if 1 - exp( -cV ) >= G(e)
## this is not quite right for truncation, as we know event happened before b
## if 1-exp(-cV) < d, but I am not sure how to pass that information along yet
default <- is.null( meanvalue )
## V ~ exp(1)
## intensity: V/c
## truncation: (G(d)+V)/c
rate <- ( fivepar["truncation"] + rexp( 1 )) / fivepar["intensity"]
## mean value inverse: M^-1( G(d)+V/c )
if( default )
y <- rate
else {
y <- stats::predict( invmvalue, rate )$y
## kludge to linearly extrapolate beyond cubic spline fit
if( is.na( y ))
y <- spline.extrapolate( meanvalue, invmvalue, rate )
}
## dispersion and location: y = a M^-1( cV ) + b
y <- meantime * fivepar["dispersion"] * y + fivepar["location"]
## rejection: y >= e? then set y to span
if( y > fivepar["rejection"] )
y <- span
y
}
###########################################################################################
spline.extrapolate <- function( meanvalue, invmvalue, x )
{
## linear extrapolation of inverse spline beyond upper end
coeff <- stats::coef( invmvalue )
nr <- nrow( coeff ) - 1
xknot <- splines::splineKnots( invmvalue )[nr+(0:1)]
yknot <- splines::splineKnots( meanvalue )[nr+1]
tmpr <- ( xknot[2] - xknot[1] )
slope <- coeff[nr,2] + tmpr * ( 2 * coeff[nr,3] + tmpr * 3 * coeff[nr,4] )
yknot + slope * ( x - xknot[2] )
}
###########################################################################################
### spline.design() is a prototype for designing spline curves
### Ultimately, pieces of spline.design, spline.temp() and spline.meanvalue()
### will be pulled out as subroutines to reduce code overlap
###########################################################################################
spline.design <- function (y = yinit, x = xinit, nspline = 8, xy = data.frame(x = x,
y = y), n = 1, horizontal = FALSE)
{
is.data <- !missing(y)
if (is.data) {
data <- y
if (missing(x))
x <- as.numeric(names(y))
datax <- x
ndata <- length(data)
choose <- round(seq(1, ndata, length = nspline))
xinit <- x <- x[choose]
yinit <- y <- y[choose]
}
else {
tmp <- seq(0, nspline - 1)
if (missing(x))
xinit <- tmp
else xinit <- x
if (missing(y))
yinit <- rep(50, nspline)
else yinit <- y
}
## plot curve and surrounding axes
graphics::par( mfrow = c(1,1), mar = rep(4.1,4))
plotit <- function( xy, fig = "temp", fit = splines::interpSpline( xy$x, xy$y ),
horizontal = FALSE, strip = .25, margin = .1 )
{
switch( fig, {
y <- xy$y
ylim <- range(y)
}
)
xlim <- range(xy$x)
xlim <- xlim + c(-1,1) * margin * diff( xlim )
if( horizontal ) {
if( diff( ylim ) == 0 )
ylim <- ylim * c(.75,1.25)
separator <- ylim[2]
ylim[2] <- ylim[2] + strip * diff( ylim )
}
else {
separator <- xlim[2]
xlim[2] <- xlim[2] + strip * diff( xlim )
}
axt <- c("n","s")
tmpar <- graphics::par( xaxt = axt[1+horizontal], yaxt = axt[2-horizontal] )
plot( xy$x, y, xlim = xlim, ylim = ylim, type="n", xlab = "", ylab = "" )
graphics::par( xaxt = "s", yaxt = "s" )
graphics::points( xy$x, y, lwd = 4 )
graphics::title( fig )
graphics::mtext( "time", 1, 2 )
graphics::mtext( fig, 2, 2 )
if( horizontal ) {
p <- pretty( c(ylim[1],separator) )
graphics::axis( 2, p[ p <= separator ] )
graphics::abline( h = separator, lty = 2 )
}
else {
p <- pretty( c(xlim[1],separator) )
graphics::axis( 1, p[ p <= separator ] )
graphics::abline( v = separator, lty = 2 )
}
curve.plot( xy, n = n, action = "refresh", fit = fit, backfit = FALSE,
save.ends = 0 )
separator
}
## place commands along right strip of plot, highlighting current command
plotcmd <- function( ans, fig, cmds, cmdlocs, usr, col = "green", rest = "black",
horizontal = TRUE )
{
ans <- c( ans, fig )
tmp <- is.na( match( cmds, ans ))
if( any( tmp )) for( i in unique( cmdlocs$adj )) {
tmpi <- tmp & i == cmdlocs$adj
if( any( tmpi ))
graphics::text( cmdlocs$x[tmpi], cmdlocs$y[tmpi], cmds[tmpi], col = rest, adj = i )
}
if( any( !tmp )) for( i in unique( cmdlocs$adj )) {
tmpi <- !tmp & i == cmdlocs$adj
if( any( tmpi ))
graphics::text( cmdlocs$x[tmpi], cmdlocs$y[tmpi], cmds[tmpi], col = col, adj = i )
}
}
cmds <- c("add","delete","replace","","finish","restart","refresh","rescale",
"","data","temp")
newlocs <- if( horizontal )
function( cmds, data = FALSE, usr )
{
if( !data )
cmds <- cmds[ cmds != "data" ]
n <- length( cmds )
blank <- seq( n )[ cmds == "" | cmds == " " ]
tmp <- diff(usr[3:4]) / 20
m <- mean( usr[1:2] )
y <- usr[4] + 0.5 * tmp - c( tmp * seq( blank[1] - 1 ), 0,
tmp * seq( blank[2] - blank[1] - 1 ), 0,
tmp * seq( n - blank[2] ))
x <- c( rep( usr[1], blank[1] - 1 ), mean( m, usr[1] ),
rep( m, blank[2] - blank[1] - 1 ), mean( m, usr[2] ),
rep( usr[2], n - blank[2] ))
adj <- c( rep( 0, blank[1] ),
rep( 0.5, blank[2] - blank[1] ),
rep( 1, n - blank[2] ))
tmp <- data.frame( x = x, y = y, adj = adj )
cmds[blank[2]] <- " "
row.names( tmp ) <- cmds
tmp
}
else
function( cmds, data = FALSE, usr )
{
if( !data )
cmds <- cmds[ cmds != "data" ]
n <- length( cmds )
blank <- seq( n )[ cmds == "" ]
tmp <- diff(usr[3:4]) / 20
m <- mean( usr[3:4] )
tmp <- c( usr[4] - tmp * seq( blank[1] - 1 ),
mean( m, usr[4] ),
m + tmp * ( seq( blank[1] + 1, blank[2] - 1 ) - mean( blank )),
mean( m, usr[3] ),
usr[3] + tmp * seq( n - blank[2] ))
tmp <- data.frame( x = rep( usr[2], n ), y = tmp, adj = rep( 1, n ))
cmds[blank[2]] <- " "
row.names( tmp ) <- cmds
tmp
}
fig <- "temp"
newans <- ans <- "replace"
graphics::par( mar = c(4.1,4.1,3.1,4.1),omi=rep(.25,4))
fit <- splines::interpSpline( xy$x, xy$y )
separator <- plotit( xy, fig, fit, horizontal )
usr <- graphics::par("usr")
cmdlocs <- newlocs( cmds, data = is.data, usr = usr)
cmds <- row.names( cmdlocs )
plotcmd( ans, fig, cmds, cmdlocs, usr )
use.data <- FALSE
rescale.data <- 1
repeat {
## get command from plot using cursor
z <- graphics::locator(1,"n")
if(( !horizontal & z$x > separator ) | ( horizontal * z$y > separator )) {
if( horizontal ) { # need to look at both z&y
x <- abs( z$x - cmdlocs$x )
x <- x == min( x )
newans <- cmds[x]
z <- abs( z$y - cmdlocs$y )[x]
newans <- newans[ z == min( z ) ][1]
}
else {
z <- abs(z$y - cmdlocs$y )
newans <- cmds[ z == min( z ) ][1]
}
switch( newans,
finish =, refresh = {
separator <- plotit( xy, fig, fit, horizontal )
usr <- graphics::par("usr")
cmdlocs <- newlocs( cmds, data = is.data, usr = usr)
},
data = {
use.data <- is.data & !use.data
if( is.data & !use.data )
plotit( xy, fig, fit, horizontal )
},
temp = {
fig <- newans
separator <- plotit( xy, fig, fit, horizontal )
usr <- graphics::par("usr")
cmdlocs <- newlocs( cmds, data = is.data, usr = usr)
},
rescale = {
cat( "enter new values followed by RETURN key\n" )
tmpy <- readline( paste( "maximum ", fig, "(",
round( max( xy$y ), 2 ), "):", sep = "" ))
if( tmpy != "" ) {
tmpy <- suppressWarnings(as.numeric( tmpy )) / max( xy$y )
xy$y <- tmpy * xy$y
if( is.data )
rescale.data <- rescale.data * tmpy
}
tmpx <- readline( paste( "maximum time(",
round( max( xy$x ), 2 ), "):", sep = "" ))
if( tmpx != "" ) {
tmpx <- suppressWarnings(as.numeric( tmpx )) / max( xy$x )
xy$x <- tmpx * xy$x
}
fit <- splines::interpSpline( xy$x, xy$y )
separator <- plotit( xy, fig, fit, horizontal )
usr <- graphics::par("usr")
cmdlocs <- newlocs( cmds, data = is.data, usr = usr)
},
restart = {
if( is.data )
rescale.data <- 1
xy <- data.frame( x = xinit, y = yinit )
fit <- splines::interpSpline( xy$x, xy$y )
separator <- plotit( xy, fig, fit, horizontal )
usr <- graphics::par("usr")
cmdlocs <- newlocs( cmds, data = is.data, usr = usr)
},
add =, delete =, replace = {
ans <- newans
}
)
if( use.data ) {
rx <- range( xy$x )
dx <- range( datax )
graphics::lines( rx[1] + ( datax - dx[1] ) * diff( rx ) / diff( dx ), data * rescale.data )
}
plotcmd( ans, fig, cmds, cmdlocs, usr )
}
else {
fit <- curve.plot( xy, n = n, action = ans, z = z, fit = fit, backfit = FALSE,
save.ends = 0 )
xy <- fit$xy
fit <- fit$fit
ans <- "replace"
plotcmd( ans, fig, cmds, cmdlocs, usr )
}
if( newans == "finish" )
break
}
plotcmd( newans, fig, cmds, cmdlocs, "red" )
tmp <- curve.plot( xy, n = n, action = "refresh", backfit = FALSE, save.ends = 0 )
tmp
}
# --- Source: five.R ---
###########################################################################################
## five parameter visualization
## These are interactive routines to visualize changing relation of time to mean value.
##
## five.show: export
## five.plot: export
## five.make: used in five.switch, five.find, five.show
## five.switch: used in five.find, five.show, five.plot
## five.find: used in five.show
## five.lines: not used (list with same name elsewhere)
###########################################################################################
five.make <- function( fit = gencurve$fit,
dispersion=10, location=100, intensity=1,
truncation = 0, rejection = 1,
fivenum = list( dispersion, location, intensity, truncation, rejection ),
u = seq( 0.01, 0.99, by = 0.01 ))
{
G <- function(x,eps=.01)
{
x <- pmax( eps, pmin( 1-eps, x ))
-log(1-x)
}
n <- prod( unlist( lapply( fivenum, length )))
organism <- matrix( u, length( u ), n + 1 )
orgnames <- "prob"
j <- 1
for( it in truncation ) for( ii in intensity ) {
tmpp <- stats::predict(fit$invmvalue, x = ( G(it)+G(u))/ii)
nay <- is.na( tmpp$y )
if( any ( nay ))
tmpp$y[nay] <- spline.extrapolate( fit$meanvalue, fit$invmvalue,
tmpp$x[nay] )
for( ir in rejection ) {
yr <- tmpp$y
yr[ u >= ir ] <- NA
for( id in dispersion ) for( il in location ) {
orgnames <- c( orgnames, paste( round( c(
dispersion, location, intensity,
truncation, rejection ), 2 ), collapse = ":" ))
j <- j + 1
organism[,j] <- id * yr + il
}
}
}
dimnames( organism ) <- list( NULL, orgnames )
organism
}
###########################################################################################
five.switch <- function( fit, pick, vals )
{
switch( pick,
dispersion =
five.make( fit, dispersion = vals ),
location =
five.make( fit, location = vals ),
intensity =
five.make( fit, intensity = 1 / vals ),
truncation =
five.make( fit, truncation = vals ),
rejection =
five.make( fit, rejection = vals ))
}
###########################################################################################
five.find <- function( fit = gencurve$fit, pick, vals, goal = .9,
refmean = mean( five.make( fit )[,2], na.rm = TRUE ),
tol = 1e-8, printit = FALSE )
{
answer <- 0
vals <- seq( min( vals ), max( vals ), length = 3 )
tmp <- apply( five.switch( fit, pick, vals )[,-1], 2, mean, na.rm = TRUE ) / refmean
if( is.na( tmp[2] ))
return( NA )
if( max( tmp, na.rm = TRUE ) < goal | min( tmp, na.rm = TRUE ) > goal )
return( NA )
## binary search
while( abs( answer - goal ) > tol & !is.na( tmp[2] )) {
if( printit )
cat( vals[2], tmp[2], "\n" )
if( tmp[2] < goal ) {
tmp[1] <- tmp[2]
vals[1] <- vals[2]
vals[2] <- mean( vals[2:3] )
}
else {
tmp[3] <- tmp[2]
vals[3] <- vals[2]
vals[2] <- mean( vals[1:2] )
}
answer <- tmp[2] <- mean( five.switch( fit, pick, vals[2] )[,2], na.rm = TRUE ) /
refmean
}
vals[2]
}
###########################################################################################
five.show <- function( fit = spline.meanvalue(), goal = .9,
tol = 1e-5, legend.flag = 1, cex = 0.5, ylim = ylims, prefix = "" )
{
fives <- c("dispersion","location","intensity","truncation","rejection")
five.range <- list( dispersion = c(0,100), location = c(0,1000),
intensity = c(.1,100), truncation = c(0,1), rejection = c(0,1) )
cat( paste( "goal = ", round( goal * 100 ), "%\n", sep = "" ))
tol <- c( rep( tol, 4 ), .01 )
names( tol ) <- fives
five.lines <- list()
ref <- five.make( fit )
ylims <- range( ref[,2], na.rm = TRUE )
refmean <- mean( ref[,2], na.rm = TRUE )
for( pick in fives ) {
cat( pick, ": " )
vals <- five.find( fit, pick, five.range[[pick]], goal = goal,
tol = tol[pick], refmean = refmean )
if( pick == "intensity" )
cat(1/vals, "\n")
else
cat(vals, "\n")
if( !is.na( vals )) {
tmp <- five.switch( fit, pick, vals )
five.lines[[pick]] <- tmp[,2]
ylims <- range( ylims, tmp[,2], na.rm = TRUE )
}
}
plot(c(0,1),ylim, type="n", xlab = "", ylab = "" )
graphics::mtext( "probability", 1, 2 )
graphics::mtext( "time", 2, 2 )
if( goal > 1 )
main <- paste( prefix, round( 100 * ( goal - 1 ), 1 ), "% time extension", sep = "" )
else
main <- paste( prefix, round( 100 * ( 1 - goal ), 1 ), "% time reduction", sep = "" )
graphics::mtext( main, 3, 1 )
graphics::lines( ref[,1], ref[,2], lty = 3, lwd = 1 )
graphics::abline( h = refmean * c( 1, goal[1] ), col = c("black","blue"), lty = c(1,3) )
col <- c("blue","red","green","aquamarine","black")
lty <- c(2,4,5,6,1)
names( col ) <- names(lty) <- fives
for( i in names( five.lines ))
graphics::lines( tmp[,1], five.lines[[i]], lty = lty[i], lwd = 1, col = col[i] )
switch( 1 + legend.flag,
graphics::legend( 0, ylim[2], names( five.lines ),
lty = lty[ names( five.lines ) ],
col = col[ names( five.lines ) ], cex = cex ),
graphics::legend( 1, ylim[1], names( five.lines ), xjust = 1, yjust = 0,
lty = lty[ names( five.lines ) ],
col = col[ names( five.lines ) ], cex = cex ))
invisible( list( ref = ref, lines = five.lines ))
}
###########################################################################################
five.plot <- function(gencurve = spline.meanvalue(), fit = gencurve$fit,
pick, vals, ylim = ylims)
{
tmpx <- seq(0.01,.99,by=.01)
G <- function(x,eps=.01)
{
x <- pmax( eps, pmin( 1-eps, x ))
-log(1-x)
}
tmp <- five.switch( fit, pick, vals )
ylims <- range( tmp[,-1], na.rm = TRUE )
plot( 0:1, ylim, type = "n",
xlab = "probability", ylab = "time" )
graphics::title( main = pick )
graphics::lines( tmp[,1], tmp[,2], lty = 3 )
for( i in 3:ncol( tmp ))
graphics::lines( tmp[,1], tmp[,i], lty = 1 )
}
###########################################################################################
five.lines <- function( invmvalue = gencurve,
dispersion=10, location=100, intensity=.5,
truncation = .25, rejection = .75,
u = seq(0.01,.99,by=.01), lty = 1 )
{
G <- function(x,eps=.01)
{
x <- pmax( eps, pmin( 1-eps, x ))
-log(1-x)
}
for( it in truncation ) for( ii in intensity )
{
tmpp <- stats::predict(invmvalue$fit$inv, x = ( G(it)+G(u))/ii)
for( ir in rejection )
{
yr <- tmpp$y
yr[ u >= rejection ] <- NA
for( id in dispersion ) for( il in location )
lines( u, id * yr + il, lty = lty )
}
}
}
# --- Source: fiveShowApp.R ---
fiveShowApp <- function(title = "Spline 5-Parameter Goal Explorer") {
# Curated modern light color scheme
app_theme <- bslib::bs_theme(
version = 5,
bg = "#ffffff",
fg = "#212529",
primary = "#1a73e8",
secondary = "#7209b7",
success = "#2ec4b6"
)
ui <- bslib::page_sidebar(
title = title,
theme = app_theme,
sidebar = bslib::sidebar(
width = 350,
shiny::h4("1. Baseline Spline", style = "color: #1a73e8; font-weight: bold; margin-bottom: 15px;"),
shiny::p("Click directly on the left plot to adjust the nodes of the baseline curve. You can also manually edit the coordinate numbers below.",
style = "font-size: 0.9em; color: #495057; margin-bottom: 15px;"),
shiny::textInput("x_coords", "X Coordinates (comma separated):",
value = "0.000, 0.153, 0.334, 0.555, 0.838, 1.236, 1.906, 5.000"),
shiny::textInput("y_coords", "Y Coordinates (comma separated):",
value = "0.000, 0.200, 0.400, 0.700, 1.100, 1.600, 2.400, 5.000"),
shiny::hr(style = "border-top: 1px solid rgba(0, 0, 0, 0.1);"),
shiny::h4("2. Goal Target", style = "color: #7209b7; font-weight: bold; margin-bottom: 15px;"),
shiny::sliderInput("goal", "Target Relative Mean (five.show):",
min = 0.5, max = 1.5, value = 0.9, step = 0.05),
shiny::hr(style = "border-top: 1px solid rgba(0, 0, 0, 0.1);"),
shiny::p("Ewing QPE Simulation Package", style = "font-size: 0.85em; color: rgba(33, 37, 41, 0.5);")
),
# Custom CSS style block for premium light aesthetics
shiny::tags$head(
shiny::tags$link(rel = "stylesheet", href = "https://fonts.googleapis.com/css2?family=Outfit:wght@300;400;600;700&display=swap"),
shiny::tags$style(shiny::HTML("
body {
background-color: #f8f9fa;
color: #212529;
font-family: 'Outfit', -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif;
}
.card {
background: #ffffff !important;
border: 1px solid rgba(0, 0, 0, 0.08) !important;
border-radius: 12px !important;
box-shadow: 0 4px 20px 0 rgba(0, 0, 0, 0.05);
transition: all 0.3s ease;
margin-bottom: 20px;
}
.card:hover {
border-color: rgba(26, 115, 232, 0.3) !important;
}
.card-header {
background: rgba(0, 0, 0, 0.02) !important;
border-bottom: 1px solid rgba(0, 0, 0, 0.08) !important;
font-weight: bold;
}
.sidebar {
background: #ffffff !important;
border-right: 1px solid rgba(0, 0, 0, 0.08) !important;
}
.control-label {
font-weight: 500;
color: #495057;
}
.form-control, .selectize-input {
background-color: #ffffff !important;
border: 1px solid rgba(0, 0, 0, 0.15) !important;
color: #212529 !important;
}
.form-control:focus, .selectize-input.focus {
border-color: #1a73e8 !important;
box-shadow: 0 0 0 0.25rem rgba(26, 115, 232, 0.25) !important;
}
pre {
background: #f1f3f4 !important;
border: 1px solid rgba(0, 0, 0, 0.08);
border-radius: 8px;
color: #7209b7 !important;
padding: 15px;
font-family: 'Courier New', Courier, monospace;
white-space: pre-wrap;
font-size: 0.9em;
}
"))
),
# Main UI body - two plots side-by-side
shiny::fluidRow(
shiny::column(
width = 6,
bslib::card(
bslib::card_header("Interactive Baseline Spline (Click plot to move nodes)"),
bslib::card_body(
shiny::plotOutput("plot_baseline", height = "500px", click = "baseline_click")
)
)
),
shiny::column(
width = 6,
bslib::card(
bslib::card_header("Goal Comparison Plot: five.show()"),
bslib::card_body(
shiny::plotOutput("plot_goal", height = "500px")
)
)
)
),
shiny::fluidRow(
shiny::column(
width = 6,
bslib::card(
bslib::card_header("Binary Search Console Output"),
bslib::card_body(
shiny::verbatimTextOutput("show_console")
)
)
),
shiny::column(
width = 6,
bslib::card(
bslib::card_header("Goal Search Explanation & Parameters"),
bslib::card_body(
shiny::HTML("
<p><strong>Goal Search:</strong> The <code>five.show()</code> function performs a separate binary search for each of the 5 parameters to find the value that yields the target relative mean time compared to the baseline spline (e.g. 90% or 110% of baseline mean).</p>
<p>The console output shows the values found during this search:</p>
<ul style='padding-left: 20px; font-size: 0.95em; line-height: 1.5em;'>
<li><strong>dispersion:</strong> Stretches/compresses the time axis to match the target.</li>
<li><strong>location:</strong> Shifts the time axis additively to match the target.</li>
<li><strong>intensity:</strong> Modifies event velocity to match the target (shown as inverse velocity).</li>
<li><strong>truncation:</strong> Crops early-stage probability to match the target.</li>
<li><strong>rejection:</strong> Disallows late-stage transitions to match the target.</li>
</ul>
<p>If a parameter cannot achieve the target mean (e.g. a rejection threshold of 1 still yields a mean higher than the target), it returns <code>NA</code>.</p>
")
)
)
)
)
)
server <- function(input, output, session) {
# Reactive fit object from input coordinates
fit_reactive <- shiny::reactive({
shiny::req(input$x_coords, input$y_coords)
# Parse text inputs
x_vals <- as.numeric(trimws(strsplit(input$x_coords, ",")[[1]]))
y_vals <- as.numeric(trimws(strsplit(input$y_coords, ",")[[1]]))
# Validations
shiny::validate(
shiny::need(length(x_vals) == length(y_vals), "Error: X and Y coordinate lists must be of equal length."),
shiny::need(length(x_vals) >= 3, "Error: Please specify at least 3 coordinate points."),
shiny::need(!any(is.na(x_vals)) && !any(is.na(y_vals)), "Error: All coordinates must be numeric values."),
shiny::need(all(diff(x_vals) > 0), "Error: X coordinates must be strictly increasing."),
shiny::need(all(diff(y_vals) > 0), "Error: Y coordinates must be strictly increasing.")
)
# Try building interpSpline and backSpline
tryCatch({
meanvalue <- splines::interpSpline(x_vals, y_vals)
invmvalue <- splines::backSpline(meanvalue)
list(meanvalue = meanvalue, invmvalue = invmvalue, xy = data.frame(x = x_vals, y = y_vals))
}, error = function(e) {
shiny::validate(
paste("Error building spline:", e$message,
"\nNote: The spline must be strictly monotonic (always increasing) to calculate its backspline.")
)
})
})
# Handle click on baseline plot to move closest point
shiny::observeEvent(input$baseline_click, {
cx <- input$baseline_click$x
cy <- input$baseline_click$y
# Parse current inputs to find closest point
x_current <- as.numeric(trimws(strsplit(input$x_coords, ",")[[1]]))
y_current <- as.numeric(trimws(strsplit(input$y_coords, ",")[[1]]))
if (length(x_current) < 3 || any(is.na(x_current)) || any(is.na(y_current))) return()
n <- length(x_current)
# Calculate closest point index in normalized Euclidean space
x_range <- max(x_current) - min(x_current)
y_range <- max(y_current) - min(y_current)
if (x_range == 0) x_range <- 1
if (y_range == 0) y_range <- 1
dists <- ((x_current - cx) / x_range)^2 + ((y_current - cy) / y_range)^2
closest_idx <- which.min(dists)
# Determine monotonicity boundaries for selected node
# Bound X:
min_x <- if (closest_idx == 1) x_current[1] else x_current[closest_idx - 1] + 0.005
max_x <- if (closest_idx == n) x_current[n] else x_current[closest_idx + 1] - 0.005
new_x <- max(min_x, min(max_x, cx))
# Bound Y:
min_y <- if (closest_idx == 1) y_current[1] else y_current[closest_idx - 1] + 0.005
max_y <- if (closest_idx == n) y_current[n] else y_current[closest_idx + 1] - 0.005
new_y <- max(min_y, min(max_y, cy))
# Update coordinates array
x_current[closest_idx] <- new_x
y_current[closest_idx] <- new_y
# Update text inputs
shiny::updateTextInput(session, "x_coords", value = paste(round(x_current, 3), collapse = ", "))
shiny::updateTextInput(session, "y_coords", value = paste(round(y_current, 3), collapse = ", "))
})
# Render baseline spline preview
output$plot_baseline <- shiny::renderPlot({
fit_obj <- fit_reactive()
shiny::req(fit_obj)
# Generate predictions for smooth curve plotting
pred_x <- seq(min(fit_obj$xy$x), max(fit_obj$xy$x), length.out = 150)
pred_y <- stats::predict(fit_obj$meanvalue, pred_x)$y
# Custom light plot styling
graphics::par(bg = "white", col.axis = "#495057", col.lab = "#212529", col.main = "#1a73e8", fg = "#cccccc")
graphics::plot(pred_x, pred_y, type = "l", col = "#1a73e8", lwd = 3,
xlab = "Time (X)", ylab = "Probability scale (Y)",
main = "Interactive Baseline Mean-Value Spline",
panel.first = graphics::grid(col = "#e9ecef", lty = 1))
# Plot nodes
graphics::points(fit_obj$xy$x, fit_obj$xy$y, col = "#7209b7", pch = 19, cex = 1.8)
# Draw outer circles as handles
graphics::points(fit_obj$xy$x, fit_obj$xy$y, col = "#7209b7", pch = 1, cex = 2.8, lwd = 1.5)
})
# Render multi-parameter goal comparison plot (five.show)
output$plot_goal <- shiny::renderPlot({
fit_obj <- fit_reactive()
shiny::req(fit_obj, input$goal)
# Plotting
graphics::par(bg = "white", col.axis = "#495057", col.lab = "#212529", col.main = "#7209b7", fg = "#cccccc")
# Run five.show directly
five.show(fit = fit_obj, goal = input$goal)
})
# Capture console output of five.show binary search
output$show_console <- shiny::renderText({
fit_obj <- fit_reactive()
shiny::req(fit_obj, input$goal)
# Redirect plots to null device during text capture
grDevices::pdf(NULL)
on.exit(grDevices::dev.off())
output_lines <- utils::capture.output({
five.show(fit = fit_obj, goal = input$goal)
})
paste(output_lines, collapse = "\n")
})
}
shiny::shinyApp(ui = ui, server = server)
}
# --- Launch Application ---
fiveShowApp()Programmatic Application Usage
Launch the interactive application natively in R:
library(ewing)
fiveShowApp()