Difference between revisions of "OpasnetUtils/Drafts"

From Testiwiki
Jump to: navigation, search
(rcode answer split into meaningful parts)
(→‎Calculations: showind works now)
 
(4 intermediate revisions by the same user not shown)
Line 24: Line 24:
  
 
'''Functions for ovariable diagnostics
 
'''Functions for ovariable diagnostics
 +
showind has problems with get() but this version of code was acceptable [http://en.opasnet.org/en-opwiki/index.php?title=Special:RTools&id=QcfKMkCd2ewUtZqP].
  
−
<rcode name="diagnostics" embed=1>
+
<rcode name="diagnostics" embed=0>
 
#This is code Op_en6007/diagnostics on page [OpasnetUtils/Drafts]]
 
#This is code Op_en6007/diagnostics on page [OpasnetUtils/Drafts]]
  
 
library(OpasnetUtils)
 
library(OpasnetUtils)
 +
 +
# Shows a table about ovariables and their index and location changes compared with parents.
 +
# showind has problems with get().
 +
showind <- function(name = ".GlobalEnv", sources = FALSE, prevresults = FALSE) {
 +
  # i ovariable
 +
  # k parent ovariable
 +
  # l index in (parent) ovariable
 +
  deptable <- data.frame()
 +
  for(i in ls(name = name)) {
 +
    d = list(get(i))[[1]]
 +
    if(class(d) == "ovariable") {
 +
      depind <- list()
 +
      if(nrow(d@dependencies)>0) {
 +
        dep <- paste(d@dependencies$Name, collapse = ", ")
 +
        for(k in d@dependencies$Name){
 +
          if(!exists(k)) cat(k, "does not exist.\n") else {
 +
            if(class(get(k)) != "ovariable") cat(k, "is not an ovariable.\n") else {
 +
              ko <- list(get(k)@output)[[1]]
 +
              if("Iter" %in% colnames(ko)) ko$Iter <- as.factor(max(as.numeric(as.character(ko$Iter))))
 +
              cols <- colnames(ko)
 +
              if(!sources) cols <- cols[!grepl("Source$", cols)]
 +
              if(!prevresults) cols <- cols[!grepl("Result$", cols)]
 +
              for(l in cols) {
 +
                if(l %in% names(depind)) {
 +
                  depind[[l]] <- union(depind[[l]], unique(ko[[l]]))
 +
                } else {
 +
                  newind <- list(unique(ko[[l]]))
 +
                  names(newind) <- l
 +
                  depind <- c(depind, newind)
 +
                }
 +
              }
 +
            }
 +
          }
 +
        }
 +
      } else {
 +
        dep <- "No dependencies"
 +
      }
 +
      curcols <- colnames(d@output)
 +
      if(!sources) curcols <- curcols[!grepl("Source$", curcols)]
 +
      if(!prevresults) curcols <- curcols[!grepl("Result$", curcols)]
 +
      droploc <- character()
 +
      for(m in curcols) {
 +
        if(!is.numeric(d@output[[m]])) {
 +
          drops <- setdiff(depind[[m]], unique(d@output[[m]]))
 +
          if(length(drops>0)) {
 +
            droploc <- paste(
 +
              droploc,
 +
              paste(
 +
                m,
 +
                paste(drops, collapse = ", "),
 +
                sep = ": "
 +
              ),
 +
              sep = " | "
 +
            )
 +
          }
 +
        }
 +
      }
 +
      if(length(droploc)==0) droploc <- NA
 +
      deptable <- rbind(
 +
        deptable,
 +
        data.frame(
 +
          Ovariable = i,
 +
          Size = nrow(d@output),
 +
          Dependencies = dep,
 +
          Current = paste(curcols, collapse = ", "),
 +
          Dropped = paste(setdiff(names(depind), curcols), collapse = ", "),
 +
          New = paste(setdiff(curcols, names(depind)), collapse = ", "),
 +
          Dropped_locations = droploc
 +
        )
 +
      )
 +
    }
 +
  }
 +
  return(deptable)
 +
}
 +
 +
ovashapetest <- function(ova) {
 +
  allr <- rownames(ova@output)
 +
  uniqr <- rownames(unique(ova@output[ova@marginal]))
 +
  cube <- sapply(ova@output[ova@marginal], FUN = function(x) length(unique(x)))
 +
  if(length(allr) == length(uniqr)) {
 +
    cat("All rows have unique marginals.\n")
 +
  } else {
 +
    cat("Warning. All rows do not have unique marginals. Make sure that this is what you want.\n")
 +
  }
 +
  cat("Number of all rows:", length(allr), "\n")
 +
  cat("Number of all rows without Iter: Iter==1", length(ova$Iter[ova$Iter=="1"]),
 +
    "nrow/N", length(allr)/openv$N, "\n")
 +
  cat("Number of unique rows:", length(uniqr), "\n")
 +
  cat("Number of rows in a full array:", prod(cube), "\n")
 +
  oprint(cube)
 +
  nonuniqr <- setdiff(allr, uniqr)
 +
#  cat("Non-unique rows:", nonuniqr, "\n")
 +
#  oprint(head(ova@output[rownames(ova@output) %in% nonuniqr , ]))
 +
  cubesm <- cube[cube>1 & cube<50]
 +
  cubn <- names(cubesm)
 +
  for(i in 2:(length(cubn))) {
 +
    for(j in 1:(i-1)){
 +
      oprint(c(cubn[i], cubn[j]))
 +
      oprint(table(ova@output[[cubn[i]]], ova@output[[cubn[j]]], useNA="ifany"))
 +
    }
 +
  }
 +
 +
  for(i in colnames(ova@output)[ova@marginal]) {
 +
    locs <- ova@output[[i]]
 +
    exper <- prod(cube[names(cube) != i])
 +
    oprint(c(i, exper))
 +
    for(j in unique(ova@output[[i]])) {
 +
      cat(j, length(locs[locs == j]), ",") 
 +
    }
 +
  }
 +
}
  
 
#####################################
 
#####################################
Line 65: Line 177:
 
               Ovariable = i,
 
               Ovariable = i,
 
               Index = j,
 
               Index = j,
−
               Class = class(get(i)@output[[j]]),
+
               Class = paste(class(get(i)@output[[j]]), collapse=" "),
 +
              Marginal = j %in% colnames(get(i)@output)[get(i)@marginal],
 
               NumLoc = length(unique(get(i)@output[[j]])),
 
               NumLoc = length(unique(get(i)@output[[j]])),
 
               Locations = paste(head(unique(get(i)@output[[j]])), collapse = " ")
 
               Locations = paste(head(unique(get(i)@output[[j]])), collapse = " ")
Line 77: Line 190:
 
}
 
}
  
