R/ana_set_cursor.R

In tdanker/ephys2: Read, analyze and plot HEKA Patchmaster files

# all names must be unique so that the cursor can be adressed
# names can be made auto-unique by using dotNames ("name.")
# dotNames will be combined in resultlists using the part preceding the dot
# this requires 
# 
# a) overriding rules to override globals with locals
# 
# b) checks to avoid overlapping sweep ranges 
# 
# c) rules for using the same dotname on the same single sweep (events)
#  
# ad c): this is only allowed with cursor marked event, which prevents it getting listed in $results()
# 

# not yet implemented:
# set_cursor("hERG", swp=1:4, ...)         # global, but only sweeps 1:4
# set_cursor(ser1, global=T, ...)          # global
# set_cursor(ser1, global=T, swp=1:4, ...) # global, but only sweeps 1:4
# set_cursor(ser1, ...)                    # local
# set_cursor(ser1, swp=1:4, ...)           # local, but only sweeps 1:4
# set_cursor(ser1, swp=1, ...)             # local, but only sweep 1 


#' Setting cursors
#' 
#' Cursors are user defined regions of interest in data traces to which 
#' \link{cursormethods}  are applied. 
#' There are two types of cursors: global cursors and event cursors. 
#' Global cursors are stored in a varaiable named "CURSORS" in the global namespace.
#' These cursors are automatically looked up and used if a series with the same stimulus name is used.
#' Event cursors are 'local' in the sense that they belong to a certain trace.  
#' 
#' 
#' @param stimname the name of the stimulus for which a cursor shall be defined, or a "series" object 
#' @param curname the name of the cursor to define. If the name ends with a dot, a number will be appended to make the name globally unique. 
#' @param method_ a \link{cursormethods} that defines how the cursor calculates its results. 
#' @param range   the cursor range
#' @param force.update   the default, False, prevents that already existing cursor settings are overwritten. 
#' @param warn if as warning should be shown when force.update is False and an existing cursor is not updated 
#' @param interactive force interactive mode
#' 
#' Interactivly setting cursors
#' 
#' To enter interactive mode, stimname should be a series proto object and range can be ommited. 
#' After interactively setting the cursor, 
#' the command to set the cursor is also copied to the clipboard 
#' for later use in a script. 
#' 
#'
#' 
#' @details this is the details
#' 
#' @seealso \link{get_eventresults}, \link{calculate.results}, and \link{get_all} to see how to get results from a tree. 
#'  \link{getSeries} to see how to get the results of an extracted series 
#' 
#' @export
#' @examples
#' data(series_NaIV)
#' set_cursor("NaIV", "peak", curMin_,c(0.01,0.013)) # global cursor
#' series_NaIV$plot()
#' series_NaIV$results()
#' 
#'  # setting eventcursors                                         
#'  data(st)
#'  set_eventcursor(st, swp=1, "ev1" , curAP_, c(2,4.3)) 
#'  st$plot(sweeps=1)

#' @describeIn set_cursor set a global cursor                                          
 
