sixianghu / dataman Goto Github PK

rateComp <- function(df,fac,peril,reorder=FALSE){
  df_sub <- filter(df,(KEY==fac) & (Peril == peril))

  if(reorder){
    suppressWarnings(min_x <- min(as.numeric(df_sub$Level1),na.rm = TRUE))
    suppressWarnings(max_x <- max(as.numeric(df_sub$Level1),na.rm = TRUE))
    suppressWarnings(oth_lvl <- as.character(df_sub$Level1[is.na(as.numeric(df_sub$Level1))]))
    df_sub$Level1 <- ordered(factor(df_sub$Level1,levels=c(paste(min_x:max_x),oth_lvl)))
  }
  df_sub <- df_sub[order(df_sub$Level1),]
  plot_ly(df_sub,x=Level1,y=Value.x, xaxis = "x1", yaxis = "y1",name="Model1") %>%
          add_trace(df,x=Level1,y=Value.y, xaxis = "x1", yaxis = "y1",name="Model2") %>%
    layout(xaxis=list(title=fac),yaxis=list(title=peril))
}

dataComp <- function(old,new,alpha=0.05){
  strName <- names(old)
  res <- data.frame(Name = NULL, Changes = NULL)
  for (i in strName){
    if (i %in% names(new)){
       x<- chisq.test(table(old[,i]),p=table(new[,i])/sum(table(new[,i])))
       if (x$p.value > alpha) {
         tmp <-data.frame(Name=i,Changes=FALSE)
         res <- rbind(res,tmp)
       }
    }
  }
  res
}

library(RColorBrewer)

modelCompPlot <- function(x,act,pred,by=NULL,weights=NULL,newGroupNum=10){
  if (is.null(x)) stop("x provided is blank.")
  if (is.null(act)) stop("act provided is blank.")
  if (is.null(pred)) stop("pred provided is blank.")

  str_pred <- NULL
  num_pred <- NULL
  if (length(x) != length(act)) stop("x and act don't have the same length")
  if (is.vector(pred)){
    str_pred <- "pred"
    num_pred <- 1
    if(length(x) != length(pred)) stop("x and pred don't have the same length")
  }
  else {
    str_pred <- colnames(pred)
    if (is.null(str_pred)) str_pred <- paste("Pred",1:nrow(pred),sep="")
    num_pred <- ncol(pred)
    if(length(x) != nrow(pred)) stop("x and pred don't have the same length")
  }

  if(is.null(weights)) {weights <- rep(1,length(x))}

  #New Group for data which has too much levels.
  if ( (is.numeric(x) || is.integer(x)) && nlevels(as.factor(x))>100 ) {
    if ( is.null(newGroupNum) ) newGroupNum <- 10

    new_band <- seq(min(x, na.rm = TRUE),max(x, na.rm = TRUE),length.out=newGroupNum)
    x <- as.character(cut(x,new_band,include.lowest = TRUE))
  }

  if(!is.null(by)){
    data.plot <- data.table::as.data.table(as.data.frame(cbind(xvar=x,by=by,act,pred,weights),stringsAsFactors=FALSE))
    setkey(data.plot,xvar,by)

    dp_name_str <- c("act",str_pred,"weights")
    data.plot <- data.plot[,lapply(.SD,as.numeric),by=list(xvar,by),.SDcols=dp_name_str]
    data.agg  <- data.plot[,lapply(.SD,weighted.mean,w=weights),by=list(xvar,by),.SDcols=dp_name_str]

    p1 <- rbokeh::figure(xlab="x",ylab="",height=500) %>% 
      rbokeh::ly_lines(xvar,act,color=by,type=list(2),
                      width=2,data=data.agg) 

    for (i in num_pred){
      p1 <- p1 %>% rbokeh::ly_lines(xvar,deparse(substitute(str_pred[i])),color=by,type=list(2),
                                    width=2,data=data.agg) 
    }
  }
  else {
    data.plot <- data.table::as.data.table(as.data.frame(cbind(xvar=x,act,pred,weights),stringsAsFactors=FALSE))
    setkey(data.plot,xvar)

    dp_name_str <- c("act",str_pred,"weights")
    data.plot <- data.plot[,lapply(.SD,as.numeric),by=xvar,.SDcols=dp_name_str]
    data.agg  <- data.plot[,lapply(.SD,weighted.mean,w=weights),by=xvar,.SDcols=dp_name_str]

    p1 <- rbokeh::figure(xlab="x",ylab="",width=700,height=800) %>% 
      rbokeh::ly_lines(xvar,act,color="#CC3399",
                       width=2,data=data.agg,legend = "Actual") 

    str_col <- brewer.pal(max(num_pred,3), "Spectral")
    for (i in 1:num_pred){
      print(str_pred[i])
      p1 <- p1 %>% rbokeh::ly_lines(xvar,str_pred[i],color=str_col[i],width=2,data=data.agg,
                                    legend=str_pred[i]) 
    }
  }

  p1
}

