statsailr_procs_base 0.1.2 → 0.2.0

checksums.yaml

@@ -1,7 +1,7 @@
 ---
 SHA256:
-  metadata.gz: ab1d309ac74444b5b0cf7ae6d1097691dbf8c8437bb03853de68c727574ce396
-  data.tar.gz: 245ddb37295e6c3dc5581aad3616ba39230bdf31b6aa0d5d33092e055e944432
+  metadata.gz: c71268a7ddcceaacdd0e8967bf3ce232667d43fe879e932b3acfc80a45235ecc
+  data.tar.gz: 822e0b2ab2bc4f040bd310e9fbe5acd883e2a4056e1c3c0a9abd70ac95945a07
 SHA512:
-  metadata.gz: f2f4fa1fa6ba0b50bf3abf3bd220cce12efdffb2533dd0da3b35cba9d604728084fa913f02f1afcbfd6ed03b5cae67fe18bc5b8c2ed03b7428a436f471c172b6
-  data.tar.gz: beba39a0885eff4d70243de4b78e601c30d26b6bdb29dbbb6436501564481b1f482a0beb10efbecf587f6d8350a934d130e592328ccdd6b3150a73a381faf315
+  metadata.gz: df438d9db6db33303a05ed4c3584f0cea3e336fc0915c2fa33da7484eb60d409b976cc97d87e02917e2babda8586dcfe5a148c2bfdfcee4094d1e55b8ba27dc7
+  data.tar.gz: 0731ce51dadc3ae5611ccbfcfd7a971065534efea91131656cc846eccfb9feb42488cee0c4f952106a435f1790122ac46f3d9124b80aaab80418c59a77025c6f

data/lib/statsailr_procs_base/proc_setting/proc_cat.R