set_cursor <- function(stimname, curname, method_ = NULL, range = NULL, 
                       path=NULL, 
                       swp=NULL,
                       global=inherits(stimname,"character"),
                       event=F,
                       eventname="",
                       interactive = is.null(range), 
                       force.update=T, warn=T, plot.fun.first)
  {
    arg1<-stimname
    if(inherits(stimname,"proto") && !is.null(swp) && event){
      path<-make_path(stimname,swp)
    }
    stimname<-get_stimname(stimname)
    if (!exists("CURSORS", .GlobalEnv)) 
        CURSORS <<- list()
    
    # auto id:
    # how and when do we do auto_id ?
    
    # only for eventcursors -this may change later when we allow "local cursors"
    if (!is.null(path) && event==T){     
        # if we do not refer to an exisiting id directly
      # which we detect by checking that we end with a dot ? 
      if(stringr::str_detect(curname,"\\.$")){
        stringr::str_sub(curname,-1)<-""
        curname<-next_id(stimname, curname)
      }
    }
    this.cursor<-CURSORS[[stimname]]$cursors[[curname]]
    if(!force.update){
      # check if the cursor already exists, and do not overwrite
      if (!is.null(this.cursor)){
        if(warn)
          warning("Cursor already exist. Use 'force.update=T' if you want to overwrite")
          return(NULL)
      }  
    }
  
    # if cursor already exists, we do not add it but modify it:
    # if method is given, we modify the method and initially reuse the range
    # if range is given, we modify the range
    # if range is not given, this will trigger interactive (shiny)
    if (!is.null(this.cursor)) {
      if (!is.null(path) ) {
        if( !identical (path, this.cursor$path) ) {
          stop("cannot set cursor: an eventcursor with this name already exisits for a different trace")
        }
      }
      if (!is.null(method_)) {
        this.cursor$analyse.methods<-method_(curname)
        this.cursor$plot.fun.last<-attr(method_(curname),"plot.fun.last")
        
      }
      if (!is.null(range)) {
        this.cursor$range <- range
      }
      this.cursor$eventname<-eventname
      this.cursor$event<-event      
        
    } else {
    
    # if it did not exist, we make one and add it to the list
    
        if (is.null(method_)) {
            stop("no method given for new cursor")
        }
        if (is.null(range)) {
            range = c(0, 0.1)
        } 
        this.cursor = makecursor(curname, range, method_(curname))
        this.cursor$path=path
        this.cursor$eventname=eventname
        this.cursor$event<-event      
    }
    
    if(!missing(plot.fun.first)){
      this.cursor$plot.fun.first<-plot.fun.first
    }
    add_cursor(stimname, this.cursor)  
    
    if (interactive) {
        if(inherits(arg1,"proto"))
          arg1<-arg1$sweeps
        stopifnot(inherits(arg1, "HEKAseries"))
        sweeps <- arg1
        sweeps <- setcursor_shiny(sweeps, curname, swp=swp)
        
        range=CURSORS[[stimname]]$cursors[[curname]]$range
        range=paste("c(", range[1], ",", range[2], ")", sep="")
        method<-deparse(substitute(method_))
        stimname<-paste("'", stimname, "'", sep="")
        curname<-paste("'", curname, "'", sep="")
        args<-paste(stimname, curname, method, range, sep=",")
        command<- paste("set_cursor(", args,")", sep="")
        writeClipboard(command)
    }
}

#' @describeIn set_cursor initialize the cursor but dont overwrite exisiting
#' @export
init_cursor <- function(...){
  set_cursor(force.update = F, warn=F, ...)
}


get_eventcursors<-function(stimname){
  CURSORS[[stimname]]$cursors[  
    # eventcursors allways have $event set to TRUE
    unlist(
      lapply(
        CURSORS[[stimname]]$cursors, 
          function(cursor) cursor$event)
      )  
    ]
}


next_id<-function(stimname, name){
  name.<-paste0(name,".")
  existing.cursors<-names(get_eventcursors(stimname))
  # extract those which start with name and follwed by a dot, then a number 
  matching.cursors<-existing.cursors[stringr::str_detect(existing.cursors,paste0("^",name,"\\."))]
  splittable<-stringr::str_split_fixed( matching.cursors, name., n=2)
  suffixes<-splittable[,2] 
  
  next.suffix <- suppressWarnings(max(as.numeric(suffixes), na.rm=T))+1
  if(next.suffix<1)
    next.suffix<-1
  paste0(name., next.suffix)
}

# gets stimulus name from HEKAseries or proto. 
# If string, returns unchanged
get_stimname <- function(stimname)
{
  if (inherits(stimname, "HEKAseries")) {
    sweeps <- stimname
    return(sweeps$Stimulus)
  } 
  if (inherits(stimname, "proto")) {
    sweeps <- stimname$sweeps
    return(stimname$sweeps$Stimulus)
  }
  if (inherits(stimname, "character")) {
    return(stimname)
  }
  stop ("Stimulus name could not be extracted")
}

#helper function to make a cursor
makecursor <- function(name, range, methods = NULL, plot.fun.first = showcursor, plot.fun.last = attr(methods, 
                                                                                                      "plot.fun.last")) {
  list(name = name, range = range, analyse.methods = methods, plot.fun.first = plot.fun.first, 
       plot.fun.last = plot.fun.last, type = attr(methods, "name"))
}


# the default function for the plot.fun.last method of cursors
showcursor <- function(cursor, col = "grey97", ...) {
  xBar(cursor$range[1], cursor$range[2], y = par("usr")[4], pos = 1, layer = T, xpd = F, 
       col.layer = col, text = cursor$name)
}