API tools faq
paste
Guest User

Flux Capacitor

a guest
Dec 31st, 2015
74
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 9.71 KB | None | 0 0
raw download clone embed print report
  1. fluxcapacitor <- function(mt=0.05 # maximum tolerance for bpm variantion
  2.                           ,mva=0.25 # maximum threshold for average ms variance
  3.                           ,mvs=0.5 # maximum threshold for single ms variance
  4.                           ,ti=0.005 # tolerance interval
  5.                           ,patch=FALSE # output to patch dir?
  6.                           ,pdir # patch dir
  7.                           ,sdir # song dir
  8.                           ,extreme=FALSE){ # if true, evaluate all solutions and select the best
  9.   read.sm <- function(sdir){ # self-explanatory
  10.     smi <- list.files(sdir,full.names=TRUE)[which(substr(list.files(sdir),nchar(list.files(sdir))-2,nchar(list.files(sdir)))==".sm")]
  11.     if(length(smi)>0){return(sm <- readLines(smi))}
  12.   }
  13.   rowmerge <- function(sm # .sm file
  14.                        ,x){ # merge specified data on multiple lines
  15.     s <- which(substr(sm,1,nchar(x)) == x)
  16.     nb <- head(which(substr(sm,1,6) =="#NOTES"),1)
  17.     f <- s + grep(";",sm[s:nb[1]])[1] - 1
  18.     m1 <- sm[s:f]
  19.     o <- m1[1]
  20.     if(length(m1) > 1){
  21.       for (i in 2:length(m1)) {
  22.         o <- paste(o,m1[i], sep="")
  23.       }
  24.     } else {
  25.       o <- m1[1]
  26.     }
  27.     o <- substr(o,nchar(x)+1,nchar(o)-1)
  28.   }
  29.   rowremove <- function(sm # .sm file
  30.                         ,x){ # remove excess data lines for specified data
  31.     s <- which(substr(sm,1,nchar(x)) == x)
  32.     nb <- head(which(substr(sm,1,6) =="#NOTES"),1)
  33.     f <- s + grep(";",sm[s:nb[1]])[1] - 1
  34.     if(s-f !=0){
  35.       r <- (s+1):f
  36.       names(sm) <- 1:length(sm)
  37.       sm <- sm[!names(sm) %in% r]
  38.     }
  39.     sm
  40.   }
  41.   getfb <- function(sm){ #determines the final measure of the file (in beats)
  42.     ns <- head(which(substr(sm,1,7)=="#NOTES:"),1)+6
  43.     nf <- head(grep(";",sm[ns:length(sm)]),1)+ns
  44.     fb <- length(c(0,which(substr(sm[ns:nf],1,1)==","),nf))*4
  45.   }
  46.   createbpmarray <- function(b # convert the bpmline into an array
  47.                              ,fb){ # removes bpms beyond the final beat; appends entry for fb
  48.     a <- lapply(lapply(unlist(strsplit(b,",")),strsplit,"="),unlist)
  49.     a <- cbind(unlist(lapply(a,"[",1)),unlist(lapply(a,"[",2)))
  50.     rownames(a) <- 1:dim(a)[1]
  51.     class(a) <- "numeric"
  52.     a <- a[1:tail(which(a[,1]<fb),1),]
  53.     a <- rbind(a,c(fb,2.6457))
  54.   }
  55.   createstoparray <- function(s # convert the stopline into an array
  56.                               ,fb){ # remove stops beyond the final beat
  57.     if(s!=""){
  58.       a <- lapply(lapply(unlist(strsplit(s,",")),strsplit,"="),unlist)
  59.       a <- cbind(unlist(lapply(a,"[",1)),unlist(lapply(a,"[",2)))
  60.       rownames(a) <- 1:dim(a)[1]
  61.       class(a) <- "numeric"
  62.       arm <- tail(which(a[,1]<fb),1)
  63.       if(length(arm)>0){
  64.         a <- a[1:arm,]
  65.       }else{
  66.         a <- NULL
  67.       }
  68.     }
  69.     if(exists("a")){rbind(a,NULL)}else{NULL}
  70.   }
  71.   createmsarray <- function(ba #bpm array
  72.                             ,sa #stop array
  73.                             ,fb){ #builds msarray until final beat
  74.     if(!missing(fb)){
  75.       ba <- rbind(ba,c(fb,2.6457))
  76.     }
  77.     mt <- as.vector(0)
  78.     for(i in 2:dim(ba)[1]){
  79.       mt[i] <- ((ba[i]-ba[i-1])/(ba[i-1,2]/60))
  80.     }
  81.     ma <- cbind(cbind(ba,mt),cumsum(mt))
  82.     if(!is.null(sa)){
  83.       ma <- cbind(ma,0)
  84.       for(i in 1:dim(sa)[1]){
  85.         mas <- head(which(ma[,1]>=sa[i,1]),1)
  86.         ma[mas:dim(ma)[1],5] <- ma[mas:dim(ma)[1],5]+sa[i,2]
  87.       }
  88.       ma[,4] <- ma[,4]+ma[,5]
  89.     }
  90.     ma[,3:4] <- cbind(c(ma[2:dim(ma)[1],3],0),c(ma[2:dim(ma)[1],4],0))
  91.     ma
  92.   }
  93.   msvar <- function(x # original msarray
  94.                     ,y){ # compares x to new msarray (y)
  95.     y <- rbind(y,NULL)
  96.     ex <- x[,1][x[,1] %in% y[,1]==FALSE]
  97.     if(length(ex)!=0){
  98.       yn <- rbind(y[,1:2],cbind(ex,NA))
  99.     }else{yn <- y[,1:2]}
  100.     yn <- yn[order(yn[,1]),]
  101.     for(i in 2:dim(yn)[1]){
  102.       if(is.na(yn[i,2])){
  103.         yn[i,2] <- yn[(i-1),2]
  104.       }
  105.     }
  106.     y <- createmsarray(yn,sa)
  107.    
  108.     d <- vector()
  109.     for(i in 1:(dim(y)[1]-1)){
  110.       z <- match(y[i+1,1],x[,1])-1
  111.       d[i] <- x[z,4]-y[i,4]
  112.     }
  113.     round(d*1000,digits=3)
  114.   }
  115.   selectsol <- function(sol # if extreme= false this will select the best option out of all evaluated solutions
  116.                         ,og){ # number of bpms removed is the primary criterion
  117.     solux <- cbind((dim(og)[1]-1) - (unlist(lapply(lapply(lapply(sol,"[[",1),dim),"[",1))-1),sqrt(cbind(unlist(lapply(lapply(lapply(sol,"[[",2),abs),mean,na.rm=TRUE)),unlist(lapply(lapply(lapply(sol,"[[",2),abs),max,na.rm=TRUE)))))
  118.     rownames(solux) <- 1:dim(solux)[1]
  119.     solux <- solux[which(solux[,2]<sqrt(mva) & solux[,3] < sqrt(mvs)),]
  120.     solux <- cbind(solux[,1],rowSums(solux[,2:3]))
  121.     solux <-as.numeric(names(which.min(solux[solux[,1]==tail(solux[order(solux[,1])],1),,drop=FALSE][,2])))
  122.   }
  123.   tolpass <- function(tol,mt,mva,mvs,ti
  124.                       ,og # original ms array used for variance checks/stops
  125.                       ,sol){ # solution list
  126.     if(dim(og)[1]==2){return(list(og,0))}
  127.     if(round(tol,digits=3)>=mt){
  128.       if(extreme==FALSE){return(sol[[length(sol)]])
  129.       }else{
  130.         cat(paste("Extreme mode enabled... solution",selectsol(sol,og),"selected.","\n"))
  131.         return(sol[[selectsol(sol,og)]])}}
  132.     tol <- tol+ti
  133.     e <- og[,1:2]
  134.     oa <- multipass(tol,mva,mvs,e)
  135.     msv <- msvar(og,oa)
  136.     rbpm <- (dim(og)[1]-1)-(dim(oa)[1]-1)
  137.     cat(paste("tol =",tol,"msva =",round(mean(msv),digits=3),"removed",rbpm,"of",(dim(og)[1]-1),"bpms","\n"))
  138.     if(extreme==FALSE){
  139.       if(length(which(abs(msv)>mvs))>0){
  140.         if(length(sol)==0){
  141.           cat(paste("Max variance average exceeded... returning original bpmline","\n"))
  142.           return(list(og,0))}
  143.         cat(paste("Max variance single exceeded... returning previous solution","\n"))
  144.         return(sol[[length(sol)]])}
  145.       if(mean(abs(msv))>mva){
  146.         if(length(sol)==0){
  147.           cat(paste("Max variance average exceeded... returning original bpmline","\n"))
  148.           return(list(og,0))}
  149.         cat(paste("Max variance average exceeded... returning previous solution","\n"))
  150.         return(sol[[length(sol)]])}
  151.     }
  152.     sol[[length(sol)+1]] <- list(oa,msv)
  153.     tolpass(tol,mt,mva,mvs,ti,og,sol)
  154.   }
  155.   multipass <- function(tol,mva,mvs
  156.                         ,e){ # reset bpm array from previous output
  157.     o <- NULL
  158.     o <- collapsebpm(tol,o,e,sa)
  159.     oa <- createmsarray(o,sa,fb)
  160.     msv <- msvar(og,oa)
  161.     if(length(which(abs(msv)>mvs))>0){return(oa)}
  162.     if(mean(abs(msv))>mva){return(oa)}
  163.     if(dim(o)[1]>1){
  164.       t <- cbind(o,c(0,o[1:(dim(o)-1)[1],2]))[1:(dim(o)[1]-1),,drop=FALSE]
  165.       tt <- length(t[which(abs(t[,2]-t[,3])<0.5*tol),])
  166.     }else{tt<-0}
  167.     if(tt!=0){
  168.       e <- oa[,1:2]
  169.     }else{return(oa)}
  170.     multipass(tol,mva,mvs,e)
  171.   }
  172.   collapsebpm <- function(tol
  173.                           ,o # new output bpm array
  174.                           ,e # extracted bpm array from each iteration
  175.                           ,sa){ # stop array
  176.     p <- rep(c(e[1,2],e[2,2]),((dim(e)[1])/2))
  177.     n <- suppressWarnings(head(which(p!=e[1:(dim(e)[1]-1),2]),1)-1)
  178.     if(abs(p[1]-p[2])<=tol){
  179.       if(length(n)==0){n<-dim(e)[1]}
  180.       if(n==dim(e)[1]){
  181.         n <- n-1
  182.         if(e[n+1,1]-e[n,1]<=2){n<-n-1}
  183.       }
  184.       l <- createmsarray(e[1:n,],sa=NULL,fb=e[n+1,1])[n,4]
  185.       bpm <- round((e[n+1,1]-e[1,1])/(l/60),digits=4)
  186.     }else{
  187.       bpm<-e[1,2]
  188.       n<-1
  189.     }
  190.     o <- rbind(o,c(e[1,1],bpm))
  191.     if(n==dim(e)[1]|is.vector(e[(n+1):dim(e)[1],])){return(o)}
  192.     e <- e[(n+1):dim(e)[1],]
  193.     collapsebpm(tol,o,e,sa)
  194.   }
  195.   rebuildline <- function(oa # array to rebuild
  196.                           ,x){ # data designation
  197.     if(!is.null(oa)){
  198.       a <- oa[1:dim(oa)[1]-1,1:2,drop=FALSE]
  199.       a <- round(a,digits=4)
  200.       n <- paste(a[,1],a[,2],sep="=")
  201.     }else{
  202.       n <- ""
  203.     }
  204.     paste(x,paste(n,collapse=","),";",sep="")
  205.   }
  206.   neg <- function(ba # check bpm and stop arrays for neg/0 values
  207.                   ,sa){
  208.     n <- length(which(ba[,2]<=0))
  209.     n2 <- length(which(sa[,2]<=0))
  210.     sum(n,n2)
  211.   }
  212.  
  213.   # Dump log data
  214.   if(patch==TRUE){cat(paste("Flux capacitor initialized with the following parameters:","\n"
  215.                             ,"Max flux tolerance =",mt,"\n"
  216.                             ,"Max average ms variation threshold =",mva,"\n"
  217.                             ,"Max single ms variation threshold =",mvs,"\n"
  218.                             ,"Flux tolerance interval =",ti,"\n","\n"))
  219.     cat(paste("Processing...",sdir,"\n"))}
  220.   # Read and clean data
  221.   options(expressions=25000)
  222.   if(missing(sdir)){sdir <- getwd()}
  223.   sm <- read.sm(sdir)
  224.   if(is.null(sm)){
  225.     cat(paste("No .sm found.","\n","\n","\n"))
  226.     return(NULL)
  227.   }
  228.   fb <- getfb(sm)
  229.   bpmline <- rowmerge(sm,"#BPMS:")
  230.   stopline <- rowmerge(sm,"#STOPS:")
  231.   sm <- rowremove(sm,x="#BPMS")
  232.   sm <- rowremove(sm,x="#STOPS")
  233.   ba <- createbpmarray(bpmline,fb)
  234.   sa <- createstoparray(stopline,fb)
  235.   og <- createmsarray(ba,sa)
  236.  
  237.   # Processing
  238.   if(neg(ba,sa)==0){
  239.     tol <- 0
  240.     sol <- list()
  241.     solux <- tolpass(tol,mt,mva,mvs,ti,og,sol)
  242.     newbpms <- rebuildline(solux[[1]],x="#BPMS:")
  243.     newstops <- rebuildline(sa,x="#STOPS:")
  244.    
  245.     if(patch==FALSE){
  246.       o <- newbpms
  247.     }else{
  248.       sm[substr(sm,1,6)=="#BPMS:"] <- newbpms
  249.       sm[substr(sm,1,7)=="#STOPS:"] <- newstops
  250.       cat(paste("Original BPMline:",bpmline,"\n"))
  251.       cat(paste("Output BPMline:",newbpms,"\n"))
  252.       cat(paste("MS Variance:",paste(solux[[2]],collapse=","),"\n","\n","\n"))
  253.       o <- sm
  254.     }
  255.   }else{
  256.     if(patch==TRUE){
  257.       o <- read.sm(sdir)
  258.     }else{}
  259.     cat(paste("Negative or 0 bpms/stops detected ","(",neg(ba,sa),")","\n",sep=""))
  260.     cat(paste("No adjustments will be made to the .sm","\n","\n","\n"))
  261.   }
  262.   if(exists("o")){o}
  263. }
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!