Изменение относительной высоты бинов гистограммы в интерактивном режиме
В субъективных оценках вероятности нужно выявить распределение мнений субъектов. Это может быть достигнуто путем предоставления субъекту возможности управлять относительной высотой каждого частотного интервала гистограммы. Т.е. при распределении вероятности огибающая кривая приобретает форму, сохраняя кумулятивную сумму (P_i)=1. Как это можно сделать с помощью R? Есть ли уже пакет, на котором я могу построить?
Альтернативно: как это можно сделать в приложении для работы с электронными таблицами (Excel, OO Calc, Google Tables)?
1 ответ
Вот некоторый код, который я собрал, используя пакет tkrplot и опционально пакет logspline.
Просто запустите функцию (вы можете изменить аргументы, но для проверки можете попробовать ее с настройками по умолчанию), затем в новом окне, которое появляется, щелкните на графике, щелчки левой кнопкой мыши добавят точку, в которой вы щелкнете, правой (или средней). щелчки уберут точку, ближайшую к тому месту, где вы нажали.
Я, вероятно, немного его уберу и включу в будущий выпуск пакета TeachingDemos (поэтому комментарии / предложения приветствуются).
TkBuildDist <- function( x=seq(min+(max-min)/nbin/2,
max-(max-min)/nbin/2,
length.out=nbin),
min=0, max=10, nbin=10, logspline=TRUE,
intervals=FALSE) {
if(logspline) logspline <- require(logspline)
require(tkrplot)
xxx <- x
brks <- seq(min, max, length.out=nbin+1)
nx <- seq( min(brks), max(brks), length.out=250 )
lx <- ux <- 0
first <- TRUE
replot <- if(logspline) {
if(intervals) {
function() {
hist(xxx, breaks=brks, probability=TRUE,xlab='', main='')
xx <- cut(xxx, brks, labels=FALSE)
fit <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )
lines( nx, doldlogspline(nx,fit), lwd=3 )
if(first) {
first <<- FALSE
lx <<- grconvertX(min, to='ndc')
ux <<- grconvertX(max, to='ndc')
}
}
} else {
function() {
hist(xxx, breaks=brks, probability=TRUE,xlab='', main='')
fit <- logspline( xxx )
lines( nx, dlogspline(nx,fit), lwd=3 )
if(first) {
first <<- FALSE
lx <<- grconvertX(min, to='ndc')
ux <<- grconvertX(max, to='ndc')
}
}
}
} else {
function() {
hist(xxx, breaks=brks, probability=TRUE,xlab='',main='')
if(first) {
first <<- FALSE
lx <<- grconvertX(min, to='ndc')
ux <<- grconvertX(max, to='ndc')
}
}
}
tt <- tktoplevel()
tkwm.title(tt, "Distribution Builder")
img <- tkrplot(tt, replot, vscale=1.5, hscale=1.5)
tkpack(img, side='top')
tkpack( tkbutton(tt, text='Quit', command=function() tkdestroy(tt)),
side='right')
iw <- as.numeric(tcl('image','width',tkcget(img,'-image')))
mouse1.down <- function(x,y) {
tx <- (as.numeric(x)-1)/iw
ux <- (tx-lx)/(ux-lx)*(max-min)+min
xxx <<- c(xxx,ux)
tkrreplot(img)
}
mouse2.down <- function(x,y) {
if(length(xxx)) {
tx <- (as.numeric(x)-1)/iw
ux <- (tx-lx)/(ux-lx)*(max-min)+min
w <- which.min( abs(xxx-ux) )
xxx <<- xxx[-w]
tkrreplot(img)
}
}
tkbind(img, '<ButtonPress-1>', mouse1.down)
tkbind(img, '<ButtonPress-2>', mouse2.down)
tkbind(img, '<ButtonPress-3>', mouse2.down)
tkwait.window(tt)
out <- list(x=xxx)
if(logspline) {
if( intervals ) {
xx <- cut(xxx, brks, labels=FALSE)
out$logspline <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )
} else {
out$logspline <- logspline(xxx)
}
}
if(intervals) {
out$intervals <- table(cut(xxx, brks))
}
out$breaks <- brks
return(out)
}
Вот еще одна версия, которая позволяет перетаскивать высоты баров:
TkBuildDist2 <- function( min=0, max=1, nbin=10, logspline=TRUE) {
if(logspline) logspline <- require(logspline)
require(tkrplot)
xxx <- rep( 1/nbin, nbin )
brks <- seq(min, max, length.out=nbin+1)
nx <- seq( min, max, length.out=250 )
lx <- ux <- ly <- uy <- 0
first <- TRUE
replot <- if(logspline) {
function() {
barplot(xxx, width=diff(brks), xlim=c(min,max), space=0,
ylim=c(0,0.5), col=NA)
axis(1,at=brks)
xx <- rep( 1:nbin, round(xxx*100) )
capture.output(fit <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ))
lines( nx, doldlogspline(nx,fit)*(max-min)/nbin, lwd=3 )
if(first) {
first <<- FALSE
lx <<- grconvertX(min, to='ndc')
ly <<- grconvertY(0, to='ndc')
ux <<- grconvertX(max, to='ndc')
uy <<- grconvertY(0.5, to='ndc')
}
}
} else {
function() {
barplot(xxx, width=diff(brks), xlim=range(brks), space=0,
ylim=c(0,0.5), col=NA)
axis(at=brks)
if(first) {
first <<- FALSE
lx <<- grconvertX(min, to='ndc')
ly <<- grconvertY(0, to='ndc')
ux <<- grconvertX(max, to='ndc')
uy <<- grconvertY(0.5, to='ndc')
}
}
}
tt <- tktoplevel()
tkwm.title(tt, "Distribution Builder")
img <- tkrplot(tt, replot, vscale=1.5, hscale=1.5)
tkpack(img, side='top')
tkpack( tkbutton(tt, text='Quit', command=function() tkdestroy(tt)),
side='right')
iw <- as.numeric(tcl('image','width',tkcget(img,'-image')))
ih <- as.numeric(tcl('image','height',tkcget(img,'-image')))
md <- FALSE
mouse.move <- function(x,y) {
if(md) {
tx <- (as.numeric(x)-1)/iw
ty <- 1-(as.numeric(y)-1)/ih
w <- findInterval(tx, seq(lx,ux, length=nbin+1))
if( w > 0 && w <= nbin && ty >= ly && ty <= uy ) {
xxx[w] <<- 0.5*(ty-ly)/(uy-ly)
xxx[-w] <<- (1-xxx[w])*xxx[-w]/sum(xxx[-w])
tkrreplot(img)
}
}
}
mouse.down <- function(x,y) {
md <<- TRUE
mouse.move(x,y)
}
mouse.up <- function(x,y) {
md <<- FALSE
}
tkbind(img, '<Motion>', mouse.move)
tkbind(img, '<ButtonPress-1>', mouse.down)
tkbind(img, '<ButtonRelease-1>', mouse.up)
tkwait.window(tt)
out <- list(breaks=brks, probs=xxx)
if(logspline) {
xx <- rep( 1:nbin, round(xxx*100) )
out$logspline <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )
}
return(out)
}