dataPlot <- function(data,xvar,yvar,weights=NULL,byvar=NULL,newGroupNum=NULL,interactive=FALSE,...){

  opts.list<-list(...)
  opts <- names(list(...))
  if("xlim" %in% opts) xlim<-opts.list$xlim
  if("ylim" %in% opts) ylim<-opts.list$ylim
  if("binwidth" %in% opts) binwidth<-opts.list$binwidth else binwidth <- 1

  # Error Trapping
  if( is.null(data) ) stop("data set provided is null.")
  if( is.null(xvar) ) stop("X variable provided is null.") 
  if( is.null(yvar) ) stop("Responce variable provided is null.")

  if (is.character(xvar)) {
    if(!xvar %in% colnames(data)) stop(paste("xvar variable (",xvar,") cannot be found.",""))
    x <- data[,which(names(data)==xvar)]
    xname <- xvar
  }
  else if (is.integer(xvar)) { 
    x <- data[,xvar]
    xname <- names(data)[xvar]
  }
  else stop ("xvar provided is either a character (variable name) or integer (position of the variable).")

  if (is.character(yvar)) {
    if(!yvar %in% colnames(data)) stop(paste("yvar variable (",yvar,") cannot be found.",""))
    yname <- yvar
    y <- data[,which(names(data)==yvar)]
  }
  else if (is.integer(yvar)) {
    y <- data[,yvar]
    yname <- names(data)[yvar]
  }
  else stop ("yvar provided is either a character (variable name) or integer (position of the variable).")

  if( !is.null(byvar) ){
    if (is.character(byvar)){
      if(!byvar %in% colnames(data) ) stop(paste("xvar variable (",byvar,") cannot be found.",""))
      by <- data[,which(names(data)==byvar)]
      byname <- byvar
    }
    else if (is.integer(byvar)) {
      xname <- names(data)[byvar]
      by <- as.character(data[,byvar])
    }
    else by <- NULL
  }
  else by <- NULL

  if( !is.null(weights) ){
    wname = "w"
    if (is.character(weights)){
      if(!weights %in% colnames(data) ) stop(paste("xvar variable (",weights,") cannot be found.",""))
      w <- data[,which(names(data)==weights)]
    }
    else if (is.integer(weights) && length(weights)==1) {
      w <- data[,weights]
    }
    else if (is.integer(weights) && length(weights)>1){
      if ( dim(data)[1] != length(weights) ) stop ("Length of weights is not the same as dimension of the data provided.")
      w <- weights
    }
  }
  else w <- rep(1,dim(data)[1])

  #New Group for xvar which has too much levels.
  if ( (is.numeric(x) || is.integer(x) ) && nlevels(as.factor(x))>100 ) {
    if ( is.null(newGroupNum) ) newGroupNum <- 10

    new_band <- seq(min(x),max(x),length.out=newGroupNum)
    x <- cut(x,new_band,include.lowest = TRUE)
  }

  #New Group for byvar which has too much levels.
  if(!is.null(by)){
    if ( (is.numeric(by) || is.integer(by)) && nlevels(as.factor(by))>100 ) {
      if ( is.null(newGroupNum) ) newGroupNum <- 10

      new_band <- seq(min(by),max(by),length.out=newGroupNum)
      by <- cut(by,new_band,include.lowest = TRUE)
    }
  }

  #Data for plot
  if (is.null(by)) {
    data.plot <- data.table::as.data.table(as.data.frame(cbind(x=x,y=y,w=w),stringsAsFactors=FALSE))
    data.table::setkey(data.plot,x)

    data.plot <- data.plot[,lapply(.SD,as.numeric),by=x,.SDcols=c("y","w")]
    data.agg <- as.data.frame(data.plot[,lapply(.SD,weighted.mean,w=w),by=x,.SDcols=c("y","w")],row.names=c("xvar","weights","observed"))
    data.freq <- as.data.frame(data.plot[,sum(w),by=x][,freq:=V1/sum(V1)])

    data.melt <- reshape2::melt(data.agg[,-3],id=c("x"))

    #line graph

    strV1 <- paste("Observation Analysis on: ",xname)

    gLine <- ggplot2::ggplot(data=data.melt,aes(x=x,y=value)) + 
      ggplot2::geom_line(size=1,colour= "magenta3") + ggplot2::geom_point(size=4,fill="white",shape=22)
    if(("xlim" %in% opts) && is.numeric(data.melt$x)) gLine <-gLine + ggplot2::scale_x_continuous(limits=xlim)
    else if(("xlim" %in% opts) && !is.numeric(data.melt$x)) gLine <-gLine + ggplot2::scale_x_discrete(limits=xlim)
    else if(("xlim" %in% opts) && is(data.melt[,"x"],"Date")) gLine <-gLine + ggplot2::scale_x_date(label=date_format("%y%m"),limits=xlim)
    if("ylim" %in% opts) gLine <-gLine + ggplot2::ylim(ylim)
    gLine <- gLine + ggplot2::xlab("") + ggplot2::ylab(yname)+ ggplot2::ggtitle(strV1)+ theme_mp_line
    if(nlevels(as.factor(data.melt$x))>25) gLine <- gLine + ggplot2::theme(axis.text.x = element_text(angle = 90,hjust=0.5,vjust=0.5))

    #histogram graph
    ghist <- ggplot2::ggplot(data=data.freq,aes(x=x,y=freq))+
      ggplot2::geom_histogram(stat="identity",colour="black",fill="yellow")
    if(("xlim" %in% opts) && is.numeric(data.melt$x)) ghist <-ghist + ggplot2::scale_x_continuous(limits=xlim)
    else if(("xlim" %in% opts) && !is.numeric(data.melt$x)) ghist <-ghist + ggplot2::scale_x_discrete(limits=xlim)
    ghist <- ghist + ggplot2::ylab("percent (%)")+
      ggplot2::scale_y_continuous(labels = percent)+
      ggplot2::xlab("")+ theme_mp_hist

    gridExtra::grid.arrange(gLine,ghist,ncol=1,nrow=2,heights=c(4,1))

    if (interactive) {
      df <- data.frame(data.agg,freq=data.freq$freq)
      gvisSingleOptionList <- list(pointSize=8,
                                   series="[
                                   {targetAxisIndex:0, type:'line',color:'magenta',pointShape: 'square'},
                                   {targetAxisIndex:1, type:'bars',color:'yellow'}]",
                                   crosshair="{trigger:'both'}",
                                   hAxis.title=xname,
                                   theme="maximized",
                                   title=paste0("Observation analysis on ",xname, " Observed"),
                                   vAxes="{1:{format:'##.#%',maxValue:1}}",
                                   explorer="{ actions: ['dragToZoom', 'rightClickToReset'],keepInBounds: true }",
                                   chartArea="{width:'90%',height:'90%'}",
                                   height=750)

      plot(googleVis::gvisComboChart(df,xvar="x",yvar="y",options=gvisSingleOptionList))

    }
  }
  else{
    data.plot <- data.table::as.data.table(as.data.frame(cbind(x=x,y=y,w=w,by=by),stringsAsFactors=FALSE))
    data.table::setkey(data.plot,x,by)

    data.plot <- data.plot[,lapply(.SD,as.numeric),by=list(x,by),.SDcols=c("y","w")]

    data.agg <- as.data.frame(data.plot[,lapply(.SD,weighted.mean,w=w),by=list(x,by),.SDcols=c("y","w")],row.names=c("xvar","by","weights","observed"))

    data.freq <- as.data.frame(data.plot[,sum(w),by=list(x,by)][,freq:=V1/sum(V1)])

    #line graph
    gLine1 <- ggplot2::ggplot(data=data.agg,aes(x=x,y=y,group=factor(by),colour=factor(by)))+
      ggplot2::geom_line(size=1) + ggplot2::geom_point(size=4,fill="white")
    if("xlim" %in% opts) gLine1 <-gLine1 + xlim(xlim)
    if("ylim" %in% opts) gLine1 <-gLine1 + ylim(ylim)
    gLine1 <- gLine1+ggplot2::xlab("")+ggplot2::ylab(yname)+ ggplot2::ggtitle(paste("Observation Analysis on: ",xname," by ",byname))+
      theme_mp_line
    if(nlevels(as.factor(data.agg$x))>25) gLine1 <- gLine1 + ggplot2::theme(axis.text.x = element_text(angle = 90,hjust=0.5,vjust=0.5))

    #histogram graph
    ghist <- ggplot2::ggplot(data=data.freq,aes(x=x,y=freq,fill=factor(by)))+ ggplot2::geom_histogram(stat="identity",binwidth=1)
    if("xlim" %in% opts) ghist <-ghist + ggplot2::xlim(xlim)
    ghist <- ghist + ggplot2::xlab("")+ ggplot2::ylab("percent (%)")+ ggplot2::scale_y_continuous(labels = percent) + 
      theme_mp_hist+ theme(legend.position="none")

    gridExtra::grid.arrange(gLine1,ghist,ncol=1,nrow=2,heights=c(4,1))
  }
}

