# mouse add points
mouseCmdAddPt<-function(mssg){
if(length(mssg$vec)>0){
vec<- as.numeric(unlist(mssg$vec))
}
src<-getCode()
replacementList<-list()
ptDefs<-getPtDefs()
updateRowPicker(session, "myTibRowCntrl", removeEntireGroup=TRUE)
sender='PointsBar.mouse.add'
keycode=mssg$keycode
newPt<-vec
selection<-getAssetName()
rowIndex<-getTibRow()
matColIndx<-getTibMatCol()
if( length( getPointMax())>1){ stop('getPointMax is too big')} #should never happen
if(!is.na(getPointMax()) && getTibMatColMax() >= getPointMax() ){ #need to split?
#split
updateRowPicker(session, "myTibRowCntrl", insertRow=rowIndex+1, selectRow=rowIndex+1)
tibs<-ptDefs$tib
tib<-tibs[[selection]]
tib<-bind_rows(tib[1:rowIndex,], tib[rowIndex:nrow(tib),])
rowIndex<-rowIndex+1
tib[[getTibColumnName()]][[rowIndex]]<-matrix(0,2,0)
tibs[[selection]]<-tib
matColIndx<-0
ptDefs$tib<-tibs
# since we just added a new row we must check if we need to
# modify (preproc) the values in that row
scripts<-getPreProcOnNewRowScripts( getTibTabId(), selection)
if(length(scripts)>0){
newTibs<-tibs # backup tibs,
newRowIndx<-rowIndex
tryCatch({
tibColNames<-names(tib)
cols<-intersect(tibColNames,names(scripts))
for(columnName in cols){
txt<-scripts[columnName]
values<-tib[[columnName]]
getAttrValue<-function(){values[rowIndex]}
context<-list(
name=getAssetName(),
column=which(tibColNames==columnName),
row=rowIndex,
tibs=tibs
)
ppenv<-list(
setAttrValue=setAttrValue,
getAttrValue=getAttrValue,
context=context,
keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode)
)
tibs<-eval(parse(text=txt), ppenv )
validateTibLists(getPtDefs()$tib, tibs)
} # all cols done successfully
ptDefs$tib<-tibs # success, reset ptDefs
}, error=function(e){
err<-paste(e$message, collapse="\n", sep="\n")
shinyalert("preproc new point Error",err, type="error")
})
} #end of scripts
} # end of split
# now add the point
newPtDefs<-ptDefs
tibs<-newPtDefs$tib
txt<-getPreProcScript()['onNewPt']
if( !is.null(txt) ){ #preproc pts
tryCatch({
getPoint<-function(){names(newPt)<-c('x','y'); newPt}
context<-list(
name=getAssetName(),
column=getTibPtColPos(),
row=rowIndex,
ptIndex=matColIndx,
tibs=tibs
)
ppenv<-list(
getPoint=getPoint,
insertPoint=insertPoint,
context=context,
keys=list(alt=mssg$altKey, shift=mssg$shiftKey, ctrl=mssg$ctrlKey, meta=mssg$metaKey, keycode=mssg$keycode),
WH=getSVGWH()
)
tibs<-eval(parse(text=txt), ppenv )
validateTibLists(getPtDefs()$tib, tibs)
newPtDefs$tib<-tibs
if(!is.null(newPtDefs)){ #update only upon success
updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matColIndx+1))
}
},error=function(e){
err<-paste(e$message, collapse="\n", sep="\n")
shinyalert("preproc new point Error",err, type="error")
})
} else { #no prepoc pts
tib<-tibs[[selection]]
pts<-tib[[getTibColumnName()]][[rowIndex]]
pts<-matrix(append(pts,newPt,2*(matColIndx)) ,2)
tibs[[selection]][[getTibColumnName()]][[rowIndex]]<-pts
newPtDefs$tib<-tibs
if(!is.null(newPtDefs)){ #update only upon success
updateAceExtDef(newPtDefs, sender=sender, selector=list( rowIndex=rowIndex, matCol=matColIndx+1))
}
}
#} #end no split
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.