−
objects.store(binoptest, showLoctable, ovashapetest)
+
objects.store(showind, binoptest, showLoctable, ovashapetest)
−
cat("Functions binoptest, showLoctable, ovashapetest stored.\n")
+
cat("Functions showind, binoptest, showLoctable, ovashapetest stored.\n")
 
</rcode>
 
</rcode>
  
Line 922: Line 1,035:
 
}
 
}
  
−
objects.store(MyPointKML, ova2spat, MyRMap, MyPlotKML)
+
objects.store(MyPointKML, ova2spat, MyRmap, MyPlotKML)
−
cat("Functions MyPointKML, ova2spat, MyRMap, MyPlotKML stored.\n")
+
cat("Functions MyPointKML, ova2spat, MyRmap, MyPlotKML stored.\n")
 
</rcode>
 
</rcode>
  

Latest revision as of 19:33, 6 June 2017



Question

Which functions are so useful that they should be taken into OpasnetUtils package? This page contains draft function which will be included when they are good enough and found important.

Answer

Call the objects stored by this code from another rode with this command: 

objects.latest("Op_en6007", code_name = "answer") # Old version that fetches all objects, depreciated and not updated.
objects.latest("Op_en6007", code_name = "diagnostics") # Functions for ovariable and model diagnostics: ovashapetest, showLoctable, binoptest
objects.latest("Op_en6007", code_name = "webropol") # Functions for operating with Webropol data
objects.latest("Op_en6007", code_name = "miscellaneous") # Functions for various tasks
objects.latest("Op_en6007", code_name = "gis") # Functions for ovariable, KML and Googl maps interactions

Rationale

Calculations

Functions for ovariable diagnostics showind has problems with get() but this version of code was acceptable [1].

+ Show code

Functions for Webropol data

+ Show code

Miscellaneous functions

+ Show code

Functions for GIS data

+ Show code

See also

References


Related files

<mfanonymousfilelist></mfanonymousfilelist>

Retrieved from "http://www.opasnet.org/testiwiki/index.php?title=OpasnetUtils/Drafts&oldid=40898"