@@ -1,65 +1,68 @@
-sts_cat = new.env()
-
-sts_cat$table = function( data , vars , missing = FALSE, ... ){
-  if( (! is.character(vars)) || length(vars) != 2 ){
-    stop("vars argument requires character vector with size of 2")
-  }
+STS_RC_Cat = setRefClass("STS_RC_Cat")
+STS_RC_Cat$methods(
+  table = function( data , vars , missing = FALSE, ... ){
+    if( (! is.character(vars)) || length(vars) != 2 ){
+      stop("vars argument requires character vector with size of 2")
+    }
 
-  df_for_table = data[ , vars ]
-  if( missing ){
-    freq_ori = table(df_for_table, useNA = "ifany")
-  }else{
-    freq_ori = table(df_for_table)
-  }
+    df_for_table = data[ , vars ]
+    if( missing ){
+      freq_ori = base::table(df_for_table, useNA = "ifany")
+    }else{
+      freq_ori = base::table(df_for_table)
+    }
 
-  freq = addmargins( freq_ori )
-  allper = format( addmargins( prop.table( freq_ori) * 100), digits = 4)
-  rowper = format( addmargins( prop.table( freq_ori, 1) * 100), digits = 4)
-  colper = format( addmargins( prop.table( freq_ori, 2) * 100), digits = 4)
+    freq = addmargins( freq_ori )
+    allper = format( addmargins( prop.table( freq_ori) * 100), digits = 4)
+    rowper = format( addmargins( prop.table( freq_ori, 1) * 100), digits = 4)
+    colper = format( addmargins( prop.table( freq_ori, 2) * 100), digits = 4)
 
-  nrow = nrow(freq)
-  ncol = ncol(freq)
-  nrow_ori = nrow(freq_ori)
+    nrow = nrow(freq)
+    ncol = ncol(freq)
+    nrow_ori = nrow(freq_ori)
 
-  temp = as.array( numeric( nrow * ncol * 4 ))
-  dim( temp ) = c( nrow * 4, ncol )
-  result = as.table( temp )
+    temp = as.array( numeric( nrow * ncol * 4 ))
+    dim( temp ) = c( nrow * 4, ncol )
+    result = base::as.table( temp )
 
-  colnames(result) = c( colnames( freq_ori ) , "Total")
+    colnames(result) = c( colnames( freq_ori ) , "Total")
 
-  row_label1 = c( rep("%",nrow_ori ) , "%")
-  row_label2 = c( rep("Row%",nrow_ori ) , "")
-  row_label3 = c( rep("Col%",nrow_ori ) , "")
+    row_label1 = c( rep("%",nrow_ori ) , "%")
+    row_label2 = c( rep("Row%",nrow_ori ) , "")
+    row_label3 = c( rep("Col%",nrow_ori ) , "")
 
-  rownames(result) = as.vector( mapply( c, c( rownames( freq_ori ), "Total" ), row_label1 , row_label2 , row_label3 ))
+    rownames(result) = as.vector( mapply( c, c( rownames( freq_ori ), "Total" ), row_label1 , row_label2 , row_label3 ))
 
-  cat( paste( "\t", names(freq), "\n", sep = "\t", collapse = "\t" ))
-  for( irow in seq(1, nrow) ){
-    for( icol in seq(1, ncol) ){
-      result[ (irow-1)*4 + 1, icol] = freq[irow, icol]
-    }
-    for( icol in seq(1, ncol) ){
-      result[ (irow-1)*4 + 2, icol] = allper[irow, icol]
-    }
-    for( icol in seq(1, ncol) ){
-      if(irow != nrow && icol != ncol){
-        result[ (irow-1)*4 + 3, icol] = rowper[irow, icol]
-      }else{
-        result[ (irow-1)*4 + 3, icol] = NA
+    cat( paste( "\t", names(freq), "\n", sep = "\t", collapse = "\t" ))
+    for( irow in seq(1, nrow) ){
+      for( icol in seq(1, ncol) ){
+        result[ (irow-1)*4 + 1, icol] = freq[irow, icol]
       }
-    }
-    for( icol in seq(1, ncol) ){
-      if(icol != ncol && irow!= nrow){
-        result[ (irow-1)*4 + 4, icol] = colper[irow, icol]
-      }else{
-        result[ (irow-1)*4 + 4, icol] = NA
+      for( icol in seq(1, ncol) ){
+        result[ (irow-1)*4 + 2, icol] = allper[irow, icol]
+      }
+      for( icol in seq(1, ncol) ){
+        if(irow != nrow && icol != ncol){
+          result[ (irow-1)*4 + 3, icol] = rowper[irow, icol]
+        }else{
+          result[ (irow-1)*4 + 3, icol] = NA
+        }
+      }
+      for( icol in seq(1, ncol) ){
+        if(icol != ncol && irow!= nrow){
+          result[ (irow-1)*4 + 4, icol] = colper[irow, icol]
+        }else{
+          result[ (irow-1)*4 + 4, icol] = NA
+        }
       }
     }
-  }
  
-  cat( paste( vars[1] , " vs ", vars[2], "\n" ) )
-  print( result )
+    cat( paste( vars[1] , " vs ", vars[2], "\n" ) )
+    print( result )
+
+    return( freq_ori )
+  }
+)
 
-  return( freq_ori )
-}
+sts_cat = STS_RC_Cat()
 

data/lib/statsailr_procs_base/proc_setting/proc_common/dev_copy.R

@@ -1,6 +1,9 @@
-sts_dev_copy = new.env()
+STS_RC_DevCopy = setRefClass("STS_RC_DevCopy")
+STS_RC_DevCopy$methods(
+  dev_copy = function( device, ... ){
+    dev.copy( device , ...)
+    dev.off()
+  }
+)
 
-sts_dev_copy$dev_copy = function( device, ... ){
-  dev.copy( device , ...)
-  dev.off()
-}
+sts_dev_copy = STS_RC_DevCopy()

data/lib/statsailr_procs_base/proc_setting/proc_common/factor.R

@@ -1,7 +1,10 @@
-sts_factor = new.env()
+STS_RC_Factor = setRefClass("STS_RC_Factor")
+STS_RC_Factor$methods(
+  convert_to_factor = function( data, vars ){
+    data[vars] = lapply(data[vars], as.factor)
+    print( paste( "as.factor is applied to", paste( vars, collapse=",") , sep=" ") )
+    return( data )
+  }
+)
 
-sts_factor$convert_to_factor = function( data, vars ){
-  data[vars] = lapply(data[vars], as.factor)
-  print( paste( "as.factor is applied to", paste( vars, collapse=",") , sep=" ") )
-  return( data )
-}
+sts_factor = STS_RC_Factor()

data/lib/statsailr_procs_base/proc_setting/proc_common/numeric.R

@@ -1,7 +1,10 @@
-sts_numeric = new.env()
+STS_RC_Numeric = setRefClass("STS_RC_Numeric")
+STS_RC_Numeric$methods(
+  convert_to_numeric = function( data, vars ){
+    data[vars] = lapply(data[vars], as.numeric)
+    print( paste( "as.numeric is applied to", paste( vars, collapse=",") , sep=" ") )
+    return( data )
+  }
+)
 
-sts_numeric$convert_to_numeric = function( data, vars ){
-  data[vars] = lapply(data[vars], as.numeric)
-  print( paste( "as.numeric is applied to", paste( vars, collapse=",") , sep=" ") )
-  return( data )
-}
+sts_numeric = STS_RC_Numeric()

data/lib/statsailr_procs_base/proc_setting/proc_filter.R

@@ -1,39 +1,42 @@
-sts_filter = new.env()
+STS_RC_Filter = setRefClass("STS_RC_Filter")
+STS_RC_Filter$methods(
+  wrap_filter = function( data, cond ){
+    lang_cond = rlang::parse_expr( cond )
+    df = dplyr::filter( data, !! lang_cond )
+    return(df)
+  },
 
-sts_filter$wrap_filter = function( data, cond ){
-  lang_cond = rlang::parse_expr( cond )
-  df = dplyr::filter( data, !! lang_cond )
-  return(df)
-}
+  wrap_select = function( data, cond ){
+    lang_cond = rlang::parse_exprs(cond)
+    df = dplyr::select(data, !!! lang_cond)
+    return(df)
+  },
 
-sts_filter$wrap_select = function( data, cond ){
-  lang_cond = rlang::parse_exprs(cond)
-  df = dplyr::select(data, !!! lang_cond)
-  return(df)
-}
-
-sts_filter$assign_to = function(var, df){
-  if( (! is.character(var)) || length(var) != 1 ){
-    stop("var argument requires character vector with size of 1")
-  }
+  assign_to = function(var, df){
+    if( (! is.character(var)) || length(var) != 1 ){
+      stop("var argument requires character vector with size of 1")
+    }
 
-  global_env = globalenv()
-  global_env[[ var[1] ]] = df
-  return(df)
-}
+    global_env = globalenv()
+    global_env[[ var[1] ]] = df
+    return(df)
+  },
 
-sts_filter$finalizer = function( df, last_inst, out ){
-  if( last_inst != "assign_to" ){
-    if( is.null(out) ){
-      cat("The last result is print out, and is not assigned to any variable.\n")
-      print(head(df))
-      cat("Use out= option for PROC COMMAND or use assing_to instruction\n")
-      cat("to assign the last result to some variable.\n")
+  finalizer = function( df, last_inst, out ){
+    if( last_inst != "assign_to" ){
+      if( is.null(out) ){
+        cat("The last result is print out, and is not assigned to any variable.\n")
+        print(head(df))
+        cat("Use out= option for PROC COMMAND or use assing_to instruction\n")
+        cat("to assign the last result to some variable.\n")
+      }else{
+        sts_filter$assign_to( out, df )
+      }
     }else{
-      sts_filter$assign_to( out, df )
+      # OK. The result dataframe is already assigned using assign_to instruction.
     }
-  }else{
-    # OK. The result dataframe is already assigned using assign_to instruction.
   }
-}
+)
+
+sts_filter = STS_RC_Filter()
 

data/lib/statsailr_procs_base/proc_setting/proc_ggplot.R

@@ -1,39 +1,42 @@
-sts_ggplot = new.env()
-
 library(rlang)
 library(ggplot2)
 
-sts_ggplot$mapping = function( data, assoc ){
-  assoc_lang = rlang::parse_exprs(assoc)
-  # https://github.com/tidyverse/ggplot2/issues/2675
-  gg = ggplot2::ggplot(data, ggplot2::aes( ,, !!! assoc_lang ))
-  return( gg )
-}
+STS_RC_Ggplot = setRefClass("STS_RC_Ggplot")
+STS_RC_Ggplot$methods(
+  mapping = function( data, assoc ){
+    assoc_lang = rlang::parse_exprs(assoc)
+    # https://github.com/tidyverse/ggplot2/issues/2675
+    gg = ggplot2::ggplot(data, ggplot2::aes( ,, !!! assoc_lang ))
+    return( gg )
+  },
 
-sts_ggplot$geom_point_wrapper = function( gg, params = NULL, ... ){
-  if( is.null(params) ){
-    gg = gg + ggplot2::geom_point()
-  }else{
-    params_lang = rlang::parse_exprs(params)
-    # https://stackoverflow.com/questions/68379666/how-to-specify-a-package-or-namespace-for-rlangexec
-    # https://stackoverflow.com/questions/70202220/big-bang-operator-for-ggplot2-geom-point-function
-    # real_fun <- get("geom_point", envir=as.environment(paste0("package:", "ggplot2")))
-    # gg = gg + rlang::exec(real_fun, !!! params_lang , ...)
-    gg = gg + rlang::inject(ggplot2::geom_point( !!! params_lang , ...))
-  }
-  return( gg )
-}
+  geom_point_wrapper = function( gg, params = NULL, ... ){
+    if( is.null(params) ){
+      gg = gg + ggplot2::geom_point()
+    }else{
+      params_lang = rlang::parse_exprs(params)
+      # https://stackoverflow.com/questions/68379666/how-to-specify-a-package-or-namespace-for-rlangexec
+      # https://stackoverflow.com/questions/70202220/big-bang-operator-for-ggplot2-geom-point-function
+      # real_fun <- get("geom_point", envir=as.environment(paste0("package:", "ggplot2")))
+      # gg = gg + rlang::exec(real_fun, !!! params_lang , ...)
+      gg = gg + rlang::inject(ggplot2::geom_point( !!! params_lang , ...))
+    }
+    return( gg )
+  },
+
+  geom_histogram_wrapper = function( gg, params = NULL, ...){
+    if( is.null(params) ){
+      gg = gg + ggplot2::geom_histogram()
+    }else{
+      params_lang = rlang::parse_exprs(params)
+      gg = gg + rlang::inject(ggplot2::geom_histogram( !!! params_lang , ...))
+    }
+    return( gg )
+  },
 
-sts_ggplot$geom_histogram_wrapper = function( gg, params = NULL, ...){
-  if( is.null(params) ){
-    gg = gg + ggplot2::geom_histogram()
-  }else{
-    params_lang = rlang::parse_exprs(params)
-    gg = gg + rlang::inject(ggplot2::geom_histogram( !!! params_lang , ...))
+  finalizer = function( gg ){
+    plot(gg)
   }
-  return( gg )
-}
+)
 
-sts_ggplot$finalizer = function( gg ){
- plot(gg)
-}
+sts_ggplot = STS_RC_Ggplot()

data/lib/statsailr_procs_base/proc_setting/proc_ggplot.rb

@@ -1,5 +1,6 @@
 module ProcGgplot
   include ProcSettingModule
+  add_setting_from( __dir__, "proc_common/factor.rb" )
 
   source_r_file( __dir__, File.basename(__FILE__ , ".rb") + ".R")
   validate_option("data", is_a: ["SymbolR", "String"], as: "SymbolR" , required: true)

data/lib/statsailr_procs_base/proc_setting/proc_group.R

@@ -1,55 +1,54 @@
-sts_group = new.env()
-
 library(rlang)
 
-sts_group$wrap_group_by = function(data, vars){
+STS_RC_Group = setRefClass("STS_RC_Group")
+STS_RC_Group$methods(
+  wrap_group_by = function(data, vars){
     vars_lang = rlang::parse_exprs(vars)
     grouped_data = rlang::inject(dplyr::group_by( data, !!! vars_lang ))
     return(grouped_data)
-}
-
+  },
 
-sts_group$wrap_mutate = function(data, params){
+  wrap_mutate = function(data, params){
     params_lang = rlang::parse_exprs(params)
     mutated_data = rlang::inject(dplyr::mutate( data, !!! params_lang ))
     return(mutated_data)
-}
+  },
 
-
-sts_group$wrap_summarize = function(data, params){
+  wrap_summarize = function(data, params){
     params_lang = rlang::parse_exprs(params)
     result = rlang::inject(dplyr::summarize( data, !!! params_lang ))
     print(result)
     return(data)
-}
-
+  },
 
-sts_group$assign_to = function(var, df){
-  df = as.data.frame(df)
+  assign_to = function(var, df){
+    df = as.data.frame(df)
 
-  if( (! is.character(var)) || length(var) != 1 ){
-    stop("var argument requires character vector with size of 1")
-  }
-
-  global_env = globalenv()
-  global_env[[ var[1] ]] = df
-  return(df)
-}
-
-sts_group$finalizer = function( df, last_inst, out ){
-  df = as.data.frame(df)
+    if( (! is.character(var)) || length(var) != 1 ){
+      stop("var argument requires character vector with size of 1")
+    }
 
-  if( last_inst != "assign_to" ){
-    if( is.null(out) ){
-      cat("The last result is print out, and is not assigned to any variable.\n")
-      print(head(df))
-      cat("Use out= option for PROC COMMAND or use assing_to instruction\n")
-      cat("to assign the last result to some variable.\n")
+    global_env = globalenv()
+    global_env[[ var[1] ]] = df
+    return(df)
+  },
+
+  finalizer = function( df, last_inst, out ){
+    df = as.data.frame(df)
+
+    if( last_inst != "assign_to" ){
+      if( is.null(out) ){
+        cat("The last result is print out, and is not assigned to any variable.\n")
+        print(head(df))
+        cat("Use out= option for PROC COMMAND or use assing_to instruction\n")
+        cat("to assign the last result to some variable.\n")
+      }else{
+        sts_group$assign_to( out, df )
+      }
     }else{
-      sts_group$assign_to( out, df )
+      # OK. The result dataframe is already assigned using assign_to instruction.
     }
-  }else{
-    # OK. The result dataframe is already assigned using assign_to instruction.
   }
-}
+)
 
+sts_group = STS_RC_Group()

data/lib/statsailr_procs_base/proc_setting/proc_mult.R

@@ -1,12 +1,13 @@
-sts_mult = new.env()
-
-sts_mult$p_adjust = function( x , method ){
-  ori_p = summary(x)[[1]][['Pr(>F)']]
-  result = p.adjust( ori_p, method )
-
-  cat( "p adjustment\n" )
-  cat( paste( "Method:", method, "\n", sep=" ", collapse=" " ) )
-  return(result)
-}
-
-
+STS_RC_Mult = setRefClass("STS_RC_Mult")
+STS_RC_Mult$methods(
+  p_adjust = function( x , method ){
+    ori_p = summary(x)[[1]][['Pr(>F)']]
+    result = p.adjust( ori_p, method )
+
+    cat( "p adjustment\n" )
+    cat( paste( "Method:", method, "\n", sep=" ", collapse=" " ) )
+    return(result)
+  }
+)
+
+sts_mult = STS_RC_Mult()

data/lib/statsailr_procs_base/proc_setting/proc_plot.R

@@ -1,52 +1,55 @@
-sts_plot = new.env()
-
-sts_plot$legend = function( legend , ... ){
-  if( (! is.character(legend)) ){
-    stop("legend argument requires character vector")
-  }
-
-  args = list(...)
-  args$legend = legend
-  args$x = if_exist_else ( "x", args, paste( "topleft" ))
-
-  do.call( get_pkg_fun( "graphics::legend") , args )
-}
-
-sts_plot$hist = function( data , var , ... ){
-  if( (! is.character(var)) || length(var) != 1 ){
-    stop("vars argument requires character vector with size of 1")
-  }
-
-  args = list(...)
-  args$x = data[[var]]
-  args$main = if_exist_else ( "main", args, paste( "Frequency of" , var ))
-  args$xlab = if_exist_else ( "xlab", args, paste( var ))
-
-  do.call( get_pkg_fun( "graphics::hist") , args )
-}
-
-sts_plot$box = function( data , var , ... ){
-  if( (! is.character(var)) || length(var) != 1 ){
-    stop("vars argument requires character vector with size of 1")
+STS_RC_Plot = setRefClass("STS_RC_Plot")
+STS_RC_Plot$methods(
+  legend = function( legend , ... ){
+    if( (! is.character(legend)) ){
+      stop("legend argument requires character vector")
+    }
+
+    args = list(...)
+    args$legend = legend
+    args$x = if_exist_else ( "x", args, paste( "topleft" ))
+
+    do.call( get_pkg_fun( "graphics::legend") , args )
+  },
+
+  hist = function( data , var , ... ){
+    if( (! is.character(var)) || length(var) != 1 ){
+      stop("vars argument requires character vector with size of 1")
+    }
+
+    args = list(...)
+    args$x = data[[var]]
+    args$main = if_exist_else ( "main", args, paste( "Frequency of" , var ))
+    args$xlab = if_exist_else ( "xlab", args, paste( var ))
+
+    do.call( get_pkg_fun( "graphics::hist") , args )
+  },
+
+  box = function( data , var , ... ){
+    if( (! is.character(var)) || length(var) != 1 ){
+      stop("vars argument requires character vector with size of 1")
+    }
+
+    args = list(...)
+    args$x = data[[var]]
+    args$main = if_exist_else ( "main", args, paste( var ))
+    args$lex.order = TRUE
+
+    do.call( get_pkg_fun( "graphics::boxplot"), args )
+  },
+
+  scatter = function( data , vars , ... ){
+    if( (! is.character(vars)) || length(vars) != 2 ){
+      stop("vars argument requires character vector with size of 2")
+    }
+
+    args = list(...)
+    args$x = data[vars]
+    args$main = if_exist_else ( "main", args, paste( vars[1], "vs", vars[2] ))
+
+    do.call( get_pkg_fun( "graphics::plot"), args )
   }
+)
 
-  args = list(...)
-  args$x = data[[var]]
-  args$main = if_exist_else ( "main", args, paste( var ))
-  args$lex.order = TRUE
-
-  do.call( get_pkg_fun( "graphics::boxplot"), args ) 
-}
-
-sts_plot$scatter = function( data , vars , ... ){
-  if( (! is.character(vars)) || length(vars) != 2 ){
-    stop("vars argument requires character vector with size of 2")
-  }
-
-  args = list(...)
-  args$x = data[vars]
-  args$main = if_exist_else ( "main", args, paste( vars[1], "vs", vars[2] ))
-
-  do.call( get_pkg_fun( "graphics::plot"), args )
-}
+sts_plot = STS_RC_Plot()
 

data/lib/statsailr_procs_base/proc_setting/proc_print.R

@@ -1,60 +1,62 @@
-sts_print = new.env()
-
-sts_print$nth = function( x , positions ){
-
-# positions are passed as strvec which is already splitted by spaces and signs
-# group these elements
-
-shift_vec = function( x, n , fill=NA ){
-  if( n == 0 ){
-    return( x )
-  }else if( n > 0 ){
-    return( c( rep(fill, n), head(x, -n)) )
-  }else if( n < 0 ){
-    return( c( tail(x, length(x) + n), rep(fill, -n)) )
-  }else{
-    print("inappropriate n.")
-    return(x)
-  }
-}
-
-colon_pos = (positions == ":")
-colon_after_pos = shift_vec( colon_pos , 1, F )
-group_num = cumsum( !( colon_pos | colon_after_pos) )
-
-position_strvec = sapply( split(positions, group_num) , function(elem){ paste( elem, collapse="" )} )
-names( position_strvec) = position_strvecp
-
-# Convert them to a list of int vectors
-
-position_list = lapply(position_strvec, function(elem){
-  range_sep = ":"
-  if( grepl( range_sep, elem, fixed = TRUE) ){ # grepl(pattern, x)
-    range = strsplit(elem, range_sep, fixed=TRUE)[[1]]
-    if( length(range) != 2){
-      print("Range should be specified with x:y form (meaning from x to y).")
-      return( 0 )
-    }else{
-      range_int = strtoi(range)
-      return( seq(range_int[1], range_int[2]) )
+STS_RC_Print = setRefClass("STS_RC_Print")
+STS_RC_Print$methods(
+  nth = function( x , positions ){
+
+    # positions are passed as strvec which is already splitted by spaces and signs
+    # group these elements
+
+    shift_vec = function( x, n , fill=NA ){
+      if( n == 0 ){
+        return( x )
+      }else if( n > 0 ){
+        return( c( rep(fill, n), head(x, -n)) )
+      }else if( n < 0 ){
+        return( c( tail(x, length(x) + n), rep(fill, -n)) )
+      }else{
+        print("inappropriate n.")
+        return(x)
+      }
     }
-  }else{
-    return( strtoi(elem))
-  }
-})
-
-# For each int vector, print corresponding rows
 
-lapply( position_list, function(nth){
-  x[ nth , ]
-})
-
-}
+    colon_pos = (positions == ":")
+    colon_after_pos = shift_vec( colon_pos , 1, F )
+    group_num = cumsum( !( colon_pos | colon_after_pos) )
+
+    position_strvec = sapply( split(positions, group_num) , function(elem){ paste( elem, collapse="" )} )
+
+    # Convert them to a list of int vectors
+
+    position_list = lapply(position_strvec, function(elem){
+      range_sep = ":"
+      if( grepl( range_sep, elem, fixed = TRUE) ){ # grepl(pattern, x)
+        range = strsplit(elem, range_sep, fixed=TRUE)[[1]]
+        if( length(range) != 2){
+          print("Range should be specified with x:y form (meaning from x to y).")
+          return( 0 )
+        }else{
+          range_int = strtoi(range)
+          return( seq(range_int[1], range_int[2]) )
+        }
+      }else{
+        return( strtoi(elem))
+      }
+    })
+
+    # For each int vector, print corresponding rows
+
+    lapply( position_list, function(nth){
+      x[ nth , ]
+    })
+
+  },
+
+  random = function( x , n  ){
+    row_num = nrow(x)
+    index = ceiling(row_num * runif(n))
+    sorted_index = sort(index)
+    x[ sorted_index , ]
+  }
+)
 
-sts_print$random = function( x , n  ){
-  row_num = nrow(x)
-  index = ceiling(row_num * runif(n))
-  sorted_index = sort(index)
-  x[ sorted_index , ]
-}
+sts_print = STS_RC_Print()
 

data/lib/statsailr_procs_base/proc_setting/proc_sort.R

@@ -1,32 +1,35 @@
-sts_sort = new.env()
+STS_RC_Sort = setRefClass("STS_RC_Sort")
+STS_RC_Sort$methods(
+  wrap_arrange = function( data, cond ){
+    lang_cond = rlang::parse_exprs(cond)
+    df = dplyr::arrange(data, !!! lang_cond)
+    return(df)
+  },
 
-sts_sort$wrap_arrange = function( data, cond ){
-  lang_cond = rlang::parse_exprs(cond)
-  df = dplyr::arrange(data, !!! lang_cond)
-  return(df)
-}
-
-sts_sort$assign_to = function(var, df){
-  if( (! is.character(var)) || length(var) != 1 ){
-    stop("var argument requires character vector with size of 1")
-  }
+  assign_to = function(var, df){
+    if( (! is.character(var)) || length(var) != 1 ){
+      stop("var argument requires character vector with size of 1")
+    }
 
-  global_env = globalenv()
-  global_env[[ var[1] ]] = df
-  return(df)
-}
+    global_env = globalenv()
+    global_env[[ var[1] ]] = df
+    return(df)
+  },
 
-sts_sort$finalizer = function( df, last_inst, out ){
-  if( last_inst != "assign_to" ){
-    if( is.null(out) ){
-      cat("The last result is print out, and is not assigned to any variable.\n")
-      print(head(df))
-      cat("Use out= option for PROC COMMAND or use assing_to instruction\n")
-      cat("to assign the last result to some variable.\n")
+  finalizer = function( df, last_inst, out ){
+    if( last_inst != "assign_to" ){
+      if( is.null(out) ){
+        cat("The last result is print out, and is not assigned to any variable.\n")
+        print(head(df))
+        cat("Use out= option for PROC COMMAND or use assing_to instruction\n")
+        cat("to assign the last result to some variable.\n")
+      }else{
+        sts_sort$assign_to( out, df )
+      }
     }else{
-      sts_sort$assign_to( out, df )
+      # OK. The result dataframe is already assigned using assign_to instruction.
     }
-  }else{
-    # OK. The result dataframe is already assigned using assign_to instruction.
   }
-}
+)
+
+sts_sort = STS_RC_Sort()

data/lib/statsailr_procs_base/proc_setting/proc_two.R

@@ -1,33 +1,35 @@
-sts_two = new.env()
+STS_RC_Two = setRefClass("STS_RC_Two")
+STS_RC_Two$methods(
+  t_test = function( data , vars , ... ){
+    if( (! is.character(vars)) || length(vars) != 2 ){
+      stop("vars argument requires character vector with size of 2")
+    }
+    x = vars[1]
+    y = vars[2]
+    result = t.test( data[[x]], data[[y]], ... )
+    return(result)
+  },
 
-sts_two$t_test = function( data , vars , ... ){
-  if( (! is.character(vars)) || length(vars) != 2 ){
-    stop("vars argument requires character vector with size of 2")
-  }
-  x = vars[1]
-  y = vars[2]
-  result = t.test( data[[x]], data[[y]], ... )
-  return(result)
-}
-
-sts_two$paired = function( data , vars , ... ){
-  if( (! is.character(vars)) || length(vars) != 2 ){
-    stop("vars argument requires character vector with size of 2")
-  }
-  x = vars[1]
-  y = vars[2]
-  result = t.test( data[[x]], data[[y]], paired = TRUE, ... )
-  return(result)
-}
+  paired = function( data , vars , ... ){
+    if( (! is.character(vars)) || length(vars) != 2 ){
+      stop("vars argument requires character vector with size of 2")
+    }
+    x = vars[1]
+    y = vars[2]
+    result = t.test( data[[x]], data[[y]], paired = TRUE, ... )
+    return(result)
+  },
 
-sts_two$wilcox_test = function( data , vars , ... ){
-  if( (! is.character(vars)) || length(vars) != 2 ){
-    stop("vars argument requires character vector with size of 2")
+  wilcox_test = function( data , vars , ... ){
+    if( (! is.character(vars)) || length(vars) != 2 ){
+      stop("vars argument requires character vector with size of 2")
+    }
+    x = vars[1]
+    y = vars[2]
+    result = wilcox.test( data[[x]], data[[y]], ... )
+    return(result)
   }
-  x = vars[1]
-  y = vars[2]
-  result = wilcox.test( data[[x]], data[[y]], ... )
-  return(result)
-}
+)
 
+sts_two = STS_RC_Two()
 

data/lib/statsailr_procs_base/proc_setting/proc_uni.R

@@ -1,126 +1,125 @@
-sts_uni = new.env()
-
-sts_uni$list2str = function ( lst, exclude=c() ){
-  str = ""
-  for( i in seq(1,length(lst))){
-    if (! names(lst)[i] %in% exclude ){
-      key = names(lst)[i]
-      value = lst[[i]]
-
-      if( length( value ) == 1 ){
-        str = paste0( str, key, "\t", value, "\n")
-      }else if( is.null( attr( value, "names"))){
-        str = paste0( str, key, "\t", paste( value , collapse=" ") , "\n")
-      }else{
-        str = paste0( str, key, "\n" )
-        str = paste0( str, paste( mapply( paste0, "\t", names(value), "\t" , value), collapse="\n") , "\n")
+STS_RC_Uni = setRefClass("STS_RC_Uni")
+STS_RC_Uni$methods(
+  list2str = function ( lst, exclude=c() ){
+    str = ""
+    for( i in seq(1,length(lst))){
+      if (! names(lst)[i] %in% exclude ){
+        key = names(lst)[i]
+        value = lst[[i]]
+
+        if( length( value ) == 1 ){
+          str = paste0( str, key, "\t", value, "\n")
+        }else if( is.null( attr( value, "names"))){
+          str = paste0( str, key, "\t", paste( value , collapse=" ") , "\n")
+        }else{
+          str = paste0( str, key, "\n" )
+          str = paste0( str, paste( mapply( paste0, "\t", names(value), "\t" , value), collapse="\n") , "\n")
+        }
       }
     }
-  }
-  return( str )
-}
-
-
-sts_uni$var = function( data , vars , hist = FALSE , ... ){
-  if( (! is.character(vars)) || length(vars) == 0 ){
-    stop("vars argument requires character vector")
-  }
-  check_name_existance = vars %in% colnames(data)
-  if( ! all(check_name_existance) ){
-    print( paste( check_name_existance , "\n") )
-    stop("vars argument should be colnames of data")
-  }
+    return( str )
+  },
 
-  results = list()
-  df = data
+  var = function( data , vars , hist = FALSE , ... ){
+    if( (! is.character(vars)) || length(vars) == 0 ){
+      stop("vars argument requires character vector")
+    }
+    check_name_existance = vars %in% colnames(data)
+    if( ! all(check_name_existance) ){
+      print( paste( check_name_existance , "\n") )
+      stop("vars argument should be colnames of data")
+    }
 
-  for( var in vars){
-    result = list()
-    result$vec = df[[ var ]]
+    results = list()
+    df = data
 
-    result$mean = mean( df[[ var ]] )
-    result$N = length( df[[ var ]] )
-    missing_pos = is.na(df[[ var ]])
+    for( var in vars){
+      result = list()
+      result$vec = df[[ var ]]
 
-    result$missing = sum( missing_pos )
-    result$n = sum( ! missing_pos )
+      result$mean = mean( df[[ var ]] )
+      result$N = length( df[[ var ]] )
+      missing_pos = is.na(df[[ var ]])
 
-    non_missing = df[[ var ]][! missing_pos]
+      result$missing = sum( missing_pos )
+      result$n = sum( ! missing_pos )
 
-    quantiles = quantile(non_missing, probs = c(1, 0.99, 0.95, 0.90, 0.75, 0.5, 0.25, 0.1, 0.05, 0.01, 0), na.rm = TRUE)
-    third_quart = quantiles[5]
-    first_quart = quantiles[7]
-    result$max = head(quantiles, 1)
-    result$min = tail(quantiles, 1)
+      non_missing = df[[ var ]][! missing_pos]
 
-    result$mean = mean(non_missing)
-    result$deviation = sd(non_missing)
-    result$median = median(non_missing)
-    result$IQR = c( first_quart ,third_quart )
-    result$quantiles = quantiles
+      quantiles = quantile(non_missing, probs = c(1, 0.99, 0.95, 0.90, 0.75, 0.5, 0.25, 0.1, 0.05, 0.01, 0), na.rm = TRUE)
+      third_quart = quantiles[5]
+      first_quart = quantiles[7]
+      result$max = head(quantiles, 1)
+      result$min = tail(quantiles, 1)
 
-    # To be implemented
-    # skewness 
-    # kurtosis
+      result$mean = mean(non_missing)
+      result$deviation = sd(non_missing)
+      result$median = median(non_missing)
+      result$IQR = c( first_quart ,third_quart )
+      result$quantiles = quantiles
 
-    results[[var]] = result
-  }
+      # To be implemented
+      # skewness
+      # kurtosis
 
-  result_str = ""
-  result_num = length(results)
-  for( i in seq(1, result_num)){
-    result_str = paste0( result_str, names(results)[i], " ", "statistics\n")
-    result_str = paste0( result_str, sts_uni$list2str(results[[i]], exclude=c("vec")), "\n")
-  }
+      results[[var]] = result
+    }
 
-  # output
-  if( hist ){
-    layout( matrix(seq(1, result_num), ncol = 1))
-    for( i in seq(1,result_num)){
-      hist( results[[ i ]]$vec , main = paste( "Histogram of" , names(results)[i] ), xlab=names(results)[i] )
+    result_str = ""
+    result_num = length(results)
+    for( i in seq(1, result_num)){
+      result_str = paste0( result_str, names(results)[i], " ", "statistics\n")
+      result_str = paste0( result_str, sts_uni$list2str(results[[i]], exclude=c("vec")), "\n")
     }
-    layout( matrix(c(1), ncol = 1))
-  }
 
-  cat( result_str )  # output is done using cat()
-  return(results)  # return value to be used by other instructions is results
-}
+    # output
+    if( hist ){
+      layout( matrix(seq(1, result_num), ncol = 1))
+      for( i in seq(1,result_num)){
+        hist( results[[ i ]]$vec , main = paste( "Histogram of" , names(results)[i] ), xlab=names(results)[i] )
+      }
+      layout( matrix(c(1), ncol = 1))
+    }
 
+    cat( result_str )  # output is done using cat()
+    return(results)  # return value to be used by other instructions is results
+  },
 
-sts_uni$qqplot = function( results , var = NULL , qqline = FALSE, ... ){
-  if ( (! is.null(var)) && (length(var) != 1) ){
-    stop("main argument needs to be length of 1 character vector")
-  }
-  if( is.null(var) ){
-    vec = results[[1]]$vec
-  }else{
-    vec = results[[var]]$vec
-  }
-  qqnorm(vec)
-  if( qqline ){
-    qqline(vec)
-  }
-}
+  qqplot = function( results , var = NULL , qqline = FALSE, ... ){
+    if ( (! is.null(var)) && (length(var) != 1) ){
+      stop("main argument needs to be length of 1 character vector")
+    }
+    if( is.null(var) ){
+      vec = results[[1]]$vec
+    }else{
+      vec = results[[var]]$vec
+    }
+    qqnorm(vec)
+    if( qqline ){
+      qqline(vec)
+    }
+  },
 
-sts_uni$hist = function( data, vars ){
-  if ( (! is.null(var)) && (length(var) != 1) ){
-    stop("main argument needs to be length of 1 character vector")
-  }
+  hist = function( data, vars ){
+    if ( (! is.null(var)) && (length(var) != 1) ){
+      stop("main argument needs to be length of 1 character vector")
+    }
 
-  size = length(vars)
-  par(mfrow(size, 1))
+    size = length(vars)
+    par(mfrow(size, 1))
 
-  for( i in seq(1, size)){
-    var = vars[[i]]
-    g = data[[var]]
-    h <- hist(g, breaks = 10, density = 10,
+    for( i in seq(1, size)){
+      var = vars[[i]]
+      g = data[[var]]
+      h <- hist(g, breaks = 10, density = 10,
             col = "lightgray", xlab = "Accuracy", main = "Overall")
-    xfit <- seq(min(g), max(g), length = 40)
-    yfit <- dnorm(xfit, mean = mean(g), sd = sd(g))
-    yfit <- yfit * diff(h$mids[1:2]) * length(g)
+      xfit <- seq(min(g), max(g), length = 40)
+      yfit <- dnorm(xfit, mean = mean(g), sd = sd(g))
+      yfit <- yfit * diff(h$mids[1:2]) * length(g)
 
-    lines(xfit, yfit, col = "black", lwd = 2)
+      lines(xfit, yfit, col = "black", lwd = 2)
+    }
   }
+)
 
-}
-
+sts_uni = STS_RC_Uni()

data/lib/statsailr_procs_base/proc_setting/proc_uni.rb

@@ -22,6 +22,7 @@ module ProcUni
     setting.runtime_args = {"results" => result("var")}
     setting.store_result = false
     setting.print_opt = false
+    setting.plot_opt = true
   end
 end
 

data/lib/statsailr_procs_base/version.rb

@@ -2,6 +2,6 @@
 
 module StatSailr
   module ProcsBase
-    VERSION = "0.1.2"
+    VERSION = "0.2.0"
   end
 end

metadata

@@ -1,14 +1,14 @@
 --- !ruby/object:Gem::Specification
 name: statsailr_procs_base
 version: !ruby/object:Gem::Version
-  version: 0.1.2
+  version: 0.2.0
 platform: ruby
 authors:
 - Toshihiro Umehara
 autorequire:
 bindir: exe
 cert_chain: []
-date: 2021-12-06 00:00:00.000000000 Z
+date: 2021-12-09 00:00:00.000000000 Z
 dependencies: []
 description: This 'statsailr_procs_base' gem provides a collection of fundamental
   PROCs for StatSailr program. This gem is essential for StatSailr to provide a useful