src <- '
  mat m1 = as<mat>(x);
  return(wrap(cor(m1)));
  '

  fx <- inline::cxxfunction( signature(x = "numeric") , 
                     body = src, 
                     plugin='RcppArmadillo', 
                     includes = 'using namespace Rcpp;
                                 using namespace arma;')

library(microbenchmark)
x <- as.matrix(mtcars)
microbenchmark(
  fx(x),
  cor(x)
)

multiParts <- function(y,p){
  if(is.null(y)) stop("no inputs")

  if(sum(p)<1) warning("Sum of proportion is less than 1, 
                       rest of the data will be dropped.")

  if(sum(p)>1) stop("Sum of the proportion is larger than 1.")

  rn <- 1:length(y)
  np <- length(p)

  res <- list()

#   Use the createDataPartition from caret package: 
#   for (i in 1:np){
#     ind <- caret::createDataPartition(y=rn,p=p[i])
#     res[[i]] <- rn[ind[[1]]]
#     rn <- rn[-ind[[1]]]
#     p <- p/(sum(p[-c(1:i)]))
#   }


#   Use sample function instead
  for (i in 1:np){
    ind <- sample(1:length(rn),size=floor(p[i]*length(rn)))
    res[[i]] <- rn[ind]
    rn <- rn[-ind]
    p <- p/(sum(p[-c(1:i)]))
  }  
  res
}

x <- c(1,NA,2)
df <- as.data.frame(cbind(x,x,x))
names(df)
PopMiss(df,na.treatment = "replace",0)